path: root/stdlib/source/library/lux/data/format/tar.lux

(.module:
  [library
   [lux {"-" [Mode Name and]}
    [abstract
     [monad {"+" [do]}]]
    [control
     [pipe {"+" [case>]}]
     ["." try {"+" [Try]}]
     ["." exception {"+" [exception:]}]
     ["<>" parser
      ["<.>" binary {"+" [Parser]}]]]
    [data
     ["." product]
     ["." binary {"+" [Binary]}]
     ["." text {"+" [Char]}
      ["%" format {"+" [format]}]
      [encoding
       ["." utf8]]]
     ["." format "_"
      ["#" binary {"+" [Writer]} ("#\." monoid)]]
     [collection
      ["." list ("#\." mix)]
      ["." row {"+" [Row]} ("#\." mix)]]]
    [math
     ["." number
      ["n" nat]
      ["." i64]]]
    [time
     ["." instant {"+" [Instant]}]
     ["." duration]]
    [world
     ["." file]]
    [type
     abstract]]])

(type: Size
  Nat)

(def: octal_size
  Size
  8)

(def: (octal_padding max_size number)
  (-> Size Text Text)
  (let [padding_size (n.- (text.size number)
                          max_size)
        padding (|> "0"
                    (list.repeated padding_size)
                    text.together)]
    (format padding number)))

(def: blank " ")
(def: null text.null)

(def: small_size Size 6)
(def: big_size Size 11)

