├── .gitignore ├── .merlin ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── _oasis ├── _tags ├── lib ├── META ├── descriptors.ml ├── iso.mldylib ├── iso.mllib ├── iso.mlpack ├── isofs.ml ├── multibyte.ml ├── pathtable.ml ├── records.ml ├── result.ml ├── s.ml ├── susp.ml └── timestamps.ml ├── lib_test ├── mkiso.sh └── test.ml ├── myocamlbuild.ml ├── opam └── setup.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | setup.bin 3 | setup.data 4 | setup.log 5 | test.native 6 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG lwt cstruct mirage-block-unix ounit io-page stringext 2 | S lib 3 | S lib_test 4 | B _build/lib 5 | B _build/lib_test 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: true 2 | language: c 3 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh 4 | script: bash -ex .travis-opam.sh 5 | env: 6 | - OCAML_VERSION=4.01 7 | - OCAML_VERSION=4.02 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Permission to use, copy, modify, and distribute this software for any 2 | purpose with or without fee is hereby granted, provided that the above 3 | copyright notice and this permission notice appear in all copies. 4 | 5 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 6 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 7 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 8 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 9 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 10 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 11 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 12 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean install build 2 | all: build doc 3 | 4 | NAME=iso-filesystem 5 | J=4 6 | 7 | export OCAMLRUNPARAM=b 8 | 9 | setup.bin: setup.ml 10 | @ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $< 11 | @rm -f setup.cmx setup.cmi setup.o setup.cmo 12 | 13 | setup.data: setup.bin 14 | @./setup.bin -configure --enable-tests 15 | 16 | build: setup.data setup.bin 17 | @./setup.bin -build -j $(J) 18 | 19 | doc: setup.data setup.bin 20 | @./setup.bin -doc -j $(J) 21 | 22 | test: setup.bin build 23 | @./lib_test/mkiso.sh 24 | @./setup.bin -test 25 | 26 | reinstall: setup.bin 27 | @ocamlfind remove $(NAME) || true 28 | @./setup.bin -reinstall 29 | 30 | clean: 31 | @ocamlbuild -clean 32 | @rm -f setup.data setup.log setup.bin test.iso 33 | 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ISO9660 Filesystem Library for OCaml 2 | ==================================== 3 | 4 | [![Build Status](https://travis-ci.org/jonludlam/ocaml-iso-filesystem.png?branch=master)](https://travis-ci.org/jonludlam/ocaml-iso-filesystem) 5 | 6 | A library that implements the ISO9660 filesystem. It exposes the 7 | contents via the KV_RO defined by the Mirage project. Extended 8 | filenames are supported via the Rock Ridge extensions. 9 | 10 | Currently read-only. 11 | 12 | See lib_test/test.ml for an example of usage. 13 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.4 2 | Name: iso9660-filesystem 3 | Version: 0.1 4 | Synopsis: ISO9660 filesystem manipulation 5 | Authors: Jon Ludlam 6 | License: ISC 7 | Plugins: META (0.4) 8 | BuildTools: ocamlbuild 9 | 10 | Library iso 11 | Pack: true 12 | CompiledObject: best 13 | Path: lib 14 | Findlibname: iso-filesystem 15 | Modules: Descriptors, Pathtable, Multibyte, Susp, Isofs, Records, Timestamps, Result, S 16 | BuildDepends: cstruct, re, mirage-types, lwt, stringext 17 | 18 | Executable test 19 | CompiledObject: best 20 | Path: lib_test 21 | MainIs: test.ml 22 | Custom: true 23 | Install: false 24 | BuildDepends: lwt, lwt.unix, iso-filesystem, cstruct, oUnit, mirage-block-unix, io-page, io-page.unix 25 | 26 | Test test 27 | Command: ./test.native 28 | Run: true 29 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: d242ca987a05167765789126dec9fcf6) 3 | # Ignore VCS directories, you can use the same kind of rule outside 4 | # OASIS_START/STOP if you want to exclude directories that contains 5 | # useless stuff for the build process 6 | true: annot, bin_annot 7 | <**/.svn>: -traverse 8 | <**/.svn>: not_hygienic 9 | ".bzr": -traverse 10 | ".bzr": not_hygienic 11 | ".hg": -traverse 12 | ".hg": not_hygienic 13 | ".git": -traverse 14 | ".git": not_hygienic 15 | "_darcs": -traverse 16 | "_darcs": not_hygienic 17 | # Library iso 18 | "lib/iso.cmxs": use_iso 19 | "lib/descriptors.cmx": for-pack(Iso) 20 | "lib/pathtable.cmx": for-pack(Iso) 21 | "lib/multibyte.cmx": for-pack(Iso) 22 | "lib/susp.cmx": for-pack(Iso) 23 | "lib/isofs.cmx": for-pack(Iso) 24 | "lib/records.cmx": for-pack(Iso) 25 | "lib/timestamps.cmx": for-pack(Iso) 26 | "lib/result.cmx": for-pack(Iso) 27 | "lib/s.cmx": for-pack(Iso) 28 | : pkg_cstruct 29 | : pkg_lwt 30 | : pkg_mirage-types 31 | : pkg_re 32 | : pkg_stringext 33 | # Executable test 34 | : pkg_cstruct 35 | : pkg_io-page 36 | : pkg_io-page.unix 37 | : pkg_lwt 38 | : pkg_lwt.unix 39 | : pkg_mirage-block-unix 40 | : pkg_mirage-types 41 | : pkg_oUnit 42 | : pkg_re 43 | : pkg_stringext 44 | : use_iso 45 | : pkg_cstruct 46 | : pkg_io-page 47 | : pkg_io-page.unix 48 | : pkg_lwt 49 | : pkg_lwt.unix 50 | : pkg_mirage-block-unix 51 | : pkg_mirage-types 52 | : pkg_oUnit 53 | : pkg_re 54 | : pkg_stringext 55 | : use_iso 56 | : custom 57 | # OASIS_STOP 58 | : syntax_camlp4o, pkg_cstruct.syntax 59 | : syntax_camlp4o, pkg_cstruct.syntax 60 | : syntax_camlp4o, pkg_cstruct.syntax 61 | : syntax_camlp4o, pkg_cstruct.syntax 62 | 63 | -------------------------------------------------------------------------------- /lib/META: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 76753c6c223c3ac567f04a6b515bdb52) 3 | version = "0.1" 4 | description = "ISO9660 filesystem manipulation" 5 | requires = "cstruct re mirage-types lwt stringext" 6 | archive(byte) = "iso.cma" 7 | archive(byte, plugin) = "iso.cma" 8 | archive(native) = "iso.cmxa" 9 | archive(native, plugin) = "iso.cmxs" 10 | exists_if = "iso.cma" 11 | # OASIS_STOP 12 | 13 | -------------------------------------------------------------------------------- /lib/descriptors.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 | open Result 18 | 19 | let identifier_val = "CD001" 20 | 21 | cenum volume_descriptor_type { 22 | BOOT_RECORD=0; 23 | PRIMARY_VOLUME_DESCRIPTOR=1; 24 | SUPPLEMENTARY_VOLUME_DESCRIPTOR=2; 25 | VOLUME_PARTITION_DESCRIPTOR=3; 26 | VOLUME_DESCRIPTOR_SET_TERMINATOR=255; 27 | } as uint8_t 28 | 29 | cstruct volume_descriptor { 30 | uint8_t ty; 31 | uint8_t id[5]; 32 | uint8_t version; 33 | uint8_t data[2041]; 34 | } as little_endian 35 | 36 | 37 | module Primary = struct 38 | type t = { 39 | system_id : string; 40 | volume_id : string; 41 | size : Int32.t; 42 | vol_set_size : int; 43 | vol_seq_no : int; 44 | block_size : int; 45 | path_table_size : Int32.t; 46 | path_table_l_loc : Int32.t option; 47 | opt_path_table_l_loc : Int32.t option; 48 | path_table_m_loc : Int32.t option; 49 | opt_path_table_m_loc : Int32.t option; 50 | root_dir : Pathtable.dir; 51 | volume_set_id : string; 52 | publisher_id : string; 53 | data_preparer_id : string; 54 | app_id : string; 55 | copyright : string; 56 | abstract_file_id : string; 57 | biblio_file_id : string; 58 | } 59 | 60 | cstruct pvd { 61 | uint8_t unused0; 62 | uint8_t system_id[32]; 63 | uint8_t volume_id[32]; 64 | uint8_t unused1[8]; 65 | uint8_t size_lsb_msb[8]; 66 | uint8_t unused2[32]; 67 | uint8_t vol_set_size_lsb_msb[4]; 68 | uint8_t vol_seq_no_lsb_msb[4]; 69 | uint8_t block_size_lsb_msb[4]; 70 | uint8_t path_table_size_lsb_msb[8]; 71 | uint32_t l_path_table; 72 | uint32_t opt_l_path_table; 73 | uint32_t m_path_table; 74 | uint32_t opt_m_path_table; 75 | uint8_t root_directory[34]; 76 | uint8_t volume_set_id[128]; 77 | uint8_t publisher_id[128]; 78 | uint8_t data_preparer_id[128]; 79 | uint8_t app_id[128]; 80 | uint8_t copyright[38]; 81 | uint8_t abstract_file_id[36]; 82 | uint8_t biblio_file_id[37]; 83 | uint8_t ctime[17]; 84 | uint8_t mtime[17]; 85 | uint8_t xtime[17]; 86 | uint8_t etime[17]; 87 | uint8_t file_structure_version; 88 | uint8_t unused3; 89 | } as little_endian 90 | 91 | let unmarshal pvd = 92 | let open Multibyte in 93 | let system_id = Cstruct.to_string (get_pvd_system_id pvd) in 94 | let volume_id = Cstruct.to_string (get_pvd_volume_id pvd) in 95 | let size = int32_of_lsb_msb (get_pvd_size_lsb_msb pvd) in 96 | let vol_set_size = int16_of_lsb_msb (get_pvd_vol_set_size_lsb_msb pvd) in 97 | let vol_seq_no = int16_of_lsb_msb (get_pvd_vol_seq_no_lsb_msb pvd) in 98 | let block_size = int16_of_lsb_msb (get_pvd_block_size_lsb_msb pvd) in 99 | let path_table_size = int32_of_lsb_msb (get_pvd_path_table_size_lsb_msb pvd) in 100 | let path_table_l_loc = get_pvd_l_path_table pvd in 101 | let opt_path_table_l_loc = get_pvd_opt_l_path_table pvd in 102 | Pathtable.unmarshal_directory (get_pvd_root_directory pvd) 103 | >>= fun root_dir -> 104 | let volume_set_id = Cstruct.to_string (get_pvd_volume_set_id pvd) in 105 | let publisher_id = Cstruct.to_string (get_pvd_publisher_id pvd) in 106 | let data_preparer_id = Cstruct.to_string (get_pvd_data_preparer_id pvd) in 107 | let app_id = Cstruct.to_string (get_pvd_app_id pvd) in 108 | let copyright = Cstruct.to_string (get_pvd_copyright pvd) in 109 | let abstract_file_id = Cstruct.to_string (get_pvd_abstract_file_id pvd) in 110 | let biblio_file_id = Cstruct.to_string (get_pvd_biblio_file_id pvd) in 111 | `Ok { system_id; volume_id; size; vol_set_size; vol_seq_no; block_size; 112 | path_table_size; path_table_l_loc = Some path_table_l_loc; 113 | opt_path_table_l_loc = Some opt_path_table_l_loc; path_table_m_loc = None; 114 | opt_path_table_m_loc = None; root_dir; volume_set_id; publisher_id; 115 | data_preparer_id; app_id; copyright; abstract_file_id; biblio_file_id } 116 | 117 | let print_pvd pvd = 118 | let string_of_int32_opt io = 119 | match io with 120 | | None -> "None" 121 | | Some i -> Printf.sprintf "%ld" i 122 | in 123 | let fields = ["system_id", pvd.system_id; 124 | "volume_id", pvd.volume_id; 125 | "size", Printf.sprintf "%ld" pvd.size; 126 | "vol_set_size", string_of_int pvd.vol_set_size; 127 | "vol_seq_no", string_of_int pvd.vol_seq_no; 128 | "block_size", string_of_int pvd.block_size; 129 | "path_table_size", Printf.sprintf "%ld" pvd.path_table_size; 130 | "path_table_l_loc", string_of_int32_opt pvd.path_table_l_loc; 131 | "opt_path_table_l_loc", string_of_int32_opt pvd.opt_path_table_l_loc; 132 | "path_table_m_loc", string_of_int32_opt pvd.path_table_m_loc; 133 | "opt_path_table_m_loc", string_of_int32_opt pvd.opt_path_table_m_loc; 134 | "volume_set_id", pvd.volume_set_id; 135 | "publisher_id", pvd.publisher_id; 136 | "data_preparer_id", pvd.data_preparer_id; 137 | "app_id", pvd.app_id; 138 | "copyright", pvd.copyright; 139 | "abstract_file_id", pvd.abstract_file_id; 140 | "biblio_file_id", pvd.biblio_file_id; 141 | ] 142 | in 143 | List.iter (fun (k,v) -> Printf.printf "%s: %s\n" k v) fields; 144 | Printf.printf "root_dir:\n"; 145 | Pathtable.print_directory pvd.root_dir 146 | 147 | end 148 | 149 | module Boot = struct 150 | type t = { 151 | system_id : string; 152 | boot_id : string; 153 | } 154 | 155 | cstruct boot_record { 156 | uint8_t boot_system_id[32]; 157 | uint8_t boot_id[32]; 158 | } as little_endian 159 | end 160 | 161 | 162 | type volume_descriptor = 163 | | Primary_volume_descriptor of Primary.t 164 | | Boot_record 165 | | Supplementary_volume_descriptor 166 | | Volume_partition_descriptor 167 | | Volume_descriptor_set_terminator 168 | 169 | let unmarshal (buf : Cstruct.t) = 170 | let ty = int_to_volume_descriptor_type (get_volume_descriptor_ty buf) in 171 | let id = Cstruct.to_string (get_volume_descriptor_id buf) in 172 | if id <> identifier_val then (`Error `Invalid_volume_descriptor_id) else 173 | match ty with 174 | | Some PRIMARY_VOLUME_DESCRIPTOR -> 175 | begin 176 | try 177 | let pvd = get_volume_descriptor_data buf in 178 | Primary.unmarshal pvd 179 | >>= fun result -> 180 | `Ok (Primary_volume_descriptor result) 181 | with e -> 182 | `Error `Invalid_primary_volume_descriptor 183 | end 184 | | Some BOOT_RECORD -> 185 | `Ok Boot_record 186 | | Some SUPPLEMENTARY_VOLUME_DESCRIPTOR -> 187 | `Ok Supplementary_volume_descriptor 188 | | Some VOLUME_PARTITION_DESCRIPTOR -> 189 | `Ok Volume_partition_descriptor 190 | | Some VOLUME_DESCRIPTOR_SET_TERMINATOR -> 191 | `Ok Volume_descriptor_set_terminator 192 | | None -> 193 | `Error `Unknown_volume_descriptor_type 194 | 195 | 196 | 197 | -------------------------------------------------------------------------------- /lib/iso.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 3a631438d6f2eba0ef81c8cc070fe15f) 3 | Iso 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /lib/iso.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 3a631438d6f2eba0ef81c8cc070fe15f) 3 | Iso 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /lib/iso.mlpack: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a3dfa407ed3f4db75ce54ea7a13f8837) 3 | Descriptors 4 | Pathtable 5 | Multibyte 6 | Susp 7 | Isofs 8 | Records 9 | Timestamps 10 | Result 11 | S 12 | # OASIS_STOP 13 | -------------------------------------------------------------------------------- /lib/isofs.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 | open Lwt 18 | 19 | type file_contents = 20 | | Immediate of string 21 | | OnDisk of Int32.t * Int32.t (* Location, length *) 22 | 23 | type file = { 24 | f_contents : file_contents; 25 | } 26 | 27 | and dir = { 28 | d_contents : (string * entry) list; 29 | } 30 | 31 | and entry = 32 | | Directory of dir 33 | | File of file 34 | 35 | exception FileNotFound of string 36 | 37 | let locate entries filename = 38 | if filename="" then raise (FileNotFound filename); 39 | 40 | let fullpath = Stringext.split filename ~on:'/' in 41 | 42 | (* Strip off leading '/' from path *) 43 | let relpath = match List.hd fullpath with "" -> List.tl fullpath | _ -> fullpath in 44 | 45 | let rec search entries path = 46 | let cur = List.hd path in 47 | let entry = 48 | try 49 | List.assoc cur entries 50 | with Not_found -> 51 | raise (FileNotFound filename) 52 | in 53 | match List.tl path, entry with 54 | | [], _ -> entry 55 | | rest, Directory d -> search d.d_contents rest 56 | | _, _ -> raise (FileNotFound filename) 57 | in 58 | search entries relpath 59 | 60 | 61 | exception No_pvd_found 62 | 63 | module Make (B: S.BLOCK_DEVICE 64 | with type 'a io = 'a Lwt.t 65 | and type page_aligned_buffer = Cstruct.t)(M: S.IO_PAGE) = struct 66 | 67 | type iso_t = { 68 | device : B.t; 69 | entries : (string * entry) list; 70 | } 71 | 72 | type t = iso_t 73 | 74 | type error = 75 | [ B.error 76 | | `Unknown_volume_descriptor_type 77 | | `Invalid_primary_volume_descriptor 78 | | `Invalid_volume_descriptor_id 79 | | `Invalid_SUSP_entry 80 | | `Unknown_error of string] 81 | 82 | type ('a, 'b) result = [ `Ok of 'a | `Error of 'b ] 83 | 84 | let openerr : ('a, [< error ]) result -> ('a, [>error]) result = 85 | function 86 | | `Ok x as z -> z 87 | | `Error `Disconnected as z -> z 88 | | `Error `Is_read_only as z -> z 89 | | `Error `Unimplemented as z -> z 90 | | `Error `Unknown _ as z -> z 91 | | `Error `Unknown_volume_descriptor_type as z -> z 92 | | `Error `Invalid_primary_volume_descriptor as z -> z 93 | | `Error `Invalid_volume_descriptor_id as z -> z 94 | | `Error `Invalid_SUSP_entry as z -> z 95 | | `Error `Unknown_error _ as z -> z 96 | 97 | exception Block_device_error of B.error 98 | 99 | let ((>>|=) : ('a, [< error]) result Lwt.t -> ('a -> ('c, [> error]) result Lwt.t) -> ('c, [> error]) result Lwt.t) = fun m f -> m >>= function 100 | | `Error x as z -> Lwt.return (openerr z) 101 | | `Ok x -> f x 102 | 103 | let return x = Lwt.return (`Ok x) 104 | 105 | let alloc bytes = 106 | let pages = M.get_buf ~n:((bytes + 4095) / 4096) () in 107 | Cstruct.sub pages 0 bytes 108 | 109 | let read device sector = 110 | let buf = alloc Records.sector_size in 111 | let sec = Int64.of_int32 Int32.(mul sector 4l) in 112 | B.read device sec [buf] 113 | 114 | let read_directory_entries sector = 115 | let len = Cstruct.len sector in 116 | let rec inner n acc = 117 | let entry_opt = Pathtable.maybe_unmarshal_directory 118 | (Cstruct.sub sector n (len - n)) in 119 | match entry_opt with 120 | | `Ok None -> 121 | `Ok acc 122 | | `Ok (Some entry) -> 123 | inner (n+entry.Pathtable.len) (entry::acc) 124 | | `Error _ as x -> x 125 | in 126 | inner 0 [] 127 | 128 | let rec read_whole_directory device dir = 129 | let name = Pathtable.get_filename dir in 130 | let sector = alloc 2048 in 131 | let read_sector n = 132 | B.read device Int64.(mul n 4L) [ sector ] 133 | >>|= fun () -> 134 | Lwt.return (read_directory_entries sector) 135 | in 136 | let total_sectors = Int64.(div (of_int32 dir.Pathtable.data_len) 2048L) in 137 | let rec inner n acc = 138 | if n=total_sectors 139 | then return (List.concat (List.rev acc)) 140 | else begin 141 | read_sector (Int64.add n (Int64.of_int32 dir.Pathtable.location)) 142 | >>|= fun entries -> 143 | inner Int64.(add n 1L) (entries::acc) 144 | end 145 | in 146 | inner 0L [] 147 | >>|= fun entries -> 148 | let convert_entry acc entry = 149 | acc >>|= fun entries -> 150 | let open Pathtable in 151 | let name = Pathtable.get_filename entry in 152 | if name="." || name=".." || Susp.is_dot_or_dotdot entry.Pathtable.susp 153 | then return entries 154 | else 155 | if List.mem Directory entry.flags 156 | then read_whole_directory device entry >>|= fun entry -> return (entry::entries) 157 | else return ((name, File { f_contents=OnDisk (entry.Pathtable.location, entry.Pathtable.data_len) })::entries) 158 | in 159 | List.fold_left convert_entry (return []) entries 160 | >>|= fun entries -> 161 | return (name, Directory { d_contents=entries }) 162 | 163 | let connect device = 164 | let page = alloc 4096 in 165 | B.get_info device >>= fun info -> 166 | let sector = Cstruct.sub page 0 Records.sector_size in 167 | let rec handle_volume_descriptors sector_num acc = 168 | B.read device (Int64.mul sector_num 4L) [ sector ] >>= fun x -> Lwt.return (openerr x) 169 | >>|= fun () -> 170 | match Descriptors.unmarshal sector with 171 | | `Ok Descriptors.Volume_descriptor_set_terminator -> return acc 172 | | `Ok other -> handle_volume_descriptors (Int64.add 1L sector_num) (other::acc) 173 | | _ -> return acc 174 | in 175 | handle_volume_descriptors 16L [] 176 | >>|= fun descriptors -> 177 | let pvd = List.fold_left (fun acc v -> 178 | match v with Descriptors.Primary_volume_descriptor pvd -> Some pvd | _ -> acc) None descriptors in 179 | (match pvd with 180 | | Some pvd -> 181 | begin 182 | read_whole_directory device pvd.Descriptors.Primary.root_dir 183 | >>|= fun x -> 184 | match x with 185 | | _, Directory {d_contents=entries} -> return {device; entries} 186 | | _, _ -> Lwt.return (`Error (`Unknown "Root directory wasn't a directory...?")) 187 | end 188 | | None -> 189 | Lwt.return (`Error (`Unknown "bah")) 190 | ) 191 | 192 | let size t key = 193 | begin 194 | try 195 | let res = `Ok (locate t.entries key) in 196 | Lwt.return res 197 | with 198 | | FileNotFound x -> 199 | Printf.printf "file not found: %s\n%!" x; 200 | Lwt.return (`Error (`Unknown_error "File not found")) 201 | end 202 | >>|= function 203 | | File { f_contents = OnDisk (loc, len) } -> 204 | return (Int64.of_int32 len) 205 | | _ -> 206 | Lwt.return (`Error (`Unknown_error "No such file")) 207 | 208 | let read t key offset length = 209 | begin 210 | try 211 | return (locate t.entries key) 212 | with 213 | | FileNotFound x -> 214 | Lwt.return (`Error (`Unknown_error "File not found")) 215 | end 216 | >>|= function 217 | | File { f_contents = OnDisk (loc, len) } -> 218 | let rounded_up_size = 2048 * ((Int32.to_int len + 2047) / 2048) in 219 | let pages = alloc rounded_up_size in 220 | let sector = Int64.mul 4L (Int64.of_int32 loc) in 221 | B.read t.device sector [pages] 222 | >>|= fun () -> 223 | return [Cstruct.sub pages offset length] 224 | | _ -> 225 | Lwt.return (`Error (`Unknown_error "No such file")) 226 | 227 | let listdir t key = 228 | begin 229 | try 230 | return (locate t.entries key) 231 | with 232 | | FileNotFound x -> 233 | Lwt.return (`Error (`Unknown_error "File not found")) 234 | end 235 | >>|= function 236 | | File _ -> 237 | Lwt.return (`Error (`Not_a_directory key)) 238 | | Directory d -> 239 | let contents = List.map fst d.d_contents in 240 | return contents 241 | 242 | module KV_RO = struct 243 | 244 | type t = iso_t 245 | 246 | type 'a io = 'a Lwt.t 247 | 248 | type id = B.t 249 | 250 | type error = 251 | | Unknown_key of string 252 | 253 | type page_aligned_buffer = Cstruct.t 254 | 255 | let disconnect t = Lwt.return () 256 | 257 | let read t key offset length = 258 | read t key offset length >>= function 259 | | `Ok x -> return x 260 | | _ -> Lwt.return (`Error (Unknown_key key)) 261 | 262 | let size t key = 263 | size t key >>= function 264 | | `Ok x -> return x 265 | | _ -> Lwt.return (`Error (Unknown_key key)) 266 | 267 | end 268 | 269 | end 270 | 271 | -------------------------------------------------------------------------------- /lib/multibyte.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 | (* Some Iso9660 are stored as both big and little endian values. 18 | This exception is raised if they're not the same (when non-zero) *) 19 | 20 | exception Invalid_coding 21 | 22 | let int32_of_lsb_msb v = 23 | let lsb = Cstruct.LE.get_uint32 v 0 in 24 | let msb = Cstruct.BE.get_uint32 v 4 in 25 | match lsb, msb with 26 | | x, 0l -> x 27 | | 0l, x -> x 28 | | x, y -> if x<>y then raise Invalid_coding else x 29 | 30 | let int16_of_lsb_msb v = 31 | let lsb = Cstruct.LE.get_uint16 v 0 in 32 | let msb = Cstruct.BE.get_uint16 v 2 in 33 | match lsb, msb with 34 | | x, 0 -> x 35 | | 0, x -> x 36 | | x, y -> if x<>y then raise Invalid_coding else x 37 | 38 | let roundup n = if n mod 2 = 1 then n+1 else n 39 | 40 | -------------------------------------------------------------------------------- /lib/pathtable.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 | open Result 18 | 19 | type flag = | Hidden | Directory | AssociatedFile | Format | Perms | NotFinal 20 | 21 | let string_of_flag = function 22 | | Hidden -> "Hidden" 23 | | Directory -> "Directory" 24 | | AssociatedFile -> "AssociatedFile" 25 | | Format -> "Format" 26 | | Perms -> "Perms" 27 | | NotFinal -> "NotFinal" 28 | 29 | type path_table_entry = { 30 | pte_location : Int32.t; 31 | pte_parent : int; 32 | pte_name : string; 33 | } 34 | 35 | type dir = { 36 | len : int; 37 | ext_len : int; 38 | location : Int32.t; 39 | data_len : Int32.t; 40 | date : unit; 41 | flags : flag list; 42 | file_unit_size : int; 43 | gap_size : int; 44 | vol_seq : int; 45 | filename : string; 46 | susp : Susp.t list; 47 | } 48 | 49 | cstruct directory { 50 | uint8_t len; 51 | uint8_t ext_len; 52 | uint8_t location_lsb_msb[8]; 53 | uint8_t data_len_lsb_msb[8]; 54 | uint8_t date[7]; 55 | uint8_t flags; 56 | uint8_t file_unit_size; 57 | uint8_t gap_size; 58 | uint8_t vol_seq_lsb_msb[4]; 59 | uint8_t filename_length; 60 | uint8_t filename_start; 61 | } as little_endian 62 | 63 | cstruct path_table_entry_lsb { 64 | uint8_t len; 65 | uint8_t ext_len; 66 | uint32_t location; 67 | uint16_t parent_dir; 68 | } as little_endian 69 | 70 | let unmarshal_one_pte_lsb v = 71 | let len = get_path_table_entry_lsb_len v in 72 | let ext_len = get_path_table_entry_lsb_ext_len v in 73 | let location = get_path_table_entry_lsb_location v in 74 | let parent = get_path_table_entry_lsb_parent_dir v in 75 | let name = Cstruct.to_string (Cstruct.sub v 8 len) in 76 | { pte_location=location; pte_parent=parent; pte_name=name } 77 | 78 | let unmarshal_pte_lsb v = 79 | let size = Cstruct.len v in 80 | let rec inner n = 81 | if n >= size then [] else 82 | let v' = Cstruct.sub v n (size-n) in 83 | let pte = unmarshal_one_pte_lsb v' in 84 | let next = n + 8 + String.length pte.pte_name |> Multibyte.roundup in 85 | pte :: (inner next) 86 | in inner 0 87 | 88 | let unmarshal_flags f = 89 | let fs = [ 90 | 0x1, Hidden; 91 | 0x2, Directory; 92 | 0x4, AssociatedFile; 93 | 0x8, Format; 94 | 0x10, Perms; 95 | (* 0x20 and 0x40 are reserved *) 96 | 0x80, NotFinal ] in 97 | let rec test n acc = 98 | if n>0x80 then acc else 99 | let acc' = 100 | if n land f = n 101 | then (List.assoc n fs)::acc 102 | else acc 103 | in 104 | test (n*2) acc' 105 | in 106 | try 107 | test 1 [] 108 | with Not_found -> 109 | failwith "Invalid flags entry" 110 | 111 | let unmarshal_directory v = 112 | let len = get_directory_len v in 113 | let ext_len = get_directory_ext_len v in 114 | let location = Multibyte.int32_of_lsb_msb (get_directory_location_lsb_msb v) in 115 | let data_len = Multibyte.int32_of_lsb_msb (get_directory_data_len_lsb_msb v) in 116 | let date = () in 117 | let flags_int = get_directory_flags v in 118 | let flags = unmarshal_flags flags_int in 119 | let file_unit_size = get_directory_file_unit_size v in 120 | let gap_size = get_directory_gap_size v in 121 | let vol_seq = Multibyte.int16_of_lsb_msb (get_directory_vol_seq_lsb_msb v) in 122 | let filename_len = get_directory_filename_length v in 123 | let filename = Cstruct.to_string (Cstruct.sub v 33 (filename_len)) in 124 | let susp_start = Multibyte.roundup (33+filename_len) in 125 | Susp.unmarshal (Cstruct.sub v susp_start (len - susp_start)) 126 | >>= fun susp -> 127 | `Ok { len; ext_len; location; data_len; date; flags; file_unit_size; gap_size; vol_seq; filename; susp } 128 | 129 | let maybe_unmarshal_directory v = 130 | let len = get_directory_len v in 131 | if len = 0 then `Ok None else begin 132 | unmarshal_directory v 133 | >>= fun dir -> 134 | `Ok (Some dir) 135 | end 136 | 137 | let print_directory d = 138 | let fields = [ 139 | "len", string_of_int d.len; 140 | "ext_len", string_of_int d.ext_len; 141 | "location", Int32.to_string d.location; 142 | "data_len", Int32.to_string d.data_len; 143 | "flags", String.concat "," (List.map string_of_flag d.flags); 144 | "file_unit_size", string_of_int d.file_unit_size; 145 | "gap_size", string_of_int d.gap_size; 146 | "vol_seq", string_of_int d.vol_seq; 147 | "filename", d.filename ] in 148 | List.iter (fun (k,v) -> Printf.printf "%s: %s\t" k v) fields 149 | 150 | let get_filename d = 151 | let base_iso_filename = Stringext.split ~on:';' d.filename |> List.hd in 152 | let filename = List.fold_left 153 | (fun acc s -> match s with | Susp.NM nm -> nm.Susp.Nm.filename | _ -> acc) 154 | base_iso_filename d.susp in 155 | if List.mem Directory d.flags 156 | then begin 157 | match d.filename with 158 | | "\000" -> "." 159 | | "\001" -> ".." 160 | | x -> filename 161 | end else filename 162 | -------------------------------------------------------------------------------- /lib/records.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 | (* ISO 9660 records *) 18 | 19 | type strA (* A-Z, 0-9, !, '\"' % & '\'' ( ) * + , - . / : ; < = > ? *) 20 | 21 | type strD (* A-Z, 0-9, _ *) 22 | 23 | 24 | let sector_size = 2048 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /lib/result.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 | 18 | type ('a, 'b) t = [ `Ok of 'a | `Error of 'b ] 19 | 20 | let bind : ('a, 'b) t -> ('a -> ('c, 'b) t) -> ('c, 'b) t = fun m f -> match m with 21 | | `Ok x -> f x 22 | | `Error _ as y -> y 23 | 24 | let return x = `Ok x 25 | 26 | let (>>=) = bind 27 | -------------------------------------------------------------------------------- /lib/s.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 | module type BLOCK_DEVICE = V1.BLOCK 18 | with type page_aligned_buffer = Cstruct.t 19 | and type 'a io = 'a Lwt.t 20 | 21 | module type IO_PAGE = sig 22 | val get_buf : ?n:int -> unit -> Cstruct.t 23 | (** [get_buf ~n ()] allocates and returns a memory block of [n] pages, 24 | represented as a {!Cstruct.t}. If there is not enough memory, 25 | an [Out_of_memory] exception is raised. *) 26 | end 27 | 28 | module type FS = V1.FS 29 | with type page_aligned_buffer = Cstruct.t 30 | and type 'a io = 'a Lwt.t 31 | -------------------------------------------------------------------------------- /lib/susp.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 | module Px = struct 18 | (* It seems that sometimes the serial field is omitted. Sadly, 19 | the version field doesn't seem to tell us whether to expect 20 | it or not, so we rely on the 'length' field, which is 44 21 | when the field is present, and 36 when not. Represent this 22 | in 't' with an option type *) 23 | 24 | type t = { 25 | mode : Int32.t; 26 | links : Int32.t; 27 | uid : Int32.t; 28 | gid : Int32.t; 29 | serial : Int32.t option; 30 | } 31 | 32 | cstruct px { 33 | uint8_t mode[8]; 34 | uint8_t links[8]; 35 | uint8_t uid[8]; 36 | uint8_t gid[8]; 37 | uint8_t serial[8]; 38 | } as little_endian 39 | 40 | let unmarshal v len = 41 | let mode = Multibyte.int32_of_lsb_msb (get_px_mode v) in 42 | let links = Multibyte.int32_of_lsb_msb (get_px_links v) in 43 | let uid = Multibyte.int32_of_lsb_msb (get_px_uid v) in 44 | let gid = Multibyte.int32_of_lsb_msb (get_px_gid v) in 45 | let serial = 46 | if len=44 47 | then Some (Multibyte.int32_of_lsb_msb (get_px_serial v)) 48 | else None in 49 | { mode; links; uid; gid; serial } 50 | 51 | end 52 | 53 | module Pn = struct 54 | type t = { 55 | dev : Int64.t 56 | } 57 | 58 | cstruct pn { 59 | uint8_t high[8]; 60 | uint8_t low[8]; 61 | } as little_endian 62 | 63 | let unmarshal v = 64 | let high = Multibyte.int32_of_lsb_msb (get_pn_high v) in 65 | let low = Multibyte.int32_of_lsb_msb (get_pn_low v) in 66 | let open Int64 in 67 | let conv x = logand 0x00000000ffffffffL (of_int32 x) in 68 | let dev = add (shift_left (conv high) 32) (conv low) in 69 | { dev } 70 | 71 | end 72 | 73 | module Nm = struct 74 | type t = { 75 | is_current : bool; 76 | is_parent : bool; 77 | cont : bool; 78 | filename : string; 79 | } 80 | 81 | cstruct nm { 82 | uint8_t flags; 83 | } as little_endian 84 | 85 | let unmarshal v = 86 | let flags = get_nm_flags v in 87 | let is_current = (flags land 2 = 2) in 88 | let is_parent = (flags land 4 = 4) in 89 | let cont = (flags land 1 = 1) in 90 | let filename = Cstruct.to_string (Cstruct.sub v 1 (Cstruct.len v - 1)) in 91 | { is_current; is_parent; cont; filename } 92 | 93 | end 94 | 95 | module Ce = struct 96 | type t = { 97 | block_location : Int32.t; 98 | offset : Int32.t; 99 | length : Int32.t; 100 | } 101 | 102 | cstruct ce { 103 | uint8_t block_location[8]; 104 | uint8_t offset[8]; 105 | uint8_t length[8]; 106 | } as little_endian 107 | 108 | let unmarshal v = 109 | let block_location = Multibyte.int32_of_lsb_msb (get_ce_block_location v) in 110 | let offset = Multibyte.int32_of_lsb_msb (get_ce_offset v) in 111 | let length = Multibyte.int32_of_lsb_msb (get_ce_length v) in 112 | { block_location; offset; length } 113 | 114 | let print ce = 115 | Printf.printf "{ block_location=%ld; offset=%ld; length=%ld }" ce.block_location ce.offset ce.length 116 | end 117 | 118 | module Sp = struct 119 | type t = { 120 | skip : int; 121 | } 122 | 123 | cstruct sp { 124 | uint8_t be; 125 | uint8_t ef; 126 | uint8_t skip; 127 | } as little_endian 128 | 129 | let unmarshal v = 130 | let be = get_sp_be v in 131 | let ef = get_sp_ef v in 132 | let skip = get_sp_skip v in 133 | if be <> 0xbe || ef <> 0xef then failwith "Not rock ridge"; 134 | { skip } 135 | 136 | let print sp = 137 | Printf.printf "{ skip=%x }" sp.skip 138 | end 139 | 140 | module Tf = struct 141 | type ty = 142 | | Creation 143 | | Modify 144 | | Access 145 | | Attributes 146 | | Backup 147 | | Expiration 148 | | Effective 149 | 150 | type t = (ty * Timestamps.t) list 151 | 152 | let bits = [ 153 | 0x01, Creation; 154 | 0x02, Modify; 155 | 0x04, Access; 156 | 0x08, Attributes; 157 | 0x10, Backup; 158 | 0x20, Expiration; 159 | 0x40, Effective 160 | ] 161 | 162 | let unmarshal v = 163 | let flags = Cstruct.get_uint8 v 0 in 164 | let len, unmarshal = 165 | if flags land 0x80 = 0x80 166 | then 17, Timestamps.Long.unmarshal 167 | else 7, Timestamps.Short.unmarshal 168 | in 169 | let rec inner n off acc = 170 | if n=0x80 then acc else 171 | if flags land n = n 172 | then 173 | let entry = unmarshal (Cstruct.sub v off len) in 174 | let ty = List.assoc n bits in 175 | inner (n*2) (off+len) ((ty,entry)::acc) 176 | else 177 | inner (n*2) (off+len) acc 178 | in inner 1 1 [] 179 | 180 | end 181 | 182 | 183 | type unhandled_entry = { 184 | signature : string; 185 | version : int; 186 | data : Cstruct.t; 187 | } 188 | 189 | cstruct susp { 190 | uint8_t signature[2]; 191 | uint8_t len; 192 | uint8_t version; 193 | } as little_endian 194 | 195 | type t = 196 | | NM of Nm.t 197 | | PX of Px.t 198 | | CE of Ce.t 199 | | TF of Tf.t 200 | | SP of Sp.t 201 | | Unhandled of unhandled_entry 202 | 203 | type error = [ `Invalid_SUSP_entry ] 204 | 205 | let unmarshal v = 206 | let total_len = Cstruct.len v in 207 | let rec inner n acc = 208 | if n>=total_len-1 then `Ok acc else begin 209 | let susp_header = Cstruct.sub v n 4 in 210 | let signature = Cstruct.to_string (get_susp_signature susp_header) in 211 | let len = get_susp_len susp_header in 212 | if len<5 || n+len > total_len 213 | then `Error `Invalid_SUSP_entry 214 | else 215 | let version = get_susp_version susp_header in 216 | let data = Cstruct.sub v (n+4) (len-4) in 217 | let entry = 218 | match signature with 219 | | "NM" -> let nm = Nm.unmarshal data in NM nm 220 | | "PX" -> let px = Px.unmarshal data len in PX px 221 | | "CE" -> let ce = Ce.unmarshal data in CE ce 222 | | "TF" -> let tf = Tf.unmarshal data in TF tf 223 | | x -> Unhandled { signature; version; data } 224 | in 225 | inner (n+len) (entry :: acc) 226 | end 227 | in inner 0 [] 228 | 229 | let is_dot_or_dotdot susp = 230 | List.fold_left (fun acc entry -> match entry with | NM nm -> nm.Nm.is_current || nm.Nm.is_parent || acc | _ -> acc) false susp 231 | -------------------------------------------------------------------------------- /lib/timestamps.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 | type t = { 18 | year : int; 19 | month : int; 20 | day : int; 21 | hour : int; 22 | minute : int; 23 | second : int; 24 | hundredths : int; 25 | tz : int; 26 | } 27 | 28 | module Long = struct 29 | cstruct tx { 30 | uint8_t year[4]; 31 | uint8_t month[2]; 32 | uint8_t day[2]; 33 | uint8_t hour[2]; 34 | uint8_t minute[2]; 35 | uint8_t second[2]; 36 | uint8_t hundredths[2]; 37 | uint8_t tz 38 | } as little_endian 39 | 40 | let unmarshal v = 41 | let year = int_of_string (Cstruct.to_string (get_tx_year v)) in 42 | let month = int_of_string (Cstruct.to_string (get_tx_month v)) in 43 | let day = int_of_string (Cstruct.to_string (get_tx_day v)) in 44 | let hour = int_of_string (Cstruct.to_string (get_tx_hour v)) in 45 | let minute = int_of_string (Cstruct.to_string (get_tx_minute v)) in 46 | let second = int_of_string (Cstruct.to_string (get_tx_second v)) in 47 | let hundredths = int_of_string (Cstruct.to_string (get_tx_hundredths v)) in 48 | let tz = get_tx_tz v in 49 | { year; month; day; hour; minute; second; hundredths; tz } 50 | 51 | end 52 | 53 | module Short = struct 54 | cstruct tx { 55 | uint8_t year; 56 | uint8_t month; 57 | uint8_t day; 58 | uint8_t hour; 59 | uint8_t minute; 60 | uint8_t second; 61 | uint8_t tz; 62 | } as little_endian 63 | 64 | let unmarshal v = 65 | let year = get_tx_year v in 66 | let month = get_tx_month v in 67 | let day = get_tx_day v in 68 | let hour = get_tx_hour v in 69 | let minute = get_tx_minute v in 70 | let second = get_tx_second v in 71 | let tz = get_tx_tz v in 72 | { year = year + 1900; month; day; hour; minute; second; hundredths=0; tz } 73 | end 74 | -------------------------------------------------------------------------------- /lib_test/mkiso.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | if type "mkisofs" > /dev/null; then 4 | mkdir test_iso 5 | echo "hello, world!" > test_iso/hello.txt 6 | echo "old file" > test_iso/old.txt 7 | touch -t 197001010001 test_iso/old.txt 8 | mkisofs -o test.iso -R test_iso 9 | else 10 | curl http://www.recoil.org/~jon/ocaml-iso9660-test.iso -o test.iso 11 | fi 12 | 13 | 14 | -------------------------------------------------------------------------------- /lib_test/test.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 | open OUnit 18 | open Lwt 19 | open Iso 20 | 21 | module Iso = Isofs.Make(Block)(Io_page) 22 | 23 | let get_description f = 24 | let open Isofs in 25 | match f.f_contents with 26 | | OnDisk (location, length) -> Printf.sprintf "%ld, %ld" (Int32.mul 2048l location) length 27 | | Immediate s -> Printf.sprintf "'%s'" s 28 | 29 | exception Error 30 | let (>>|=) m f = m >>= function 31 | | `Error e -> fail Error 32 | | `Ok x -> f x 33 | 34 | let rec print prefix entries = 35 | List.iter 36 | (function 37 | | (name, Isofs.File f) -> 38 | Printf.printf "%s%s (%s)\n" prefix name (get_description f) 39 | | (name, Isofs.Directory d) -> 40 | Printf.printf "%s%s\n" prefix name; 41 | print (Printf.sprintf "%s%s/" prefix name) d.Isofs.d_contents 42 | ) 43 | entries 44 | 45 | let th = 46 | Block.connect "test.iso" 47 | >>|= fun b -> 48 | Iso.connect b 49 | >>|= fun iso -> 50 | print "/" iso.Iso.entries; 51 | Iso.KV_RO.size iso "/hello.txt" 52 | >>|= fun size -> 53 | Iso.KV_RO.read iso "/hello.txt" 0 (Int64.to_int size) 54 | >>|= fun result -> 55 | List.iter (fun x -> Printf.printf "%s" (Cstruct.to_string x)) result; 56 | Lwt.return (`Ok ()) 57 | 58 | let _ = 59 | Lwt_main.run th 60 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: caa3c68c772f60a10166930be044ce5b) *) 3 | module OASISGettext = struct 4 | (* # 22 "src/oasis/OASISGettext.ml" *) 5 | 6 | 7 | let ns_ str = 8 | str 9 | 10 | 11 | let s_ str = 12 | str 13 | 14 | 15 | let f_ (str: ('a, 'b, 'c, 'd) format4) = 16 | str 17 | 18 | 19 | let fn_ fmt1 fmt2 n = 20 | if n = 1 then 21 | fmt1^^"" 22 | else 23 | fmt2^^"" 24 | 25 | 26 | let init = 27 | [] 28 | 29 | 30 | end 31 | 32 | module OASISExpr = struct 33 | (* # 22 "src/oasis/OASISExpr.ml" *) 34 | 35 | 36 | 37 | 38 | 39 | open OASISGettext 40 | 41 | 42 | type test = string 43 | 44 | 45 | type flag = string 46 | 47 | 48 | type t = 49 | | EBool of bool 50 | | ENot of t 51 | | EAnd of t * t 52 | | EOr of t * t 53 | | EFlag of flag 54 | | ETest of test * string 55 | 56 | 57 | 58 | type 'a choices = (t * 'a) list 59 | 60 | 61 | let eval var_get t = 62 | let rec eval' = 63 | function 64 | | EBool b -> 65 | b 66 | 67 | | ENot e -> 68 | not (eval' e) 69 | 70 | | EAnd (e1, e2) -> 71 | (eval' e1) && (eval' e2) 72 | 73 | | EOr (e1, e2) -> 74 | (eval' e1) || (eval' e2) 75 | 76 | | EFlag nm -> 77 | let v = 78 | var_get nm 79 | in 80 | assert(v = "true" || v = "false"); 81 | (v = "true") 82 | 83 | | ETest (nm, vl) -> 84 | let v = 85 | var_get nm 86 | in 87 | (v = vl) 88 | in 89 | eval' t 90 | 91 | 92 | let choose ?printer ?name var_get lst = 93 | let rec choose_aux = 94 | function 95 | | (cond, vl) :: tl -> 96 | if eval var_get cond then 97 | vl 98 | else 99 | choose_aux tl 100 | | [] -> 101 | let str_lst = 102 | if lst = [] then 103 | s_ "" 104 | else 105 | String.concat 106 | (s_ ", ") 107 | (List.map 108 | (fun (cond, vl) -> 109 | match printer with 110 | | Some p -> p vl 111 | | None -> s_ "") 112 | lst) 113 | in 114 | match name with 115 | | Some nm -> 116 | failwith 117 | (Printf.sprintf 118 | (f_ "No result for the choice list '%s': %s") 119 | nm str_lst) 120 | | None -> 121 | failwith 122 | (Printf.sprintf 123 | (f_ "No result for a choice list: %s") 124 | str_lst) 125 | in 126 | choose_aux (List.rev lst) 127 | 128 | 129 | end 130 | 131 | 132 | # 132 "myocamlbuild.ml" 133 | module BaseEnvLight = struct 134 | (* # 22 "src/base/BaseEnvLight.ml" *) 135 | 136 | 137 | module MapString = Map.Make(String) 138 | 139 | 140 | type t = string MapString.t 141 | 142 | 143 | let default_filename = 144 | Filename.concat 145 | (Sys.getcwd ()) 146 | "setup.data" 147 | 148 | 149 | let load ?(allow_empty=false) ?(filename=default_filename) () = 150 | if Sys.file_exists filename then 151 | begin 152 | let chn = 153 | open_in_bin filename 154 | in 155 | let st = 156 | Stream.of_channel chn 157 | in 158 | let line = 159 | ref 1 160 | in 161 | let st_line = 162 | Stream.from 163 | (fun _ -> 164 | try 165 | match Stream.next st with 166 | | '\n' -> incr line; Some '\n' 167 | | c -> Some c 168 | with Stream.Failure -> None) 169 | in 170 | let lexer = 171 | Genlex.make_lexer ["="] st_line 172 | in 173 | let rec read_file mp = 174 | match Stream.npeek 3 lexer with 175 | | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> 176 | Stream.junk lexer; 177 | Stream.junk lexer; 178 | Stream.junk lexer; 179 | read_file (MapString.add nm value mp) 180 | | [] -> 181 | mp 182 | | _ -> 183 | failwith 184 | (Printf.sprintf 185 | "Malformed data file '%s' line %d" 186 | filename !line) 187 | in 188 | let mp = 189 | read_file MapString.empty 190 | in 191 | close_in chn; 192 | mp 193 | end 194 | else if allow_empty then 195 | begin 196 | MapString.empty 197 | end 198 | else 199 | begin 200 | failwith 201 | (Printf.sprintf 202 | "Unable to load environment, the file '%s' doesn't exist." 203 | filename) 204 | end 205 | 206 | 207 | let rec var_expand str env = 208 | let buff = 209 | Buffer.create ((String.length str) * 2) 210 | in 211 | Buffer.add_substitute 212 | buff 213 | (fun var -> 214 | try 215 | var_expand (MapString.find var env) env 216 | with Not_found -> 217 | failwith 218 | (Printf.sprintf 219 | "No variable %s defined when trying to expand %S." 220 | var 221 | str)) 222 | str; 223 | Buffer.contents buff 224 | 225 | 226 | let var_get name env = 227 | var_expand (MapString.find name env) env 228 | 229 | 230 | let var_choose lst env = 231 | OASISExpr.choose 232 | (fun nm -> var_get nm env) 233 | lst 234 | end 235 | 236 | 237 | # 237 "myocamlbuild.ml" 238 | module MyOCamlbuildFindlib = struct 239 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) 240 | 241 | 242 | (** OCamlbuild extension, copied from 243 | * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild 244 | * by N. Pouillard and others 245 | * 246 | * Updated on 2009/02/28 247 | * 248 | * Modified by Sylvain Le Gall 249 | *) 250 | open Ocamlbuild_plugin 251 | 252 | type conf = 253 | { no_automatic_syntax: bool; 254 | } 255 | 256 | (* these functions are not really officially exported *) 257 | let run_and_read = 258 | Ocamlbuild_pack.My_unix.run_and_read 259 | 260 | 261 | let blank_sep_strings = 262 | Ocamlbuild_pack.Lexers.blank_sep_strings 263 | 264 | 265 | let exec_from_conf exec = 266 | let exec = 267 | let env_filename = Pathname.basename BaseEnvLight.default_filename in 268 | let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in 269 | try 270 | BaseEnvLight.var_get exec env 271 | with Not_found -> 272 | Printf.eprintf "W: Cannot get variable %s\n" exec; 273 | exec 274 | in 275 | let fix_win32 str = 276 | if Sys.os_type = "Win32" then begin 277 | let buff = Buffer.create (String.length str) in 278 | (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. 279 | *) 280 | String.iter 281 | (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) 282 | str; 283 | Buffer.contents buff 284 | end else begin 285 | str 286 | end 287 | in 288 | fix_win32 exec 289 | 290 | let split s ch = 291 | let buf = Buffer.create 13 in 292 | let x = ref [] in 293 | let flush () = 294 | x := (Buffer.contents buf) :: !x; 295 | Buffer.clear buf 296 | in 297 | String.iter 298 | (fun c -> 299 | if c = ch then 300 | flush () 301 | else 302 | Buffer.add_char buf c) 303 | s; 304 | flush (); 305 | List.rev !x 306 | 307 | 308 | let split_nl s = split s '\n' 309 | 310 | 311 | let before_space s = 312 | try 313 | String.before s (String.index s ' ') 314 | with Not_found -> s 315 | 316 | (* ocamlfind command *) 317 | let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] 318 | 319 | (* This lists all supported packages. *) 320 | let find_packages () = 321 | List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) 322 | 323 | 324 | (* Mock to list available syntaxes. *) 325 | let find_syntaxes () = ["camlp4o"; "camlp4r"] 326 | 327 | 328 | let well_known_syntax = [ 329 | "camlp4.quotations.o"; 330 | "camlp4.quotations.r"; 331 | "camlp4.exceptiontracer"; 332 | "camlp4.extend"; 333 | "camlp4.foldgenerator"; 334 | "camlp4.listcomprehension"; 335 | "camlp4.locationstripper"; 336 | "camlp4.macro"; 337 | "camlp4.mapgenerator"; 338 | "camlp4.metagenerator"; 339 | "camlp4.profiler"; 340 | "camlp4.tracer" 341 | ] 342 | 343 | 344 | let dispatch conf = 345 | function 346 | | After_options -> 347 | (* By using Before_options one let command line options have an higher 348 | * priority on the contrary using After_options will guarantee to have 349 | * the higher priority override default commands by ocamlfind ones *) 350 | Options.ocamlc := ocamlfind & A"ocamlc"; 351 | Options.ocamlopt := ocamlfind & A"ocamlopt"; 352 | Options.ocamldep := ocamlfind & A"ocamldep"; 353 | Options.ocamldoc := ocamlfind & A"ocamldoc"; 354 | Options.ocamlmktop := ocamlfind & A"ocamlmktop"; 355 | Options.ocamlmklib := ocamlfind & A"ocamlmklib" 356 | 357 | | After_rules -> 358 | 359 | (* When one link an OCaml library/binary/package, one should use 360 | * -linkpkg *) 361 | flag ["ocaml"; "link"; "program"] & A"-linkpkg"; 362 | 363 | if not (conf.no_automatic_syntax) then begin 364 | (* For each ocamlfind package one inject the -package option when 365 | * compiling, computing dependencies, generating documentation and 366 | * linking. *) 367 | List.iter 368 | begin fun pkg -> 369 | let base_args = [A"-package"; A pkg] in 370 | (* TODO: consider how to really choose camlp4o or camlp4r. *) 371 | let syn_args = [A"-syntax"; A "camlp4o"] in 372 | let (args, pargs) = 373 | (* Heuristic to identify syntax extensions: whether they end in 374 | ".syntax"; some might not. 375 | *) 376 | if Filename.check_suffix pkg "syntax" || 377 | List.mem pkg well_known_syntax then 378 | (syn_args @ base_args, syn_args) 379 | else 380 | (base_args, []) 381 | in 382 | flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; 383 | flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; 384 | flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; 385 | flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; 386 | flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; 387 | 388 | (* TODO: Check if this is allowed for OCaml < 3.12.1 *) 389 | flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; 390 | flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; 391 | flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; 392 | flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; 393 | end 394 | (find_packages ()); 395 | end; 396 | 397 | (* Like -package but for extensions syntax. Morover -syntax is useless 398 | * when linking. *) 399 | List.iter begin fun syntax -> 400 | flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 401 | flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 402 | flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 403 | flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & 404 | S[A"-syntax"; A syntax]; 405 | end (find_syntaxes ()); 406 | 407 | (* The default "thread" tag is not compatible with ocamlfind. 408 | * Indeed, the default rules add the "threads.cma" or "threads.cmxa" 409 | * options when using this tag. When using the "-linkpkg" option with 410 | * ocamlfind, this module will then be added twice on the command line. 411 | * 412 | * To solve this, one approach is to add the "-thread" option when using 413 | * the "threads" package using the previous plugin. 414 | *) 415 | flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); 416 | flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); 417 | flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); 418 | flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); 419 | flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); 420 | flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); 421 | flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); 422 | flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); 423 | 424 | | _ -> 425 | () 426 | end 427 | 428 | module MyOCamlbuildBase = struct 429 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 430 | 431 | 432 | (** Base functions for writing myocamlbuild.ml 433 | @author Sylvain Le Gall 434 | *) 435 | 436 | 437 | 438 | 439 | 440 | open Ocamlbuild_plugin 441 | module OC = Ocamlbuild_pack.Ocaml_compiler 442 | 443 | 444 | type dir = string 445 | type file = string 446 | type name = string 447 | type tag = string 448 | 449 | 450 | (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 451 | 452 | 453 | type t = 454 | { 455 | lib_ocaml: (name * dir list * string list) list; 456 | lib_c: (name * dir * file list) list; 457 | flags: (tag list * (spec OASISExpr.choices)) list; 458 | (* Replace the 'dir: include' from _tags by a precise interdepends in 459 | * directory. 460 | *) 461 | includes: (dir * dir list) list; 462 | } 463 | 464 | 465 | let env_filename = 466 | Pathname.basename 467 | BaseEnvLight.default_filename 468 | 469 | 470 | let dispatch_combine lst = 471 | fun e -> 472 | List.iter 473 | (fun dispatch -> dispatch e) 474 | lst 475 | 476 | 477 | let tag_libstubs nm = 478 | "use_lib"^nm^"_stubs" 479 | 480 | 481 | let nm_libstubs nm = 482 | nm^"_stubs" 483 | 484 | 485 | let dispatch t e = 486 | let env = 487 | BaseEnvLight.load 488 | ~filename:env_filename 489 | ~allow_empty:true 490 | () 491 | in 492 | match e with 493 | | Before_options -> 494 | let no_trailing_dot s = 495 | if String.length s >= 1 && s.[0] = '.' then 496 | String.sub s 1 ((String.length s) - 1) 497 | else 498 | s 499 | in 500 | List.iter 501 | (fun (opt, var) -> 502 | try 503 | opt := no_trailing_dot (BaseEnvLight.var_get var env) 504 | with Not_found -> 505 | Printf.eprintf "W: Cannot get variable %s\n" var) 506 | [ 507 | Options.ext_obj, "ext_obj"; 508 | Options.ext_lib, "ext_lib"; 509 | Options.ext_dll, "ext_dll"; 510 | ] 511 | 512 | | After_rules -> 513 | (* Declare OCaml libraries *) 514 | List.iter 515 | (function 516 | | nm, [], intf_modules -> 517 | ocaml_lib nm; 518 | let cmis = 519 | List.map (fun m -> (String.uncapitalize m) ^ ".cmi") 520 | intf_modules in 521 | dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis 522 | | nm, dir :: tl, intf_modules -> 523 | ocaml_lib ~dir:dir (dir^"/"^nm); 524 | List.iter 525 | (fun dir -> 526 | List.iter 527 | (fun str -> 528 | flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) 529 | ["compile"; "infer_interface"; "doc"]) 530 | tl; 531 | let cmis = 532 | List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") 533 | intf_modules in 534 | dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] 535 | cmis) 536 | t.lib_ocaml; 537 | 538 | (* Declare directories dependencies, replace "include" in _tags. *) 539 | List.iter 540 | (fun (dir, include_dirs) -> 541 | Pathname.define_context dir include_dirs) 542 | t.includes; 543 | 544 | (* Declare C libraries *) 545 | List.iter 546 | (fun (lib, dir, headers) -> 547 | (* Handle C part of library *) 548 | flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] 549 | (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; 550 | A("-l"^(nm_libstubs lib))]); 551 | 552 | flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] 553 | (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); 554 | 555 | flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] 556 | (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); 557 | 558 | (* When ocaml link something that use the C library, then one 559 | need that file to be up to date. 560 | This holds both for programs and for libraries. 561 | *) 562 | dep ["link"; "ocaml"; tag_libstubs lib] 563 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 564 | 565 | dep ["compile"; "ocaml"; tag_libstubs lib] 566 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 567 | 568 | (* TODO: be more specific about what depends on headers *) 569 | (* Depends on .h files *) 570 | dep ["compile"; "c"] 571 | headers; 572 | 573 | (* Setup search path for lib *) 574 | flag ["link"; "ocaml"; "use_"^lib] 575 | (S[A"-I"; P(dir)]); 576 | ) 577 | t.lib_c; 578 | 579 | (* Add flags *) 580 | List.iter 581 | (fun (tags, cond_specs) -> 582 | let spec = BaseEnvLight.var_choose cond_specs env in 583 | let rec eval_specs = 584 | function 585 | | S lst -> S (List.map eval_specs lst) 586 | | A str -> A (BaseEnvLight.var_expand str env) 587 | | spec -> spec 588 | in 589 | flag tags & (eval_specs spec)) 590 | t.flags 591 | | _ -> 592 | () 593 | 594 | 595 | let dispatch_default conf t = 596 | dispatch_combine 597 | [ 598 | dispatch t; 599 | MyOCamlbuildFindlib.dispatch conf; 600 | ] 601 | 602 | 603 | end 604 | 605 | 606 | # 606 "myocamlbuild.ml" 607 | open Ocamlbuild_plugin;; 608 | let package_default = 609 | { 610 | MyOCamlbuildBase.lib_ocaml = [("iso", ["lib"], [])]; 611 | lib_c = []; 612 | flags = []; 613 | includes = [("lib_test", ["lib"])] 614 | } 615 | ;; 616 | 617 | let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} 618 | 619 | let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; 620 | 621 | # 622 "myocamlbuild.ml" 622 | (* OASIS_STOP *) 623 | Ocamlbuild_plugin.dispatch dispatch_default;; 624 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "iso-filesystem" 3 | version: "0.1" 4 | maintainer: "opam-devel@lists.ocaml.org" 5 | authors: [ "Jon Ludlam" ] 6 | license: "ISC" 7 | build: [ 8 | ["ocaml" "setup.ml" "-configure" "--prefix" prefix] 9 | ["ocaml" "setup.ml" "-build"] 10 | ] 11 | install: ["ocaml" "setup.ml" "-install"] 12 | remove: [ 13 | ["ocamlfind" "remove" "iso-filesystem"] 14 | ] 15 | build-test: [ 16 | ["ocaml" "setup.ml" "-configure" "--enable-tests"] 17 | ["ocaml" "setup.ml" "-build"] 18 | ["lib_test/mkiso.sh"] 19 | ["ocaml" "setup.ml" "-test"] 20 | ] 21 | depends: [ 22 | "cstruct" 23 | "io-page" {build} 24 | "lwt" 25 | "mirage-block-unix" {build} 26 | "mirage-types" 27 | "ocamlfind" {build} 28 | "ounit" {build} 29 | "re" 30 | "stringext" 31 | ] 32 | -------------------------------------------------------------------------------- /setup.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jonludlam/ocaml-iso-filesystem/e60e8c81309dc8af171ab459e20d07365d7d5425/setup.ml --------------------------------------------------------------------------------