extra/tar/tar.factor

   1 USING: combinators io io.files io.streams.duplex
   2 io.streams.string kernel math math.parser
   3 namespaces pack prettyprint sequences strings system ;
   4 USING: hexdump tools.interpreter ;
   5 IN: tar
   6
   7 : zero-checksum 256 ;
   8
   9 TUPLE: tar-header name mode uid gid size mtime checksum typeflag
  10 linkname magic version uname gname devmajor devminor prefix ;
  11
  12 : <tar-header> ( -- obj ) tar-header construct-empty ;
  13
  14 : tar-trim ( seq -- newseq )
  15     [ "\0 " member? ] trim ;
  16
  17 : read-tar-header ( -- obj )
  18     <tar-header>
  19     100 read-c-string* over set-tar-header-name
  20     8 read-c-string* tar-trim oct> over set-tar-header-mode
  21     8 read-c-string* tar-trim oct> over set-tar-header-uid
  22     8 read-c-string* tar-trim oct> over set-tar-header-gid
  23     12 read-c-string* tar-trim oct> over set-tar-header-size
  24     12 read-c-string* tar-trim oct> over set-tar-header-mtime
  25     8 read-c-string* tar-trim oct> over set-tar-header-checksum
  26     read1 over set-tar-header-typeflag
  27     100 read-c-string* over set-tar-header-linkname
  28     6 read over set-tar-header-magic
  29     2 read over set-tar-header-version
  30     32 read-c-string* over set-tar-header-uname
  31     32 read-c-string* over set-tar-header-gname
  32     8 read tar-trim oct> over set-tar-header-devmajor
  33     8 read tar-trim oct> over set-tar-header-devminor
  34     155 read-c-string* over set-tar-header-prefix ;
  35
  36 : header-checksum ( seq -- x )
  37     148 swap cut-slice 8 tail-slice
  38     [ 0 [ + ] reduce ] 2apply + 256 + ;
  39
  40 TUPLE: checksum-error ;
  41 TUPLE: malformed-block-error ;
  42
  43 SYMBOL: base-dir
  44 SYMBOL: out-stream
  45 SYMBOL: filename
  46
  47 : (read-data-blocks) ( tar-header -- )
  48     512 read [
  49         over tar-header-size dup 512 <= [
  50             head-slice
  51             >string write
  52             drop
  53         ] [
  54             drop
  55             >string write
  56             dup tar-header-size 512 - over set-tar-header-size
  57             (read-data-blocks)
  58         ] if
  59     ] [
  60         drop
  61     ] if* ;
  62
  63 : read-data-blocks ( tar-header out -- )
  64     >r stdio get r> <duplex-stream> [
  65         (read-data-blocks)
  66     ] with-stream* ;
  67
  68 : parse-tar-header ( seq -- obj )
  69     [ header-checksum ] keep over zero-checksum = [
  70         2drop
  71         \ tar-header construct-empty
  72         0 over set-tar-header-size
  73         0 over set-tar-header-checksum
  74     ] [
  75         [ read-tar-header ] string-in
  76         [ tar-header-checksum = [
  77                 \ checksum-error construct-empty throw
  78             ] unless
  79         ] keep
  80     ] if ;
  81
  82 TUPLE: unknown-typeflag str ;
  83 : <unknown-typeflag> ( ch -- obj )
  84     1string \ unknown-typeflag construct-boa ;
  85
  86 TUPLE: unimplemented-typeflag header ;
  87 : <unimplemented-typeflag> ( header -- obj )
  88     global [ "Unimplemented typeflag: " print dup . flush ] bind
  89     tar-header-typeflag
  90     1string \ unimplemented-typeflag construct-boa ;
  91
  92 : tar-path+ ( path -- newpath )
  93     base-dir get swap path+ ;
  94
  95 ! Normal file
  96 : typeflag-0
  97   tar-header-name tar-path+ <file-writer>
  98   [ read-data-blocks ] keep stream-close ;
  99
 100 ! Hard link
 101 : typeflag-1 ( header -- )
 102    <unimplemented-typeflag> throw ;
 103
 104 ! Symlink
 105 : typeflag-2 ( header -- )
 106     <unimplemented-typeflag> throw ;
 107
 108 ! character special
 109 : typeflag-3 ( header -- )
 110     <unimplemented-typeflag> throw ;
 111
 112 ! Block special
 113 : typeflag-4 ( header -- )
 114     <unimplemented-typeflag> throw ;
 115
 116 ! Directory
 117 : typeflag-5 ( header -- )
 118     tar-header-name tar-path+ make-directories ;
 119
 120 ! FIFO
 121 : typeflag-6 ( header -- )
 122     <unimplemented-typeflag> throw ;
 123
 124 ! Contiguous file
 125 : typeflag-7 ( header -- )
 126     <unimplemented-typeflag> throw ;
 127
 128 ! Global extended header
 129 : typeflag-8 ( header -- )
 130     <unimplemented-typeflag> throw ;
 131
 132 ! Extended header
 133 : typeflag-9 ( header -- )
 134     <unimplemented-typeflag> throw ;
 135
 136 ! Global POSIX header
 137 : typeflag-g ( header -- )
 138     <unimplemented-typeflag> throw ;
 139
 140 ! Extended POSIX header
 141 : typeflag-x ( header -- )
 142     <unimplemented-typeflag> throw ;
 143
 144 ! Solaris access control list
 145 : typeflag-A ( header -- )
 146     <unimplemented-typeflag> throw ;
 147
 148 ! GNU dumpdir
 149 : typeflag-D ( header -- )
 150     <unimplemented-typeflag> throw ;
 151
 152 ! Solaris extended attribute file
 153 : typeflag-E ( header -- )
 154     <unimplemented-typeflag> throw ;
 155
 156 ! Inode metadata
 157 : typeflag-I ( header -- )
 158     <unimplemented-typeflag> throw ;
 159
 160 ! Long link name
 161 : typeflag-K ( header -- )
 162     <unimplemented-typeflag> throw ;
 163
 164 ! Long file name
 165 : typeflag-L ( header -- )
 166     <string-writer> [ read-data-blocks ] keep
 167     >string [ CHAR: \0 = ] rtrim filename set
 168     global [ "long filename: " write filename get . flush ] bind
 169     filename get tar-path+ make-directories ;
 170
 171 ! Multi volume continuation entry
 172 : typeflag-M ( header -- )
 173     <unimplemented-typeflag> throw ;
 174
 175 ! GNU long file name
 176 : typeflag-N ( header -- )
 177     <unimplemented-typeflag> throw ;
 178
 179 ! Sparse file
 180 : typeflag-S ( header -- )
 181     <unimplemented-typeflag> throw ;
 182
 183 ! Volume header
 184 : typeflag-V ( header -- )
 185     <unimplemented-typeflag> throw ;
 186
 187 ! Vendor extended header type
 188 : typeflag-X ( header -- )
 189     <unimplemented-typeflag> throw ;
 190
 191 : (parse-tar) ( -- )
 192     512 read
 193     global [ dup hexdump. flush ] bind
 194     [
 195         parse-tar-header
 196         ! global [ dup tar-header-name [ print flush ] when* ] bind
 197         dup tar-header-typeflag
 198         {
 199             { CHAR: \0 [ typeflag-0 ] }
 200             { CHAR: 0 [ typeflag-0 ] }
 201             { CHAR: 1 [ typeflag-1 ] }
 202             { CHAR: 2 [ typeflag-2 ] }
 203             { CHAR: 3 [ typeflag-3 ] }
 204             { CHAR: 4 [ typeflag-4 ] }
 205             { CHAR: 5 [ typeflag-5 ] }
 206             { CHAR: 6 [ typeflag-6 ] }
 207             { CHAR: 7 [ typeflag-7 ] }
 208             { CHAR: g [ typeflag-g ] }
 209             { CHAR: x [ typeflag-x ] }
 210             { CHAR: A [ typeflag-A ] }
 211             { CHAR: D [ typeflag-D ] }
 212             { CHAR: E [ typeflag-E ] }
 213             { CHAR: I [ typeflag-I ] }
 214             { CHAR: K [ typeflag-K ] }
 215             { CHAR: L [ typeflag-L ] }
 216             { CHAR: M [ typeflag-M ] }
 217             { CHAR: N [ typeflag-N ] }
 218             { CHAR: S [ typeflag-S ] }
 219             { CHAR: V [ typeflag-V ] }
 220             { CHAR: X [ typeflag-X ] }
 221             [ <unknown-typeflag> throw ]
 222         } case
 223         ! dup tar-header-size zero? [
 224             ! out-stream get [ stream-close ] when
 225             ! out-stream off
 226             ! drop
 227         ! ] [
 228             ! dup tar-header-name
 229             ! dup parent-dir base-dir swap path+
 230             ! global [ dup [ . flush ] when* ] bind
 231             ! make-directories <file-writer>
 232             ! out-stream set
 233             ! read-tar-blocks
 234         ! ] if
 235         (parse-tar)
 236     ] when* ;
 237
 238 : parse-tar ( path -- obj )
 239     <file-reader> [
 240         "tar-test" resource-path base-dir set
 241         global [ nl nl nl "Starting to parse .tar..." print flush ] bind
 242         global [ "Expanding to: " write base-dir get . flush ] bind
 243         (parse-tar)
 244     ] with-stream ;
 245