extra/git/git.factor

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