(template [<exception> <limit> <size>
           <type> <in> <out> <writer> <suffix>
           <coercion>]
  [(def: .public <limit>
     Nat
     (|> ..octal_size
         (list.repeated <size>)
         (list\mix n.* 1)
         ++))

   (exception: .public (<exception> {value Nat})
     (exception.report
      ["Value" (%.nat value)]
      ["Maximum" (%.nat (-- <limit>))]))

   (abstract: .public <type>
     {}
     
     Nat

     (def: .public (<in> value)
       (-> Nat (Try <type>))
       (if (n.< <limit> value)
         (#try.Success (:abstraction value))
         (exception.except <exception> [value])))

     (def: .public <out>
       (-> <type> Nat)
       (|>> :representation))

     (def: <writer>
       (Writer <type>)
       (let [suffix <suffix>
             padded_size (n.+ (text.size suffix) <size>)]
         (|>> :representation
              (\ n.octal encoded)
              (..octal_padding <size>)
              (text.suffix suffix)
              (\ utf8.codec encoded)
              (format.segment padded_size))))

     (def: <coercion>
       (-> Nat <type>)
       (|>> (n.% <limit>)
            :abstraction))
     )]

  [not_a_small_number small_limit ..small_size
   Small small from_small
   small_writer (format ..blank ..null)
   as_small]
  [not_a_big_number big_limit ..big_size
   Big big from_big
   big_writer ..blank
   as_big]
  )

(exception: .public (wrong_character {expected Char} {actual Char})
  (exception.report
   ["Expected" (%.nat expected)]
   ["Actual" (%.nat actual)]))

(def: small_suffix
  (Parser Any)
  (do <>.monad
    [pre_end <binary>.bits/8
     end <binary>.bits/8
     _ (let [expected (`` (char (~~ (static ..blank))))]
         (<>.assertion (exception.error ..wrong_character [expected pre_end])
                       (n.= expected pre_end)))
     _ (let [expected (`` (char (~~ (static ..null))))]
         (<>.assertion (exception.error ..wrong_character [expected end])
                       (n.= expected end)))]
    (in [])))

(def: small_parser
  (Parser Small)
  (do <>.monad
    [digits (<binary>.segment ..small_size)
     digits (<>.lifted (\ utf8.codec decoded digits))
     _ ..small_suffix]
    (<>.lifted
     (do {! try.monad}
       [value (\ n.octal decoded digits)]
       (..small value)))))

(def: big_parser
  (Parser Big)
  (do <>.monad
    [digits (<binary>.segment ..big_size)
     digits (<>.lifted (\ utf8.codec decoded digits))
     end <binary>.bits/8
     _ (let [expected (`` (char (~~ (static ..blank))))]
         (<>.assertion (exception.error ..wrong_character [expected end])
                       (n.= expected end)))]
    (<>.lifted
     (do {! try.monad}
       [value (\ n.octal decoded digits)]
       (..big value)))))

(abstract: Checksum
  {}
  
  Text

  (def: from_checksum
    (-> Checksum Text)
    (|>> :representation))

  (def: dummy_checksum
    Checksum
    (:abstraction "        "))

  (def: checksum_suffix
    (format ..blank ..null))

  (def: checksum
    (-> Binary Nat)
    (binary.aggregate n.+ 0))

  (def: checksum_checksum
    (|> ..dummy_checksum
        :representation
        (\ utf8.codec encoded)
        ..checksum))

  (def: checksum_code
    (-> Binary Checksum)
    (|>> ..checksum
         ..as_small
         ..from_small
         (\ n.octal encoded)
         (..octal_padding ..small_size)
         (text.suffix ..checksum_suffix)
         :abstraction))

  (def: checksum_writer
    (Writer Checksum)
    (let [padded_size (n.+ (text.size ..checksum_suffix)
                           ..small_size)]
      (|>> :representation
           (\ utf8.codec encoded)
           (format.segment padded_size))))

  (def: checksum_parser
    (Parser [Nat Checksum])
    (do <>.monad
      [ascii (<binary>.segment ..small_size)
       digits (<>.lifted (\ utf8.codec decoded ascii))
       _ ..small_suffix
       value (<>.lifted
              (\ n.octal decoded digits))]
      (in [value
           (:abstraction (format digits ..checksum_suffix))])))
  )

(def: last_ascii
  Char
  (number.hex "007F"))

(def: ascii?
  (-> Text Bit)
  (|>> (\ utf8.codec encoded)
       (binary.aggregate (function (_ char verdict)
                           (.and verdict
                                 (n.<= ..last_ascii char)))
                         true)))

(exception: .public (not_ascii {text Text})
  (exception.report
   ["Text" (%.text text)]))

(def: .public name_size Size 31)
(def: .public path_size Size 99)

(def: (un_padded string)
  (-> Binary (Try Binary))
  (case (binary.size string)
    0 (#try.Success string)
    size (loop [end (-- size)]
           (case end
             0 (#try.Success (\ utf8.codec encoded ""))
             _ (do try.monad
                 [last_char (binary.read/8! end string)]
                 (`` (case (.nat last_char)
                       (^ (char (~~ (static ..null))))
                       (recur (-- end))

                       _
                       (binary.slice 0 (++ end) string))))))))

(template [<type> <representation> <size> <exception> <in> <out> <writer> <parser> <none>]
  [(abstract: .public <type>
     {}
     
     <representation>

     (exception: .public (<exception> {value Text})
       (exception.report
        ["Value" (%.text value)]
        ["Size" (%.nat (text.size value))]
        ["Maximum" (%.nat <size>)]))

     (def: .public (<in> value)
       (-> <representation> (Try <type>))
       (if (..ascii? value)
         (if (|> value
                 (\ utf8.codec encoded)
                 binary.size
                 (n.> <size>))
           (exception.except <exception> [value])
           (#try.Success (:abstraction value)))
         (exception.except ..not_ascii [value])))

     (def: .public <out>
       (-> <type> <representation>)
       (|>> :representation))

     (def: <writer>
       (Writer <type>)
       (let [suffix ..null
             padded_size (n.+ (text.size suffix) <size>)]
         (|>> :representation
              (text.suffix suffix)
              (\ utf8.codec encoded)
              (format.segment padded_size))))

     (def: <parser>
       (Parser <type>)
       (do <>.monad
         [string (<binary>.segment <size>)
          end <binary>.bits/8
          .let [expected (`` (char (~~ (static ..null))))]
          _ (<>.assertion (exception.error ..wrong_character [expected end])
                          (n.= expected end))]
         (<>.lifted
          (do {! try.monad}
            [ascii (..un_padded string)
             text (\ utf8.codec decoded ascii)]
            (<in> text)))))

     (def: .public <none>
       <type>
       (try.trusted (<in> "")))
     )]

  [Name Text      ..name_size name_is_too_long name from_name name_writer name_parser anonymous]
  [Path file.Path ..path_size path_is_too_long path from_path path_writer path_parser no_path]
  )

(def: magic_size Size 7)

(abstract: Magic
  {}
  
  Text

  (def: ustar (:abstraction "ustar  "))

  (def: from_magic
    (-> Magic Text)
    (|>> :representation))

  (def: magic_writer
    (Writer Magic)
    (let [padded_size (n.+ (text.size ..null)
                           ..magic_size)]
      (|>> :representation
           (\ utf8.codec encoded)
           (format.segment padded_size))))

  (def: magic_parser
    (Parser Magic)
    (do <>.monad
      [string (<binary>.segment ..magic_size)
       end <binary>.bits/8
       .let [expected (`` (char (~~ (static ..null))))]
       _ (<>.assertion (exception.error ..wrong_character [expected end])
                       (n.= expected end))]
      (<>.lifted
       (\ try.monad each (|>> :abstraction)
          (\ utf8.codec decoded string)))))
  )

(def: block_size Size 512)

(def: owner_id_size ..small_size)

(def: blank_size Size (text.size ..blank))
(def: null_size Size (text.size ..null))
(def: mode_size Size ..small_size)
(def: content_size Size ..big_size)
(def: modification_time_size Size ..big_size)
(def: checksum_size Size ..small_size)
(def: link_flag_size Size 1)
(def: device_size Size ..small_size)

(def: small_number
  (-> Size Size)
  (|>> ($_ n.+ ..blank_size ..null_size)))

(def: big_number
  (-> Size Size)
  (|>> ($_ n.+ ..blank_size)))

(def: string
  (-> Size Size)
  (|>> ($_ n.+ ..null_size)))

(def: header_size
  ($_ n.+
      ... name
      (..string ..path_size)
      ... mode
      (..small_number ..mode_size)
      ... uid
      (..small_number ..owner_id_size)
      ... gid
      (..small_number ..owner_id_size)
      ... size
      (..big_number ..content_size)
      ... mtime
      (..big_number ..modification_time_size)
      ... chksum
      (..small_number ..checksum_size)
      ... linkflag
      ..link_flag_size
      ... linkname
      (..string ..path_size)
      ... magic
      (..string ..magic_size)
      ... uname
      (..string ..name_size)
      ... gname
      (..string ..name_size)
      ... devmajor
      (..small_number ..device_size)
      ... devminor
      (..small_number ..device_size)))

(abstract: Link_Flag
  {}
  
  Char

  (def: link_flag
    (-> Link_Flag Char)
    (|>> :representation))

  (def: link_flag_writer
    (Writer Link_Flag)
    (|>> :representation
         format.bits/8))

  (with_expansions [<options> (as_is [0 old_normal]
                                     [(char "0") normal]
                                     [(char "1") link]
                                     [(char "2") symbolic_link]
                                     [(char "3") character]
                                     [(char "4") block]
                                     [(char "5") directory]
                                     [(char "6") fifo]
                                     [(char "7") contiguous])]
    (template [<flag> <name>]
      [(def: <name>
         Link_Flag
         (:abstraction <flag>))]

      <options>
      )

    (exception: .public (invalid_link_flag {value Nat})
      (exception.report
       ["Value" (%.nat value)]))

    (def: link_flag_parser
      (Parser Link_Flag)
      (do <>.monad
        [linkflag <binary>.bits/8]
        (case (.nat linkflag)
          (^template [<value> <link_flag>]
            [(^ <value>)
             (in <link_flag>)])
          (<options>)

          _
          (<>.lifted
           (exception.except ..invalid_link_flag [(.nat linkflag)]))))))
  )

(abstract: .public Mode
  {}
  
  Nat

  (def: .public mode
    (-> Mode Nat)
    (|>> :representation))

  (def: .public (and left right)
    (-> Mode Mode Mode)
    (:abstraction
     (i64.or (:representation left)
             (:representation right))))

  (def: mode_writer
    (Writer Mode)
    (|>> :representation
         ..small
         try.trusted
         ..small_writer))

  (exception: .public (invalid_mode {value Nat})
    (exception.report
     ["Value" (%.nat value)]))

  (with_expansions [<options> (as_is ["0000" none]
                                     
                                     ["0001" execute_by_other]
                                     ["0002" write_by_other]
                                     ["0004" read_by_other]

                                     ["0010" execute_by_group]
                                     ["0020" write_by_group]
                                     ["0040" read_by_group]

                                     ["0100" execute_by_owner]
                                     ["0200" write_by_owner]
                                     ["0400" read_by_owner]

                                     ["1000" save_text]
                                     ["2000" set_group_id_on_execution]
                                     ["4000" set_user_id_on_execution])]
    (template [<code> <name>]
      [(def: .public <name>
         Mode
         (:abstraction (number.oct <code>)))]

      <options>
      )

    (def: maximum_mode
      Mode
      ($_ and
          ..none
          
          ..execute_by_other
          ..write_by_other
          ..read_by_other

          ..execute_by_group
          ..write_by_group
          ..read_by_group

          ..execute_by_owner
          ..write_by_owner
          ..read_by_owner

          ..save_text
          ..set_group_id_on_execution
          ..set_user_id_on_execution
          ))

    (def: mode_parser
      (Parser Mode)
      (do {! <>.monad}
        [value (\ ! each ..from_small ..small_parser)]
        (if (n.> (:representation ..maximum_mode)
                 value)
          (<>.lifted
           (exception.except ..invalid_mode [value]))
          (in (:abstraction value))))))
  )

(def: maximum_content_size
  Nat
  (|> ..octal_size
      (list.repeated ..content_size)
      (list\mix n.* 1)))

(abstract: .public Content
  {}
  
  [Big Binary]

  (def: .public (content content)
    (-> Binary (Try Content))
    (do try.monad
      [size (..big (binary.size content))]
      (in (:abstraction [size content]))))

  (def: from_content
    (-> Content [Big Binary])
    (|>> :representation))

  (def: .public data
    (-> Content Binary)
    (|>> :representation product.right))
  )

(type: .public ID
  Small)

(def: .public no_id
  ID
  (..as_small 0))

(type: .public Owner
  (Record
   [#name Name
    #id ID]))

(type: .public Ownership
  (Record
   [#user Owner
    #group Owner]))

(type: .public File
  [Path Instant Mode Ownership Content])

(type: .public Normal File)
(type: .public Symbolic_Link Path)
(type: .public Directory Path)
(type: .public Contiguous File)

(type: .public Entry
  (Variant
   (#Normal ..Normal)
   (#Symbolic_Link ..Symbolic_Link)
   (#Directory ..Directory)
   (#Contiguous ..Contiguous)))

(type: Device
  Small)

(def: no_device
  Device
  (try.trusted (..small 0)))

(type: .public Tar
  (Row Entry))

(def: (blocks size)
  (-> Big Nat)
  (n.+ (n./ ..block_size
            (..from_big size))
       (case (n.% ..block_size (..from_big size))
         0 0
         _ 1)))

(def: rounded_content_size
  (-> Big Nat)
  (|>> ..blocks
       (n.* ..block_size)))

(type: Header
  (Record
   [#path Path
    #mode Mode
    #user_id ID
    #group_id ID
    #size Big
    #modification_time Big
    #checksum Checksum
    #link_flag Link_Flag
    #link_name Path
    #magic Magic
    #user_name Name
    #group_name Name
    #major_device Device
    #minor_device Device]))

(def: header_writer'
  (Writer Header)
  ($_ format.and
      ..path_writer
      ..mode_writer
      ..small_writer
      ..small_writer
      ..big_writer
      ..big_writer
      ..checksum_writer
      ..link_flag_writer
      ..path_writer
      ..magic_writer
      ..name_writer
      ..name_writer
      ..small_writer
      ..small_writer
      ))

(def: (header_writer header)
  (Writer Header)
  (let [checksum (|> header
                     (with@ #checksum ..dummy_checksum)
                     (format.result ..header_writer')
                     ..checksum_code)]
    (|> header
        (with@ #checksum checksum)
        (format.result ..header_writer')
        (format.segment ..block_size))))

(def: modification_time
  (-> Instant Big)
  (|>> instant.relative
       (duration.ticks duration.second)
       .nat
       ..as_big))

(def: (file_writer link_flag)
  (-> Link_Flag (Writer File))
  (function (_ [path modification_time mode ownership content])
    (let [[size content] (..from_content content)
          writer ($_ format.and
                     ..header_writer
                     (format.segment (..rounded_content_size size)))]
      (writer [[#path path
                #mode mode
                #user_id (value@ [#user #id] ownership)
                #group_id (value@ [#group #id] ownership)
                #size size
                #modification_time (..modification_time modification_time)
                #checksum ..dummy_checksum
                #link_flag link_flag
                #link_name ..no_path
                #magic ..ustar
                #user_name (value@ [#user #name] ownership)
                #group_name (value@ [#group #name] ownership)
                #major_device ..no_device
                #minor_device ..no_device]
               content]))))

(def: normal_file_writer
  (Writer File)
  (..file_writer ..normal))

(def: contiguous_file_writer
  (Writer File)
  (..file_writer ..contiguous))

(def: (symbolic_link_writer path)
  (Writer Path)
  (..header_writer
   [#path ..no_path
    #mode ..none
    #user_id ..no_id
    #group_id ..no_id
    #size (..as_big 0)
    #modification_time (..as_big 0)
    #checksum ..dummy_checksum
    #link_flag ..symbolic_link
    #link_name path
    #magic ..ustar
    #user_name ..anonymous
    #group_name ..anonymous
    #major_device ..no_device
    #minor_device ..no_device]))

(def: (directory_writer path)
  (Writer Path)
  (..header_writer
   [#path path
    #mode ..none
    #user_id ..no_id
    #group_id ..no_id
    #size (..as_big 0)
    #modification_time (..as_big 0)
    #checksum ..dummy_checksum
    #link_flag ..directory
    #link_name ..no_path
    #magic ..ustar
    #user_name ..anonymous
    #group_name ..anonymous
    #major_device ..no_device
    #minor_device ..no_device]))

(def: entry_writer
  (Writer Entry)
  (|>> (case> (#Normal value) (..normal_file_writer value)
              (#Symbolic_Link value) (..symbolic_link_writer value)
              (#Directory value) (..directory_writer value)
              (#Contiguous value) (..contiguous_file_writer value))))

(def: end_of_archive_size
  Size
  (n.* 2 ..block_size))

(def: .public writer
  (Writer Tar)
  (let [end_of_archive (binary.empty ..end_of_archive_size)]
    (function (_ tar)
      (format\composite (row\mix (function (_ next total)
                                   (format\composite total (..entry_writer next)))
                                 format\identity
                                 tar)
                        (format.segment ..end_of_archive_size end_of_archive)))))

(exception: .public (wrong_checksum {expected Nat} {actual Nat})
  (exception.report
   ["Expected" (%.nat expected)]
   ["Actual" (%.nat actual)]))

(def: header_padding_size
  (n.- header_size block_size))

... When the checksum gets originally calculated, the assumption is that all the characters in the checksum field
... of the header will be spaces.
... This means that just calculating the checksum of the 512 bytes of the header, when reading them, would yield
... an incorrect result, as the contents of the checksum field would be an actual checksum, instead of just spaces.
... To correct for this, it is necessary to calculate the checksum of just the checksum field, subtract that, and then
... add-in the checksum of the spaces.
(def: (expected_checksum checksum header)
  (-> Checksum Binary Nat)
  (let [|checksum| (|> checksum
                       ..from_checksum
                       (\ utf8.codec encoded)
                       ..checksum)]
    (|> (..checksum header)
        (n.- |checksum|)
        (n.+ ..checksum_checksum))))

(def: header_parser
  (Parser Header)
  (do <>.monad
    [binary_header (<>.speculative (<binary>.segment block_size))
     path ..path_parser
     mode ..mode_parser
     user_id ..small_parser
     group_id ..small_parser
     size ..big_parser
     modification_time ..big_parser
     [actual checksum_code] ..checksum_parser
     _ (let [expected (expected_checksum checksum_code binary_header)]
         (<>.lifted
          (exception.assertion ..wrong_checksum [expected actual]
                               (n.= expected actual))))
     link_flag ..link_flag_parser
     link_name ..path_parser
     magic ..magic_parser
     user_name ..name_parser
     group_name ..name_parser
     major_device ..small_parser
     minor_device ..small_parser
     _ (<binary>.segment ..header_padding_size)]
    (in [#path path
         #mode mode
         #user_id user_id
         #group_id group_id
         #size size
         #modification_time modification_time
         #checksum checksum_code
         #link_flag link_flag
         #link_name link_name
         #magic magic
         #user_name user_name
         #group_name group_name
         #major_device major_device
         #minor_device minor_device])))

(exception: .public (wrong_link_flag {expected Link_Flag} {actual Link_Flag})
  (exception.report
   ["Expected" (%.nat (..link_flag expected))]
   ["Actual" (%.nat (..link_flag actual))]))

(def: (file_parser expected)
  (-> Link_Flag (Parser File))
  (do <>.monad
    [header ..header_parser
     _ (<>.assertion (exception.error ..wrong_link_flag [expected (value@ #link_flag header)])
                     (same? expected (value@ #link_flag header)))
     .let [size (value@ #size header)
           rounded_size (..rounded_content_size size)]
     content (<binary>.segment (..from_big size))
     content (<>.lifted (..content content))
     _ (<binary>.segment (n.- (..from_big size) rounded_size))]
    (in [(value@ #path header)
         (|> header
             (value@ #modification_time)
             ..from_big
             .int
             duration.of_millis
             (duration.up (|> duration.second duration.millis .nat))
             instant.absolute)
         (value@ #mode header)
         [#user [#name (value@ #user_name header)
                 #id (value@ #user_id header)]
          #group [#name (value@ #group_name header)
                  #id (value@ #group_id header)]]
         content])))

(def: (file_name_parser expected extractor)
  (-> Link_Flag (-> Header Path) (Parser Path))
  (do <>.monad
    [header ..header_parser
     _ (<>.lifted
        (exception.assertion ..wrong_link_flag [expected (value@ #link_flag header)]
                             (n.= (..link_flag expected)
                                  (..link_flag (value@ #link_flag header)))))]
    (in (extractor header))))

(def: entry_parser
  (Parser Entry)
  ($_ <>.either
      (\ <>.monad each (|>> #..Normal)
         (<>.either (..file_parser ..normal)
                    (..file_parser ..old_normal)))
      (\ <>.monad each (|>> #..Symbolic_Link)
         (..file_name_parser ..symbolic_link (value@ #link_name)))
      (\ <>.monad each (|>> #..Directory)
         (..file_name_parser ..directory (value@ #path)))
      (\ <>.monad each (|>> #..Contiguous)
         (..file_parser ..contiguous))))

... It's safe to implement the parser this way because the range of values for Nat is 2^64
... Whereas the maximum possible value for the checksum of a 512 block is (256 × 512) = 131,072
(def: end_of_archive_block_parser
  (Parser Any)
  (do <>.monad
    [block (<binary>.segment ..block_size)]
    (let [actual (..checksum block)]
      (<>.lifted
       (exception.assertion ..wrong_checksum [0 actual]
                            (n.= 0 actual))))))

(exception: .public invalid_end_of_archive)

(def: end_of_archive_parser
  (Parser Any)
  (do <>.monad
    [_ (<>.at_most 2 end_of_archive_block_parser)
     done? <binary>.end?]
    (<>.lifted
     (exception.assertion ..invalid_end_of_archive []
                          done?))))

(def: .public parser
  (Parser Tar)
  (|> (<>.some entry_parser)
      (\ <>.monad each row.of_list)
      (<>.before ..end_of_archive_parser)))