extra/git/git.factor

   1 ! Copyright (C) 2015 Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs assocs.extras calendar
   4 calendar.format checksums checksums.sha combinators
   5 combinators.short-circuit combinators.smart compression.zlib
   6 constructors endian formatting grouping hashtables ini-file io
   7 io.directories io.encodings.binary io.encodings.string
   8 io.encodings.utf8 io.files io.files.info io.pathnames
   9 io.streams.byte-array io.streams.peek kernel math math.bitwise
  10 math.parser namespaces random sequences sequences.extras
  11 splitting splitting.monotonic strings ;
  12 IN: git
  13
  14 ERROR: byte-expected offset ;
  15 : read1* ( -- n )
  16     read1 [ tell-input byte-expected ] unless* ;
  17
  18 ERROR: separator-expected expected-one-of got ;
  19
  20 : read-until* ( separators -- data )
  21     dup read-until [ nip ] [ separator-expected ] if ;
  22
  23 : find-git-directory ( path -- path' )
  24     [ ".git" tail? ] find-up-to-root ; inline
  25
  26 ERROR: not-a-git-directory path ;
  27
  28 : current-git-directory ( -- path )
  29     current-directory get find-git-directory [
  30         current-directory get not-a-git-directory
  31     ] unless* ;
  32
  33 : make-git-path ( str -- path )
  34     current-git-directory prepend-path ;
  35
  36 : make-refs-path ( str -- path )
  37     [ "refs/" make-git-path ] dip append-path ;
  38
  39 : make-object-path ( str -- path )
  40     [ "objects/" make-git-path ] dip 2 cut append-path append-path ;
  41
  42 : make-idx-path ( sha -- path )
  43     "objects/pack/pack-" ".idx" surround make-git-path ;
  44
  45 : make-pack-path ( sha -- path )
  46     "objects/pack/pack-" ".pack" surround make-git-path ;
  47
  48 : git-binary-contents ( str -- contents )
  49     make-git-path binary file-contents ;
  50
  51 : git-utf8-contents ( str -- contents )
  52     make-git-path utf8 file-contents ;
  53
  54 : git-lines ( str -- contents )
  55     make-git-path utf8 file-lines ;
  56
  57 ERROR: expected-one-line lines ;
  58
  59 : git-line ( str -- contents )
  60     git-lines dup length 1 =
  61     [ first ] [ expected-one-line ] if ;
  62
  63 : git-unpacked-object-exists? ( hash -- ? )
  64     make-object-path file-exists? ;
  65
  66 TUPLE: index-entry ctime mtime dev ino mode uid gid size sha1 flags name ;
  67 CONSTRUCTOR: <index-entry> index-entry ( ctime mtime dev ino mode uid gid size sha1 flags name -- obj ) ;
  68
  69 : read-index-entry-v2 ( -- seq )
  70     4 read be> 4 read be> 2array
  71     4 read be> 4 read be> 2array
  72     4 read be> 4 read be> 4 read be>
  73     4 read be> 4 read be> 4 read be>
  74     20 read bytes>hex-string
  75     2 read be> { 0 } read-until drop [ utf8 decode ] [ length ] bi
  76     7 + 8 mod dup zero? [ 8 swap - ] unless read drop
  77     <index-entry> ;
  78
  79 TUPLE: git-index magic version entries checksum ;
  80 CONSTRUCTOR: <git-index> git-index ( magic version entries checksum -- obj ) ;
  81
  82 ERROR: unhandled-git-version n ;
  83
  84 : git-index-contents ( -- git-index )
  85     "index" make-git-path binary [
  86         4 read utf8 decode
  87         4 read be>
  88         4 read be> over {
  89             { 2 [ [ read-index-entry-v2 ] replicate ] }
  90             [ unhandled-git-version ]
  91         } case
  92         20 read bytes>hex-string
  93         <git-index>
  94     ] with-file-reader ;
  95
  96 : make-git-object ( str -- obj )
  97     [
  98         [ "blob " ] dip [ length number>string "\0" ] [ ] bi
  99     ] B{ } append-outputs-as ;
 100
 101 : path>git-object ( path -- bytes )
 102     binary file-contents make-git-object sha1 checksum-bytes ;
 103
 104 : git-hash-object ( str -- hash )
 105     make-git-object sha1 checksum-bytes ;
 106
 107 : changed-index-by-sha1 ( -- seq )
 108     git-index-contents entries>>
 109     [ [ sha1>> ] [ name>> path>git-object bytes>hex-string ] bi = ] reject ;
 110
 111 : changed-index-by-mtime ( -- seq )
 112     git-index-contents entries>>
 113     [
 114         [ mtime>> first ]
 115         [ name>> file-info modified>> timestamp>unix-time >integer ] bi = not
 116     ] filter ;
 117
 118 TUPLE: commit hash tree parents author committer gpgsig message ;
 119 CONSTRUCTOR: <commit> commit ( tree parents author committer -- obj ) ;
 120
 121 TUPLE: tree hash tree parents author committer gpgsig message ;
 122 CONSTRUCTOR: <tree> tree ( -- obj ) ;
 123
 124 : gmt-offset>duration ( string -- duration )
 125     3 cut [ string>number ] bi@
 126     [ hours ] [ minutes ] bi* time+ ;
 127
 128 : git-date>string ( seq -- string )
 129     last2
 130     [ string>number unix-time>timestamp ]
 131     [ gmt-offset>duration [ time+ ] [ >>gmt-offset ] bi ] bi*
 132     timestamp>git-string ;
 133
 134 : commit. ( commit -- )
 135     {
 136         [ hash>> "commit " prepend print ]
 137         [ author>> "Author: " prepend split-words 2 head* join-words print ]
 138         [ author>> split-words git-date>string "Date:   " prepend print ]
 139         [ message>> split-lines [ "    " prepend ] map join-lines nl print nl ]
 140     } cleave ;
 141
 142 ERROR: unknown-field name parameter ;
 143
 144 : set-git-object-field ( obj name parameter -- obj )
 145     swap {
 146         { "tree" [ >>tree ] }
 147         { "parent" [ >>parents ] }
 148         { "author" [ >>author ] }
 149         { "committer" [ >>committer ] }
 150         { "gpgsig" [ >>gpgsig ] }
 151         { "message" [ >>message ] }
 152         [ unknown-field ]
 153     } case ; inline
 154
 155 : git-string>assoc ( string -- assoc )
 156     "\n\n" split1 [
 157         split-lines [ nip first CHAR: \s = ] monotonic-split
 158         [
 159             dup length 1 = [
 160                 first " " split1 2array
 161             ] [
 162                 [ first " " split1 ]
 163                 [ rest [ rest ] map ] bi
 164                 swap prefix join-lines 2array
 165             ] if
 166         ] map
 167     ] [
 168         "message" swap 2array
 169     ] bi* suffix ;
 170
 171 : parse-new-git-object ( string class -- commit )
 172     new swap git-string>assoc [ first2 set-git-object-field ] each ; inline
 173
 174 ERROR: unknown-git-object obj ;
 175
 176 : parse-object ( bytes -- git-obj )
 177     utf8 [
 178         { 0 } read-until 0 = drop dup " " split1 drop {
 179             { "blob" [ "unimplemented blob parsing" throw ] }
 180             { "commit" [
 181                 " " split1
 182                 [ "commit" assert= ] [ string>number read ] bi*
 183                 commit parse-new-git-object
 184             ] }
 185             { "tree" [ tree parse-new-git-object ] }
 186             [ unknown-git-object ]
 187         } case
 188     ] with-byte-reader ;
 189
 190 ERROR: idx-v1-unsupported ;
 191
 192 TUPLE: idx version table triples packfile-sha1 idx-sha1 ;
 193 CONSTRUCTOR: <idx> idx ( version table triples packfile-sha1 idx-sha1 -- obj ) ;
 194 ! sha1, crc32, offset
 195
 196 : parse-idx-v2 ( -- idx )
 197     4 read be>
 198     256 4 * read 4 group [ be> ] map
 199     dup last
 200     [ [ 20 read bytes>hex-string ] replicate ]
 201     [ [ 4 read ] replicate ]
 202     [ [ 4 read be> ] replicate ] tri 3array flip
 203     20 read bytes>hex-string
 204     20 read bytes>hex-string <idx> ;
 205
 206 : parse-idx ( path -- idx )
 207     binary [
 208         4 read be> {
 209             { 0xff744f63 [ parse-idx-v2 ] }
 210             [ idx-v1-unsupported ]
 211         } case
 212     ] with-file-reader ;
 213
 214 SYMBOL: #bits
 215
 216 : read-type-length ( -- pair )
 217     0 #bits [
 218         read1*
 219         [ -4 shift 3 bits ] [ 4 bits ] [ ] tri
 220         0x80 mask? [
 221             #bits [ 4 + ] change
 222             [
 223                 read1* [
 224                     7 bits #bits get shift bitor
 225                     #bits [ 7 + ] change
 226                 ] [ 0x80 mask? ] bi
 227             ] loop
 228         ] when 2array
 229     ] with-variable ;
 230
 231 : read-be-length ( -- length )
 232     read1* dup 0x80 mask? [
 233         7 bits [
 234             read1*
 235             [ [ 1 + 7 shift ] [ 7 bits ] bi* bitor ]
 236             [ 0x80 mask? ] bi
 237         ] loop
 238     ] when ;
 239
 240 : read-le-length ( -- length )
 241     read1* dup 0x80 mask? [
 242         7 bits [
 243             read1*
 244             [ 7 bits 7 shift bitor ]
 245             [ 0x80 mask? ] bi
 246         ] loop
 247     ] when ;
 248
 249 DEFER: git-object-from-pack
 250
 251 TUPLE: insert bytes ;
 252 CONSTRUCTOR: <insert> insert ( bytes -- insert ) ;
 253 TUPLE: copy offset size ;
 254 CONSTRUCTOR: <copy> copy ( offset size -- copy ) ;
 255
 256 : parse-delta ( -- delta/f )
 257     read1 [
 258         dup 0x80 mask? not [
 259             7 bits read <insert>
 260         ] [
 261             [ 0 0 ] dip
 262             dup 0x01 mask? [ [ read1* bitor ] 2dip ] when
 263             dup 0x02 mask? [ [ read1* 8 shift bitor ] 2dip ] when
 264             dup 0x04 mask? [ [ read1* 16 shift bitor ] 2dip ] when
 265             dup 0x08 mask? [ [ read1* 24 shift bitor ] 2dip ] when
 266             dup 0x10 mask? [ [ read1* bitor ] dip ] when
 267             dup 0x20 mask? [ [ read1* 8 shift bitor ] dip ] when
 268             dup 0x40 mask? [ [ read1* 16 shift bitor ] dip ] when
 269             drop [ 65536 ] when-zero <copy>
 270         ] if
 271     ] [
 272         f
 273     ] if* ;
 274
 275 : parse-deltas ( bytes -- deltas )
 276     binary [
 277         read-le-length
 278         read-le-length
 279         [ parse-delta ] loop>array 3array
 280     ] with-byte-reader ;
 281
 282 ERROR: unknown-delta-operation op ;
 283
 284 : apply-delta ( delta -- )
 285     {
 286         { [ dup insert? ] [ bytes>> write ] }
 287         { [ dup copy? ] [ [ offset>> seek-absolute seek-input ] [ size>> read write ] bi ] }
 288         [ unknown-delta-operation ]
 289     } cond ;
 290
 291 : do-deltas ( bytes delta-bytes -- bytes' )
 292     [ binary ] 2dip '[
 293         _ binary [
 294             _ parse-deltas third [ apply-delta ] each
 295         ] with-byte-reader
 296     ] with-byte-writer ;
 297
 298
 299 ERROR: unsupported-packed-raw-type type ;
 300
 301 : read-packed-raw ( -- string )
 302     read-type-length first2 swap {
 303         { 1 [ 256 + read uncompress ] }
 304         [ unsupported-packed-raw-type ]
 305     } case ;
 306
 307 SYMBOL: initial-offset
 308
 309 : read-offset-delta ( size -- obj )
 310     [ read-be-length neg initial-offset get + ] dip 256 + read uncompress
 311     [ seek-absolute seek-input read-packed-raw ] dip 2array ;
 312
 313 : read-sha1-delta ( size -- obj )
 314     [ 20 read bytes>hex-string git-object-from-pack ] dip read uncompress 2array ;
 315
 316 ! XXX: actual length is stored in the gzip header
 317 ! We add 256 instead of using it for now.
 318 : read-packed ( -- obj/f )
 319     tell-input initial-offset [
 320         read-type-length first2 swap {
 321             { 1 [ 256 + read uncompress parse-object ] }
 322             { 6 [ read-offset-delta first2 do-deltas parse-object ] }
 323             ! { 7 [ B read-sha1-delta ] }
 324             [ number>string "unknown packed type: " prepend throw ]
 325         } case
 326     ] with-variable ;
 327
 328 : parse-packed-object ( sha1 offset -- obj )
 329     [ make-pack-path binary ] dip '[
 330         input-stream [ <peek-stream> ] change
 331         _ seek-absolute seek-input read-packed
 332     ] with-file-reader ;
 333
 334 ! https://stackoverflow.com/questions/18010820/git-the-meaning-of-object-size-returned-by-git-verify-pack
 335 TUPLE: pack magic version count objects sha1 ;
 336 : parse-pack ( path -- pack )
 337     binary [
 338         input-stream [ <peek-stream> ] change
 339         4 read >string
 340         4 read be>
 341         4 read be> 3array
 342         [ peek1 ] [ read-packed ] produce 2array
 343     ] with-file-reader ;
 344
 345 : git-read-idx ( sha -- obj ) make-idx-path parse-idx ;
 346
 347 ! Broken for now
 348 ! : git-read-pack ( sha -- obj ) make-pack-path parse-pack ;
 349
 350 : parsed-idx>hash ( seq -- hash )
 351     H{ } clone [
 352         '[
 353             [ packfile-sha1>> ]
 354             [ triples>> ] bi
 355             [ first3 rot [ 3array ] dip _ set-at ] with each
 356         ] each
 357     ] keep ;
 358
 359 MEMO: git-parse-all-idx ( -- seq )
 360     "objects/pack/" make-git-path qualified-directory-files
 361     [ ".idx" tail? ] filter
 362     [ parse-idx ] map
 363     parsed-idx>hash ;
 364
 365 ERROR: no-pack-for sha1 ;
 366
 367 : find-pack-for ( sha1 -- triple )
 368     git-parse-all-idx ?at [ no-pack-for ] unless ;
 369
 370 : git-object-from-pack ( sha1 -- pack )
 371     [ find-pack-for [ first ] [ third ] bi parse-packed-object ] keep >>hash ;
 372
 373 : git-object-contents ( hash -- contents )
 374     make-object-path binary file-contents uncompress ;
 375
 376 : git-read-object ( sha -- obj )
 377     dup git-unpacked-object-exists? [
 378         [ git-object-contents parse-object ] keep >>hash
 379     ] [
 380         git-object-from-pack
 381     ] if ;
 382
 383 ! !: git-object-contents ( hash -- contents )
 384     ! make-object-path ! binary file-contents uncompress ;
 385     ! [ git-read-object ] [ git-object-from-pack ] if ;
 386
 387 : parsed-idx>hash2 ( seq -- hash )
 388     [
 389         [ triples>> [ [ drop f ] [ first ] bi ] [ set-at ] sequence>hashtable ]
 390         [ packfile-sha1>> ] bi
 391     ] [ set-at ] sequence>hashtable ; inline
 392
 393 ERROR: expected-ref got ;
 394
 395 : parse-ref-line ( string -- string' )
 396     " " split1 [
 397         dup "ref:" = [ drop ] [ expected-ref ] if
 398     ] dip ;
 399
 400 : list-refs ( -- seq )
 401     current-git-directory "refs/" append-path recursive-directory-files ;
 402
 403 : remote-refs-dirs ( -- seq )
 404     "remotes" make-refs-path directory-files ;
 405
 406 : ref-contents ( str -- line ) make-refs-path git-line ;
 407 : git-stash-ref-sha1 ( -- contents ) "stash" ref-contents ;
 408 : git-ref ( ref -- sha1 ) git-line parse-ref-line ;
 409 : git-head-ref ( -- sha1 ) "HEAD" git-ref ;
 410 : git-log-for-ref ( ref -- log ) git-line git-read-object ;
 411 : git-head-object ( -- commit ) git-head-ref git-log-for-ref ;
 412 : git-config ( -- config ) "config" make-git-path ;
 413
 414 SYMBOL: parents
 415 ERROR: repeated-parent-hash hash ;
 416
 417 : git-log ( -- log )
 418     H{ } clone parents [
 419         git-head-object [
 420             parents>> dup string? [ random ] unless [
 421                 dup git-unpacked-object-exists?
 422                 [ git-read-object ] [ git-object-from-pack ] if
 423             ] [ f ] if*
 424         ] follow
 425     ] with-variable ;
 426
 427 : filter-git-remotes ( seq -- seq' )
 428     [ "remote" head? ] filter-keys ;
 429
 430 : github-git-remote? ( hash -- ? )
 431     "url" of [ CHAR: / = ] trim-tail "git@github.com:" head? ;
 432
 433 : github-https-remote? ( hash -- ? )
 434     "url" of [ CHAR: / = ] trim-tail "https://github.com/" head? ;
 435
 436 : github-git-remote-matches? ( hash owner repo -- ? )
 437     [ "url" of [ CHAR: / = ] trim-tail ] 2dip "git@github.com:%s/%s" sprintf = ;
 438
 439 : github-https-remote-matches? ( hash owner repo -- ? )
 440     [ "url" of [ CHAR: / = ] trim-tail ] 2dip "https://github.com/%s/%s" sprintf = ;
 441
 442 : git-remote? ( hash -- ? )
 443     { [ github-git-remote? ] [ github-https-remote? ] } 1|| ;
 444
 445 : git-remote-matches? ( hash owner repo -- ? )
 446     { [ github-git-remote-matches? ] [ github-https-remote-matches? ] } 3|| ;
 447
 448 : git-config-path ( -- path )
 449     current-directory get find-git-directory "config" append-path ;
 450
 451 : parse-git-config ( -- seq )
 452     git-config-path utf8 file-contents string>ini >alist ;
 453
 454 : has-any-git-at-urls? ( git-ini -- ? )
 455     [ github-git-remote? ] any-value? ;
 456
 457 : has-remote-repo? ( git-ini owner repo -- ? )
 458     '[ _ _ git-remote-matches? ] filter-values f like ;
 459
 460 : write-git-config ( seq -- )
 461     ini>string git-config-path utf8 set-file-contents ;
 462
 463 : ensure-git-remote ( owner repo -- )
 464     [ parse-git-config ] 2dip
 465     3dup has-remote-repo? [
 466         3drop
 467     ] [
 468         [
 469             pick has-any-git-at-urls? [
 470                 [ "git@github.com:%s/%s" sprintf ]
 471                 [ drop "+refs/heads/*:refs/remotes/%s/*" sprintf ] 2bi
 472                 '{ { "url" _ } { "fetch" _ } } >hashtable
 473             ] [
 474                 [ "https://github.com/%s/%s" sprintf ]
 475                 [ drop "+refs/heads/*:refs/remotes/%s/*" sprintf ] 2bi
 476                 '{ { "url" _ } { "fetch" _ } } >hashtable
 477             ] if
 478         ] 2keep "_" glue "\"" dup surround "remote " prepend swap 2array
 479         suffix write-git-config
 480     ] if ;
 481
 482 : ensure-pr-remote ( pr-json -- )
 483     "head" of "repo" of "full_name" of "/" split first2 ensure-git-remote ;