├── .gitattributes ├── .github └── workflows │ └── main.yml ├── .gitignore ├── .travis.yml ├── CHANGES.md ├── LICENSE.md ├── MAINTAINERS ├── Makefile ├── README.md ├── bin ├── dune └── otar.ml ├── dune-project ├── eio ├── dune ├── tar_eio.ml └── tar_eio.mli ├── lib ├── dune ├── tar.ml ├── tar.mli ├── tar_gz.ml └── tar_gz.mli ├── lib_test ├── allocate_set_partial_test.ml ├── dune ├── global_extended_headers_test.ml ├── long-implicit-dir.tar ├── long-pax.tar ├── long.tar ├── parse_test.ml ├── pax-shenanigans.tar └── write_test.ml ├── mirage ├── dune ├── tar_mirage.ml └── tar_mirage.mli ├── tar-eio.opam ├── tar-eio.opam.template ├── tar-mirage.opam ├── tar-mirage.opam.template ├── tar-unix.opam ├── tar-unix.opam.template ├── tar.opam ├── tar.opam.template ├── test ├── dune └── tarball.t └── unix ├── dune ├── tar_lwt_unix.ml ├── tar_lwt_unix.mli ├── tar_unix.ml └── tar_unix.mli /.gitattributes: -------------------------------------------------------------------------------- 1 | *.tar binary 2 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Main workflow 2 | 3 | on: 4 | pull_request: 5 | push: 6 | schedule: 7 | # Prime the caches every Monday 8 | - cron: 0 1 * * MON 9 | 10 | jobs: 11 | build: 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | os: 16 | - windows-latest 17 | ocaml-compiler: 18 | - 4.14.x 19 | 20 | runs-on: ${{ matrix.os }} 21 | 22 | steps: 23 | - name: Checkout code 24 | uses: actions/checkout@v3 25 | 26 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 27 | uses: ocaml/setup-ocaml@v2 28 | with: 29 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 30 | opam-repositories: | 31 | opam-repository-mingw: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset 32 | default: https://github.com/ocaml/opam-repository.git 33 | opam-local-packages: | 34 | *.opam 35 | !tar-eio.opam 36 | 37 | - run: | 38 | opam depext conf-pkg-config 39 | opam install --deps-only --with-test tar tar-unix tar-mirage 40 | 41 | - run: opam exec -- dune build -p tar,tar-unix,tar-mirage 42 | 43 | - run: opam exec -- dune runtest -p tar,tar-unix,tar-mirage 44 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | *.install 3 | *.merlin 4 | .*.swp 5 | empty 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: false 3 | services: 4 | - docker 5 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh 6 | script: bash -ex ./.travis-docker.sh 7 | env: 8 | global: 9 | - PACKAGE="tar" 10 | - PINS="tar:. tar-unix:. tar-mirage:." 11 | matrix: 12 | - DISTRO="alpine" OCAML_VERSION="4.03" PACKAGE="tar-unix" 13 | - DISTRO="alpine" OCAML_VERSION="4.04" PACKAGE="tar-unix" 14 | - DISTRO="alpine" OCAML_VERSION="4.06" PACKAGE="tar-unix" 15 | - DISTRO="alpine" OCAML_VERSION="4.06" PACKAGE="tar-mirage" 16 | - DISTRO="alpine" OCAML_VERSION="4.07" PACKAGE="tar-mirage" 17 | - DISTRO="alpine" OCAML_VERSION="4.08" PACKAGE="tar-mirage" 18 | - DISTRO="alpine" OCAML_VERSION="4.09" PACKAGE="tar-mirage" 19 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v3.3.0 (2025-03-06) 2 | 3 | - Deprecate `Tar.( let* )` in favor of the new `Tar.Syntax` module (@kit-ty-kate, #167) 4 | - tar-mirage: remove mirage-clock dependency in favor of mirage-ptime (@hannesm, #168) 5 | 6 | ## v3.2.0 (2025-01-20) 7 | 8 | - Fix the Tar monad with Tar_gz and allow the `read` operation (@dinosaure, @BChabanne, @reynir, #161) 9 | - Add `x-maintenance-intent` field into opam files (@hannesm, #162) 10 | - Defaults level per entries to the global level (@reynir, #157) 11 | - Update `Tar_eio` with the last version of `tar` (@patricoferris, #159) 12 | 13 | ## v3.1.2 (2024-09-20) 14 | 15 | - Fix a wrong assumption in `Tar_lwt_unix.run` for `Tar.Really_read _` that one 16 | tar block was always read. This meant that using `Tar.Really_read` with a 17 | size different from 512 would fail. (Reported by @jonahbeckford, review by @hannesm, @reynir, #153) 18 | - Document better the actual behavior of `Tar_unix.extract` and 19 | `Tar_lwt_unix.extract` (@reynir, #155) 20 | 21 | ## v3.1.1 (2024-09-13) 22 | 23 | - Expose `Tar_lwt_unix.run` as we do with `Tar_unix.run` and `Tar_eio.run`. 24 | This was an oversight in v3.0.0. (Reported by @jonahbeckford, @reynir, #150) 25 | 26 | ## v3.0.0 (2024-08-05) 27 | 28 | - Fix `Header.marshal` and the checksum and the length (@reynir, #145) 29 | - Delete a mutable field about the level into the header (@hannesm, #141) 30 | - **BREAKING**: de-functorize the package (@hannesm, @reynir, @dinosaure, #140, #143, #146) 31 | 32 | These PRs attempt to de-functorize `Tar` so that users can implement I/O 33 | themselves, using `Tar`'s own element serialization/deserialization functions 34 | to take advantage of read/write methods. This avoids imposing on the user the 35 | implementation of a module that is too rigid in his/her case (which could have 36 | performance implications). 37 | 38 | `Tar` offers functions for serializing/deserializing tar-specific elements 39 | from `string`. It is then up to the user to know how to obtain or write these 40 | `strings`. 41 | 42 | To this, these PRs add "logics" (see `'a Tar.t`) requiring read and/or write 43 | implementations and describing how to extract all entries from a tar file or 44 | how to write a tar file according to a "dispenser" (like `Seq.to_dispenser`) 45 | of entries. 46 | 47 | These logics do not depend on a particular "scheduler", and these PRs propose 48 | a derivation of these logics with `tar-unix`, `tar-eio` and `tar-mirage`. 49 | These latter derivations mean that the API for these packages has only been 50 | extended, and there are no breaking changes as such. 51 | 52 | These logics also make it easy to offer a compression/decompression layer with 53 | `decompress`, so you can easily manipulate and/or create a .tar.gz file. 54 | 55 | ## v2.6.0 (2023-09-07) 56 | 57 | - Add eio backend for tar in tar-eio (@patricoferris, review by @talex5, @reynir, #132) 58 | - Also apply backwards compatibility fix when GNU LongName is used. The compatibility fix is unfortunately also applied for unknown-to-ocaml-tar link indicators (reported by @gravicappa in #129, @reynir, #133) 59 | - `tar`: support pax Global Extended Headers. This adds state to tar parsing. 60 | (#119, #120, @MisterDA) 61 | - Support GNU LongLink and LongName. Prior, `Tar.HeaderWriter` and 62 | `Tar.HeaderReader` supported both, but `Tar.Header.Link` only had `LongLink` 63 | and (de)serialized to (from) GNU LongName (#127) 64 | - Compatibility level when reading / parsing is removed. Only GNU 65 | LongLink/LongName extensions were affected by the compatibility level when 66 | reading (#127) 67 | - Add module types `Tar.HEADERREADER` and `Tar.HEADERWRITER` describing the 68 | output of `Tar.HeaderReader` and `Tar.HeaderWriter` respectively (#127) 69 | - Types `Tar.READER.t` and `Tar.WRITER.t` are renamed to `io` (#127) 70 | - Add `write_global` function for writing a global PAX extended header (#127) 71 | - Rework IO-specific modules (tar-unix etc.) harmonizing them (#127) 72 | - Avoid exceptions in tar and use result instead. The exceptions 73 | `End_of_stream` and `Checksum_mismatch` are removed (#127) 74 | - Remove the `Tar_cstruct` module as it was unused (#127) 75 | - Remove debug printers (#127) 76 | - Finally remove the unused camlp-streams dependency (#127) 77 | 78 | ## v2.5.1 (2023-06-20) 79 | 80 | - Treat headers with link indicator '0' or '\000' (`Normal`) as directories for backward compatibility (reported in #129, fix by @reynir) 81 | 82 | ## v2.5.0 (2023-06-06) 83 | 84 | - File names and link names are used from PAX headers when parsing (reported by @gravicappa, fixed in #128 by @reynir) 85 | 86 | ## v2.4.0 (2023-03-30) 87 | 88 | - Switch to alcotest for tests (@MisterDA, review by @reynir, #121) 89 | - **BREAKING**: fix ustar magic version. Previously, the version "0\000" was 90 | serialized instead of the correct version "00". This means tar archives may 91 | not be reproducable with older versions. (@reynir, @hannesm, #117 and #122) 92 | - Remove `ppx_cstruct`dependency (@hannesm, review by @reynir, #117) 93 | - Properly skip Pax GlobalExtendedHeaders (@MisterDA, @reynir, #116 and #118) 94 | 95 | ## v2.3.0 (2023-02-09) 96 | 97 | - `tar-mirage`: implement mirage-kv.6.0.0 (@reynir, @hannesm) 98 | 99 | ## v2.2.2 (2022-12-12) 100 | 101 | - `tar-mirage`: fix writing of data when data+tar header is a multiple of `sector_size` greater than 1 (@reynir, review by @hannesm, #100) 102 | 103 | ## v2.2.1 (2022-10-28) 104 | 105 | - `tar-mirage`: fix writing of data, previously the end_of_archive was set 512 bytes short (#99 @hannesm @reynir) 106 | 107 | ## v2.2.0 (2022-10-19) 108 | 109 | - `tar-mirage` requires and implements `mirage-kv.5.0.0` (@hannesm, #96) 110 | - `tar-mirage` implements `Mirage_kv.RW` (append-only) (@hannesm, @reynir, @dinosaure, review by @MisterDA, #93) 111 | - Update usage of `cstruct` in `tar`: unnecessary memsets removed, use `Cstruct.of_string` (@hannesm, #93) 112 | - Fix `tar-mirage` read buffer allocation error (@reynir, review by @hannesm, #94) 113 | - `tar` and `tar-mirage` do not require `re` anymore, `tar-mirage` doesn't depend on `iopage` and works with solo5 and other improvements (@hannesm, review by @reynir, #90) 114 | 115 | ## v2.1.0 (2022-08-31) 116 | 117 | - `tar-mirage` requires `mirage-block.2.0.0` (@kit-ty-kate, #86) 118 | - Remove `io-page-unix` dependency (@hannesm, #87) 119 | - Add GZip support (@dinosaure, #88) 120 | 121 | ## v2.0.1 (2022-03-09) 122 | 123 | - Set `O_CLOEXEC` on opened files and be sure to close opened files 124 | (@MisterDA, @talex5, #83) 125 | - OCaml 5.00 support (add a new dependecy `camlp-stream`) (@Sudha247, #84) 126 | - Missing padding in LongLing 'L' case (@dra27, #82) 127 | 128 | ## v2.0.0 (2021-09-23) 129 | 130 | - Bump lower-bound on Cstruct to 6.0.0 (@MisterDA, @djs55, @dinosaure, #74) 131 | - Update to Dune 2.9 and generate opam files (@MisterDA, @djs55, @dinosaure, #74) 132 | - Support only OCaml versions 4.08 and higher. (@MisterDA, @dinosaure, #77) 133 | - Don't print any logging to stdout or stderr (@MisterDA, @djs55, @dinosaure, #74) 134 | - Remove `Tar.Make.Header`, `Tar_cstruct.Header`, `Tar_unix.Header`, and 135 | `Tar_lwt_unix.Header` to keep only Tar.Header and use it everywhere. 136 | - `Tar.Make.Header.get_next_header` becomes `Tar.Make.get_next_header`; 137 | - `Tar_cstruct.Header.get_next_header` becomes `Tar_cstruct.get_next_header`; 138 | - `Tar_lwt_unix.Header.get_next_header` becomes `Tar_lwt_unix.get_next_header`; 139 | - `Tar_lwt_unix.Header.of_file` becomes `Tar_lwt_unix.header_of_file`; 140 | - `Tar_unix.Header.get_next_header` becomes `Tar_unix.get_next_header`; 141 | - `Tar_unix.Header.of_file` becomes `Tar_unix.header_of_file`; 142 | - All the `Tar_*.Header.t` values have to be changed to `Tar.Header.t`. 143 | (@MisterDA, @dinosaure, #77) 144 | - Fix parsing of pax Extended Header File Times with sub-second 145 | granularity. (@MisterDA, @dinosaure, #77) 146 | - Add `Tar_unix.transform` and `Tar_lwt_unix.transform` to help 147 | transforming headers of a streamed tar archive between two file 148 | descriptors. (@MisterDA, @dinosaure, #77) 149 | - Remove `{build}` tag on the `dune` dependency (@CraigFe, @hannesm, #72) 150 | - Adapt `ocaml-tar` to newer MirageOS interfaces (@hannesm, @dinosaure, #73) 151 | - Update gnu.org link (@reynir, @dinosaure, #79) 152 | - `file_mode` defaults to `0o400` (@reynir, @MisterDA, @dinosaure, #78) 153 | 154 | ## v1.1.0 (2019-04-08) 155 | 156 | - Do not depend on mirage-types, use mirage-kv instead (@hannesm) 157 | - Support mirage-kv 2.0.0 (@hannesm) 158 | - Do not suppress "unused value" warning (@emillon) 159 | - Represent link indicator as a char. This transforms comments into actual code 160 | (@emillon) 161 | 162 | ## v1.0.1 (2019-02-04) 163 | - fix tar-unix build with modern cstruct.lwt (@avsm) 164 | 165 | ## v1.0.0 (2019-02-03) 166 | - port build to dune from builder (@avsm) 167 | - upgrade opam metadata to 2.0 (@avsm) 168 | - remove topkg in favour of dune-release (@avsm) 169 | - use modern `ppx_cstruct` instead of `cstruct.ppx` (#65 @avsm @djs55) 170 | - test with OCaml 4.07 as well (@avsm) 171 | 172 | ## v0.9.0 (2017-11-25) 173 | 174 | - preliminary support for Cstruct.t-backed tar processing (#54 by @hcarty) 175 | - fix build with OCaml 4.06.0 (and `-safe-string`) 176 | 177 | ## v0.8.0 (2017-05-09) 178 | 179 | - split into 3 packages: `tar`, `tar-unix`, `tar-mirage` 180 | - use jbuilder for building 181 | - add support for reading @LongLink headers 182 | - mark deprecated functions with @@ocaml.deprecated 183 | - fix some warnings 184 | 185 | ## v0.7.1 (2017-02-03) 186 | 187 | - convert build system to topkg (#43, @hannesm) 188 | 189 | ## v0.7.0 (2017-01-19) 190 | 191 | - Build against MirageOS version 3, and drop support for earlier versions. 192 | - Support only OCaml versions 4.03 and higher. 193 | 194 | ## v0.6.1 (2016-09-30) 195 | 196 | - fix a bug in the key=value interface when the archive isn't a multiple 197 | of 4KiB in size 198 | 199 | ## v0.6.0 (2016-09-19) 200 | 201 | - support for pax headers 202 | - removed Tar.Archive.fold: please use HeaderReader instead 203 | 204 | ## v0.5.1 (2016-08-30) 205 | 206 | - handle EINTR and short writes properly (@ivg) 207 | - avoid a warning catching `Failure` exceptions from `int_of_string` 208 | 209 | ## v0.5.0 (2016-04-24) 210 | 211 | - now requires cstruct >= 1.9.0 and OCaml 4.02+ 212 | 213 | ## v0.4.2 (2016-04-22) 214 | 215 | - test: only run tests if mirage-block-unix is present 216 | - improve the opam file 217 | - travis: simplify the configuration 218 | 219 | ## v0.4.1 (2015-07-21) 220 | 221 | - fix Tar_mirage when using block devices with < 4096 byte 222 | sectors 223 | 224 | ## v0.4.0 (2015-07-19) 225 | 226 | - add tar.mirage in ocamlfind, containing Tar_mirage which 227 | exposes a BLOCK device as a KV_RO 228 | 229 | ## v0.3.0 (2015-04-06) 230 | 231 | - add Tar.Make functor which allows easier integration with 232 | camlzip 233 | - always initialise tar header unused bytes to 0 (previously 234 | would use uninitialised data) 235 | - modernise Travis CI scripts to use OPAM 1.2 workflow. 236 | 237 | ## v0.2.1 (2013-11-15) 238 | 239 | - Re-add some old deprecated functions 240 | 241 | ## v0.2.0 (2013-10-13) 242 | 243 | - Add 'Tar.Archive.fold' for folding over entries in an archive 244 | 245 | ## v0.1.1 (2013-10-03) 246 | 247 | - Rename ocamlfind package from 'ocaml-tar' to simply 'tar' 248 | 249 | ## v0.1.0 (2013-10-03) 250 | 251 | - Initial release 252 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | ## ISC License 2 | 3 | Copyright (c) 2012-2018 The ocaml-tar contributors 4 | 5 | Permission to use, copy, modify, and/or distribute this software for any 6 | purpose with or without fee is hereby granted, provided that the above 7 | copyright notice and this permission notice appear in all copies. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | -------------------------------------------------------------------------------- /MAINTAINERS: -------------------------------------------------------------------------------- 1 | How to submit changes to this project 2 | ===================================== 3 | 4 | Please submit changes as pull requests to the repository on github. 5 | Please ensure that all changes have descriptive commit comments and 6 | include a Signed-off-by: line. 7 | 8 | Maintainers list 9 | ---------------- 10 | 11 | * Thomas Gazagnaire 12 | * David Scott 13 | * Jonathan Ludlam 14 | * Romain Calascibetta 15 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build clean test install uninstall 2 | 3 | build: 4 | dune build 5 | 6 | test: 7 | dune runtest 8 | 9 | install: 10 | dune install 11 | 12 | uninstall: 13 | dune uninstall 14 | 15 | clean: 16 | dune clean 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## tar — decode and encode tar files 2 | 3 | [![OCaml-CI Build Status](https://img.shields.io/endpoint?url=https://ci.ocamllabs.io/badge/mirage/ocaml-tar/main&logo=ocaml)](https://ci.ocamllabs.io/github/mirage/ocaml-tar) 4 | [![GitHub Actions Build Status](https://github.com/mirage/ocaml-tar/actions/workflows/main.yml/badge.svg?branch=main)](https://github.com/mirage/ocaml-tar/actions) 5 | 6 | tar is a simple library to read and write tar files with an emphasis on 7 | streaming. 8 | 9 | This is pure OCaml code, no C bindings. 10 | 11 | ## Installation 12 | 13 | `tar` can be installed with `opam`: 14 | 15 | opam install tar 16 | opam install tar-unix # for use in Unix/Lwt 17 | opam install tar-mirage # for use in MirageOS 18 | 19 | If you don't use `opam` consult the [`tar.opam`](tar.opam) file for build 20 | instructions. 21 | 22 | ## Example toplevel session 23 | 24 | In utop: 25 | ``` 26 | utop # #require "tar";; 27 | utop # #require "tar-unix";; 28 | 29 | utop # let f = Lwt_unix.openfile "/tmp/foo.tar" [ Unix.O_RDONLY ] 0;; 30 | val f : Lwt_unix.file_descr = 31 | 32 | utop # Lwt.bind f Tar_lwt_unix.Archive.list;; 33 | [{Tar.Header.file_name = "_build/lib/tar.mli.depends"; 34 | Tar.Header.file_mode = 420; Tar.Header.user_id = 1000; 35 | Tar.Header.group_id = 1000; Tar.Header.file_size = 21L; 36 | Tar.Header.mod_time = 1381080315L; 37 | Tar.Header.link_indicator = Tar.Header.Link.Normal; 38 | Tar.Header.link_name = ""}; 39 | {Tar.Header.file_name = "_build/lib/tar_unix.mli.depends"; 40 | Tar.Header.file_mode = 420; Tar.Header.user_id = 1000; 41 | Tar.Header.group_id = 1000; Tar.Header.file_size = 27L; 42 | Tar.Header.mod_time = 1381080318L; 43 | Tar.Header.link_indicator = Tar.Header.Link.Normal; 44 | Tar.Header.link_name = ""}; 45 | {Tar.Header.file_name = "_build/lib/tar.mllib"; 46 | Tar.Header.file_mode = ...; Tar.Header.user_id = ...; 47 | Tar.Header.group_id = ...; Tar.Header.file_size = ...; 48 | Tar.Header.mod_time = ...; Tar.Header.link_indicator = ...; 49 | Tar.Header.link_name = ...}; 50 | ...] 51 | ``` 52 | 53 | ## Compressed _tarball_ 54 | 55 | The distribution gives a small implementation to create a _tarball_, a 56 | compressed archive. The software allows to list the contents of a given 57 | tarball. The compression is done with [decompress][]. You can look at 58 | the project documentation for more information on how to compress. 59 | 60 | Alternatively, it is possible to use the `Tar_gz` module which offers the same 61 | interface as `Tar` with compression. 62 | 63 | [decompress]: https://github.com/mirage/decompress 64 | 65 | ## Example users 66 | 67 | This library is used by 68 | * [xapi](https://github.com/xapi-project/xen-api) to read and write VM images; 69 | * [obuilder](https://github.com/ocurrent/obuilder) to copy files extensively. 70 | 71 | ## Documentation 72 | 73 | The documentation and API reference is automatically generated by 74 | `odoc` from the interfaces. It can be consulted [online][2]. 75 | 76 | [2]: https://mirage.github.io/ocaml-tar/ 77 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name otar) 3 | (public_name otar) 4 | (package tar-unix) 5 | (libraries unix tar.gz tar_unix)) 6 | -------------------------------------------------------------------------------- /bin/otar.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2022 Romain Calascibetta 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Tar.Syntax 18 | 19 | let () = Printexc.record_backtrace true 20 | 21 | let ( / ) = Filename.concat 22 | 23 | let contents_of_path path = 24 | let fd = ref `None in 25 | let buf = Bytes.create 0x100 in 26 | let rec dispenser () = match !fd with 27 | | `Closed -> Tar.return (Ok None) 28 | | `None -> 29 | let fd' = Unix.openfile path Unix.[ O_RDONLY; O_CLOEXEC ] 0o644 in 30 | fd := `Active fd'; 31 | dispenser () 32 | | `Active fd' -> 33 | match Unix.read fd' buf 0 (Bytes.length buf) with 34 | | 0 | exception End_of_file -> 35 | Unix.close fd'; fd := `Closed; Tar.return (Ok None) 36 | | len -> 37 | let str = Bytes.sub_string buf 0 len in 38 | Tar.return (Ok (Some str)) in 39 | dispenser 40 | 41 | let to_stream lst = 42 | let lst = ref lst in 43 | fun () -> match !lst with 44 | | [] -> None 45 | | x :: r -> lst := r; Some x 46 | 47 | let create_tarball directory fd = 48 | let files = Sys.readdir directory in 49 | let os = match Sys.os_type with 50 | | "Win32" -> Gz.NTFS (* XXX(dinosaure): true? *) 51 | | "Unix" | "Cygwin" | _ -> Gz.Unix in 52 | let mtime = Unix.gettimeofday () in 53 | let dir_hdr = Tar.Header.make ~file_mode:0o755 54 | ~mod_time:(Int64.of_float mtime) (Filename.concat directory "") 0L in 55 | let dir_entry = (None, dir_hdr, (fun () -> Tar.return (Ok None))) in 56 | let entries = Array.fold_left begin fun acc filename -> 57 | let stat = Unix.LargeFile.stat (directory / filename) in 58 | match stat.st_kind with 59 | | Unix.S_REG -> 60 | let file_mode = if stat.st_perm land 0o111 <> 0 then 0o755 else 0o644 in 61 | let mod_time = Int64.of_float stat.Unix.LargeFile.st_mtime in 62 | let user_id = stat.st_uid in 63 | let group_id = stat.st_gid in 64 | let level = Some Tar.Header.Ustar in 65 | let hdr = Tar.Header.make 66 | ~file_mode ~mod_time ~user_id ~group_id 67 | (directory / filename) stat.st_size in 68 | (level, hdr, contents_of_path (directory / filename)) :: acc 69 | | _ -> acc end [] files in 70 | let entries = to_stream (dir_entry :: entries) in 71 | let entries () = Tar.return (Ok (entries ())) in 72 | let t = Tar.out ~level:Tar.Header.Ustar entries in 73 | let t = Tar_gz.out_gzipped ~level:4 ~mtime:(Int32.of_float mtime) os t in 74 | match Tar_unix.run t fd with 75 | | Ok () -> () 76 | | Error err -> 77 | Format.eprintf "%s: %a\n%!" Sys.executable_name Tar_unix.pp_error err 78 | 79 | let make directory oc = 80 | let fd, fd_close = match oc with 81 | | None -> Unix.stdout, ignore 82 | | Some filename -> 83 | let fd = Unix.openfile filename Unix.[ O_TRUNC; O_CREAT; O_WRONLY; O_CLOEXEC ] 0o644 in 84 | fd, (fun () -> Unix.close fd) in 85 | Fun.protect ~finally:fd_close @@ fun () -> 86 | create_tarball directory fd 87 | 88 | let sizes = [| "B"; "KiB"; "MiB"; "GiB"; "TiB"; "PiB"; "EiB"; "ZiB"; "YiB" |] 89 | 90 | let bytes_to_size ?(decimals = 2) ppf = function 91 | | 0L -> Format.fprintf ppf "0 byte" 92 | | n -> 93 | let n = Int64.to_float n in 94 | let i = Float.floor (Float.log n /. Float.log 1024.) in 95 | let r = n /. Float.pow 1024. i in 96 | Format.fprintf ppf "%.*f %s" decimals r sizes.(int_of_float i) 97 | 98 | let list filename = 99 | let go ?global:_ hdr () = 100 | Format.printf "%s (%s, %a)\n%!" 101 | hdr.Tar.Header.file_name 102 | (Tar.Header.Link.to_string hdr.link_indicator) 103 | (bytes_to_size ~decimals:2) hdr.Tar.Header.file_size ; 104 | let* () = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in 105 | Tar.return (Ok ()) 106 | in 107 | let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0 in 108 | match Tar_unix.run (Tar_gz.in_gzipped (Tar.fold go ())) fd with 109 | | Ok () -> () 110 | | Error (`Unix _) -> 111 | Format.eprintf "Some UNIX error occurred.\n%!" 112 | | Error (`Msg e) -> 113 | Format.eprintf "Some error: %s.\n%!" e 114 | | Error (`Unexpected_end_of_file | `Eof) -> 115 | Format.eprintf "Unexpected end of file.\n%!" 116 | | Error `Gz err -> 117 | Format.eprintf "Some Gzip error occurred: %s.\n%!" err 118 | | Error (`Fatal _) -> 119 | Format.eprintf "Some fatal error occurred.\n%!" 120 | 121 | let () = match Sys.argv with 122 | | [| _; "list"; filename; |] when Sys.file_exists filename -> 123 | list filename 124 | | [| _; directory |] when Sys.is_directory directory -> 125 | make directory None 126 | | [| _; directory; output |] when Sys.is_directory directory -> 127 | make directory (Some output) 128 | | _ -> 129 | let cmd = Filename.basename Sys.argv.(0) in 130 | Format.eprintf "%s []\n%s list \n" cmd cmd 131 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.9) 2 | (name tar) 3 | (cram enable) 4 | 5 | (formatting disabled) 6 | (generate_opam_files true) 7 | 8 | (source (github mirage/ocaml-tar)) 9 | (license ISC) 10 | (authors 11 | "Dave Scott" 12 | "Thomas Gazagnaire" 13 | "David Allsopp" 14 | "Antonin Décimo" 15 | "Reynir Björnsson" 16 | "Hannes Mehnert" 17 | ) 18 | (maintainers 19 | "Reynir Björnsson " 20 | "dave@recoil.org") 21 | (documentation "https://mirage.github.io/ocaml-tar/") 22 | 23 | (package 24 | (name tar) 25 | (synopsis "Decode and encode tar format files in pure OCaml") 26 | (description 27 | "\| tar is a library to read and write tar files with an emphasis on 28 | "\| streaming. 29 | "\| 30 | "\| This is pure OCaml code, no C bindings. 31 | ) 32 | (tags ("org:xapi-project" "org:mirage")) 33 | (depends 34 | (ocaml (>= 4.08.0)) 35 | (decompress (>= 1.5.1)) 36 | ) 37 | ) 38 | 39 | (package 40 | (name tar-unix) 41 | (synopsis "Decode and encode tar format files from Unix") 42 | (description 43 | "\| tar is a library to read and write tar files with an emphasis on 44 | "\| streaming. This library provides a Unix or Windows compatible interface. 45 | ) 46 | (tags ("org:xapi-project" "org:mirage")) 47 | (depends 48 | (ocaml (>= 4.08.0)) 49 | (lwt (>= 5.7.0)) 50 | (tar (= :version)) 51 | ) 52 | ) 53 | 54 | (package 55 | (name tar-mirage) 56 | (synopsis "Read and write tar format files via MirageOS interfaces") 57 | (description 58 | "\| tar is a library to read and write tar files with an emphasis on 59 | "\| streaming. This library is functorised over external OS dependencies 60 | "\| to facilitate embedding within MirageOS. 61 | ) 62 | (tags ("org:xapi-project" "org:mirage")) 63 | (conflicts (result (< 1.5))) 64 | (depends 65 | (ocaml (>= 4.08.0)) 66 | (cstruct (>= 6.0.0)) 67 | (lwt (>= 5.6.0)) 68 | (mirage-block (>= 2.0.0)) 69 | (mirage-ptime (>= 5.0.0)) 70 | (mirage-kv (>= 6.0.0)) 71 | optint 72 | ptime 73 | (tar (= :version)) 74 | (mirage-block-unix (and :with-test (>= 2.13.0))) 75 | (alcotest (and (>= 1.7.0) :with-test)) 76 | (alcotest-lwt (and (>= 1.7.0) :with-test)) 77 | (tar-unix (and :with-test (= :version))) 78 | ) 79 | ) 80 | 81 | (package 82 | (name tar-eio) 83 | (synopsis "Decode and encode tar format files using Eio") 84 | (description 85 | "\| tar is a library to read and write tar files with an emphasis on 86 | "\| streaming. This library uses Eio to provide a portable tar library. 87 | ) 88 | (tags ("org:xapi-project" "org:mirage")) 89 | (depends 90 | (ocaml (>= 5.00.0)) 91 | (eio (and (>= 1.1))) 92 | (tar (= :version)) 93 | ) 94 | ) 95 | -------------------------------------------------------------------------------- /eio/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tar_eio) 3 | (public_name tar-eio) 4 | (libraries tar eio)) 5 | -------------------------------------------------------------------------------- /eio/tar_eio.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2006-2013 Citrix Systems Inc. 3 | * Copyright (C) 2012 Thomas Gazagnaire 4 | * Copyright (C) 2023 Patrick Ferris 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type decode_error = 20 | [ `Fatal of Tar.error | `Unexpected_end_of_file | `Msg of string ] 21 | 22 | let ( / ) = Eio.Path.( / ) 23 | let ( let* ) = Result.bind 24 | let ( let+ ) v f = Result.map f v 25 | 26 | module High : sig 27 | type t 28 | type 'a s = 'a 29 | 30 | external inj : 'a s -> ('a, t) Tar.io = "%identity" 31 | external prj : ('a, t) Tar.io -> 'a s = "%identity" 32 | end = struct 33 | type t 34 | type 'a s = 'a 35 | 36 | external inj : 'a -> 'b = "%identity" 37 | external prj : 'b -> 'a = "%identity" 38 | end 39 | 40 | type t = High.t 41 | 42 | let value v = Tar.High (High.inj v) 43 | 44 | type src = Flow : _ Eio.Flow.source -> src | File : _ Eio.File.ro -> src 45 | 46 | let src_to_flow = function 47 | | Flow f -> (f :> Eio.Flow.source_ty Eio.Flow.source) 48 | | File f -> (f :> Eio.Flow.source_ty Eio.Flow.source) 49 | 50 | let skip f n = 51 | let buffer_size = 32768 in 52 | let buffer = Cstruct.create buffer_size in 53 | let rec loop (n : int) = 54 | if n <= 0 then Ok () 55 | else 56 | let amount = min n buffer_size in 57 | let block = Cstruct.sub buffer 0 amount in 58 | Eio.Flow.read_exact f block; 59 | loop (n - amount) 60 | in 61 | loop n 62 | 63 | let run t f = 64 | let rec run : type a. (a, 'err, t) Tar.t -> (a, 'err) result = function 65 | | Tar.Write _ -> assert false 66 | | Tar.Read len -> ( 67 | let f = src_to_flow f in 68 | let b = Cstruct.create len in 69 | match Eio.Flow.single_read f b with 70 | | len -> Ok (Cstruct.to_string ~len b) 71 | | exception End_of_file -> 72 | (* XXX: should we catch other exceptions?! *) 73 | Error `Unexpected_end_of_file) 74 | | Tar.Really_read len -> ( 75 | let f = src_to_flow f in 76 | let b = Cstruct.create len in 77 | try 78 | Eio.Flow.read_exact f b; 79 | Ok (Cstruct.to_string b) 80 | with End_of_file -> Error `Unexpected_end_of_file) 81 | | Tar.Seek n -> ( 82 | (* Seek is really just skip in ocaml-tar *) 83 | match f with 84 | | Flow f -> skip f n 85 | | File f -> 86 | let _set : Optint.Int63.t = 87 | Eio.File.seek f (Optint.Int63.of_int n) `Cur 88 | in 89 | Ok ()) 90 | | Tar.Return value -> value 91 | | Tar.High value -> High.prj value 92 | | Tar.Bind (x, f) -> ( 93 | match run x with Ok value -> run (f value) | Error _ as err -> err) 94 | in 95 | run t 96 | 97 | let fold f source init = run (Tar.fold f init) source 98 | let stat path = Eio.Path.stat ~follow:true path 99 | 100 | (** Return the header needed for a particular file on disk *) 101 | let header_of_file ?level ?getpwuid ?getgrgid filepath : Tar.Header.t = 102 | let level = Tar.Header.compatibility level in 103 | let stat = stat filepath in 104 | let pwent = Option.map (fun f -> f stat.uid) getpwuid in 105 | let grent = Option.map (fun f -> f stat.gid) getgrgid in 106 | let uname = if level = V7 then Some "" else pwent in 107 | let gname = if level = V7 then Some "" else grent in 108 | let file_mode = stat.perm in 109 | let user_id = stat.uid |> Int64.to_int in 110 | let group_id = stat.gid |> Int64.to_int in 111 | let file_size = stat.size |> Optint.Int63.to_int64 in 112 | let mod_time = Int64.of_float stat.mtime in 113 | let link_indicator = Tar.Header.Link.Normal in 114 | let link_name = "" in 115 | let devmajor = if level = Ustar then stat.dev |> Int64.to_int else 0 in 116 | let devminor = if level = Ustar then stat.rdev |> Int64.to_int else 0 in 117 | Tar.Header.make ~file_mode ~user_id ~group_id ~mod_time ~link_indicator 118 | ~link_name ?uname ?gname ~devmajor ~devminor (snd filepath) file_size 119 | 120 | let copy dst len = 121 | let blen = 65536 in 122 | let rec read_write dst len = 123 | if len = 0 then value (Ok ()) 124 | else 125 | let open Tar.Syntax in 126 | let slen = min blen len in 127 | let* str = Tar.really_read slen in 128 | let* _written = Result.ok (Eio.Flow.copy_string str dst) |> value in 129 | read_write dst (len - slen) 130 | in 131 | read_write dst len 132 | 133 | let extract ?(filter = fun _ -> true) src dst = 134 | let f ?global:_ hdr () = 135 | let open Tar.Syntax in 136 | let path = dst / hdr.Tar.Header.file_name in 137 | match (filter hdr, hdr.Tar.Header.link_indicator) with 138 | | true, Tar.Header.Link.Normal -> 139 | Eio.Path.with_open_out ~create:(`If_missing hdr.Tar.Header.file_mode) 140 | path 141 | @@ fun dst -> copy dst (Int64.to_int hdr.Tar.Header.file_size) 142 | | true, Tar.Header.Link.Symbolic -> 143 | Eio.Path.symlink ~link_to:hdr.link_name path; 144 | Tar.return (Ok ()) 145 | | true, Tar.Header.Link.Directory -> 146 | Eio.Path.mkdir ~perm:hdr.file_mode path; 147 | Tar.return (Ok ()) 148 | | _ -> 149 | let* () = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in 150 | Tar.return (Ok ()) 151 | in 152 | fold f src () 153 | 154 | let write_strings fd datas = 155 | List.iter (fun d -> Eio.Flow.copy_string d fd) datas 156 | 157 | let write_header ?level hdr fl = 158 | let+ bytes = Tar.encode_header ?level hdr in 159 | write_strings fl bytes 160 | 161 | let copy src sink len = 162 | let blen = 65536 in 163 | let buf = Cstruct.create blen in 164 | let rec read_and_write len = 165 | if len = 0 then Ok () 166 | else 167 | match Eio.Flow.single_read src buf with 168 | | n -> 169 | Eio.Flow.write sink [ Cstruct.sub buf 0 n ]; 170 | read_and_write (len - n) 171 | | exception End_of_file -> Error (`Msg "Unexpected end of file") 172 | in 173 | read_and_write len 174 | 175 | let append_file ?level ?header filename dst = 176 | let header = 177 | match header with None -> header_of_file ?level filename | Some x -> x 178 | in 179 | let* () = write_header ?level header dst in 180 | Eio.Path.with_open_in filename @@ fun src -> 181 | (* TOCTOU [also, header may not be valid for file] *) 182 | copy src dst (Int64.to_int header.Tar.Header.file_size) 183 | 184 | let write_global_extended_header ?level header sink = 185 | Result.map (write_strings sink) 186 | (Tar.encode_global_extended_header ?level header) 187 | 188 | let write_end fl = 189 | write_strings fl [ Tar.Header.zero_block; Tar.Header.zero_block ] 190 | 191 | let create ?level ?global ?(filter = fun _ -> true) ~src dst = 192 | match global with 193 | | None -> Ok () 194 | | Some hdr -> 195 | let* () = write_global_extended_header ?level hdr dst in 196 | let rec copy_files directory = 197 | let rec next = function 198 | | [] -> Ok () 199 | | name :: names -> ( 200 | try 201 | let filename = directory / name in 202 | let header = header_of_file ?level filename in 203 | if filter header then 204 | match header.Tar.Header.link_indicator with 205 | | Normal -> 206 | let* () = append_file ?level ~header filename dst in 207 | next names 208 | | Directory -> 209 | (* TODO first finish curdir (and close the dir fd), then go deeper *) 210 | let* () = copy_files filename in 211 | next names 212 | | _ -> Ok () (* NYI *) 213 | else Ok () 214 | with End_of_file -> Ok ()) 215 | in 216 | next (Eio.Path.read_dir directory) 217 | in 218 | let+ () = copy_files src in 219 | write_end dst 220 | -------------------------------------------------------------------------------- /eio/tar_eio.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2006-2009 Citrix Systems Inc. 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** {1 Eio Tar} 18 | 19 | This library provides low-level and high-level abstractions for reading 20 | and writing Tar files using Eio. 21 | *) 22 | 23 | type t 24 | 25 | type src = 26 | | Flow : _ Eio.Flow.source -> src 27 | | File : _ Eio.File.ro -> src (** Sources for tar files *) 28 | 29 | type decode_error = 30 | [ `Fatal of Tar.error | `Unexpected_end_of_file | `Msg of string ] 31 | (** Possible decoding errors *) 32 | 33 | (** {2 High-level Interface} *) 34 | 35 | val run : 36 | ('a, ([> `Unexpected_end_of_file ] as 'b), t) Tar.t -> src -> ('a, 'b) result 37 | (** [run tar src] will run the given [tar] using {! Eio} on [src]. *) 38 | 39 | val extract : 40 | ?filter:(Tar.Header.t -> bool) -> 41 | src -> 42 | Eio.Fs.dir_ty Eio.Path.t -> 43 | (unit, [> decode_error ]) result 44 | (** [extract src dst] extracts the tar file from [src] into [dst]. For example: 45 | 46 | {[ 47 | Eio.Path.with_open_in src @@ fun src -> 48 | Tar_eio.extract src dst 49 | ]} 50 | 51 | will extract the file at [src] into the directory at [dst]. Note that this function 52 | only creates {b files}, {b directories} and {b symlinks} with the correct mode (it does not, for 53 | example, set the ownership of the files according to the tar file). 54 | 55 | @param filter Can be used to exclude certain entries based on their header. *) 56 | 57 | val create : 58 | ?level:Tar.Header.compatibility -> 59 | ?global:Tar.Header.Extended.t -> 60 | ?filter:(Tar.Header.t -> bool) -> 61 | src:Eio.Fs.dir_ty Eio.Path.t -> 62 | _ Eio.Flow.sink -> 63 | (unit, [> decode_error ]) result 64 | (** [create ~src dst] is the opposite of {! extract}. The path [src] is tarred 65 | into [dst]. 66 | 67 | @param filter Can be used to exclude certain entries based on their header. 68 | *) 69 | 70 | val fold : 71 | (?global:Tar.Header.Extended.t -> 72 | Tar.Header.t -> 73 | 'acc -> 74 | ('acc, ([> `Fatal of Tar.error | `Unexpected_end_of_file ] as 'b), t) Tar.t) -> 75 | src -> 76 | 'acc -> 77 | ('acc, 'b) result 78 | (** [fold f src init] folds over the tarred [src]. *) 79 | 80 | (** {2 Low-level Interface} *) 81 | 82 | val value : ('a, 'err) result -> ('a, 'err, t) Tar.t 83 | (** Converts a normal result into {! Tar}s IO type *) 84 | 85 | val append_file : 86 | ?level:Tar.Header.compatibility -> 87 | ?header:Tar.Header.t -> 88 | Eio.Fs.dir_ty Eio.Path.t -> 89 | _ Eio.Flow.sink -> 90 | (unit, [> decode_error ]) result 91 | (** [append_file dst sink] *) 92 | 93 | val header_of_file : 94 | ?level:Tar.Header.compatibility -> 95 | ?getpwuid:(int64 -> string) -> 96 | ?getgrgid:(int64 -> string) -> 97 | Eio.Fs.dir_ty Eio.Path.t -> 98 | Tar.Header.t 99 | (** Return the header needed for a particular file on disk. [getpwuid] and [getgrgid] are optional 100 | functions that should take the uid and gid respectively and return the passwd and group entry 101 | names for each. These will be added to the header. *) 102 | 103 | val write_header : 104 | ?level:Tar.Header.compatibility -> 105 | Tar.Header.t -> 106 | _ Eio.Flow.sink -> 107 | (unit, [> decode_error ]) result 108 | 109 | val write_global_extended_header : 110 | ?level:Tar.Header.compatibility -> 111 | Tar.Header.Extended.t -> 112 | _ Eio.Flow.sink -> 113 | (unit, [> decode_error ]) result 114 | 115 | val write_end : _ Eio.Flow.sink -> unit 116 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tar) 3 | (modules tar) 4 | (public_name tar) 5 | (wrapped false)) 6 | 7 | (library 8 | (name tar_gz) 9 | (modules tar_gz) 10 | (public_name tar.gz) 11 | (wrapped false) 12 | (libraries tar decompress.gz decompress.de)) 13 | -------------------------------------------------------------------------------- /lib/tar.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2006-2009 Citrix Systems Inc. 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Tar utilities 18 | 19 | {e %%VERSION%% - {{:%%PKG_HOMEPAGE%% }homepage}} *) 20 | 21 | (** The type of errors that may occur. *) 22 | type error = [ 23 | | `Checksum_mismatch 24 | | `Corrupt_pax_header 25 | | `Zero_block 26 | | `Unmarshal of string 27 | ] 28 | 29 | (** [pp_error ppf e] pretty prints the error [e] on the formatter [ppf]. *) 30 | val pp_error : Format.formatter -> [< error] -> unit 31 | 32 | module Header : sig 33 | (** Process and create tar file headers. *) 34 | 35 | (** tar format assumptions. Default is {!V7} (for compatibility with versions 36 | of ocaml-tar before this type was introduced). 37 | @see *) 38 | type compatibility = 39 | | OldGNU (** GNU tar < 1.12 *) 40 | | GNU (** GNU tar 1.12 - 1.13.25 *) 41 | | V7 (** Origin 7th Release format *) 42 | | Ustar (** POSIX.1-1988 *) 43 | | Posix (** POSIX.1-2001 *) 44 | 45 | (** Return the compatibility level, defaults to {!V7}. *) 46 | val compatibility : compatibility option -> compatibility 47 | 48 | module Link : sig 49 | (** Determines the type of the file. *) 50 | type t = 51 | | Normal 52 | | Hard (** a hard link *) 53 | | Symbolic (** a symbolic link *) 54 | | Character (** a character device node *) 55 | | Block (** a block device node *) 56 | | Directory (** a directory (also indicated by trailing [/] in [file_name]) *) 57 | | FIFO (** a FIFO node *) 58 | | GlobalExtendedHeader (** a PaxExtension global header *) 59 | | PerFileExtendedHeader (** a PaxExtension per-file header *) 60 | | LongLink (** a GNU LongLink i.e. a very long link name *) 61 | | LongName (** a GNU LongName i.e. a very long filename *) 62 | val to_string: t -> string 63 | end 64 | 65 | module Extended: sig 66 | type t = { 67 | access_time: int64 option; (** second granularity since the Epoch *) 68 | charset: string option; 69 | comment: string option; 70 | group_id: int option; 71 | gname: string option; 72 | header_charset: string option; 73 | link_path: string option; 74 | mod_time: int64 option; (** second granularity since the Epoch *) 75 | path: string option; 76 | file_size: int64 option; 77 | user_id: int option; 78 | uname: string option; 79 | } 80 | (** Represents a "Pax" extended header. *) 81 | 82 | (** [make ()] creates an extended header. *) 83 | val make : 84 | ?access_time:int64 -> 85 | ?charset:string -> 86 | ?comment:string -> 87 | ?group_id:int -> 88 | ?gname:string -> 89 | ?header_charset:string -> 90 | ?link_path:string -> 91 | ?mod_time:int64 -> 92 | ?path:string -> 93 | ?file_size:int64 -> 94 | ?user_id:int -> 95 | ?uname:string -> 96 | unit -> 97 | t 98 | 99 | (** Pretty-print the extended header record. *) 100 | val to_detailed_string : t -> string 101 | 102 | (** Unmarshal a pax Extended Header block. This header block may 103 | be preceded by [global] blocks which will override some 104 | fields. *) 105 | val unmarshal : global:t option -> string -> (t, [> error ]) result 106 | end 107 | 108 | (** Represents a standard archive (note checksum not stored). *) 109 | type t = { 110 | file_name : string; 111 | file_mode: int; 112 | user_id: int; 113 | group_id: int; 114 | file_size: int64; 115 | mod_time: int64; 116 | link_indicator: Link.t; 117 | link_name: string; 118 | uname: string; 119 | gname: string; 120 | devmajor: int; 121 | devminor: int; 122 | extended: Extended.t option; 123 | } 124 | 125 | (** Helper function to make a simple header. *) 126 | 127 | (** [make file_name file_size] creates a simple header. 128 | [file_mode] defaults to [0o400], [user_id], [group_id] default to [0], 129 | [mod_time] defaults to [0L] (epoch), [link_indicator] defaults to [Normal], 130 | [link_name], [uname] and [gname] default to [""], and [devmajor] and 131 | [devminor] default to [0]. *) 132 | val make : 133 | ?file_mode:int -> 134 | ?user_id:int -> 135 | ?group_id:int -> 136 | ?mod_time:int64 -> 137 | ?link_indicator:Link.t -> 138 | ?link_name:string -> 139 | ?uname:string -> 140 | ?gname:string -> 141 | ?devmajor:int -> 142 | ?devminor:int -> 143 | string -> 144 | int64 -> 145 | t 146 | 147 | (** Length of a header block. *) 148 | val length : int 149 | 150 | (** A blank header block (two of these in series mark the end of the tar). *) 151 | val zero_block : string 152 | 153 | (** Pretty-print the header record. *) 154 | val to_detailed_string : t -> string 155 | 156 | (** Unmarshal a header block, returning [None] if it's all zeroes. 157 | This header block may be preceded by an [?extended] block which 158 | will override some fields. *) 159 | val unmarshal : 160 | ?extended:Extended.t -> 161 | string -> 162 | (t, [> `Zero_block | `Checksum_mismatch | `Unmarshal of string]) result 163 | 164 | (** Marshal a header block, computing and inserting the checksum. *) 165 | val marshal : 166 | ?level:compatibility -> 167 | bytes -> 168 | t -> 169 | (unit, [> `Msg of string ]) result 170 | 171 | (** Compute the amount of zero-padding required to round up the file size 172 | to a whole number of blocks. *) 173 | val compute_zero_padding_length : t -> int 174 | 175 | (** Return the required zero-padding as a string. *) 176 | val zero_padding : t -> string 177 | 178 | (** [to_sectors t] is the number of sectors occupied by the data. *) 179 | val to_sectors: t -> int64 180 | end 181 | 182 | (** {1 Decoding and encoding of a whole archive} *) 183 | 184 | (** The type of the decode state. *) 185 | type decode_state 186 | 187 | (** [decode_state ~global ()] constructs a decode_state. *) 188 | val decode_state : ?global:Header.Extended.t -> unit -> decode_state 189 | 190 | (** [decode t data] decodes [data] taking the current state [t] into account. 191 | It may result on success in a new state, optionally some action that should 192 | be done ([`Read] or [`Skip]), or a decoded [`Header]. Possibly a new global 193 | PAX header is provided as well. 194 | 195 | If no [`Read] or [`Skip] is returned, the new state should be used with 196 | [decode] with the next [Header.length] sized string, which will lead to 197 | further decoding until [`Eof] (or an error) occurs. *) 198 | val decode : decode_state -> string -> 199 | (decode_state * [ `Read of int | `Skip of int | `Header of Header.t ] option * Header.Extended.t option, 200 | [ `Eof | `Fatal of error ]) 201 | result 202 | 203 | (** [encode_header ~level hdr] encodes the header with the provided [level] 204 | (defaults to [V7]) into a list of strings to be written to the disk. 205 | Once a header is written, the payload (padded to multiples of 206 | [Header.length]) should follow. *) 207 | val encode_header : ?level:Header.compatibility -> 208 | Header.t -> (string list, [> `Msg of string ]) result 209 | 210 | (** [encode_global_extended_header hdr] encodes the global extended header as 211 | a list of strings. *) 212 | val encode_global_extended_header : 213 | ?level:Header.compatibility -> 214 | Header.Extended.t -> 215 | (string list, [> `Msg of string ]) result 216 | 217 | (** {1 Pure implementation of [fold].} 218 | 219 | [fold] produces a [('a, 'err, 't) t] value which can be {b evaluated} by 220 | a scheduler (such as [lwt] or [unix]). This value describe when we require 221 | to [Read] (like {!val:Stdlib.input}), [Really_read] (like 222 | {!val:Stdlib.really_read}) and [Seek] (like {!val:Stdlib.seek_in}). 223 | 224 | We can compose these actions with [Bind], [Return] and [High]. The latter 225 | allows you to use a value [('a, 't) io] that comes from the scheduler used - 226 | so you can use an Lwt value (['a Lwt.t]) without depending on Lwt 227 | ([('a, lwt) t]) at this stage. 228 | 229 | For further informations, you can look at the paper about Lightweight 230 | Higher Kind Polymorphism available 231 | {{:https://www.cl.cam.ac.uk/~jdy22/papers/lightweight-higher-kinded-polymorphism.pdf} here}. *) 232 | 233 | type ('a, 't) io 234 | 235 | type ('a, 'err, 't) t = 236 | | Really_read : int -> (string, 'err, 't) t 237 | | Read : int -> (string, 'err, 't) t 238 | | Seek : int -> (unit, 'err, 't) t 239 | | Bind : ('a, 'err, 't) t * ('a -> ('b, 'err, 't) t) -> ('b, 'err, 't) t 240 | | Return : ('a, 'err) result -> ('a, 'err, 't) t 241 | | High : (('a, 'err) result, 't) io -> ('a, 'err, 't) t 242 | | Write : string -> (unit, 'err, 't) t 243 | 244 | val really_read : int -> (string, _, _) t 245 | val read : int -> (string, _, _) t 246 | val seek : int -> (unit, _, _) t 247 | val bind : ('a, 'err, 't) t -> ('a -> ('b, 'err, 't) t) -> ('b, 'err, 't) t 248 | val return : ('a, 'err) result -> ('a, 'err, _) t 249 | val write : string -> (unit, _, _) t 250 | 251 | module Syntax : sig 252 | val ( let* ) : ('a, 'err, 't) t -> ('a -> ('b, 'err, 't) t) -> ('b, 'err, 't) t 253 | end 254 | 255 | val ( let* ) : ('a, 'err, 't) t -> ('a -> ('b, 'err, 't) t) -> ('b, 'err, 't) t 256 | [@@ocaml.deprecated "Use Tar.bind or Tar.Syntax.( let* )"] 257 | (** Deprecated. Use Tar.bind or Tar.Syntax.( let* ) *) 258 | 259 | type ('a, 'err, 't) fold = 260 | (?global:Header.Extended.t -> Header.t -> 'a -> ('a, 'err, 't) t) -> 261 | 'a -> 262 | ('a, 'err, 't) t 263 | 264 | val fold : ('a, [> `Fatal of error ], 't) fold 265 | (** [fold f] is a [_ t] that reads an archive and executes [f] on each header. 266 | [f] is expected to either read or skip the file contents, or return an 267 | error. *) 268 | 269 | type ('err, 't) content = unit -> (string option, 'err, 't) t 270 | type ('err, 't) entry = Header.compatibility option * Header.t * ('err, 't) content 271 | type ('err, 't) entries = unit -> (('err, 't) entry option, 'err, 't) t 272 | 273 | val out : 274 | ?level:Header.compatibility 275 | -> ?global_hdr:Header.Extended.t 276 | -> ([> `Msg of string ] as 'err, 't) entries 277 | -> (unit, 'err, 't) t 278 | (** [out hdr entries] is a [_ t] that writes [entries] into an archive. [hdr] is 279 | the global header and each entry must come from a {!type:content} stream and 280 | the associated header.*) 281 | -------------------------------------------------------------------------------- /lib/tar_gz.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2022 Romain Calascibetta 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Tar.Syntax 18 | 19 | external ba_get_int32_ne : De.bigstring -> int -> int32 = "%caml_bigstring_get32" 20 | external ba_set_int32_ne : De.bigstring -> int -> int32 -> unit = "%caml_bigstring_set32" 21 | 22 | let bigstring_blit_string src ~src_off dst ~dst_off ~len = 23 | let len0 = len land 3 in 24 | let len1 = len asr 2 in 25 | for i = 0 to len1 - 1 do 26 | let i = i * 4 in 27 | (* TODO: use String.get_int32_ne when ocaml-tar requires OCaml >= 4.13 *) 28 | let v = Bytes.get_int32_ne (Bytes.unsafe_of_string src) (src_off + i) in 29 | ba_set_int32_ne dst (dst_off + i) v 30 | done; 31 | for i = 0 to len0 - 1 do 32 | let i = (len1 * 4) + i in 33 | let v = String.get src (src_off + i) in 34 | Bigarray.Array1.set dst (dst_off + i) v 35 | done 36 | 37 | let bigstring_blit_bytes src ~src_off dst ~dst_off ~len = 38 | let len0 = len land 3 in 39 | let len1 = len asr 2 in 40 | for i = 0 to len1 - 1 do 41 | let i = i * 4 in 42 | let v = ba_get_int32_ne src (src_off + i) in 43 | Bytes.set_int32_ne dst (dst_off + i) v 44 | done; 45 | for i = 0 to len0 - 1 do 46 | let i = (len1 * 4) + i in 47 | let v = Bigarray.Array1.get src (src_off + i) in 48 | Bytes.set dst (dst_off + i) v 49 | done 50 | 51 | type decoder = 52 | { mutable gz : Gz.Inf.decoder 53 | ; ic_buffer : De.bigstring 54 | ; oc_buffer : De.bigstring 55 | ; tp_length : int 56 | ; mutable pos : int } 57 | 58 | let read_through_gz 59 | : decoder -> bytes -> (int, 'err, _) Tar.t 60 | = fun ({ ic_buffer; oc_buffer; tp_length; _ } as state) res -> 61 | let rec until_full_or_end gz (res, res_off, res_len) = 62 | match Gz.Inf.decode gz with 63 | | `Flush gz -> 64 | let max = De.bigstring_length oc_buffer - Gz.Inf.dst_rem gz in 65 | let len = min res_len max in 66 | bigstring_blit_bytes oc_buffer ~src_off:0 res ~dst_off:res_off ~len; 67 | if len < max 68 | then ( state.pos <- len 69 | ; state.gz <- gz 70 | ; Tar.return (Ok (res_off + len)) ) 71 | else until_full_or_end (Gz.Inf.flush gz) (res, res_off + len, res_len - len) 72 | | `End gz -> 73 | let max = De.bigstring_length oc_buffer - Gz.Inf.dst_rem gz in 74 | let len = min res_len max in 75 | bigstring_blit_bytes oc_buffer ~src_off:0 res ~dst_off:res_off ~len; 76 | state.pos <- len; 77 | state.gz <- gz; 78 | Tar.return (Ok (res_off + len)) 79 | | `Await gz -> 80 | let* tp_buffer = Tar.read tp_length in 81 | let len = String.length tp_buffer in 82 | bigstring_blit_string tp_buffer ~src_off:0 ic_buffer ~dst_off:0 ~len; 83 | let gz = Gz.Inf.src gz ic_buffer 0 len in 84 | until_full_or_end gz (res, res_off, res_len) 85 | | `Malformed err -> Tar.return (Error (`Gz err)) in 86 | let max = (De.bigstring_length oc_buffer - Gz.Inf.dst_rem state.gz) - state.pos in 87 | let len = min (Bytes.length res) max in 88 | bigstring_blit_bytes oc_buffer ~src_off:state.pos res ~dst_off:0 ~len; 89 | if len < max 90 | then ( state.pos <- state.pos + len 91 | ; Tar.return (Ok len) ) 92 | else until_full_or_end (Gz.Inf.flush state.gz) (res, len, Bytes.length res - len) 93 | 94 | let really_read_through_gz decoder len = 95 | let res = Bytes.create len in 96 | let* len = read_through_gz decoder res in 97 | if Bytes.length res = len 98 | then Tar.return (Ok (Bytes.unsafe_to_string res)) 99 | else Tar.return (Error `Eof) 100 | 101 | let read_through_gz decoder len = 102 | let res = Bytes.create len in 103 | let* len = read_through_gz decoder res in 104 | let str = Bytes.sub_string res 0 len in 105 | Tar.return (Ok str) 106 | 107 | type error = [ `Fatal of Tar.error | `Eof | `Gz of string ] 108 | 109 | let seek_through_gz 110 | : decoder -> int -> (unit, [> error ], _) Tar.t 111 | = fun state len -> 112 | let* _buf = really_read_through_gz state len in 113 | Tar.return (Ok ()) 114 | 115 | let in_gzipped t = 116 | let rec go 117 | : type a. decoder -> (a, [> error ] as 'err, 't) Tar.t -> (a, 'err, 't) Tar.t 118 | = fun decoder -> function 119 | | Tar.Really_read len -> 120 | really_read_through_gz decoder len 121 | | Tar.Read len -> 122 | read_through_gz decoder len 123 | | Tar.Seek len -> seek_through_gz decoder len 124 | | Tar.Return _ as ret -> ret 125 | | Tar.Bind (x, f) -> 126 | Tar.Bind (go decoder x, (fun x -> go decoder (f x))) 127 | | Tar.High _ as high -> high 128 | | Tar.Write _ as v -> v in 129 | let decoder = 130 | let oc_buffer = De.bigstring_create 0x1000 in 131 | { gz= Gz.Inf.decoder `Manual ~o:oc_buffer 132 | ; oc_buffer 133 | ; ic_buffer= De.bigstring_create 0x1000 134 | ; tp_length= 0x1000 135 | ; pos= 0 } in 136 | go decoder t 137 | 138 | type encoder = 139 | { mutable state : [ `Await of Gz.Def.encoder ] 140 | ; ic_buffer : De.bigstring 141 | ; oc_buffer : De.bigstring } 142 | 143 | let ( let* ) x f = Tar.Bind (x, f) 144 | 145 | let rec until_await oc_pos oc_buffer = function 146 | | `Flush gz as state -> 147 | let max = De.bigstring_length oc_buffer - Gz.Def.dst_rem gz - oc_pos in 148 | let len = min 0x100 max in 149 | let res = Bytes.create len in 150 | bigstring_blit_bytes oc_buffer ~src_off:oc_pos res ~dst_off:0 ~len; 151 | let* () = Tar.write (Bytes.unsafe_to_string res) in 152 | if len > 0 then until_await (oc_pos + len) oc_buffer state 153 | else 154 | Gz.Def.dst gz oc_buffer 0 (De.bigstring_length oc_buffer) 155 | |> Gz.Def.encode 156 | |> until_await 0 oc_buffer 157 | | `Await gz -> Tar.return (Ok (`Await gz)) 158 | | `End _ -> assert false 159 | 160 | let rec until_end oc_pos oc_buffer = function 161 | | `Await _ -> assert false 162 | | (`Flush gz | `End gz) as state -> 163 | let max = De.bigstring_length oc_buffer - Gz.Def.dst_rem gz - oc_pos in 164 | let len = min 0x100 max in 165 | let res = Bytes.create len in 166 | bigstring_blit_bytes oc_buffer ~src_off:oc_pos res ~dst_off:0 ~len; 167 | let* () = Tar.write (Bytes.unsafe_to_string res) in 168 | if len > 0 then until_end (oc_pos + len) oc_buffer state 169 | else match state with 170 | | `End _ -> Tar.return (Ok ()) 171 | | `Flush gz -> 172 | Gz.Def.dst gz oc_buffer 0 (De.bigstring_length oc_buffer) 173 | |> Gz.Def.encode 174 | |> until_end 0 oc_buffer 175 | 176 | let write_gz ({ state; ic_buffer; oc_buffer; } as encoder) str = 177 | let rec go (str, str_off, str_len) state = 178 | if str_len = 0 179 | then Tar.return (Ok state) 180 | else begin 181 | let len = min str_len (De.bigstring_length ic_buffer) in 182 | bigstring_blit_string str ~src_off:str_off ic_buffer ~dst_off:0 ~len; 183 | let `Await gz = state in 184 | let gz = Gz.Def.src gz ic_buffer 0 len in 185 | let* state = until_await 0 oc_buffer (Gz.Def.encode gz) in 186 | go (str, str_off + len, str_len - len) state 187 | end in 188 | let* state = go (str, 0, String.length str) state in 189 | encoder.state <- state; 190 | Tar.return (Ok ()) 191 | 192 | let out_gzipped ~level ~mtime os t = 193 | let rec go 194 | : type a. encoder -> (a, 'err, 't) Tar.t -> (a, 'err, 't) Tar.t 195 | = fun encoder -> function 196 | | Tar.Really_read _ as ret -> ret 197 | | Tar.Read _ as ret -> ret 198 | | Tar.Seek _ as ret -> ret 199 | | Tar.Return _ as ret -> ret 200 | | Tar.Bind (x, f) -> 201 | Tar.Bind (go encoder x, (fun x -> go encoder (f x))) 202 | | Tar.High _ as high -> high 203 | | Tar.Write str -> write_gz encoder str in 204 | let ic_buffer = De.bigstring_create 0x1000 in 205 | let oc_buffer = De.bigstring_create 0x1000 in 206 | let q = De.Queue.create 4096 in 207 | let w = De.Lz77.make_window ~bits:15 in 208 | let gz = Gz.Def.encoder `Manual `Manual ~q ~w ~level ~mtime os in 209 | let gz = Gz.Def.dst gz oc_buffer 0 (De.bigstring_length oc_buffer) in 210 | let* state = until_await 0 oc_buffer (Gz.Def.encode gz) in 211 | let encoder = 212 | { state 213 | ; ic_buffer 214 | ; oc_buffer } in 215 | let* result = go encoder t in 216 | let `Await gz = encoder.state in 217 | let* () = 218 | Gz.Def.src gz ic_buffer 0 0 219 | |> Gz.Def.encode 220 | |> until_end 0 oc_buffer in 221 | Tar.return (Ok result) 222 | -------------------------------------------------------------------------------- /lib/tar_gz.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2022 Romain Calascibetta 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | type error = [ `Fatal of Tar.error | `Eof | `Gz of string ] 18 | 19 | val in_gzipped : ('a, ([> error ] as 'err), 't) Tar.t -> ('a, 'err, 't) Tar.t 20 | (** [in_gzipped] takes a {i tar process} (like {!val:Tar.fold}) and add a 21 | uncompression layer to be able to manipulate a [*.tar.gz] archive. *) 22 | 23 | val out_gzipped : 24 | level:int 25 | -> mtime:int32 26 | -> Gz.os 27 | -> ('a, 'err, 't) Tar.t 28 | -> ('a, 'err, 't) Tar.t 29 | (** [out_gzipped] takes a {i tar process} (like {!val:Tar.out}) and add a 30 | compression layer to be able to generate a [*.tar.gz] archive. *) 31 | -------------------------------------------------------------------------------- /lib_test/allocate_set_partial_test.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Int63 = Optint.Int63 4 | 5 | module B(Size : sig val sector_size : int end) = struct 6 | include Block 7 | include Size 8 | 9 | let convert_path os path = 10 | let ch = Unix.open_process_in (Printf.sprintf "cygpath -%c -- %s" (match os with `Mixed -> 'm' | `Unix -> 'u' | `Windows -> 'w') path) in 11 | let line = input_line ch in 12 | close_in ch; 13 | line 14 | 15 | let connect name = 16 | let name = if Sys.win32 then convert_path `Windows name else name in 17 | connect ~prefered_sector_size:(Some sector_size) name 18 | end 19 | 20 | module Block512 = B(struct let sector_size = 512 end) 21 | 22 | module Block4096 = B(struct let sector_size = 4096 end) 23 | 24 | module type BLOCK = sig 25 | include module type of Block 26 | val connect : string -> t Lwt.t 27 | val sector_size : int 28 | end 29 | 30 | let int63_hdr_len = Int63.of_int Tar.Header.length 31 | 32 | module Test(B : BLOCK) = struct 33 | module KV_RW = Tar_mirage.Make_KV_RW(B) 34 | 35 | let kv_rw_error = 36 | Lwt.wrap1 (Result.fold ~ok:Fun.id ~error:(Alcotest.failf "%a" KV_RW.pp_error)) 37 | 38 | let kv_rw_write_error = 39 | Lwt.wrap1 (Result.fold ~ok:Fun.id ~error:(Alcotest.failf "%a" KV_RW.pp_write_error)) 40 | 41 | let connect_block switch = 42 | let filename = Filename.temp_file "tar-allocate-set-partial-test" ".tar" in 43 | B.connect filename >|= fun b -> 44 | Lwt_switch.add_hook (Some switch) (fun () -> 45 | B.disconnect b >>= fun () -> Lwt_unix.unlink filename); 46 | b 47 | 48 | let resize b size = 49 | B.resize b size >|= 50 | Result.iter_error (Alcotest.failf "%a" B.pp_write_error) 51 | 52 | let allocate_empty_file switch () = 53 | connect_block switch >>= fun b -> 54 | resize b 10240L >>= fun () -> 55 | KV_RW.connect b >>= fun t -> 56 | KV_RW.allocate t (Mirage_kv.Key.v "empty") Int63.zero >>= 57 | kv_rw_write_error 58 | 59 | let set_partial_no_file switch () = 60 | connect_block switch >>= fun b -> 61 | resize b 10240L >>= fun () -> 62 | KV_RW.connect b >>= fun t -> 63 | KV_RW.set_partial t (Mirage_kv.Key.v "nonexistent") 64 | ~offset:Int63.zero "" >>= function 65 | | Ok () -> Alcotest.fail "expected set_partial on nonexistent file to fail" 66 | | Error _ -> Lwt.return_unit 67 | 68 | let allocate_is_zeroed switch () = 69 | connect_block switch >>= fun b -> 70 | resize b 10240L >>= fun () -> 71 | KV_RW.connect b >>= fun t -> 72 | let key = Mirage_kv.Key.v "zeroed" in 73 | KV_RW.allocate t key int63_hdr_len >>= 74 | kv_rw_write_error >>= fun () -> 75 | KV_RW.get t key >>= 76 | kv_rw_error >|= 77 | Alcotest.(check string) "is zeroed" (String.make Tar.Header.length '\000') 78 | 79 | let allocate_two_one_byte_files_zeroed switch () = 80 | connect_block switch >>= fun b -> 81 | resize b 10240L >>= fun () -> 82 | KV_RW.connect b >>= fun t -> 83 | let k1 = Mirage_kv.Key.v "zeroed" and k2 = Mirage_kv.Key.v "zeroed2" in 84 | KV_RW.allocate t k1 Int63.one >>= 85 | kv_rw_write_error >>= fun () -> 86 | KV_RW.allocate t k2 Int63.one >>= 87 | kv_rw_write_error >>= fun () -> 88 | KV_RW.get t k1 >>= 89 | kv_rw_error >>= fun s -> 90 | Alcotest.(check string) "is zero" "\000" s; 91 | KV_RW.get t k2 >>= 92 | kv_rw_error >|= 93 | Alcotest.(check string) "is zero" "\000" 94 | 95 | let allocate_set_partial_first_byte switch () = 96 | connect_block switch >>= fun b -> 97 | resize b 10240L >>= fun () -> 98 | KV_RW.connect b >>= fun t -> 99 | let k = Mirage_kv.Key.v "X" in 100 | KV_RW.allocate t k Int63.(add one one) >>= 101 | kv_rw_write_error >>= fun () -> 102 | KV_RW.set_partial t k ~offset:Int63.zero "X" >>= 103 | kv_rw_write_error >>= fun () -> 104 | KV_RW.get t k >>= 105 | kv_rw_error >|= 106 | Alcotest.(check string) "partial" "X\000" 107 | 108 | let rename_nonexistent_file switch () = 109 | connect_block switch >>= fun b -> 110 | resize b 10240L >>= fun () -> 111 | KV_RW.connect b >>= fun t -> 112 | let source = Mirage_kv.Key.v "source" 113 | and dest = Mirage_kv.Key.v "destination" in 114 | KV_RW.rename t ~source ~dest >|= function 115 | | Ok () -> Alcotest.fail "Expected failure to rename nonexistent file" 116 | | Error _ -> () 117 | 118 | let set_rename switch () = 119 | connect_block switch >>= fun b -> 120 | resize b 10240L >>= fun () -> 121 | KV_RW.connect b >>= fun t -> 122 | let source = Mirage_kv.Key.v "source" 123 | and dest = Mirage_kv.Key.v "destination" in 124 | let s = 125 | String.init (3 * Tar.Header.length) 126 | (fun i -> "0123456789".[i mod 10]) 127 | in 128 | KV_RW.set t source s >>= 129 | kv_rw_write_error >>= fun () -> 130 | KV_RW.rename t ~source ~dest >>= 131 | kv_rw_write_error >>= fun () -> 132 | KV_RW.get t dest >>= 133 | kv_rw_error >|= fun s' -> 134 | Alcotest.(check string) "renamed" s s' 135 | 136 | let tests = 137 | let ( >:: ) desc f = 138 | Alcotest_lwt.test_case (Printf.sprintf "%s b%d" desc B.sector_size) `Quick f 139 | in 140 | [ 141 | "allocate empty file" >:: allocate_empty_file; 142 | "set_partial nonexistent file" >:: set_partial_no_file; 143 | "allocate is zeroed" >:: allocate_is_zeroed; 144 | "allocate two one-byte files" >:: allocate_two_one_byte_files_zeroed; 145 | "allocate and set first byte" >:: allocate_set_partial_first_byte; 146 | "set and rename" >:: set_rename; 147 | ] 148 | 149 | end 150 | 151 | module Test512 = Test(Block512) 152 | module Test4096 = Test(Block4096) 153 | 154 | 155 | let () = 156 | Lwt_main.run @@ Alcotest_lwt.run "tar-allocate-set-partial" 157 | [ 158 | "Test512", Test512.tests; 159 | "Test4096", Test4096.tests; 160 | ] 161 | -------------------------------------------------------------------------------- /lib_test/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names parse_test write_test allocate_set_partial_test global_extended_headers_test) 3 | (package tar-mirage) 4 | (libraries 5 | mirage-block-unix 6 | mirage-block 7 | alcotest 8 | alcotest-lwt 9 | lwt 10 | tar-unix 11 | tar-mirage 12 | )) 13 | -------------------------------------------------------------------------------- /lib_test/global_extended_headers_test.ml: -------------------------------------------------------------------------------- 1 | let level = Tar.Header.Ustar 2 | 3 | let make_extended user_id = 4 | Tar.Header.Extended.make ~user_id () 5 | 6 | let make_file = 7 | let gen = ref 0 in 8 | fun () -> 9 | let name = "file" ^ string_of_int !gen in 10 | incr gen; 11 | let hdr = Tar.Header.make name 0L in 12 | hdr 13 | 14 | let ( let* ) = Result.bind 15 | 16 | (* Tests that global and per-file extended headers correctly override 17 | each other. *) 18 | let use_global_extended_headers _test_ctxt = 19 | (* Write an archive using global and per-file pax extended headers *) 20 | begin try Sys.remove "test.tar" with _ -> () end; 21 | let cout = Unix.openfile "test.tar" [ Unix.O_CREAT ; Unix.O_WRONLY ] 0o644 in 22 | let g0 = make_extended 1000 in 23 | let g1 = make_extended 3000 in 24 | match 25 | Fun.protect ~finally:(fun () -> Unix.close cout) 26 | (fun () -> 27 | let* () = Tar_unix.write_global_extended_header ~level g0 cout in 28 | let hdr = make_file () in 29 | let* () = Tar_unix.write_header ~level hdr cout in 30 | let hdr = make_file () in 31 | let hdr = { hdr with Tar.Header.extended = Some (make_extended 2000) } in 32 | let* () = Tar_unix.write_header ~level hdr cout in 33 | let hdr = make_file () in 34 | let* () = Tar_unix.write_header ~level hdr cout in 35 | let hdr = make_file () in 36 | let* () = Tar_unix.write_global_extended_header ~level g1 cout in 37 | let* () = Tar_unix.write_header ~level hdr cout in 38 | Tar_unix.write_end cout) 39 | with 40 | | Error `Msg msg -> Alcotest.failf "failed to write something: %s" msg 41 | | Error `Unix (err, f, a) -> 42 | Alcotest.failf "failed to write: unix error %s %s %s" (Unix.error_message err) f a 43 | | Ok () -> 44 | (* Read the same archive, testing that headers have been squashed. *) 45 | let header = 46 | let pp ppf hdr = Fmt.pf ppf "%s" (Tar.Header.Extended.to_detailed_string hdr) in 47 | Alcotest.testable (fun ppf hdr -> Fmt.pf ppf "%a" Fmt.(option pp) hdr) ( = ) 48 | in 49 | let f ?global hdr idx = 50 | let open Tar.Syntax in 51 | let* _pos = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in 52 | match idx with 53 | | 0 -> 54 | Alcotest.check header "expected global header" (Some g0) global; 55 | Alcotest.(check int) "expected user" 1000 hdr.Tar.Header.user_id; 56 | Tar.return (Ok 1) 57 | | 1 -> 58 | Alcotest.check header "expected global header" (Some g0) global; 59 | Alcotest.(check int) "expected user" 2000 hdr.Tar.Header.user_id; 60 | Tar.return (Ok 2) 61 | | 2 -> 62 | Alcotest.check header "expected global header" (Some g0) global; 63 | Alcotest.(check int) "expected user" 1000 hdr.Tar.Header.user_id; 64 | Tar.return (Ok 3) 65 | | 3 -> 66 | Alcotest.check header "expected global header" (Some g1) global; 67 | Alcotest.(check int) "expected user" 3000 hdr.Tar.Header.user_id; 68 | Tar.return (Ok 4) 69 | | _ -> Alcotest.fail "too many headers" 70 | in 71 | match Tar_unix.fold f "test.tar" 0 with 72 | | Ok 4 -> () 73 | | Ok n -> Alcotest.failf "early abort, expected 4, received %u" n 74 | | Error e -> Alcotest.failf "failed to read: %a" Tar_unix.pp_error e 75 | 76 | let () = 77 | let suite = "tar - pax global extended headers", [ 78 | Alcotest.test_case "can use pax global extended headers" `Quick use_global_extended_headers; 79 | ] 80 | in 81 | Alcotest.run "global extended headers" [suite] 82 | -------------------------------------------------------------------------------- /lib_test/long-implicit-dir.tar: -------------------------------------------------------------------------------- 1 | ././@LongLink00004000000000000000000000000040000000000000007753Lustar some/long/name/for/a/directory/some/long/name000040000000000000000000000000000000000000000104260ustar -------------------------------------------------------------------------------- /lib_test/long-pax.tar: -------------------------------------------------------------------------------- 1 | ./PaxHeaders/t0000644000000000000000000000013014422476211010460 xustar0029 mtime=1682603145.67112816 2 | 30 atime=1684310947.150643301 3 | 29 ctime=1682603145.67112816 4 | t/0000755000175000017500000000000014422476211012226 5ustar00reynirreynir00000000000000t/PaxHeaders/someveryveryverylongggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggg0000644000000000000000000000054514422476144032274 xustar00267 path=t/someveryveryverylonggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggname 5 | 30 mtime=1682603108.810960785 6 | 30 atime=1682603108.810960785 7 | 30 ctime=1682603108.810960785 8 | t/someveryveryverylonggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggg0000644000175000017500000000000014422476144036253 0ustar00reynirreynir00000000000000t/PaxHeaders/someveryveryverylongggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggg0000644000000000000000000000075514422476211032272 xustar00269 linkpath=someveryveryverylonggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggname 9 | 136 path=t/someveryveryverylonggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggglink 10 | 29 mtime=1682603145.67112816 11 | 30 atime=1684310947.150643301 12 | 29 ctime=1682603145.67112816 13 | t/someveryveryverylonggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggg0000777000175000017500000000000014422476211062625 2someveryveryverylongggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggustar00reynirreynir00000000000000 -------------------------------------------------------------------------------- /lib_test/long.tar: -------------------------------------------------------------------------------- 1 | ././@LongLink0000644000000000000000000000033200000000000011601 Lustar rootrootABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ010000775000175000017500000000000013044571037026126 5ustar erwanerwan././@LongLink0000644000000000000000000000066200000000000011607 Lustar rootrootABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/BCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ010000775000175000017500000000000013044571053026124 5ustar erwanerwan././@LongLink0000644000000000000000000000121400000000000011601 Lustar rootrootABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/BCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/CDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.txtABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ010000664000175000017500000000000713044555175026132 0ustar erwanerwancoucou 2 | -------------------------------------------------------------------------------- /lib_test/parse_test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2011-2013 Citrix Inc 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | open Lwt.Infix 16 | open Tar.Syntax 17 | 18 | let convert_path os path = 19 | let ch = Unix.open_process_in (Printf.sprintf "cygpath -%c -- %s" (match os with `Mixed -> 'm' | `Unix -> 'u' | `Windows -> 'w') path) in 20 | let line = input_line ch in 21 | close_in ch; 22 | line 23 | 24 | module Unix = struct 25 | include Unix 26 | 27 | let openfile path = 28 | if Sys.win32 then openfile (convert_path `Windows path) else openfile path 29 | let stat path = 30 | if Sys.win32 then stat (convert_path `Windows path) else stat path 31 | let truncate path = 32 | if Sys.win32 then truncate (convert_path `Windows path) else truncate path 33 | end 34 | 35 | let list filename = 36 | let f ?global:_ hdr acc = 37 | print_endline hdr.Tar.Header.file_name; 38 | let* () = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in 39 | Tar.return (Ok (hdr :: acc)) 40 | in 41 | match Tar_unix.fold f filename [] with 42 | | Ok acc -> List.rev acc 43 | | Error e -> Alcotest.failf "unexpected error: %a" Tar_unix.pp_error e 44 | 45 | let pp_header f x = Fmt.pf f "%s" (Tar.Header.to_detailed_string x) 46 | let header = Alcotest.testable pp_header ( = ) 47 | 48 | let error : Tar.error Alcotest.testable = Alcotest.testable Tar.pp_error ( = ) 49 | 50 | let link = Alcotest.testable (Fmt.of_to_string Tar.Header.Link.to_string) ( = ) 51 | 52 | let header () = 53 | (* check header marshalling and unmarshalling *) 54 | let h = Tar.Header.make ~file_mode:5 ~user_id:1001 ~group_id:1002 ~mod_time:55L ~link_name:"" "hello" 1234L in 55 | let txt = "hello\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0000000005\0000001751\0000001752\00000000002322\00000000000067\0000005534\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" in 56 | let c = Bytes.create (String.length txt) in 57 | Bytes.blit_string txt 0 c 0 (String.length txt); 58 | let c' = Bytes.create Tar.Header.length in 59 | for i = 0 to Tar.Header.length - 1 do Bytes.set c' i '\000' done; 60 | match Tar.Header.marshal c' h with 61 | | Ok () -> 62 | Alcotest.(check bytes) "marshalled headers" c c'; 63 | Alcotest.(check (result header error)) "unmarshalled headers" (Ok h) (Tar.Header.unmarshal (Bytes.unsafe_to_string c')); 64 | Alcotest.(check int) "zero padding length" 302 (Tar.Header.compute_zero_padding_length h) 65 | | Error `Msg msg -> 66 | Alcotest.failf "error marshalling: %s" msg 67 | 68 | let set_difference a b = List.filter (fun a -> not(List.mem a b)) a 69 | 70 | let with_file ~prefix ~suffix f = 71 | let filename = Filename.temp_file prefix suffix in 72 | Fun.protect (fun () -> f filename) ~finally:(fun () -> Sys.remove filename) 73 | 74 | let with_tmpdir f = 75 | let filename = Filename.(temp_file (__FILE__ |> basename |> remove_extension) "") in 76 | Sys.remove filename; 77 | Unix.mkdir filename 0o700; 78 | Fun.protect (fun () -> f filename) ~finally:(fun () -> Unix.rmdir filename) 79 | 80 | let with_tar ?(level:Tar.Header.compatibility option) ?files ?(sector_size = 512) () f = 81 | let format = match level with 82 | | None -> "" 83 | | Some format -> "--format=" ^ match format with 84 | | Tar.Header.OldGNU -> "oldgnu" | GNU -> "gnu" | V7 -> "v7" | Ustar -> "ustar" | Posix -> "posix" 85 | in 86 | let files = match files with 87 | | None -> List.map (fun x -> "lib/" ^ x) (Array.to_list (Sys.readdir "lib")) 88 | | Some files -> files in 89 | with_file ~prefix:"tar-test" ~suffix:".tar" @@ fun tar_filename -> 90 | let tar_filename = if Sys.win32 then convert_path `Unix tar_filename else tar_filename in 91 | let tar_block_size = sector_size / 512 in 92 | let cmdline = Printf.sprintf "tar -cf %s -b %d %s %s" tar_filename tar_block_size format (String.concat " " files) in 93 | begin match Unix.system cmdline with 94 | | Unix.WEXITED 0 -> () 95 | | Unix.WEXITED n -> Alcotest.failf "%s: exited with %d" cmdline n 96 | | _ -> Alcotest.failf "%s: unknown error" cmdline 97 | end; 98 | f tar_filename files 99 | 100 | let can_read_tar () = 101 | with_tar () @@ fun tar_filename files -> 102 | let files' = List.map (fun t -> t.Tar.Header.file_name) (list tar_filename) in 103 | flush stdout; 104 | let missing = set_difference files files' in 105 | let missing' = set_difference files' files in 106 | Alcotest.(check (list string)) "missing" [] missing; 107 | Alcotest.(check (list string)) "missing'" [] missing' 108 | 109 | let can_write_pax () = 110 | with_file ~prefix:"tar-test" ~suffix:".tar" @@ fun filename -> 111 | (* This userid is too large for a regular ustar header *) 112 | let user_id = 0x07777777 + 1 in 113 | (* Write a file which would need a pax header *) 114 | let fd = Unix.openfile filename [ O_CREAT; O_WRONLY; O_CLOEXEC ] 0o0644 in 115 | Fun.protect 116 | (fun () -> 117 | let header = Tar.Header.make ~user_id "test" 0L in 118 | match Tar_unix.write_header header fd with 119 | | Ok () -> 120 | (match Tar_unix.write_end fd with 121 | | Ok () -> () 122 | | Error `Msg msg -> 123 | Alcotest.failf "error writing end %s" msg) 124 | | Error `Msg msg -> 125 | Alcotest.failf "error writing header %s" msg 126 | | Error `Unix (e, f, a) -> 127 | Alcotest.failf "error writing header - unix error %s %s %s" 128 | (Unix.error_message e) f a 129 | ) ~finally:(fun () -> Unix.close fd); 130 | (* Read it back and verify the header was read *) 131 | match list filename with 132 | | [ one ] -> Alcotest.(check int) "user_id" user_id one.Tar.Header.user_id 133 | | xs -> Alcotest.failf "Headers = %a" (Fmt.list pp_header) xs 134 | 135 | let can_list_longlink_tar () = 136 | let all = list "lib_test/long.tar" in 137 | let filenames = List.map (fun h -> h.Tar.Header.file_name) all in 138 | (* List.iteri (fun i x -> Printf.fprintf stderr "%d: %s\n%!" i x) filenames; *) 139 | let expected = [ 140 | "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/"; 141 | "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/BCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/"; 142 | "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/BCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/CDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.txt"; 143 | ] in 144 | Alcotest.(check (list string)) "respects filenames" expected filenames 145 | 146 | let can_list_long_pax_tar () = 147 | let all = list "lib_test/long-pax.tar" in 148 | let filenames = List.map (fun h -> h.Tar.Header.file_name) all in 149 | (* List.iteri (fun i x -> Printf.fprintf stderr "%d: %s\n%!" i x) filenames; *) 150 | let expected = [ 151 | "t/"; 152 | "t/someveryveryverylonggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggname"; 153 | "t/someveryveryverylonggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggglink"; 154 | ] in 155 | Alcotest.(check (list string)) "respects filenames" expected filenames 156 | 157 | (* "pax-shenanigans.tar" is an archive with a regular file "placeholder" with a 158 | pax header "path=clearly/a/directory/". The resulting header has normal link 159 | indicator with file path "clearly/a/directory/". Normal files with file 160 | names ending in slash should be treated as directories for backward 161 | compatibility. In GNU tar and bsdtar this seems to be done even when the 162 | file name ends in a slash due to pax headers. 163 | If you find this test questionable and want to change the behavior I don't 164 | disagree. If so, please add a test for the normal-as-directory backward 165 | compatibilty without a pax header. 166 | - Reynir 167 | *) 168 | let can_list_pax_implicit_dir () = 169 | let f ?global:_ hdr () = 170 | Alcotest.(check link) "is directory" Tar.Header.Link.Directory hdr.Tar.Header.link_indicator; 171 | Alcotest.(check string) "filename is patched" "clearly/a/directory/" hdr.file_name; 172 | let* () = Tar.seek (Int64.to_int hdr.file_size) in 173 | Tar.return (Ok ()) 174 | in 175 | match Tar_unix.fold f "lib_test/pax-shenanigans.tar" () with 176 | | Ok () -> () 177 | | Error e -> Alcotest.failf "unexpected error: %a" Tar_unix.pp_error e 178 | 179 | (* Sample tar generated with commit 1583f71ea33b2836d3fb996ac7dc35d55abe2777: 180 | [let buf = 181 | let long_name = "some/long/name/for/a/directory/" in 182 | let long_hdr = Tar.Header.make ~link_indicator:Tar.Header.Link.LongName "././@LongLink" Int64.(succ (of_int (String.length long_name))) in 183 | let hdr = Tar.Header.make "some/long/name" 0L in 184 | let buf = Cstruct.create ((3+2) * 512) in 185 | let level = Tar.Header.GNU in 186 | Tar.Header.marshal ~level buf long_hdr; 187 | Cstruct.blit_from_string long_name 0 buf 512 (String.length long_name); 188 | Tar.Header.marshal ~level (Cstruct.shift buf 1024) hdr; 189 | buf] *) 190 | let can_list_longlink_implicit_dir () = 191 | let f ?global:_ hdr () = 192 | Alcotest.(check link) "is directory" Tar.Header.Link.Directory hdr.Tar.Header.link_indicator; 193 | Alcotest.(check string) "filename is patched" "some/long/name/for/a/directory/" hdr.file_name; 194 | let* () = Tar.seek (Int64.to_int hdr.file_size) in 195 | Tar.return (Ok ()) 196 | in 197 | match Tar_unix.fold f "lib_test/long-implicit-dir.tar" () with 198 | | Ok () -> () 199 | | Error e -> Alcotest.failf "unexpected error: %a" Tar_unix.pp_error e 200 | 201 | let starts_with ~prefix s = 202 | let len_s = String.length s 203 | and len_pre = String.length prefix in 204 | let rec aux i = 205 | if i = len_pre then true 206 | else if String.unsafe_get s i <> String.unsafe_get prefix i then false 207 | else aux (i + 1) 208 | in len_s >= len_pre && aux 0 209 | 210 | let can_transform_tar () = 211 | let level = Tar.Header.Ustar in 212 | with_tar ~level () @@ fun tar_in _file_list -> 213 | let tar_out = Filename.temp_file "tar-transformed" ".tar" in 214 | let fd_out = Unix.openfile tar_out [ O_WRONLY; O_CREAT; O_CLOEXEC ] 0o644 in 215 | with_tmpdir @@ fun temp_dir -> 216 | let f ?global:_ hdr _ = 217 | let* () = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in 218 | let hdr = 219 | { hdr with 220 | Tar.Header.file_name = Filename.concat temp_dir hdr.file_name; 221 | file_size = 0L 222 | } 223 | in 224 | match Tar_unix.write_header ~level hdr fd_out with 225 | | Ok () -> Tar.return (Ok ()) 226 | | Error _ -> Alcotest.fail "error writing header" 227 | in 228 | match Tar_unix.fold f tar_in () with 229 | | Error e -> Alcotest.failf "error folding %a" Tar_unix.pp_error e 230 | | Ok () -> 231 | match Tar_unix.write_end fd_out with 232 | | Error _ -> Alcotest.fail "couldn't write end" 233 | | Ok () -> 234 | Unix.close fd_out; 235 | let f ?global:_ hdr _ = 236 | let* () = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in 237 | Alcotest.(check string) "Filename was transformed" temp_dir 238 | (String.sub hdr.file_name 0 (min (String.length hdr.file_name) (String.length temp_dir))); 239 | Tar.return (Ok ()) 240 | in 241 | match Tar_unix.fold f tar_out () with 242 | | Error e -> Alcotest.failf "error folding2 %a" Tar_unix.pp_error e 243 | | Ok () -> () 244 | 245 | module Block4096 = struct 246 | include Block 247 | 248 | let sector_size = 4096 249 | 250 | let connect name = 251 | let name = if Sys.win32 then convert_path `Windows name else name in 252 | connect ~prefered_sector_size:(Some 4096) name 253 | 254 | let with_block name f = 255 | connect name >>= fun b -> 256 | Lwt.finalize (fun () -> f b) (fun () -> disconnect b) 257 | end 258 | 259 | module type BLOCK = sig 260 | include Mirage_block.S 261 | val with_block: string -> (t -> unit Lwt.t) -> unit Lwt.t 262 | val sector_size : int 263 | end 264 | 265 | module B = struct 266 | include Block 267 | 268 | let sector_size = 512 269 | 270 | let connect name = 271 | let name = if Sys.win32 then convert_path `Windows name else name in 272 | connect ~prefered_sector_size:(Some 512) name 273 | 274 | let with_block name f = 275 | connect name >>= fun b -> 276 | Lwt.finalize (fun () -> f b) (fun () -> disconnect b) 277 | end 278 | 279 | module Test(B: BLOCK) = struct 280 | let add_data_to_tar ?(level:Tar.Header.compatibility option) ?files _switch () f = 281 | with_tar ?level ?files ~sector_size:B.sector_size () @@ fun tar_filename files -> 282 | let size = Unix.(stat tar_filename).st_size in 283 | let size = B.sector_size * ((pred size + 4096 + B.sector_size) / B.sector_size) in 284 | Unix.truncate tar_filename size; 285 | B.with_block tar_filename @@ fun b -> 286 | let module KV_RW = Tar_mirage.Make_KV_RW(B) in 287 | KV_RW.connect b >>= fun t -> 288 | KV_RW.set t (Mirage_kv.Key.v "barf") "foobar" >>= fun x -> 289 | Result.iter_error (fun e -> 290 | Alcotest.failf "%a" KV_RW.pp_write_error e) 291 | x; 292 | let files = "barf" :: files in 293 | f tar_filename files 294 | 295 | let add_more_data_to_tar ?(level:Tar.Header.compatibility option) ?files _switch () f = 296 | with_tar ?level ?files ~sector_size:B.sector_size () @@ fun tar_filename files -> 297 | let size = Unix.(stat tar_filename).st_size in 298 | (* Add 4 KB rounding up to block size *) 299 | let size = B.sector_size * ((pred size + 4096 + B.sector_size) / B.sector_size) in 300 | Unix.truncate tar_filename size; 301 | B.with_block tar_filename @@ fun b -> 302 | let module KV_RW = Tar_mirage.Make_KV_RW(B) in 303 | KV_RW.connect b >>= fun t -> 304 | KV_RW.set t (Mirage_kv.Key.v "barf") "foobar" >>= fun x -> 305 | Result.iter_error (fun e -> 306 | Alcotest.failf "%a" KV_RW.pp_write_error e) 307 | x; 308 | KV_RW.set t (Mirage_kv.Key.v "barf2") "foobar2" >>= fun x -> 309 | Result.iter_error (fun e -> 310 | Alcotest.failf "%a" KV_RW.pp_write_error e) 311 | x; 312 | let files = "barf" :: "barf2" :: files in 313 | f tar_filename files 314 | 315 | let write_with_full_archive ?(level:Tar.Header.compatibility option) ?files _switch () = 316 | with_tar ?level ?files () @@ fun tar_filename _files -> 317 | B.with_block tar_filename @@ fun b -> 318 | let module KV_RW = Tar_mirage.Make_KV_RW(B) in 319 | KV_RW.connect b >>= fun t -> 320 | KV_RW.set t (Mirage_kv.Key.v "barf") "foobar" >>= function 321 | | Error `No_space -> Lwt.return () 322 | | _ -> Alcotest.fail "expected `No_space" 323 | 324 | let check_tar tar_filename files = 325 | B.with_block tar_filename @@ fun b -> 326 | let module KV_RO = Tar_mirage.Make_KV_RO(B) in 327 | KV_RO.connect b >>= fun k -> 328 | files |> Lwt_list.iter_s @@ fun file -> 329 | let size = 330 | if file = "barf" then 6L 331 | else if file = "barf2" then 7L 332 | else Unix.LargeFile.((stat file).st_size) 333 | in 334 | let read_file key ofs len = 335 | if key = "barf" then String.sub "foobar" ofs len 336 | else if key = "barf2" then String.sub "foobar2" ofs len 337 | else 338 | let fd = Unix.openfile key [ O_RDONLY; O_CLOEXEC ] 0 in 339 | Fun.protect 340 | (fun () -> 341 | let (_: int) = Unix.lseek fd ofs Unix.SEEK_SET in 342 | let buf = Bytes.make len '\000' in 343 | let len' = Unix.read fd buf 0 len in 344 | Alcotest.(check int) "same length" len len'; 345 | Bytes.to_string buf 346 | ) ~finally:(fun () -> Unix.close fd) in 347 | let read_tar key = 348 | KV_RO.get k key >>= function 349 | | Error e -> Alcotest.failf "KV_RO.read (%a) %a" Mirage_kv.Key.pp key KV_RO.pp_error e 350 | | Ok buf -> Lwt.return buf in 351 | (* Read whole file *) 352 | let value = read_file file 0 (Int64.to_int size) in 353 | read_tar (Mirage_kv.Key.v file) >>= fun value' -> 354 | Alcotest.(check string) "same content" value value'; 355 | if Int64.compare size 2L = 1 then begin 356 | let value = read_file file 1 ((Int64.to_int size) - 2) in 357 | read_tar (Mirage_kv.Key.v file) >>= fun value' -> 358 | let value'' = String.sub value' 1 ((Int64.to_int size) - 2) in 359 | Alcotest.(check string) "same content" value value''; 360 | Lwt.return_unit 361 | end else Lwt.return_unit 362 | 363 | let can_read_through_BLOCK ~files _switch () = 364 | with_tar ~files ~sector_size:B.sector_size () check_tar 365 | 366 | let write_test switch () = 367 | add_data_to_tar switch () check_tar 368 | 369 | let write_more_test switch () = 370 | add_more_data_to_tar switch () check_tar 371 | 372 | let check_not_padded switch () = 373 | Unix.openfile "empty" [ O_WRONLY; O_CREAT; O_TRUNC; O_CLOEXEC ] 0o644 |> Unix.close; 374 | can_read_through_BLOCK ~files:["empty"] switch () 375 | end 376 | 377 | module Sector512 = Test(B) 378 | module Sector4096 = Test(Block4096) 379 | 380 | let () = 381 | let ( >:: ) desc f = Alcotest.test_case desc `Quick f in 382 | let suite = "parse_test", [ 383 | "header" >:: header; 384 | "can_read_tar" >:: can_read_tar; 385 | "can write pax headers" >:: can_write_pax; 386 | "can read @Longlink" >:: can_list_longlink_tar; 387 | "can read pax long names and links" >:: can_list_long_pax_tar; 388 | "can read pax header with implicit directory" >:: can_list_pax_implicit_dir; 389 | "can transform tars" >:: can_transform_tar; 390 | "can read @LongLink with implicit directory" >:: can_list_longlink_implicit_dir; 391 | ] 392 | in 393 | let ( >:: ) desc f = Alcotest_lwt.test_case desc `Quick f in 394 | let lwt_suite = "parse_test-lwt", [ 395 | "can_read_through_BLOCK/512" >:: Sector512.can_read_through_BLOCK ~files:[]; 396 | "not 4KiB padded" >:: Sector512.check_not_padded; 397 | "can_read_through_BLOCK/4096" >:: Sector4096.can_read_through_BLOCK ~files:[]; 398 | "add_data_to_tar BLOCK/512" >:: Sector512.write_test; 399 | "add_more_data_to_tar BLOCK/512" >:: Sector512.write_more_test; 400 | "write_with_full_archive BLOCK/512" >:: Sector512.write_with_full_archive; 401 | "add_data_to_tar BLOCK/4096" >:: Sector4096.write_test; 402 | "add_more_data_to_tar BLOCK/4096" >:: Sector4096.write_more_test; 403 | ] 404 | in 405 | (* pwd = _build/default/lib_test *) 406 | Unix.chdir "../../.."; 407 | Alcotest.run "parse-test" [suite]; 408 | Lwt_main.run @@ Alcotest_lwt.run "parse-test-lwt" [lwt_suite] 409 | -------------------------------------------------------------------------------- /lib_test/pax-shenanigans.tar: -------------------------------------------------------------------------------- 1 | paxheader00004000000000000000000000000043000000000000006505x00000035 path=clearly/a/directory/ 2 | placeholder00004000000000000000000000000000000000000000006627 -------------------------------------------------------------------------------- /lib_test/write_test.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module B(Size : sig val sector_size : int end) = struct 4 | include Block 5 | include Size 6 | 7 | let convert_path os path = 8 | let ch = Unix.open_process_in (Printf.sprintf "cygpath -%c -- %s" (match os with `Mixed -> 'm' | `Unix -> 'u' | `Windows -> 'w') path) in 9 | let line = input_line ch in 10 | close_in ch; 11 | line 12 | 13 | let connect name = 14 | let name = if Sys.win32 then convert_path `Windows name else name in 15 | connect ~prefered_sector_size:(Some sector_size) name 16 | end 17 | 18 | module Block512 = B(struct let sector_size = 512 end) 19 | 20 | module Block4096 = B(struct let sector_size = 4096 end) 21 | 22 | module type BLOCK = sig 23 | include module type of Block 24 | val connect: string -> t Lwt.t 25 | val sector_size : int 26 | end 27 | 28 | module Test(B : BLOCK) = struct 29 | module KV_RW = Tar_mirage.Make_KV_RW(B) 30 | 31 | let kv_rw_write_error = 32 | Lwt.wrap1 33 | (Result.iter_error (Alcotest.failf "%a" KV_RW.pp_write_error)) 34 | 35 | let str n = 36 | Bytes.unsafe_to_string (Bytes.create n) 37 | 38 | let connect_block switch = 39 | let filename = Filename.temp_file "tar-write-test" ".tar" in 40 | B.connect filename >|= fun b -> 41 | Lwt_switch.add_hook (Some switch) (fun () -> 42 | B.disconnect b >>= fun () -> 43 | Lwt_unix.unlink filename); 44 | b 45 | 46 | let resize b size = 47 | B.resize b size >|= fun x -> 48 | Result.iter_error (Alcotest.failf "%a" B.pp_write_error) 49 | x 50 | 51 | let write_empty_file switch () = 52 | connect_block switch >>= fun b -> 53 | resize b 10240L >>= fun () -> 54 | KV_RW.connect b >>= fun t -> 55 | KV_RW.set t (Mirage_kv.Key.v "barf") "" >>= 56 | kv_rw_write_error >>= fun () -> 57 | Lwt.return_unit 58 | 59 | let write_sector_size_file switch () = 60 | connect_block switch >>= fun b -> 61 | resize b 10240L >>= fun () -> 62 | KV_RW.connect b >>= fun t -> 63 | KV_RW.set t (Mirage_kv.Key.v "barf") (str B.sector_size) >>= 64 | kv_rw_write_error >>= fun () -> 65 | Lwt.return_unit 66 | 67 | let write_sector_size switch () = 68 | connect_block switch >>= fun b -> 69 | resize b 10240L >>= fun () -> 70 | KV_RW.connect b >>= fun t -> 71 | KV_RW.set t (Mirage_kv.Key.v "barf") (str (B.sector_size - 512)) >>= 72 | kv_rw_write_error >>= fun () -> 73 | Lwt.return_unit 74 | 75 | let write_two_sector_size switch () = 76 | connect_block switch >>= fun b -> 77 | resize b 10240L >>= fun () -> 78 | KV_RW.connect b >>= fun t -> 79 | KV_RW.set t (Mirage_kv.Key.v "barf") (str (2 * B.sector_size - 512)) >>= 80 | kv_rw_write_error >>= fun () -> 81 | Lwt.return_unit 82 | 83 | let write_two_files switch () = 84 | connect_block switch >>= fun b -> 85 | resize b 10240L >>= fun () -> 86 | KV_RW.connect b >>= fun t -> 87 | KV_RW.set t (Mirage_kv.Key.v "first") (str (B.sector_size - 512)) >>= 88 | kv_rw_write_error >>= fun () -> 89 | KV_RW.set t (Mirage_kv.Key.v "second") (str (2 * B.sector_size - 512)) >>= 90 | kv_rw_write_error >>= fun () -> 91 | Lwt.return_unit 92 | 93 | let write_two_files_remove_first switch () = 94 | let first = Mirage_kv.Key.v "first" and second = Mirage_kv.Key.v "second" in 95 | connect_block switch >>= fun b -> 96 | resize b 10240L >>= fun () -> 97 | KV_RW.connect b >>= fun t -> 98 | KV_RW.set t first (str (B.sector_size - 512)) >>= 99 | kv_rw_write_error >>= fun () -> 100 | KV_RW.set t second (str (2 * B.sector_size - 512)) >>= 101 | kv_rw_write_error >>= fun () -> 102 | KV_RW.remove t first >>= function 103 | | Error _ (* XXX: `Append_only *) -> 104 | Lwt.return_unit 105 | | Ok () -> Alcotest.fail "Expected Error `Append_only" 106 | 107 | let write_two_files_remove_second switch () = 108 | let first = Mirage_kv.Key.v "first" and second = Mirage_kv.Key.v "second" in 109 | connect_block switch >>= fun b -> 110 | resize b 10240L >>= fun () -> 111 | KV_RW.connect b >>= fun t -> 112 | KV_RW.set t first (str (B.sector_size - 512)) >>= 113 | kv_rw_write_error >>= fun () -> 114 | KV_RW.set t second (str (2 * B.sector_size - 512)) >>= 115 | kv_rw_write_error >>= fun () -> 116 | KV_RW.remove t second >>= 117 | kv_rw_write_error 118 | 119 | let remove_odd_file switch () = 120 | let first = Mirage_kv.Key.v "first" in 121 | connect_block switch >>= fun b -> 122 | resize b 10240L >>= fun () -> 123 | KV_RW.connect b >>= fun t -> 124 | KV_RW.set t first (str 1) >>= 125 | kv_rw_write_error >>= fun () -> 126 | KV_RW.remove t first >>= 127 | kv_rw_write_error 128 | 129 | let set_after_remove switch () = 130 | let first = Mirage_kv.Key.v "first" and second = Mirage_kv.Key.v "second" in 131 | connect_block switch >>= fun b -> 132 | resize b 10240L >>= fun () -> 133 | KV_RW.connect b >>= fun t -> 134 | KV_RW.set t first "Some data\n" >>= 135 | kv_rw_write_error >>= fun () -> 136 | KV_RW.remove t first >>= 137 | kv_rw_write_error >>= fun () -> 138 | KV_RW.set t second "More data\n" >>= 139 | kv_rw_write_error 140 | 141 | let allocate_doesn't_affect_beyond_end_of_archive data_size switch () = 142 | let first = Mirage_kv.Key.v "first" in 143 | connect_block switch >>= fun b -> 144 | let align_sector n = (n + pred B.sector_size) / B.sector_size in 145 | let align_block n = (n + 511) / 512 in 146 | let size = B.sector_size * align_sector (512 + 512 * (align_block data_size) + 1024 + 512) in 147 | resize b (Int64.of_int size) >>= fun () -> 148 | (* write an empty archive with trailing \xFFs *) 149 | let config = B.to_config b in 150 | let oc = open_out config.path in 151 | output_string oc (String.init 1024 (Fun.const '\000')); 152 | output_string oc (String.init (size - 1024) (Fun.const '\xFF')); 153 | close_out oc; 154 | KV_RW.connect b >>= fun t -> 155 | KV_RW.allocate t first (Optint.Int63.of_int data_size) >>= 156 | kv_rw_write_error >|= fun () -> 157 | let ic = open_in config.path in 158 | Fun.protect 159 | (fun () -> 160 | seek_in ic 512; (* skip header *) 161 | (* check file content *) 162 | for _ = 1 to data_size do 163 | Alcotest.(check char) "corrupt data" '\x00' (input_char ic); 164 | done; 165 | for _ = 1 to 512 * align_block data_size - data_size do 166 | Alcotest.(check char) "corrupt padding" '\x00' (input_char ic); 167 | done; 168 | (* check sentinel *) 169 | for _ = 1 to 1024 do 170 | Alcotest.(check char) "corrupt sentinel" '\x00' (input_char ic); 171 | done; 172 | (* check tail is untouched *) 173 | for _ = 1 to size - 512 - 512 * align_block data_size - 1024 do 174 | Alcotest.(check char) "corrupt tail" '\xff' (input_char ic); 175 | done; 176 | Alcotest.(check int) "same position" size (pos_in ic) 177 | ) ~finally:(fun () -> close_in ic) 178 | 179 | 180 | 181 | let tests = 182 | let ( >:: ) desc f = 183 | Alcotest_lwt.test_case (Printf.sprintf "%s b%d" desc B.sector_size) `Quick f 184 | in 185 | [ 186 | "write empty" >:: write_empty_file; 187 | "write block size" >:: write_sector_size_file; 188 | "write block size" >:: write_sector_size; 189 | "write two blocks" >:: write_two_sector_size; 190 | "write two files" >:: write_two_files; 191 | "write two files remove first" >:: write_two_files_remove_first; 192 | "write two files remove second" >:: write_two_files_remove_second; 193 | "remove odd sized file" >:: remove_odd_file; 194 | "set after remove" >:: set_after_remove; 195 | "allocate doesn't affect tail after archive 0" >:: allocate_doesn't_affect_beyond_end_of_archive 0; 196 | "allocate doesn't affect tail after archive 1" >:: allocate_doesn't_affect_beyond_end_of_archive 1; 197 | "allocate doesn't affect tail after archive 1 sector" >:: allocate_doesn't_affect_beyond_end_of_archive (B.sector_size - 512); 198 | ] 199 | end 200 | 201 | module Test512 = Test(Block512) 202 | module Test4096 = Test(Block4096) 203 | 204 | let () = 205 | Lwt_main.run @@ Alcotest_lwt.run "tar-write" [ 206 | "Test512", Test512.tests; 207 | "Test4096", Test4096.tests; 208 | ] 209 | -------------------------------------------------------------------------------- /mirage/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tar_mirage) 3 | (public_name tar-mirage) 4 | (libraries tar lwt mirage-kv mirage-block ptime mirage-ptime optint) 5 | (wrapped false)) 6 | -------------------------------------------------------------------------------- /mirage/tar_mirage.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 Citrix Systems Inc. 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Tar archives as read-only key=value stores for Mirage *) 18 | 19 | open Lwt.Infix 20 | 21 | module StringMap = Map.Make(String) 22 | 23 | module Make_KV_RO (BLOCK : Mirage_block.S) = struct 24 | 25 | type entry = 26 | | Value of Tar.Header.t * int64 27 | | Dict of Tar.Header.t * entry StringMap.t 28 | 29 | type t = { 30 | b: BLOCK.t; 31 | mutable map: entry; 32 | (** offset in bytes *) 33 | mutable end_of_archive: int64; 34 | info: Mirage_block.info; 35 | write_lock : Lwt_mutex.t; 36 | } 37 | 38 | type key = Mirage_kv.Key.t 39 | 40 | type error = [ Mirage_kv.error | `Block of BLOCK.error ] 41 | 42 | let pp_error ppf = function 43 | | #Mirage_kv.error as e -> Mirage_kv.pp_error ppf e 44 | | `Block b -> BLOCK.pp_error ppf b 45 | 46 | let read t sector_start buffers = 47 | Lwt_result.map_error (fun e -> `Block e) 48 | (BLOCK.read t.b sector_start buffers) 49 | 50 | let get_node t key = 51 | let rec find e = function 52 | | [] -> Ok e 53 | | hd::tl -> match e with 54 | | Value _ -> Error (`Dictionary_expected key) 55 | | Dict (_, m) -> match StringMap.find_opt hd m with 56 | | Some e -> find e tl 57 | | None -> Error (`Not_found key) 58 | in 59 | find t (Mirage_kv.Key.segments key) 60 | 61 | let exists t key = 62 | let r = match get_node t.map key with 63 | | Ok (Value _) -> Ok (Some `Value) 64 | | Ok (Dict _) -> Ok (Some `Dictionary) 65 | | Error (`Not_found _) -> Ok None 66 | | Error e -> Error e 67 | in 68 | Lwt.return r 69 | 70 | let size t key = 71 | let r = match get_node t.map key with 72 | | Ok (Value (e, _)) -> Ok (Optint.Int63.of_int64 e.file_size) 73 | | Ok (Dict (e, _)) -> Ok (Optint.Int63.of_int64 e.file_size) 74 | | Error e -> Error e 75 | in 76 | Lwt.return r 77 | 78 | let read_data info b offset buffer len = 79 | assert(len <= 512); 80 | (* Tar assumes 512 byte sectors, but BLOCK might have 4096 byte sectors for example *) 81 | let sector_size = info.Mirage_block.sector_size in 82 | let sector' = Int64.(div offset (of_int sector_size)) in 83 | let sector_aligned_len = 84 | if len mod sector_size == 0 then 85 | len 86 | else 87 | len + (sector_size - len mod sector_size) 88 | in 89 | let tmp = Cstruct.create sector_aligned_len in 90 | BLOCK.read b sector' [ tmp ] >>= function 91 | | Error e -> 92 | Lwt.return (Error (`Msg 93 | (Format.asprintf "Failed to read sector %Ld from block device: %a" sector' 94 | BLOCK.pp_error e))) 95 | | Ok () -> 96 | (* If the BLOCK sector size is big, then we need to select the 512 bytes we want *) 97 | let offset_in_cs = Int64.(to_int (sub offset (mul sector' (of_int sector_size)))) in 98 | Cstruct.blit_to_bytes tmp offset_in_cs buffer 0 len; 99 | Lwt.return (Ok ()) 100 | 101 | let fold info b f init = 102 | let open Lwt_result.Infix in 103 | let rec go t offset ?global ?data acc = 104 | (match data with 105 | | None -> 106 | let buf = Bytes.make Tar.Header.length '\000' in 107 | read_data info b offset buf Tar.Header.length >|= fun () -> 108 | Int64.(add offset (of_int Tar.Header.length)), Bytes.unsafe_to_string buf 109 | | Some data -> 110 | Lwt.return (Ok (offset, data))) >>= fun (offset, data) -> 111 | match Tar.decode t data with 112 | | Ok (t, Some `Header hdr, g) -> 113 | let global = Option.fold ~none:global ~some:(fun g -> Some g) g in 114 | f offset ?global hdr acc >>= fun acc' -> 115 | let off' = 116 | Int64.(add offset (add hdr.Tar.Header.file_size 117 | (of_int (Tar.Header.compute_zero_padding_length hdr)))) 118 | in 119 | go t off' ?global acc' 120 | | Ok (t, Some `Skip n, g) -> 121 | let global = Option.fold ~none:global ~some:(fun g -> Some g) g in 122 | let off' = Int64.(add offset (of_int n)) in 123 | go t off' ?global acc 124 | | Ok (t, Some `Read n, g) -> 125 | let global = Option.fold ~none:global ~some:(fun g -> Some g) g in 126 | let buf = Bytes.make n '\000' in 127 | read_data info b offset buf n >>= fun () -> 128 | let data = Bytes.unsafe_to_string buf in 129 | let off' = Int64.(add offset (of_int n)) in 130 | go t off' ?global ~data acc 131 | | Ok (t, None, g) -> 132 | let global = Option.fold ~none:global ~some:(fun g -> Some g) g in 133 | go t offset ?global acc 134 | | Error `Eof -> Lwt.return (Ok acc) 135 | | Error `Fatal _ as e -> Lwt.return e 136 | in 137 | go (Tar.decode_state ()) 0L init 138 | 139 | (* [read_partial_sector t sector_start ~offset ~length dst] 140 | reads a single sector and blits [length] bytes from [offset] into [dst] 141 | with the same offset. *) 142 | let read_partial_sector t sector_start ~offset ~length dst = 143 | assert Int64.(add offset length <= of_int t.info.sector_size); 144 | let length = Int64.to_int length and offset = Int64.to_int offset in 145 | assert (Cstruct.length dst >= t.info.sector_size); 146 | if length = 0 then Lwt_result.return () else 147 | let ( >>>= ) = Lwt_result.bind in 148 | let src = Cstruct.create t.info.sector_size in 149 | read t sector_start [ src ] >>>= fun () -> 150 | Cstruct.blit src offset dst offset length; 151 | Lwt_result.return () 152 | 153 | let get_partial t key ~offset ~length = 154 | match get_node t.map key with 155 | | Error e -> Lwt.return (Error e) 156 | | Ok (Dict _) -> Lwt.return (Error (`Value_expected key)) 157 | | Ok (Value (hdr, start_block)) -> 158 | let open Int64 in 159 | let offset = Optint.Int63.to_int64 offset in 160 | let sector_size = of_int t.info.Mirage_block.sector_size in 161 | (* Compute the unaligned data we need to read *) 162 | let start_bytes = 163 | let sec = mul start_block 512L in 164 | add sec offset 165 | in 166 | let length_bytes = 167 | min (sub hdr.Tar.Header.file_size offset) 168 | (of_int length) 169 | in 170 | if length_bytes < 0L then 171 | Lwt.return (Ok "") 172 | else 173 | let end_bytes = add start_bytes length_bytes in 174 | (* Compute the starting sector and ending sector (rounding down then up) *) 175 | let start_sector, start_padding = 176 | div start_bytes sector_size, rem start_bytes sector_size 177 | in 178 | let end_sector = div end_bytes sector_size in 179 | let n_sectors = succ (sub end_sector start_sector) in 180 | let buf = Cstruct.create (to_int (mul n_sectors sector_size)) in 181 | (* XXX: this is to work around limitations in some block implementations *) 182 | let tmps = 183 | let sec_size_int = to_int sector_size in 184 | List.init (to_int n_sectors) 185 | (fun sec -> Cstruct.sub buf (sec * sec_size_int) sec_size_int) 186 | in 187 | read t start_sector tmps >|= function 188 | | Error _ as e -> e 189 | | Ok () -> 190 | let buf = 191 | Cstruct.sub buf (to_int start_padding) (to_int length_bytes) 192 | in 193 | Ok (Cstruct.to_string buf) 194 | 195 | let get t key = 196 | get_partial t key ~offset:Optint.Int63.zero ~length:max_int 197 | 198 | let list t key = 199 | let r = match get_node t.map key with 200 | | Ok (Dict (_, m)) -> 201 | Ok (StringMap.fold (fun sub value acc -> 202 | let key = Mirage_kv.Key.add key sub in 203 | match value with 204 | | Dict _ -> (key, `Dictionary) :: acc 205 | | Value _ -> (key, `Value) :: acc) 206 | m []) 207 | | Ok (Value _) -> Error (`Dictionary_expected key) 208 | | Error e -> Error e 209 | in 210 | Lwt.return r 211 | 212 | let to_ptime hdr = 213 | Option.value ~default:Ptime.epoch 214 | (Ptime.of_float_s (Int64.to_float hdr.Tar.Header.mod_time)) 215 | 216 | let last_modified t key = 217 | let r = match get_node t.map key with 218 | | Ok (Dict (hdr, _)) -> Ok (to_ptime hdr) 219 | | Ok (Value (hdr, _)) -> Ok (to_ptime hdr) 220 | | Error e -> Error e 221 | in 222 | Lwt.return r 223 | 224 | let digest t key = 225 | get t key >|= function 226 | | Error e -> Error e 227 | | Ok data -> Ok (Digest.string data) 228 | 229 | (* Compare filenames without a leading / or ./ *) 230 | let trim_slash x = 231 | let startswith prefix x = 232 | let prefix' = String.length prefix in 233 | let x' = String.length x in 234 | x' >= prefix' && (String.sub x 0 prefix' = prefix) in 235 | if startswith "./" x 236 | then String.sub x 2 (String.length x - 2) 237 | else if startswith "/" x 238 | then String.sub x 1 (String.length x - 1) 239 | else x 240 | 241 | let is_dict filename = 242 | String.get filename (pred (String.length filename)) = '/' 243 | 244 | let insert map key value = 245 | let rec go m = function 246 | | [] -> assert false 247 | | [hd] -> StringMap.add hd value m 248 | | hd::tl -> 249 | let hdr, m' = match StringMap.find_opt hd m with 250 | | None -> Tar.Header.make hd 0L, StringMap.empty 251 | | Some (Value _) -> assert false 252 | | Some (Dict (hdr, m)) -> hdr, m 253 | in 254 | let m'' = go m' tl in 255 | StringMap.add hd (Dict (hdr, m'')) m 256 | in 257 | go map (Mirage_kv.Key.segments key) 258 | 259 | let remove map key = 260 | let rec go m = function 261 | | [] -> assert false 262 | | [hd] -> StringMap.remove hd m 263 | | hd::tl -> 264 | let hdr, m' = match StringMap.find_opt hd m with 265 | | None -> Tar.Header.make hd 0L, StringMap.empty 266 | | Some (Value _) -> assert false 267 | | Some (Dict (hdr, m)) -> hdr, m 268 | in 269 | let m'' = go m' tl in 270 | if StringMap.is_empty m'' then 271 | StringMap.remove hd m 272 | else 273 | StringMap.add hd (Dict (hdr, m'')) m 274 | in 275 | go map (Mirage_kv.Key.segments key) 276 | 277 | let connect b = 278 | BLOCK.get_info b >>= fun info -> 279 | let ssize = info.Mirage_block.sector_size in 280 | if ssize mod 512 <> 0 || ssize < 512 then 281 | invalid_arg "Sector size needs to be >= 512 and a multiple of 512"; 282 | let f offset ?global:_ hdr (_, map) = 283 | let filename = trim_slash hdr.Tar.Header.file_name in 284 | let map = 285 | if filename = "" then 286 | map 287 | else 288 | let data_tar_offset = Int64.(div offset (of_int Tar.Header.length)) in 289 | let v_or_d = 290 | if is_dict filename then 291 | Dict (hdr, StringMap.empty) 292 | else 293 | Value (hdr, data_tar_offset) 294 | in 295 | insert map (Mirage_kv.Key.v filename) v_or_d 296 | in 297 | let eof = Int64.(add offset 298 | (add hdr.Tar.Header.file_size 299 | (of_int (Tar.Header.compute_zero_padding_length hdr)))) 300 | in 301 | Lwt.return (Ok (eof, map)) 302 | in 303 | fold info b f (0L, StringMap.empty) >>= function 304 | | Error `Fatal e -> 305 | Format.kasprintf failwith "Fatal error reading archive: %a" Tar.pp_error e 306 | | Error `Msg msg -> 307 | Format.kasprintf failwith "Error reading archive: %s" msg 308 | | Ok (end_of_archive, map) -> 309 | let end_of_archive = Int64.(add end_of_archive (of_int (2 * Tar.Header.length))) in 310 | let map = Dict (Tar.Header.make "/" 0L, map) in 311 | let write_lock = Lwt_mutex.create () in 312 | Lwt.return ({ b; map; info; end_of_archive; write_lock }) 313 | 314 | let disconnect _ = Lwt.return_unit 315 | 316 | end 317 | 318 | 319 | module Make_KV_RW (BLOCK : Mirage_block.S) = struct 320 | 321 | include Make_KV_RO(BLOCK) 322 | 323 | type write_error = [ 324 | | `Block of BLOCK.error 325 | | `Block_write of BLOCK.write_error 326 | | Mirage_kv.write_error 327 | | `Entry_already_exists 328 | | `Path_segment_is_a_value 329 | | `Append_only 330 | | `Msg of string ] 331 | 332 | let pp_write_error ppf = function 333 | | `Block e -> Fmt.pf ppf "read error while writing: %a" BLOCK.pp_error e 334 | | `Block_write e -> BLOCK.pp_write_error ppf e 335 | | #Mirage_kv.write_error as e -> Mirage_kv.pp_write_error ppf e 336 | | `Entry_already_exists -> Fmt.string ppf "entry already exists" 337 | | `Path_segment_is_a_value -> Fmt.string ppf "path segment is a value" 338 | | `Append_only -> Fmt.string ppf "append only" 339 | | `Msg msg -> Fmt.pf ppf "writing tar header failed: %s" msg 340 | 341 | let write t sector_start buffers = 342 | Lwt_result.map_error (fun e -> `Block_write e) 343 | (BLOCK.write t.b sector_start buffers) 344 | 345 | let free t = 346 | Int64.(sub (mul (of_int t.info.sector_size) t.info.size_sectors) 347 | t.end_of_archive) 348 | 349 | let is_safe_to_set t key = 350 | let rec find e path = 351 | match e, path with 352 | | (Value _ | Dict _), [] -> Error `Entry_already_exists 353 | | Value _, _hd :: _tl -> Error `Path_segment_is_a_value 354 | | Dict (_, m), hd :: tl -> 355 | match StringMap.find_opt hd m with 356 | | Some e -> find e tl 357 | | None -> 358 | (* if either (part of) the path or the file doesn't exist we're good *) 359 | Ok () 360 | in 361 | find t.map (Mirage_kv.Key.segments key) 362 | 363 | let header_of_key ?last_modified key len = 364 | let mod_time = 365 | match last_modified with 366 | | Some mod_time -> Int64.of_float (Ptime.to_float_s mod_time) 367 | | None -> 368 | let ptime = Mirage_ptime.now () in 369 | Int64.of_float (Ptime.to_float_s ptime) 370 | in 371 | Tar.Header.make ~mod_time (Mirage_kv.Key.to_string key) (Int64.of_int len) 372 | 373 | (* [space_needed header] is the number of bytes necessary for the data part including padding *) 374 | let space_needed header = 375 | let data_size = header.Tar.Header.file_size in 376 | let padding_size = Tar.Header.compute_zero_padding_length header in 377 | Int64.(add (of_int padding_size) data_size) 378 | 379 | let update_insert map key hdr offset = 380 | match map with 381 | | Value _ -> 382 | (* if the root is a value we have done something very wrong. This should 383 | be catched by [is_safe_to_set]. *) 384 | assert false 385 | | Dict (root, map) -> 386 | (* [insert] may raise if [key] is [empty]. However, [is_safe_to_set] 387 | should catch that since [empty] always exists as a dict (root). *) 388 | let map = insert map key (Value (hdr, offset)) in 389 | Dict (root, map) 390 | 391 | let update_remove map key = 392 | match map with 393 | | Value _ -> 394 | (* if the root is a value we have done something very wrong. This should 395 | be catched by [is_safe_to_set]. *) 396 | assert false 397 | | Dict (root, map) -> 398 | (* [remove] may raise if [key] is [empty]. *) 399 | let map = remove map key in 400 | Dict (root, map) 401 | 402 | let write_data info b offset buffer = 403 | assert (String.length buffer <= Tar.Header.length); 404 | let sector_size = info.Mirage_block.sector_size in 405 | let sector = Int64.(div offset (of_int sector_size)) in 406 | let block = Cstruct.create sector_size in 407 | BLOCK.read b sector [ block ] >>= function 408 | | Error e -> Lwt.return (Error (`Block e)) 409 | | Ok () -> 410 | let start_offset = Int64.to_int offset mod sector_size in 411 | Cstruct.blit_from_string buffer 0 block start_offset (String.length buffer); 412 | BLOCK.write b sector [ block ] >>= function 413 | | Error e -> Lwt.return (Error (`Block_write e)) 414 | | Ok () -> Lwt.return (Ok ()) 415 | 416 | let write_header (t : t) header_start_bytes hdr = 417 | (* it is important we write at level [Ustar] at most as we assume the 418 | header(s) taking up exactly 512 bytes. With [GNU] level extra blocks 419 | may be used for long names. *) 420 | let open Lwt_result.Infix in 421 | Lwt_result.lift (Tar.encode_header ~level:Tar.Header.Ustar hdr) >>= fun datas -> 422 | Lwt_list.fold_left_s (fun acc buf -> 423 | Lwt_result.lift acc >>= fun off' -> 424 | write_data t.info t.b off' buf >|= fun () -> 425 | Int64.(add off' (of_int (String.length buf)))) 426 | (Ok header_start_bytes) datas 427 | 428 | let set t key data = 429 | Lwt_mutex.with_lock t.write_lock (fun () -> 430 | let data = Cstruct.of_string data in 431 | let ( >>>= ) = Lwt_result.bind in 432 | let r = 433 | let ( let* ) = Result.bind in 434 | let* () = is_safe_to_set t key in 435 | let hdr = header_of_key key (Cstruct.length data) in 436 | let space_needed = space_needed hdr in 437 | let* () = 438 | if free t >= Int64.(add space_needed (of_int Tar.Header.length)) then 439 | Ok () 440 | else 441 | Error `No_space 442 | in 443 | Ok (hdr, space_needed) 444 | in 445 | Lwt.return r >>>= fun (hdr, space_needed) -> 446 | let open Int64 in 447 | let sector_size = of_int t.info.Mirage_block.sector_size in 448 | let data_start_bytes = sub t.end_of_archive (of_int Tar.Header.length) in 449 | let header_start_bytes = sub data_start_bytes (of_int Tar.Header.length) in 450 | let sentinel = mul 2L (of_int Tar.Header.length) in 451 | let end_bytes = add data_start_bytes (add space_needed sentinel) in 452 | (* Compute the starting sector and ending sector *) 453 | let data_start_sector, data_start_sector_offset = 454 | div data_start_bytes sector_size, 455 | rem data_start_bytes sector_size 456 | in 457 | let end_sector = div (add end_bytes (pred sector_size)) sector_size in 458 | let last_sector_offset = rem end_bytes sector_size in 459 | let pad = Tar.Header.compute_zero_padding_length hdr in 460 | 461 | let data = 462 | let slack = 463 | if last_sector_offset = 0L then 464 | 0 465 | else 466 | to_int (sub sector_size last_sector_offset) 467 | in 468 | Cstruct.concat [ 469 | Cstruct.create (to_int data_start_sector_offset); 470 | data; 471 | Cstruct.create (pad + to_int sentinel + slack); 472 | ] 473 | in 474 | (* [data] is always at least one sector as the sentinel is always present *) 475 | let first_sector, remaining_sectors = Cstruct.split data t.info.sector_size in 476 | let last_sector = 477 | (* sub on whole [data] as the first sector and last sector might be the same *) 478 | Cstruct.sub data 479 | (Cstruct.length data - t.info.sector_size) 480 | t.info.sector_size 481 | in 482 | (* blit in slack at the end if needed *) 483 | begin if last_sector_offset = 0L then Lwt_result.return () else 484 | read_partial_sector t (pred end_sector) last_sector 485 | ~offset:last_sector_offset 486 | ~length:(sub sector_size last_sector_offset) 487 | end >>>= fun () -> 488 | (* to write robustly as we can: 489 | - we write sectors 2..n, 490 | - then the header, 491 | - then we blit the first (data) sector as it may contain the header, 492 | - finally we write the first (data) sector which contains the first tar data block. 493 | *) 494 | let remaining_sectors = 495 | (* XXX: this is to work around limitations in some block implementations *) 496 | List.init (Cstruct.length remaining_sectors / to_int sector_size) 497 | (fun sector -> 498 | Cstruct.sub remaining_sectors 499 | (sector * to_int sector_size) 500 | (to_int sector_size)) 501 | in 502 | write t (succ data_start_sector) remaining_sectors >>>= fun () -> 503 | (* finally write header and first block *) 504 | write_header t header_start_bytes hdr >>>= fun _new_offset -> 505 | (* read in slack at beginning which could include the header *) 506 | read_partial_sector t data_start_sector first_sector 507 | ~offset:0L ~length:data_start_sector_offset >>>= fun () -> 508 | write t data_start_sector [ first_sector ] >>>= fun () -> 509 | let tar_offset = Int64.div data_start_bytes (of_int Tar.Header.length) in 510 | t.end_of_archive <- end_bytes; 511 | t.map <- update_insert t.map key hdr tar_offset; 512 | Lwt.return (Ok ())) 513 | 514 | let remove t key = 515 | let ( >>>= ) = Lwt_result.bind in 516 | Lwt_mutex.with_lock t.write_lock (fun () -> 517 | match get_node t.map key with 518 | | Error e -> Lwt.return (Error e) 519 | | Ok (Dict _) -> Lwt.return (Error (`Value_expected key)) 520 | | Ok (Value (hdr, start_block)) -> 521 | (* We can only easily remove if the key is the very last entry. *) 522 | let open Int64 in 523 | let end_data_bytes = 524 | add (mul start_block 512L) 525 | (add hdr.file_size (of_int (Tar.Header.compute_zero_padding_length hdr))) 526 | in 527 | if equal end_data_bytes (sub t.end_of_archive 1024L) then begin 528 | t.map <- update_remove t.map key; 529 | let start_bytes = mul (pred start_block) 512L in 530 | let sector_size = of_int t.info.sector_size in 531 | let start_sector, start_sector_offset = 532 | div start_bytes sector_size, rem start_bytes sector_size 533 | in 534 | let end_bytes = add start_bytes 1024L in 535 | let end_sector, last_sector_offset = 536 | div (add end_bytes (pred sector_size)) sector_size, rem end_bytes sector_size 537 | in 538 | let buf = Cstruct.create (to_int (mul sector_size (sub end_sector start_sector))) in 539 | let first_sector = Cstruct.sub buf 0 t.info.sector_size in 540 | let last_sector = 541 | Cstruct.sub buf (Cstruct.length buf - t.info.sector_size) t.info.sector_size 542 | in 543 | read_partial_sector t start_sector_offset first_sector 544 | ~offset:0L ~length:start_sector_offset >>>= fun () -> 545 | begin if last_sector_offset = 0L then Lwt_result.return () else 546 | read_partial_sector t (pred end_sector) last_sector 547 | ~offset:last_sector_offset ~length:(sub sector_size last_sector_offset) 548 | end >>>= fun () -> 549 | (* To remove as robustly as possible we first zero the second 550 | sector (if applicable). *) 551 | begin if Cstruct.length buf > t.info.sector_size then 552 | write t (succ start_sector) 553 | [Cstruct.sub buf t.info.sector_size t.info.sector_size] >>>= fun () -> 554 | write t start_sector [Cstruct.sub buf 0 t.info.sector_size] 555 | else 556 | write t start_sector [buf] 557 | end >>>= fun () -> 558 | t.end_of_archive <- end_bytes; 559 | Lwt_result.return () 560 | end else 561 | Lwt.return (Error `Append_only)) 562 | 563 | let rename t ~source ~dest = 564 | let ( >>>= ) = Lwt_result.bind in 565 | Lwt_mutex.with_lock t.write_lock (fun () -> 566 | Lwt.return (is_safe_to_set t dest) >>>= fun () -> 567 | Lwt.return begin match get_node t.map source with 568 | | Ok Value (hdr, data_offset) -> Ok (hdr, data_offset) 569 | | Ok Dict _ -> Error `Append_only 570 | | Error _ as e -> e 571 | end >>>= fun (hdr, data_offset) -> 572 | let hdr = { hdr with Tar.Header.file_name = Mirage_kv.Key.to_string dest } in 573 | write_header t Int64.(sub (mul data_offset (of_int Tar.Header.length)) (of_int Tar.Header.length)) hdr >>>= fun _new_off -> 574 | t.map <- update_insert t.map dest hdr data_offset; 575 | t.map <- update_remove t.map source; 576 | Lwt_result.return ()) 577 | 578 | let set_partial t key ~offset data = 579 | let ( >>>= ) = Lwt_result.bind in 580 | Lwt_mutex.with_lock t.write_lock (fun () -> 581 | if Optint.Int63.(compare offset zero < 0) then 582 | invalid_arg "Tar_mirage.set_partial: negative offset"; 583 | Lwt.return begin match get_node t.map key with 584 | | Ok Value (hdr, data_offset) -> 585 | Ok (hdr, Int64.(mul data_offset (of_int Tar.Header.length))) 586 | | Ok Dict _ -> Error `Path_segment_is_a_value 587 | | Error _ as e -> e 588 | end >>>= fun (hdr, data_offset) -> 589 | let offset = Optint.Int63.to_int64 offset in 590 | let open Int64 in 591 | let end_bytes = add offset (of_int (String.length data)) in 592 | begin if end_bytes > hdr.file_size then 593 | Lwt_result.fail `Append_only 594 | else 595 | Lwt_result.return () 596 | end >>>= fun () -> 597 | (* compute the offsets into the archive *) 598 | let end_bytes = add data_offset end_bytes in 599 | let start_bytes = add data_offset offset in 600 | let sector_size = of_int t.info.sector_size in 601 | let start_sector_offset = rem start_bytes sector_size in 602 | let end_sector = div (add end_bytes (pred sector_size)) sector_size in 603 | let last_sector_offset = rem end_bytes sector_size in 604 | (* allocate a buffer for what we need to write, and blit in data and slack 605 | at first and last sector. *) 606 | let data' = 607 | let len = 608 | add start_sector_offset 609 | (add (of_int (String.length data)) 610 | (if last_sector_offset = 0L then 611 | 0L 612 | else 613 | sub sector_size last_sector_offset)) 614 | in 615 | Cstruct.create (to_int len) 616 | in 617 | Cstruct.blit_from_string data 0 data' 618 | (to_int start_sector_offset) (String.length data); 619 | read_partial_sector t (div start_bytes sector_size) data' 620 | ~offset:0L ~length:start_sector_offset >>>= fun () -> 621 | let last_sector = 622 | Cstruct.sub data' (Cstruct.length data' - t.info.sector_size) 623 | t.info.sector_size 624 | in 625 | begin if last_sector_offset = 0L then Lwt_result.return () else 626 | read_partial_sector t (pred end_sector) last_sector 627 | ~offset:last_sector_offset 628 | ~length:(sub sector_size last_sector_offset) 629 | end >>>= fun () -> 630 | (* XXX: this is to work around limitations in some block implementations *) 631 | let data' = 632 | List.init (Cstruct.length data' / t.info.sector_size) 633 | (fun sector -> 634 | Cstruct.sub data' (sector * t.info.sector_size) t.info.sector_size) 635 | in 636 | write t (div start_bytes sector_size) data') 637 | 638 | let allocate t key ?last_modified size = 639 | Lwt_mutex.with_lock t.write_lock (fun () -> 640 | let ( >>>= ) = Lwt_result.bind in 641 | let r = 642 | let ( let* ) = Result.bind in 643 | (* XXX: map `Entry_already_exists to `Append_only ?! *) 644 | let* () = is_safe_to_set t key in 645 | let hdr = header_of_key ?last_modified key (Optint.Int63.to_int size) in 646 | let space_needed = space_needed hdr in 647 | let* () = 648 | if free t >= Int64.(add space_needed (of_int Tar.Header.length)) then 649 | Ok () 650 | else 651 | Error `No_space 652 | in 653 | Ok (hdr, space_needed) 654 | in 655 | Lwt.return r >>>= fun (hdr, space_needed) -> 656 | let open Int64 in 657 | let sector_size = of_int t.info.Mirage_block.sector_size in 658 | let header_start_bytes = 659 | sub t.end_of_archive (of_int (2 * Tar.Header.length)) 660 | in 661 | (* we don't have to zero the block before end_of_archive as it is 662 | already zero due to the terminating double zero block (sentinel) *) 663 | let to_zero_start_bytes = t.end_of_archive in 664 | (* space_needed - 1 block + sentinel = space_needed + 1 block *) 665 | let end_bytes = add t.end_of_archive 666 | (add space_needed (of_int Tar.Header.length)) in 667 | (* Compute the starting sector and ending sector *) 668 | let to_zero_start_sector, to_zero_start_sector_offset = 669 | div to_zero_start_bytes sector_size, 670 | rem to_zero_start_bytes sector_size 671 | in 672 | let last_sector_offset = rem end_bytes sector_size in 673 | let end_sector = div (add end_bytes (pred sector_size)) sector_size in 674 | (* [num_to_zero_sectors] is at least 1 as we need to write at least one 675 | zero block of the new sentinel. *) 676 | let num_to_zero_sectors = to_int (sub end_sector to_zero_start_sector) in 677 | let zero_sector = Cstruct.create t.info.Mirage_block.sector_size in 678 | let data = Array.init num_to_zero_sectors (fun _ -> zero_sector) in 679 | let nonzero_sector c = 680 | (* we allocate a new buffer if [c] is [zero_sector], otherwise we can 681 | reuse it in the case first and last sectors are the same. *) 682 | if c != zero_sector then c else Cstruct.create (Cstruct.length c) 683 | in 684 | (* Read slack at start and end sector(s) *) 685 | let () = data.(0) <- nonzero_sector data.(0) in 686 | read_partial_sector t to_zero_start_sector data.(0) 687 | ~offset:0L 688 | ~length:to_zero_start_sector_offset 689 | >>>= fun () -> 690 | let last = nonzero_sector data.(num_to_zero_sectors - 1) in 691 | let () = data.(num_to_zero_sectors - 1 ) <- last in 692 | begin if last_sector_offset = 0L then Lwt_result.return () else 693 | read_partial_sector t (pred end_sector) last 694 | ~offset:last_sector_offset 695 | ~length:(sub sector_size last_sector_offset) 696 | end >>>= fun () -> 697 | write t to_zero_start_sector (Array.to_list data) >>>= fun () -> 698 | write_header t header_start_bytes hdr >>>= fun _new_offset -> 699 | let tar_offset = div (sub t.end_of_archive (of_int Tar.Header.length)) (of_int Tar.Header.length) in 700 | t.end_of_archive <- end_bytes; 701 | t.map <- update_insert t.map key hdr tar_offset; 702 | Lwt.return (Ok ())) 703 | end 704 | -------------------------------------------------------------------------------- /mirage/tar_mirage.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2006-2009 Citrix Systems Inc. 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Tar for Mirage *) 18 | 19 | module Make_KV_RO (BLOCK : Mirage_block.S) : sig 20 | (** Construct a read-only key-value store from an existing block device 21 | containing tar-format data. *) 22 | 23 | include Mirage_kv.RO 24 | 25 | val connect: BLOCK.t -> t Lwt.t 26 | (** [connect block] 27 | 28 | @raise Invalid_argument if [block] has a sector size that is not a 29 | positive multiple of 512. *) 30 | end 31 | 32 | module Make_KV_RW (BLOCK : Mirage_block.S) : sig 33 | (** Construct a read-write key-value store from an existing block device 34 | containing tar-format data. Note that it is append-only meaning removing 35 | or renaming files is currently unsupported and will return an error. *) 36 | 37 | include Mirage_kv.RW 38 | 39 | val connect: BLOCK.t -> t Lwt.t 40 | (** [connect block] 41 | 42 | @raise Invalid_argument if [block] has a sector size that is not a 43 | positive multiple of 512. *) 44 | 45 | val free : t -> int64 46 | (** [free t] is the number of unused bytes. *) 47 | end 48 | -------------------------------------------------------------------------------- /tar-eio.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Decode and encode tar format files using Eio" 4 | description: """ 5 | tar is a library to read and write tar files with an emphasis on 6 | streaming. This library uses Eio to provide a portable tar library. 7 | """ 8 | maintainer: ["Reynir Björnsson " "dave@recoil.org"] 9 | authors: [ 10 | "Dave Scott" 11 | "Thomas Gazagnaire" 12 | "David Allsopp" 13 | "Antonin Décimo" 14 | "Reynir Björnsson" 15 | "Hannes Mehnert" 16 | ] 17 | license: "ISC" 18 | tags: ["org:xapi-project" "org:mirage"] 19 | homepage: "https://github.com/mirage/ocaml-tar" 20 | doc: "https://mirage.github.io/ocaml-tar/" 21 | bug-reports: "https://github.com/mirage/ocaml-tar/issues" 22 | depends: [ 23 | "dune" {>= "2.9"} 24 | "ocaml" {>= "5.00.0"} 25 | "eio" {>= "1.1"} 26 | "tar" {= version} 27 | "odoc" {with-doc} 28 | ] 29 | build: [ 30 | ["dune" "subst"] {dev} 31 | [ 32 | "dune" 33 | "build" 34 | "-p" 35 | name 36 | "-j" 37 | jobs 38 | "--promote-install-files=false" 39 | "@install" 40 | "@runtest" {with-test} 41 | "@doc" {with-doc} 42 | ] 43 | ["dune" "install" "-p" name "--create-install-files" name] 44 | ] 45 | dev-repo: "git+https://github.com/mirage/ocaml-tar.git" 46 | x-maintenance-intent: [ "(latest)" ] 47 | -------------------------------------------------------------------------------- /tar-eio.opam.template: -------------------------------------------------------------------------------- 1 | x-maintenance-intent: [ "(latest)" ] 2 | -------------------------------------------------------------------------------- /tar-mirage.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Read and write tar format files via MirageOS interfaces" 4 | description: """ 5 | tar is a library to read and write tar files with an emphasis on 6 | streaming. This library is functorised over external OS dependencies 7 | to facilitate embedding within MirageOS. 8 | """ 9 | maintainer: ["Reynir Björnsson " "dave@recoil.org"] 10 | authors: [ 11 | "Dave Scott" 12 | "Thomas Gazagnaire" 13 | "David Allsopp" 14 | "Antonin Décimo" 15 | "Reynir Björnsson" 16 | "Hannes Mehnert" 17 | ] 18 | license: "ISC" 19 | tags: ["org:xapi-project" "org:mirage"] 20 | homepage: "https://github.com/mirage/ocaml-tar" 21 | doc: "https://mirage.github.io/ocaml-tar/" 22 | bug-reports: "https://github.com/mirage/ocaml-tar/issues" 23 | depends: [ 24 | "dune" {>= "2.9"} 25 | "ocaml" {>= "4.08.0"} 26 | "cstruct" {>= "6.0.0"} 27 | "lwt" {>= "5.6.0"} 28 | "mirage-block" {>= "2.0.0"} 29 | "mirage-ptime" {>= "5.0.0"} 30 | "mirage-kv" {>= "6.0.0"} 31 | "optint" 32 | "ptime" 33 | "tar" {= version} 34 | "mirage-block-unix" {with-test & >= "2.13.0"} 35 | "alcotest" {>= "1.7.0" & with-test} 36 | "alcotest-lwt" {>= "1.7.0" & with-test} 37 | "tar-unix" {with-test & = version} 38 | "odoc" {with-doc} 39 | ] 40 | conflicts: [ 41 | "result" {< "1.5"} 42 | ] 43 | build: [ 44 | ["dune" "subst"] {dev} 45 | [ 46 | "dune" 47 | "build" 48 | "-p" 49 | name 50 | "-j" 51 | jobs 52 | "--promote-install-files=false" 53 | "@install" 54 | "@runtest" {with-test} 55 | "@doc" {with-doc} 56 | ] 57 | ["dune" "install" "-p" name "--create-install-files" name] 58 | ] 59 | dev-repo: "git+https://github.com/mirage/ocaml-tar.git" 60 | x-maintenance-intent: [ "(latest)" ] 61 | -------------------------------------------------------------------------------- /tar-mirage.opam.template: -------------------------------------------------------------------------------- 1 | x-maintenance-intent: [ "(latest)" ] 2 | -------------------------------------------------------------------------------- /tar-unix.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Decode and encode tar format files from Unix" 4 | description: """ 5 | tar is a library to read and write tar files with an emphasis on 6 | streaming. This library provides a Unix or Windows compatible interface. 7 | """ 8 | maintainer: ["Reynir Björnsson " "dave@recoil.org"] 9 | authors: [ 10 | "Dave Scott" 11 | "Thomas Gazagnaire" 12 | "David Allsopp" 13 | "Antonin Décimo" 14 | "Reynir Björnsson" 15 | "Hannes Mehnert" 16 | ] 17 | license: "ISC" 18 | tags: ["org:xapi-project" "org:mirage"] 19 | homepage: "https://github.com/mirage/ocaml-tar" 20 | doc: "https://mirage.github.io/ocaml-tar/" 21 | bug-reports: "https://github.com/mirage/ocaml-tar/issues" 22 | depends: [ 23 | "dune" {>= "2.9"} 24 | "ocaml" {>= "4.08.0"} 25 | "lwt" {>= "5.7.0"} 26 | "tar" {= version} 27 | "odoc" {with-doc} 28 | ] 29 | build: [ 30 | ["dune" "subst"] {dev} 31 | [ 32 | "dune" 33 | "build" 34 | "-p" 35 | name 36 | "-j" 37 | jobs 38 | "--promote-install-files=false" 39 | "@install" 40 | "@runtest" {with-test} 41 | "@doc" {with-doc} 42 | ] 43 | ["dune" "install" "-p" name "--create-install-files" name] 44 | ] 45 | dev-repo: "git+https://github.com/mirage/ocaml-tar.git" 46 | x-maintenance-intent: [ "(latest)" ] 47 | -------------------------------------------------------------------------------- /tar-unix.opam.template: -------------------------------------------------------------------------------- 1 | x-maintenance-intent: [ "(latest)" ] 2 | -------------------------------------------------------------------------------- /tar.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Decode and encode tar format files in pure OCaml" 4 | description: """ 5 | tar is a library to read and write tar files with an emphasis on 6 | streaming. 7 | 8 | This is pure OCaml code, no C bindings. 9 | """ 10 | maintainer: ["Reynir Björnsson " "dave@recoil.org"] 11 | authors: [ 12 | "Dave Scott" 13 | "Thomas Gazagnaire" 14 | "David Allsopp" 15 | "Antonin Décimo" 16 | "Reynir Björnsson" 17 | "Hannes Mehnert" 18 | ] 19 | license: "ISC" 20 | tags: ["org:xapi-project" "org:mirage"] 21 | homepage: "https://github.com/mirage/ocaml-tar" 22 | doc: "https://mirage.github.io/ocaml-tar/" 23 | bug-reports: "https://github.com/mirage/ocaml-tar/issues" 24 | depends: [ 25 | "dune" {>= "2.9"} 26 | "ocaml" {>= "4.08.0"} 27 | "decompress" {>= "1.5.1"} 28 | "odoc" {with-doc} 29 | ] 30 | build: [ 31 | ["dune" "subst"] {dev} 32 | [ 33 | "dune" 34 | "build" 35 | "-p" 36 | name 37 | "-j" 38 | jobs 39 | "--promote-install-files=false" 40 | "@install" 41 | "@runtest" {with-test} 42 | "@doc" {with-doc} 43 | ] 44 | ["dune" "install" "-p" name "--create-install-files" name] 45 | ] 46 | dev-repo: "git+https://github.com/mirage/ocaml-tar.git" 47 | x-maintenance-intent: [ "(latest)" ] 48 | -------------------------------------------------------------------------------- /tar.opam.template: -------------------------------------------------------------------------------- 1 | x-maintenance-intent: [ "(latest)" ] 2 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (package tar-unix) 3 | (enabled_if (= %{os_type} "Unix")) 4 | (deps %{bin:otar})) 5 | -------------------------------------------------------------------------------- /test/tarball.t: -------------------------------------------------------------------------------- 1 | Tests of the otar binary 2 | $ mkdir archive 3 | $ echo "Hello World" > archive/foo 4 | $ otar archive/ v.tar.gz 5 | $ otar list v.tar.gz 6 | archive/ (Directory, 0 byte) 7 | archive/foo (Normal, 12.00 B) 8 | 9 | Tests decoding of various tar formats 10 | $ if tar --version | grep -q GNU; then 11 | > tar -cz --format=gnu -f v-gnu.tar.gz archive/ 12 | > otar list v-gnu.tar.gz 13 | > else printf "archive/ (Directory, 0 byte)\narchive/foo (Normal, 12.00 B)\n"; fi 14 | archive/ (Directory, 0 byte) 15 | archive/foo (Normal, 12.00 B) 16 | $ if tar --version | grep -q GNU; then 17 | > tar -cz --format=oldgnu -f v-oldgnu.tar.gz archive/ 18 | > otar list v-oldgnu.tar.gz 19 | > else printf "archive/ (Directory, 0 byte)\narchive/foo (Normal, 12.00 B)\n"; fi 20 | archive/ (Directory, 0 byte) 21 | archive/foo (Normal, 12.00 B) 22 | $ tar -cz --format=pax -f v-pax.tar.gz archive/ 23 | $ otar list v-pax.tar.gz 24 | archive/ (Directory, 0 byte) 25 | archive/foo (Normal, 12.00 B) 26 | $ tar -cz --format=posix -f v-posix.tar.gz archive/ 27 | $ otar list v-posix.tar.gz 28 | archive/ (Directory, 0 byte) 29 | archive/foo (Normal, 12.00 B) 30 | $ tar -cz --format=ustar -f v-ustar.tar.gz archive/ 31 | $ otar list v-ustar.tar.gz 32 | archive/ (Directory, 0 byte) 33 | archive/foo (Normal, 12.00 B) 34 | $ tar -cz --format=v7 -f v-v7.tar.gz archive/ 35 | $ otar list v-v7.tar.gz 36 | archive/ (Directory, 0 byte) 37 | archive/foo (Normal, 12.00 B) 38 | 39 | Test decoding of git archive 40 | $ git init -q archive && cd archive 41 | $ git config user.email 'author@example.com' && git config user.name 'A U Thor' 42 | $ git add . && git commit -q -m "Initial commit" 43 | $ git archive -o ../archive.tar.gz --prefix=archive/ HEAD 44 | $ cd ../ && otar list archive.tar.gz 45 | archive/ (Directory, 0 byte) 46 | archive/foo (Normal, 12.00 B) 47 | -------------------------------------------------------------------------------- /unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tar_unix) 3 | (public_name tar-unix) 4 | (libraries tar lwt lwt.unix) 5 | (wrapped false)) 6 | -------------------------------------------------------------------------------- /unix/tar_lwt_unix.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2006-2013 Citrix Systems Inc. 3 | * Copyright (C) 2012 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Tar.Syntax 19 | 20 | type decode_error = [ 21 | | `Fatal of Tar.error 22 | | `Unix of Unix.error * string * string 23 | | `Unexpected_end_of_file 24 | | `Msg of string 25 | ] 26 | 27 | let pp_decode_error ppf = function 28 | | `Fatal err -> Tar.pp_error ppf err 29 | | `Unix (err, fname, arg) -> 30 | Format.fprintf ppf "Unix error %s (function %s, arg %s)" 31 | (Unix.error_message err) fname arg 32 | | `Unexpected_end_of_file -> 33 | Format.fprintf ppf "Unexpected end of file" 34 | | `Msg msg -> 35 | Format.fprintf ppf "Error %s" msg 36 | 37 | let safe f a = 38 | let open Lwt.Infix in 39 | Lwt.catch 40 | (fun () -> f a >|= fun r -> Ok r) 41 | (function 42 | | Unix.Unix_error (e, f, a) -> Lwt.return (Error (`Unix (e, f, a))) 43 | | e -> Lwt.reraise e) 44 | 45 | let read_complete fd buf len = 46 | let open Lwt_result.Infix in 47 | let rec loop offset = 48 | if offset < len then 49 | safe (Lwt_unix.read fd buf offset) (len - offset) >>= fun read -> 50 | if read = 0 then 51 | Lwt.return (Error `Unexpected_end_of_file) 52 | else 53 | loop (offset + read) 54 | else 55 | Lwt.return (Ok ()) 56 | in 57 | loop 0 58 | 59 | let seek fd n = 60 | safe (Lwt_unix.lseek fd n) Unix.SEEK_CUR 61 | |> Lwt_result.map ignore 62 | 63 | let safe_close fd = 64 | Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) 65 | 66 | module High : sig 67 | type t 68 | type 'a s = 'a Lwt.t 69 | 70 | external inj : 'a s -> ('a, t) Tar.io = "%identity" 71 | external prj : ('a, t) Tar.io -> 'a s = "%identity" 72 | end = struct 73 | type t 74 | type 'a s = 'a Lwt.t 75 | 76 | external inj : 'a -> 'b = "%identity" 77 | external prj : 'a -> 'b = "%identity" 78 | end 79 | 80 | type t = High.t 81 | 82 | let value v = Tar.High (High.inj v) 83 | 84 | let run t fd = 85 | let open Lwt_result.Infix in 86 | let rec run : type a. (a, [> decode_error ] as 'err, t) Tar.t -> (a, 'err) result Lwt.t = function 87 | | Tar.Write str -> 88 | safe (Lwt_unix.write_string fd str 0) (String.length str) >>= fun _write -> 89 | Lwt_result.return () 90 | | Tar.Read len -> 91 | let b = Bytes.make len '\000' in 92 | safe (Lwt_unix.read fd b 0) len >>= fun read -> 93 | if read = 0 then 94 | Lwt_result.fail `Unexpected_end_of_file 95 | else if len = read then 96 | Lwt_result.return (Bytes.unsafe_to_string b) 97 | else 98 | Lwt_result.return (Bytes.sub_string b 0 read) 99 | | Tar.Really_read len -> 100 | let buf = Bytes.make len '\000' in 101 | read_complete fd buf len >|= fun () -> 102 | Bytes.unsafe_to_string buf 103 | | Tar.Seek len -> seek fd len 104 | | Tar.Return value -> Lwt.return value 105 | | Tar.High value -> High.prj value 106 | | Tar.Bind (x, f) -> 107 | run x >>= fun value -> run (f value) in 108 | run t 109 | 110 | let fold f filename init = 111 | let open Lwt_result.Infix in 112 | safe Lwt_unix.(openfile filename [ O_RDONLY ]) 0 >>= fun fd -> 113 | Lwt.finalize 114 | (fun () -> run (Tar.fold f init) fd) 115 | (fun () -> safe_close fd) 116 | 117 | let unix_err_to_msg = function 118 | | `Unix (e, f, s) -> 119 | `Msg (Format.sprintf "error %s in function %s %s" 120 | (Unix.error_message e) f s) 121 | 122 | let copy ~dst_fd len = 123 | let blen = 65536 in 124 | let rec read_write ~dst_fd len = 125 | if len = 0 then value (Lwt.return (Ok ())) 126 | else 127 | let slen = min blen len in 128 | let* str = Tar.really_read slen in 129 | let* _written = Lwt_result.map_error unix_err_to_msg 130 | (safe (Lwt_unix.write_string dst_fd str 0) slen) |> value in 131 | read_write ~dst_fd (len - slen) 132 | in 133 | read_write ~dst_fd len 134 | 135 | let extract ?(filter = fun _ -> true) ~src dst = 136 | let safe_close fd = 137 | let open Lwt.Infix in 138 | Lwt.catch 139 | (fun () -> Lwt_unix.close fd) 140 | (fun _ -> Lwt.return_unit) 141 | >|= Result.ok in 142 | let f ?global:_ hdr () = 143 | match filter hdr, hdr.Tar.Header.link_indicator with 144 | | true, Tar.Header.Link.Normal -> 145 | let* dst = Lwt_result.map_error 146 | unix_err_to_msg 147 | (safe Lwt_unix.(openfile (Filename.concat dst hdr.Tar.Header.file_name) [ O_WRONLY; O_CREAT ]) hdr.Tar.Header.file_mode) 148 | |> value in 149 | begin try 150 | let* () = copy ~dst_fd:dst (Int64.to_int hdr.Tar.Header.file_size) in 151 | let* () = value (safe_close dst) in 152 | Tar.return (Ok ()) 153 | with exn -> 154 | let* () = value (safe_close dst) in 155 | Tar.return (Error (`Exn exn)) 156 | end 157 | | _ -> 158 | let* () = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in 159 | Tar.return (Ok ()) 160 | in 161 | fold f src () 162 | 163 | (** Return the header needed for a particular file on disk *) 164 | let header_of_file ?level file = 165 | let open Lwt_result.Infix in 166 | let level = Tar.Header.compatibility level in 167 | safe Lwt_unix.LargeFile.stat file >>= fun stat -> 168 | let file_mode = stat.Lwt_unix.LargeFile.st_perm in 169 | let user_id = stat.Lwt_unix.LargeFile.st_uid in 170 | let group_id = stat.Lwt_unix.LargeFile.st_gid in 171 | let file_size = stat.Lwt_unix.LargeFile.st_size in 172 | let mod_time = Int64.of_float stat.Lwt_unix.LargeFile.st_mtime in 173 | let link_indicator = Tar.Header.Link.Normal in 174 | let link_name = "" in 175 | (if level = V7 then 176 | Lwt.return (Ok "") 177 | else 178 | Lwt.catch 179 | (fun () -> safe Lwt_unix.getpwuid stat.Lwt_unix.LargeFile.st_uid) 180 | (function 181 | | Not_found -> 182 | Lwt.return (Error (`Msg ("No user entry found for UID"))) 183 | | e -> Lwt.reraise e) >|= fun pwent -> 184 | pwent.Lwt_unix.pw_name) >>= fun uname -> 185 | (if level = V7 then 186 | Lwt.return (Ok "") 187 | else 188 | Lwt.catch 189 | (fun () -> safe Lwt_unix.getgrgid stat.Lwt_unix.LargeFile.st_gid) 190 | (function 191 | | Not_found -> 192 | Lwt.return (Error (`Msg ("No group entry found for GID"))) 193 | | e -> Lwt.reraise e) >|= fun grent -> 194 | grent.Lwt_unix.gr_name) >>= fun gname -> 195 | let devmajor = if level = Ustar then stat.Lwt_unix.LargeFile.st_dev else 0 in 196 | let devminor = if level = Ustar then stat.Lwt_unix.LargeFile.st_rdev else 0 in 197 | let hdr = Tar.Header.make ~file_mode ~user_id ~group_id ~mod_time ~link_indicator ~link_name 198 | ~uname ~gname ~devmajor ~devminor file file_size 199 | in 200 | Lwt.return (Ok hdr) 201 | 202 | let write_strings fd datas = 203 | let open Lwt_result.Infix in 204 | Lwt_list.fold_left_s (fun acc d -> 205 | Lwt_result.lift acc >>= fun _written -> 206 | Lwt_result.map_error unix_err_to_msg 207 | (safe (Lwt_unix.write_string fd d 0) (String.length d))) 208 | (Ok 0) datas >|= fun _written -> 209 | () 210 | 211 | let write_header ?level header fd = 212 | let open Lwt_result.Infix in 213 | Lwt_result.lift (Tar.encode_header ?level header) >>= fun header_strings -> 214 | write_strings fd header_strings 215 | 216 | let copy ~src_fd ~dst_fd len = 217 | let open Lwt_result.Infix in 218 | let blen = 65536 in 219 | let buffer = Bytes.make blen '\000' in 220 | let rec read_write ~src_fd ~dst_fd len = 221 | if len = 0 then 222 | Lwt.return (Ok ()) 223 | else 224 | let l = min blen len in 225 | Lwt_result.map_error 226 | (function 227 | | `Unix _ as e -> unix_err_to_msg e 228 | | `Unexpected_end_of_file -> 229 | `Msg "Unexpected end of file") 230 | (read_complete src_fd buffer l) >>= fun () -> 231 | Lwt_result.map_error unix_err_to_msg 232 | (safe (Lwt_unix.write dst_fd buffer 0) l) >>= fun _written -> 233 | read_write ~src_fd ~dst_fd (len - l) 234 | in 235 | read_write ~src_fd ~dst_fd len 236 | 237 | let append_file ?level ?header filename fd = 238 | let open Lwt_result.Infix in 239 | (match header with 240 | | None -> header_of_file ?level filename 241 | | Some x -> Lwt.return (Ok x)) >>= fun header -> 242 | write_header ?level header fd >>= fun () -> 243 | Lwt_result.map_error unix_err_to_msg 244 | (safe Lwt_unix.(openfile filename [ O_RDONLY ]) 0) >>= fun src -> 245 | (* TOCTOU [also, header may not be valid for file] *) 246 | Lwt.finalize 247 | (fun () -> copy ~src_fd:src ~dst_fd:fd 248 | (Int64.to_int header.Tar.Header.file_size)) 249 | (fun () -> safe_close src) 250 | 251 | let write_global_extended_header ?level header fd = 252 | let open Lwt_result.Infix in 253 | Lwt_result.lift (Tar.encode_global_extended_header ?level header) >>= fun header_strings -> 254 | write_strings fd header_strings 255 | 256 | let write_end fd = 257 | write_strings fd [ Tar.Header.zero_block ; Tar.Header.zero_block ] 258 | 259 | let create ?level ?global ?(filter = fun _ -> true) ~src dst = 260 | let open Lwt_result.Infix in 261 | Lwt_result.map_error unix_err_to_msg 262 | (safe Lwt_unix.(openfile dst [ O_WRONLY ; O_CREAT ]) 0o644) >>= fun dst_fd -> 263 | Lwt.finalize 264 | (fun () -> 265 | (match global with 266 | | None -> Lwt.return (Ok ()) 267 | | Some hdr -> write_global_extended_header ?level hdr dst_fd) >>= fun () -> 268 | let rec copy_files directory = 269 | safe Lwt_unix.opendir directory >>= fun dir -> 270 | Lwt.finalize 271 | (fun () -> 272 | let rec next () = 273 | try 274 | safe Lwt_unix.readdir dir >>= fun name -> 275 | let filename = Filename.concat directory name in 276 | header_of_file ?level filename >>= fun header -> 277 | if filter header then 278 | match header.Tar.Header.link_indicator with 279 | | Normal -> 280 | append_file ?level ~header filename dst_fd >>= fun () -> 281 | next () 282 | | Directory -> 283 | (* TODO first finish curdir (and close the dir fd), then go deeper *) 284 | copy_files filename >>= fun () -> 285 | next () 286 | | _ -> Lwt.return (Ok ()) (* NYI *) 287 | else Lwt.return (Ok ()) 288 | with End_of_file -> Lwt.return (Ok ()) 289 | in 290 | next ()) 291 | (fun () -> 292 | Lwt.catch 293 | (fun () -> Lwt_unix.closedir dir) 294 | (fun _ -> Lwt.return_unit)) 295 | in 296 | copy_files src >>= fun () -> 297 | write_end dst_fd) 298 | (fun () -> safe_close dst_fd) 299 | -------------------------------------------------------------------------------- /unix/tar_lwt_unix.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2006-2009 Citrix Systems Inc. 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Lwt_unix I/O for tar-formatted data *) 18 | 19 | type decode_error = [ 20 | | `Fatal of Tar.error 21 | | `Unix of Unix.error * string * string 22 | | `Unexpected_end_of_file 23 | | `Msg of string 24 | ] 25 | 26 | val pp_decode_error : Format.formatter -> decode_error -> unit 27 | 28 | type t 29 | 30 | val run : ('a, [> decode_error ] as 'b, t) Tar.t -> Lwt_unix.file_descr -> 31 | ('a, 'b) result Lwt.t 32 | val value : ('a, 'err) result Lwt.t -> ('a, 'err, t) Tar.t 33 | 34 | (** [fold f filename acc] folds over the tar archive. The function [f] is called 35 | for each [hdr : Tar.Header.t]. It should forward the position in the file 36 | descriptor by [hdr.Tar.Header.file_size]. *) 37 | val fold : 38 | (?global:Tar.Header.Extended.t -> Tar.Header.t -> 'a -> 39 | ('a, [> decode_error ] as 'err, t) Tar.t) -> 40 | string -> 'a -> ('a, 'err) result Lwt.t 41 | 42 | (** [extract ~filter ~src dst] extracts the tar archive [src] into the 43 | directory [dst]. If [filter] is provided (defaults to [fun _ -> true]), any 44 | file where [filter hdr] returns [false], is skipped. No directories are 45 | created including [dst] and any (implicit or explicit) directories in the 46 | archive. *) 47 | val extract : 48 | ?filter:(Tar.Header.t -> bool) -> 49 | src:string -> string -> 50 | (unit, [> `Exn of exn | decode_error ]) result Lwt.t 51 | 52 | (** [create ~level ~filter ~src dst] creates a tar archive at [dst]. It uses 53 | [src], a directory name, as input. If [filter] is provided 54 | (defaults to [fun _ -> true]), any file where [filter hdr] returns [false] 55 | is skipped. *) 56 | val create : ?level:Tar.Header.compatibility -> 57 | ?global:Tar.Header.Extended.t -> 58 | ?filter:(Tar.Header.t -> bool) -> 59 | src:string -> string -> 60 | (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result Lwt.t 61 | 62 | (** [header_of_file ~level filename] returns the tar header of [filename]. *) 63 | val header_of_file : ?level:Tar.Header.compatibility -> string -> 64 | (Tar.Header.t, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result Lwt.t 65 | 66 | (** [append_file ~level ~header filename fd] appends the contents of [filename] 67 | to the tar archive [fd]. If [header] is not provided, {header_of_file} is 68 | used for constructing a header. *) 69 | val append_file : ?level:Tar.Header.compatibility -> ?header:Tar.Header.t -> 70 | string -> Lwt_unix.file_descr -> 71 | (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result Lwt.t 72 | 73 | (** [write_header ~level hdr fd] writes the header [hdr] to [fd]. *) 74 | val write_header : ?level:Tar.Header.compatibility -> 75 | Tar.Header.t -> Lwt_unix.file_descr -> 76 | (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result Lwt.t 77 | 78 | (** [write_global_extended_header ~level hdr fd] writes the extended header [hdr] to 79 | [fd]. *) 80 | val write_global_extended_header : ?level:Tar.Header.compatibility -> 81 | Tar.Header.Extended.t -> Lwt_unix.file_descr -> 82 | (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result Lwt.t 83 | 84 | (** [write_end fd] writes the tar end marker to [fd]. *) 85 | val write_end : Lwt_unix.file_descr -> (unit, [ `Msg of string ]) result Lwt.t 86 | -------------------------------------------------------------------------------- /unix/tar_unix.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2006-2009 Citrix Systems Inc. 3 | * Copyright (C) 2012 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | let ( let* ) = Result.bind 19 | 20 | let rec safe f a = 21 | try Ok (f a) with 22 | | Unix.Unix_error (Unix.EINTR, _, _) -> safe f a 23 | | Unix.Unix_error (e, f, s) -> Error (`Unix (e, f, s)) 24 | 25 | let safe_close fd = 26 | try Unix.close fd with _ -> () 27 | 28 | let read_complete fd buf len = 29 | let rec loop offset = 30 | if offset < len then 31 | let* n = safe (Unix.read fd buf offset) (len - offset) in 32 | if n = 0 then 33 | Error `Unexpected_end_of_file 34 | else 35 | loop (offset + n) 36 | else 37 | Ok () 38 | in 39 | loop 0 40 | 41 | let seek fd n = 42 | safe (Unix.lseek fd n) Unix.SEEK_CUR 43 | |> Result.map ignore 44 | 45 | type error = [ 46 | | `Fatal of Tar.error 47 | | `Unix of Unix.error * string * string 48 | | `Unexpected_end_of_file 49 | | `Msg of string 50 | ] 51 | 52 | let pp_error ppf = function 53 | | `Fatal err -> Tar.pp_error ppf err 54 | | `Unix (err, fname, arg) -> 55 | Format.fprintf ppf "Unix error %s (function %s, arg %s)" 56 | (Unix.error_message err) fname arg 57 | | `Unexpected_end_of_file -> 58 | Format.fprintf ppf "Unexpected end of file" 59 | | `Msg msg -> 60 | Format.fprintf ppf "Error %s" msg 61 | 62 | (* XXX(dinosaure): This is a trick to pass from a value ['a] to a value 63 | [('a, High.t) Tar.io]. It may seem that the code is "unsafe" but physically 64 | the value remains the same (we mainly want to decorate the type of our value 65 | with new information). For more information on this trick, it is well 66 | described in this research paper: 67 | 68 | https://www.cl.cam.ac.uk/~jdy22/papers/lightweight-higher-kinded-polymorphism.pdf 69 | *) 70 | module High : sig 71 | type t 72 | type 'a s = 'a 73 | 74 | external inj : 'a s -> ('a, t) Tar.io = "%identity" 75 | external prj : ('a, t) Tar.io -> 'a s = "%identity" 76 | end = struct 77 | type t 78 | type 'a s = 'a 79 | 80 | external inj : 'a -> 'b = "%identity" 81 | external prj : 'a -> 'b = "%identity" 82 | end 83 | 84 | type t = High.t 85 | 86 | let value v = Tar.High (High.inj v) 87 | 88 | let run t fd = 89 | let rec run : type a. (a, _ as 'err, t) Tar.t -> (a, 'err) result = function 90 | | Tar.Write str -> 91 | let* _write = safe (Unix.write_substring fd str 0) (String.length str) in 92 | Ok () 93 | | Tar.Read len -> 94 | let b = Bytes.make len '\000' in 95 | let* read = safe (Unix.read fd b 0) len in 96 | if read = 0 then 97 | Error `Unexpected_end_of_file 98 | else if len = read then 99 | Ok (Bytes.unsafe_to_string b) 100 | else 101 | Ok (Bytes.sub_string b 0 read) 102 | | Tar.Really_read len -> 103 | let buf = Bytes.make len '\000' in 104 | begin match read_complete fd buf len with 105 | | Ok () -> Ok (Bytes.unsafe_to_string buf) 106 | | Error _ as err -> err end 107 | | Tar.Seek len -> seek fd len 108 | | Tar.Return value -> value 109 | | Tar.High value -> High.prj value 110 | | Tar.Bind (x, f) -> 111 | match run x with 112 | | Ok value -> run (f value) 113 | | Error _ as err -> err in 114 | run t 115 | 116 | let fold f filename init = 117 | let* fd = safe Unix.(openfile filename [ O_RDONLY ]) 0 in 118 | Fun.protect 119 | ~finally:(fun () -> safe_close fd) 120 | (fun () -> run (Tar.fold f init) fd) 121 | 122 | let unix_err_to_msg = function 123 | | `Unix (e, f, s) -> 124 | `Msg (Format.sprintf "error %s in function %s %s" 125 | (Unix.error_message e) f s) 126 | 127 | let copy ~dst_fd len = 128 | let blen = 65536 in 129 | let rec read_write ~dst_fd len = 130 | let open Tar.Syntax in 131 | if len = 0 then Tar.return (Ok ()) 132 | else 133 | let slen = min blen len in 134 | let* str = Tar.really_read (min blen len) in 135 | safe (Unix.write_substring dst_fd str 0) slen 136 | |> Result.map_error unix_err_to_msg 137 | |> function 138 | | Ok _ -> read_write ~dst_fd (len - slen) 139 | | Error _ as err -> Tar.return err 140 | in 141 | read_write ~dst_fd len 142 | 143 | let extract ?(filter = fun _ -> true) ~src dst = 144 | let f ?global:_ hdr () = 145 | if filter hdr then 146 | match hdr.Tar.Header.link_indicator with 147 | | Tar.Header.Link.Normal -> 148 | begin match Result.map_error unix_err_to_msg 149 | (safe Unix.(openfile (Filename.concat dst hdr.Tar.Header.file_name) 150 | [ O_WRONLY ; O_CREAT ]) hdr.Tar.Header.file_mode) with 151 | | Error _ as err -> Tar.return err 152 | | Ok dst -> 153 | try copy ~dst_fd:dst (Int64.to_int hdr.Tar.Header.file_size) 154 | with exn -> safe_close dst; Tar.return (Error (`Exn exn)) 155 | end 156 | (* TODO set owner / mode / mtime etc. *) 157 | | _ -> 158 | (* TODO handle directories, links, etc. *) 159 | let open Tar.Syntax in 160 | let* () = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in 161 | Tar.return (Ok ()) 162 | else 163 | let open Tar.Syntax in 164 | let* () = Tar.seek (Int64.to_int hdr.Tar.Header.file_size) in 165 | Tar.return (Ok ()) 166 | in 167 | fold f src () 168 | 169 | (** Return the header needed for a particular file on disk *) 170 | let header_of_file ?level file = 171 | let level = Tar.Header.compatibility level in 172 | let* stat = safe Unix.LargeFile.lstat file in 173 | let file_mode = stat.Unix.LargeFile.st_perm in 174 | let user_id = stat.Unix.LargeFile.st_uid in 175 | let group_id = stat.Unix.LargeFile.st_gid in 176 | let mod_time = Int64.of_float stat.Unix.LargeFile.st_mtime in 177 | (* TODO evaluate stat.st_kind *) 178 | let link_indicator = Tar.Header.Link.Normal in 179 | let link_name = "" in 180 | let* uname = 181 | if level = V7 then 182 | Ok "" 183 | else 184 | try 185 | let* passwd_entry = safe Unix.getpwuid stat.Unix.LargeFile.st_uid in 186 | Ok passwd_entry.Unix.pw_name 187 | with Not_found -> Error (`Msg ("No user entry found for UID")) 188 | in 189 | let devmajor = if level = Ustar then stat.Unix.LargeFile.st_dev else 0 in 190 | let* gname = 191 | if level = V7 then 192 | Ok "" 193 | else 194 | try 195 | let* passwd_entry = safe Unix.getgrgid stat.Unix.LargeFile.st_gid in 196 | Ok passwd_entry.Unix.gr_name 197 | with Not_found -> Error (`Msg "No group entry found for GID") 198 | in 199 | let devminor = if level = Ustar then stat.Unix.LargeFile.st_rdev else 0 in 200 | Ok (Tar.Header.make ~file_mode ~user_id ~group_id ~mod_time ~link_indicator ~link_name 201 | ~uname ~gname ~devmajor ~devminor file stat.Unix.LargeFile.st_size) 202 | 203 | let write_strings fd datas = 204 | let* _written = 205 | List.fold_left (fun acc d -> 206 | let* _written = acc in 207 | Result.map_error unix_err_to_msg 208 | (safe (Unix.write_substring fd d 0) (String.length d))) 209 | (Ok 0) datas 210 | in 211 | Ok () 212 | 213 | let write_header ?level header fd = 214 | let* header_strings = Tar.encode_header ?level header in 215 | write_strings fd header_strings 216 | 217 | let copy ~src_fd ~dst_fd len = 218 | let blen = 65536 in 219 | let buffer = Bytes.make blen '\000' in 220 | let rec read_write ~src_fd ~dst_fd len = 221 | if len = 0 then Ok () 222 | else 223 | let l = min blen len in 224 | let* () = 225 | Result.map_error 226 | (function 227 | | `Unix _ as e -> unix_err_to_msg e 228 | | `Unexpected_end_of_file -> 229 | `Msg "Unexpected end of file") 230 | (read_complete src_fd buffer l) 231 | in 232 | let* _written = 233 | Result.map_error unix_err_to_msg 234 | (safe (Unix.write dst_fd buffer 0) l) 235 | in 236 | read_write ~src_fd ~dst_fd (len - l) 237 | in 238 | read_write ~src_fd ~dst_fd len 239 | 240 | let append_file ?level ?header filename fd = 241 | let* header = match header with 242 | | None -> header_of_file ?level filename 243 | | Some x -> Ok x 244 | in 245 | let* () = write_header ?level header fd in 246 | let* src = 247 | Result.map_error unix_err_to_msg 248 | (safe Unix.(openfile filename [ O_RDONLY ]) 0) 249 | in 250 | (* TOCTOU [also, header may not be valid for file] *) 251 | Fun.protect ~finally:(fun () -> safe_close src) 252 | (fun () -> copy ~src_fd:src ~dst_fd:fd 253 | (Int64.to_int header.Tar.Header.file_size)) 254 | 255 | let write_global_extended_header ?level header fd = 256 | let* header_strings = Tar.encode_global_extended_header ?level header in 257 | write_strings fd header_strings 258 | 259 | let write_end fd = 260 | write_strings fd [ Tar.Header.zero_block ; Tar.Header.zero_block ] 261 | 262 | let create ?level ?global ?(filter = fun _ -> true) ~src dst = 263 | let* dst_fd = 264 | Result.map_error unix_err_to_msg 265 | (safe Unix.(openfile dst [ O_WRONLY ; O_CREAT ]) 0o644) 266 | in 267 | Fun.protect ~finally:(fun () -> safe_close dst_fd) 268 | (fun () -> 269 | let* () = match global with 270 | | None -> Ok () 271 | | Some hdr -> write_global_extended_header ?level hdr dst_fd 272 | in 273 | let rec copy_files directory = 274 | let* dir = safe Unix.opendir directory in 275 | Fun.protect ~finally:(fun () -> try Unix.closedir dir with _ -> ()) 276 | (fun () -> 277 | let rec next () = 278 | try 279 | let* name = safe Unix.readdir dir in 280 | let filename = Filename.concat directory name in 281 | let* header = header_of_file ?level filename in 282 | if filter header then 283 | match header.Tar.Header.link_indicator with 284 | | Normal -> 285 | let* () = append_file ?level ~header filename dst_fd in 286 | next () 287 | | Directory -> 288 | (* TODO first finish curdir (and close the dir fd), then go deeper *) 289 | let* () = copy_files filename in 290 | next () 291 | | _ -> Ok () (* NYI *) 292 | else Ok () 293 | with End_of_file -> Ok () 294 | in 295 | next ()) 296 | in 297 | let* () = copy_files src in 298 | write_end dst_fd) 299 | -------------------------------------------------------------------------------- /unix/tar_unix.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2006-2009 Citrix Systems Inc. 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Unix I/O for tar-formatted data. *) 18 | 19 | type error = [ 20 | | `Fatal of Tar.error 21 | | `Unix of Unix.error * string * string 22 | | `Unexpected_end_of_file 23 | | `Msg of string 24 | ] 25 | 26 | type t 27 | 28 | val pp_error : Format.formatter -> error -> unit 29 | 30 | val run : ('a, [> error ] as 'b, t) Tar.t -> Unix.file_descr -> ('a, 'b) result 31 | val value : ('a, 'err) result -> ('a, 'err, t) Tar.t 32 | 33 | (** [fold f filename acc] folds over the tar archive. The function [f] is called 34 | for each [hdr : Tar.Header.t]. It should forward the position in the file 35 | descriptor by [hdr.Tar.Header.file_size]. *) 36 | val fold : 37 | (?global:Tar.Header.Extended.t -> Tar.Header.t -> 'a -> 38 | ('a, error, t) Tar.t) -> 39 | string -> 'a -> ('a, error) result 40 | 41 | (** [extract ~filter ~src dst] extracts the tar archive [src] into the 42 | directory [dst]. If [filter] is provided (defaults to [fun _ -> true]), any 43 | file where [filter hdr] returns [false], is skipped. No directories are 44 | created including [dst] and any (implicit or explicit) directories in the 45 | archive. *) 46 | val extract : 47 | ?filter:(Tar.Header.t -> bool) -> 48 | src:string -> string -> 49 | (unit, [> `Exn of exn | error ]) result 50 | 51 | (** [create ~level ~filter ~src dst] creates a tar archive at [dst]. It uses 52 | [src], a directory name, as input. If [filter] is provided 53 | (defaults to [fun _ -> true]), any file where [filter hdr] returns [false] 54 | is skipped. *) 55 | val create : ?level:Tar.Header.compatibility -> 56 | ?global:Tar.Header.Extended.t -> 57 | ?filter:(Tar.Header.t -> bool) -> 58 | src:string -> string -> 59 | (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result 60 | 61 | (** [header_of_file ~level filename] returns the tar header of [filename]. *) 62 | val header_of_file : ?level:Tar.Header.compatibility -> string -> 63 | (Tar.Header.t, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result 64 | 65 | (** [append_file ~level ~header filename fd] appends the contents of [filename] 66 | to the tar archive [fd]. If [header] is not provided, {header_of_file} is 67 | used for constructing a header. *) 68 | val append_file : ?level:Tar.Header.compatibility -> ?header:Tar.Header.t -> 69 | string -> Unix.file_descr -> 70 | (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result 71 | 72 | (** [write_header ~level hdr fd] writes the header [hdr] to [fd]. *) 73 | val write_header : ?level:Tar.Header.compatibility -> 74 | Tar.Header.t -> Unix.file_descr -> 75 | (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result 76 | 77 | (** [write_global_extended_header ~level hdr fd] writes the extended header [hdr] to 78 | [fd]. *) 79 | val write_global_extended_header : ?level:Tar.Header.compatibility -> 80 | Tar.Header.Extended.t -> Unix.file_descr -> 81 | (unit, [ `Msg of string | `Unix of (Unix.error * string * string) ]) result 82 | 83 | (** [write_end fd] writes the tar end marker to [fd]. *) 84 | val write_end : Unix.file_descr -> (unit, [> `Msg of string ]) result 85 | --------------------------------------------------------------------------------