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

(.require
 [library
  [lux (.except Mode #mode and)
   [ffi (.only)]
   [abstract
    [monad (.only do)]]
   [control
    ["<>" parser]
    ["[0]" pipe]
    ["[0]" try (.only Try)]
    ["[0]" exception (.only Exception)]]
   [data
    ["[0]" product]
    ["[0]" binary (.only Binary)
     ["[1]!" \\unsafe]
     ["[0]" \\format (.only Format) (.use "[1]#[0]" monoid)]
     ["<[1]>" \\parser (.only Parser)]]
    ["[0]" text (.only)
     [char (.only Char)]
     ["%" \\format]
     [encoding
      ["[0]" utf8]]]
    [collection
     ["[0]" list (.use "[1]#[0]" mix)]
     ["[0]" sequence (.only Sequence) (.use "[1]#[0]" mix)]
     [array
      [\\unsafe (.only)]]]]
   [math
    ["[0]" number (.only)
     ["n" nat]
     ["[0]" i64]]]
   [meta
    [macro
     ["^" pattern]]
    [type
     ["[0]" primitive (.except def #name)]]]
   [world
    ["[0]" file]
    [time
     ["[0]" instant (.only Instant)]
     ["[0]" duration]]]]])

(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)

(with_template [<exception> <limit> <size>
                <type> <in> <out> <format> <suffix>
                <coercion>]
  [(def .public <limit>
     Nat
     (|> ..octal_size
         (list.repeated <size>)
         (list#mix n.* 1)
         ++))

   (exception.def .public (<exception> value)
     (Exception Nat)
     (exception.report
      (list ["Value" (%.nat value)]
            ["Maximum" (%.nat (-- <limit>))])))

   (primitive.def .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 <format>
       (Format <type>)
       (let [suffix <suffix>
             padded_size (n.+ (text.size suffix) <size>)]
         (|>> representation
              (at n.octal encoded)
              (..octal_padding <size>)
              (text.suffix suffix)
              (at 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_format (%.format ..blank ..null)
   as_small]
  [not_a_big_number big_limit ..big_size
   Big big from_big
   big_format ..blank
   as_big]
  )

(exception.def .public (wrong_character [expected actual])
  (Exception [Char Char])
  (exception.report
   (list ["Expected" (%.nat expected)]
         ["Actual" (%.nat actual)])))

(def small_suffix
  (Parser Any)
  (do <>.monad
    [pre_end <binary>.bits_8
     _ (let [expected (`` (char (,, (static ..blank))))]
         (<>.assertion (exception.error ..wrong_character [expected pre_end])
                       (n.= expected pre_end)))

     end <binary>.bits_8
     _ (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 (at utf8.codec decoded digits))
     _ ..small_suffix]
    (<>.lifted
     (do [! try.monad]
       [value (at n.octal decoded digits)]
       (..small value)))))

(def big_parser
  (Parser Big)
  (do <>.monad
    [digits (<binary>.segment ..big_size)
     digits (<>.lifted (at 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 (at n.octal decoded digits)]
       (..big value)))))

(primitive.def Checksum
  Text

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

  (def dummy_checksum
    Checksum
    (abstraction "        "))

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

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

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

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

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

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

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

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

(exception.def .public (not_ascii text)
  (Exception Text)
  (exception.report
   (list ["Text" (%.text text)])))

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

(def (un_padded string)
  (-> Binary Binary)
  (when (binary!.size string)
    0
    string
    
    size
    (loop (again [end (-- size)])
      (when end
        0 (at utf8.codec encoded "")
        _ (let [last_char (binary!.bits_8 end string)]
            (`` (when (.nat last_char)
                  (char (,, (static ..null)))
                  (again (-- end))

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

(with_template [<type> <representation> <size> <exception> <in> <out> <format> <parser> <none>]
  [(primitive.def .public <type>
     <representation>

     (exception.def .public (<exception> value)
       (Exception Text)
       (exception.report
        (list ["Value" (%.text value)]
              ["Size" (%.nat (text.size value))]
              ["Maximum" (%.nat <size>)])))

     (def .public (<in> value)
       (-> <representation> (Try <type>))
       (if (..ascii? value)
         (if (|> value
                 (at 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 <format>
       (Format <type>)
       (let [suffix ..null
             padded_size (n.+ (text.size suffix) <size>)]
         (|>> representation
              (text.suffix suffix)
              (at 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]
            [text (at utf8.codec decoded (..un_padded string))]
            (<in> text)))))

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

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

(def magic_size Size 7)

(primitive.def Magic
  Text

  (def ustar
    (abstraction "ustar  "))

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

  (def magic_format
    (Format Magic)
    (let [padded_size (n.+ (text.size ..null)
                           ..magic_size)]
      (|>> representation
           (at 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
       (at try.monad each (|>> abstraction)
           (at 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)
  (|>> (all n.+ ..blank_size ..null_size)))

(def big_number
  (-> Size Size)
  (|>> (all n.+ ..blank_size)))

(def string
  (-> Size Size)
  (|>> (all n.+ ..null_size)))

(def header_size
  (all 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)))

(primitive.def Link_Flag
  Char

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

  (def link_flag_format
    (Format Link_Flag)
    (|>> representation
         \\format.bits_8))

  (with_expansions [<options> (these [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])]
    (with_template [<flag> <name>]
      [(def <name>
         Link_Flag
         (abstraction <flag>))]

      <options>
      )

    (exception.def .public (invalid_link_flag value)
      (Exception Nat)
      (exception.report
       (list ["Value" (%.nat value)])))

    (def link_flag_parser
      (Parser Link_Flag)
      (do <>.monad
        [it <binary>.bits_8]
        (when (.nat it)
          (^.with_template [<value> <link_flag>]
            [<value>
             (in <link_flag>)])
          (<options>)

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

(primitive.def .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_format
    (Format Mode)
    (|>> representation
         ..small
         try.trusted
         ..small_format))

  (exception.def .public (invalid_mode value)
    (Exception Nat)
    (exception.report
     (list ["Value" (%.nat value)])))

  (with_expansions [<options> (these ["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])]
    (with_template [<code> <name>]
      [(def .public <name>
         Mode
         (abstraction (number.oct <code>)))]

      <options>
      )

    (def maximum_mode
      Mode
      (all 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 (at ! 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)))

(primitive.def .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
  (Sequence Entry))

(def (blocks size)
  (-> Big Nat)
  (n.+ (n./ ..block_size
            (..from_big size))
       (when (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_format'
  (Format Header)
  (all \\format.and
       ..path_format
       ..mode_format
       ..small_format
       ..small_format
       ..big_format
       ..big_format
       ..checksum_format
       ..link_flag_format
       ..path_format
       ..magic_format
       ..name_format
       ..name_format
       ..small_format
       ..small_format
       ))

(def (header_format header)
  (Format Header)
  (let [checksum (|> header
                     (has #checksum ..dummy_checksum)
                     (\\format.result ..header_format')
                     ..checksum_code)]
    (|> header
        (has #checksum checksum)
        (\\format.result ..header_format')
        (\\format.segment ..block_size))))

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

(def (file_format link_flag)
  (-> Link_Flag (Format File))
  (function (_ [path modification_time mode ownership content])
    (let [[size content] (..from_content content)
          format (all \\format.and
                      ..header_format
                      (\\format.segment (..rounded_content_size size)))]
      (format [[#path path
                #mode mode
                #user_id (the [#user #id] ownership)
                #group_id (the [#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 (the [#user #name] ownership)
                #group_name (the [#group #name] ownership)
                #major_device ..no_device
                #minor_device ..no_device]
               content]))))

(def normal_file_format
  (Format File)
  (..file_format ..normal))

(def contiguous_file_format
  (Format File)
  (..file_format ..contiguous))

(def (symbolic_link_format path)
  (Format Path)
  (..header_format
   [#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_format path)
  (Format Path)
  (..header_format
   [#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_format
  (Format Entry)
  (|>> (pipe.when
         {#Normal value} (..normal_file_format value)
         {#Symbolic_Link value} (..symbolic_link_format value)
         {#Directory value} (..directory_format value)
         {#Contiguous value} (..contiguous_file_format value))))

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

(def .public format
  (Format Tar)
  (let [end_of_archive (binary!.empty ..end_of_archive_size)]
    (function (_ tar)
      (\\format#composite (sequence#mix (function (_ next total)
                                          (\\format#composite total (..entry_format next)))
                                        \\format#identity
                                        tar)
                          (\\format.segment ..end_of_archive_size end_of_archive)))))

(exception.def .public (wrong_checksum [expected actual])
  (Exception [Nat Nat])
  (exception.report
   (list ["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
                       (at 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])))

(def (file_parser header)
  (-> Header (Parser File))
  (do <>.monad
    [.let [size (the #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 [(the #path header)
         (|> header
             (the #modification_time)
             ..from_big
             .int
             duration.of_millis
             (duration.up (|> duration.second duration.millis .nat))
             instant.absolute)
         (the #mode header)
         [#user [#name (the #user_name header)
                 #id (the #user_id header)]
          #group [#name (the #group_name header)
                  #id (the #group_id header)]]
         content])))

(def entry_parser
  (Parser Entry)
  (do [! <>.monad]
    [header ..header_parser]
    (cond (same? ..contiguous (the #link_flag header))
          (at ! each (|>> {..#Contiguous}) (..file_parser header))

          (same? ..symbolic_link (the #link_flag header))
          (in {..#Symbolic_Link (the #link_name header)})
          
          (same? ..directory (the #link_flag header))
          (in {..#Directory (the #path header)})

          ... (or (same? ..normal (the #link_flag header))
          ...     (same? ..old_normal (the #link_flag header)))
          (at ! each (|>> {..#Normal}) (..file_parser header)))))

... 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.def .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)
      (at <>.monad each sequence.of_list)
      (<>.before ..end_of_archive_parser)))