├── .gitignore ├── .merlin ├── .travis.yml ├── CHANGES.md ├── Makefile ├── Makefile.config ├── Makefile.local ├── README.md ├── _oasis ├── _tags ├── bin ├── .merlin ├── config.ml └── tftpd.ml ├── lib ├── .merlin ├── META ├── tftp-wire.mldylib ├── tftp-wire.mllib ├── tftp.ml ├── tftp.mldylib ├── tftp.mllib ├── tftp.odocl ├── tftp_S.ml ├── tftp_S.mli ├── tftp_config.ml ├── tftp_wire.ml └── tftp_wire.mli ├── mirage ├── .merlin ├── tftp-mirage.mldylib ├── tftp-mirage.mllib └── tftp_mirage.ml ├── myocamlbuild.ml ├── setup.ml └── tftp.opam ├── descr ├── install └── opam /.gitignore: -------------------------------------------------------------------------------- 1 | # Standard OCaml droppings 2 | *.annot 3 | *.cmo 4 | *.cma 5 | *.cmi 6 | *.a 7 | *.o 8 | *.cmx 9 | *.cmxs 10 | *.cmxa 11 | 12 | _build/ 13 | 14 | *.byte 15 | *.native 16 | *.docdir 17 | 18 | # Oasis droppings 19 | setup.data 20 | setup.log 21 | 22 | # Mirage droppings 23 | /bin/tftpd 24 | /bin/tftpd.xe 25 | /bin/tftpd.xl 26 | /bin/tftpd_libvirt.xml 27 | /bin/mir-tftpd 28 | /bin/log 29 | /bin/Makefile 30 | /bin/main.ml 31 | /bin/static*.ml* 32 | 33 | /log 34 | /files 35 | 36 | # OCaml/OPAM droppings 37 | doc/** 38 | !tftp.opam/** 39 | /bin/tftpd.xl.in 40 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG lwt mirage mirage-env io-page ipaddr cstruct cstruct.syntax sexplib.syntax 2 | PKG tftp tftp.mirage 3 | B _build/** 4 | B _build/lib_test 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh 4 | script: bash -ex .travis-opam.sh 5 | 6 | sudo: true 7 | 8 | env: 9 | global: 10 | - ALCOTEST_SHOW_ERRORS=1 11 | - PACKAGE="tftp" 12 | matrix: 13 | - OCAML_VERSION=4.01 14 | - OCAML_VERSION=4.02 15 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ### 0.1.4 (2015-08-12) 2 | 3 | + Fixing OPAM and Make runes 4 | + Inline environment stuff for Mirage for now 5 | 6 | ### 0.1.3 (2015-07-08) 7 | 8 | + More OPAM and Make runes 9 | + Add `bin/mirage_env.ml` as it's not released yet 10 | + Update Oasis outputs 11 | 12 | ### 0.1.2 (2015-07-08) 13 | 14 | + First cut, quite basic, release 15 | + Basic TFTP protocol support; no options yet, mode=octet only 16 | + Simple Mirage unikernel server included 17 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | -include Makefile.config 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: 343ec959150e53c69f8ddebf984af100) 5 | 6 | SETUP = ocaml setup.ml 7 | 8 | build: setup.data 9 | $(SETUP) -build $(BUILDFLAGS) 10 | 11 | doc: setup.data build 12 | $(SETUP) -doc $(DOCFLAGS) 13 | 14 | test: setup.data build 15 | $(SETUP) -test $(TESTFLAGS) 16 | 17 | all: 18 | $(SETUP) -all $(ALLFLAGS) 19 | 20 | install: setup.data 21 | $(SETUP) -install $(INSTALLFLAGS) 22 | 23 | reinstall: setup.data 24 | $(SETUP) -reinstall $(REINSTALLFLAGS) 25 | 26 | distclean: 27 | $(SETUP) -distclean $(DISTCLEANFLAGS) 28 | 29 | setup.data: 30 | $(SETUP) -configure $(CONFIGUREFLAGS) 31 | 32 | configure: 33 | $(SETUP) -configure $(CONFIGUREFLAGS) 34 | 35 | .PHONY: build doc test all install reinstall distclean configure 36 | 37 | # OASIS_STOP 38 | 39 | -include Makefile.local 40 | -------------------------------------------------------------------------------- /Makefile.config: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2015 Richard Mortier 2 | # 3 | # Permission to use, copy, modify, and distribute this software for any 4 | # purpose with or without fee is hereby granted, provided that the above 5 | # copyright notice and this permission notice appear in all copies. 6 | # 7 | # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | 15 | BUILDFLAGS ?= # -classic-display 16 | MIRFLAGS ?= 17 | -------------------------------------------------------------------------------- /Makefile.local: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2015 Richard Mortier 2 | # 3 | # Permission to use, copy, modify, and distribute this software for any 4 | # purpose with or without fee is hereby granted, provided that the above 5 | # copyright notice and this permission notice appear in all copies. 6 | # 7 | # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | 15 | .PHONY: setup-clean setup clean uninstall tftpd \ 16 | gh-pages opam test-opam pr release update-release publish 17 | 18 | ## Oasis targets 19 | 20 | setup-clean: clean distclean 21 | oasis setup-clean 22 | $(RM) setup.* _tags configure myocamlbuild.ml 23 | $(RM) lib/META lib/*.ml*lib lib/*.mlpack 24 | 25 | setup.ml: _oasis 26 | oasis setup 27 | 28 | setup: setup.ml setup.data 29 | 30 | ## Mirage targets 31 | 32 | clean: 33 | $(SETUP) -clean $(CLEANFLAGS) 34 | [ -r bin/Makefile ] && mirage clean bin/config.ml || true 35 | $(RM) log bin/tftpd 36 | 37 | uninstall: 38 | ocaml setup.ml -uninstall $(UNINSTALLFLAGS) 39 | ocamlfind remove tftp 40 | 41 | tftpd: bin/tftpd 42 | bin/tftpd: bin/Makefile bin/tftpd.ml \ 43 | $(wildcard lib/*.ml) $(wildcard mirage/*.ml) 44 | mirage build bin/config.ml 45 | cp bin/_build/main.native bin/tftpd 46 | bin/Makefile: bin/config.ml 47 | mirage configure --unix bin/config.ml $(MIRFLAGS) 48 | 49 | ## Documentation 50 | 51 | doc/html/.git: 52 | mkdir -p doc/html 53 | cd doc/html && ( \ 54 | git init && \ 55 | git remote add origin git@github.com:mor1/ocaml-tftp.git && \ 56 | git checkout -B gh-pages \ 57 | ) 58 | 59 | gh-pages: doc/html/.git 60 | cd doc/html && git checkout -B gh-pages 61 | rm -f doc/html/* 62 | $(MAKE) doc && cp tftp.docdir/* doc/html/ 63 | cd doc/html && ( \ 64 | git add * && \ 65 | git commit -a -m "Documentation updates" && \ 66 | git push origin gh-pages \ 67 | ) 68 | 69 | ## Release targets 70 | 71 | VERSION = $(shell grep '^Version:' _oasis | sed 's/Version: *//') 72 | NAME = $(shell grep '^Name:' _oasis | sed 's/Name: *//') 73 | ARCHIVE = https://github.com/mor1/ocaml-tftp/archive/$(VERSION).tar.gz 74 | 75 | opam: release publish pr 76 | 77 | release: 78 | git tag -a $(VERSION) -m "Version $(VERSION)." 79 | git push upstream $(VERSION) 80 | 81 | update-release: 82 | git push upstream master 83 | git tag -f $(VERSION) -m "Version $(VERSION)." 84 | git push --force upstream $(VERSION) 85 | 86 | publish: 87 | OPAMYES=1 opam pin add -n . 88 | opam publish prepare $(NAME).$(VERSION) $(ARCHIVE) 89 | 90 | pr: 91 | OPAMYES=1 opam pin add -n $(NAME) $(NAME).$(VERSION) 92 | opam publish submit $(NAME).$(VERSION) && $(RM) -r $(NAME).$(VERSION) 93 | 94 | test-opam: 95 | opam switch system 96 | opam switch remove test-opam -y 97 | opam switch test-opam -A system -y 98 | eval $$(opam config env) 99 | opam pin add tftp . -k git -y 100 | opam switch system 101 | eval $$(opam config env) 102 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://travis-ci.org/mor1/ocaml-tftp.svg?branch=master)](https://travis-ci.org/mor1/ocaml-tftp) 2 | 3 | # A Trivial FTP Server 4 | 5 | Documentation at . 6 | 7 | ## Testing on OSX 8 | 9 | Following 10 | : 11 | 12 | $ sudo launchctl load -F /System/Library/LaunchDaemons/tftp.plist 13 | 14 | To change the served directory from the default of `/private/tftpboot`, edit the 15 | `.plist` file and restart: 16 | 17 | $ sudo launchctl start com.apple.tftpd 18 | 19 | ## TODO 20 | 21 | + Sort out logging 22 | + Remove installed callbacks on final ACK 23 | + Add options support: 24 | + blocksize 25 | + timeout 26 | + transfer size 27 | + window size 28 | + Ensure strings in (eg) error packets are valid NETASCII 29 | + Add some testing goodness 30 | + Requirements traceability using 31 | + Write a client 32 | + Add Travis 33 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.4 2 | Name: tftp 3 | Version: 0.1.4 4 | Synopsis: Trivial FTP 5 | Authors: Richard Mortier 6 | License: ISC 7 | BuildTools: ocamlbuild 8 | 9 | AlphaFeatures: ocamlbuild_more_args, pure_interface 10 | 11 | Plugins: META (0.4), DevFiles (0.4) 12 | XDevFilesMakefileNoTargets: clean, uninstall 13 | XDevFilesEnableConfigure: false 14 | 15 | 16 | Flag "lwt" 17 | Description : Lwt_unix backend 18 | Default : true 19 | 20 | Flag "mirage" 21 | Description : Mirage backend 22 | Default : true 23 | 24 | 25 | Library "tftp-wire" 26 | CompiledObject: best 27 | Path: lib/ 28 | FindlibName: wire 29 | FindlibParent: tftp 30 | Modules: Tftp_wire 31 | BuildDepends: cstruct, cstruct.syntax, sexplib.syntax 32 | 33 | Library "tftp" 34 | CompiledObject: best 35 | Path: lib/ 36 | FindlibName: tftp 37 | Modules: Tftp, Tftp_config 38 | BuildDepends: mirage, lwt, tftp.wire, io-page 39 | 40 | # Library "tftp-lwt" 41 | # Build $: flag(lwt) 42 | # FindlibName : lwt 43 | # FindlibParent : tftp 44 | # Path : lwt 45 | # Modules : Tftp_lwt 46 | # BuildDepends : lwt, tftp 47 | 48 | Library "tftp-mirage" 49 | Build $: flag(mirage) 50 | FindlibName : mirage 51 | FindlibParent : tftp 52 | Path : mirage 53 | Modules : Tftp_mirage 54 | BuildDepends : mirage-types, lwt, tftp, logs 55 | 56 | 57 | Document "tftp" 58 | Type: OCamlbuild (0.4) 59 | BuildTools+: ocamldoc 60 | Title: TFTP API reference 61 | Install: true 62 | PostCommand: cp doc/style.css tftp.docdir/ 63 | XOCamlbuildPath: lib/ 64 | XOCamlbuildExtraArgs: 65 | "-docflags '-colorize-code -short-functors -short-paths -charset utf-8'" 66 | XOCamlbuildLibraries: tftp.wire, tftp 67 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: af558be8bbd11436eaddc1330f2d5e19) 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 tftp-wire 18 | "lib/tftp-wire.cmxs": use_tftp-wire 19 | # Library tftp 20 | "lib/tftp.cmxs": use_tftp 21 | : pkg_cstruct 22 | : pkg_cstruct.syntax 23 | : pkg_io-page 24 | : pkg_lwt 25 | : pkg_mirage 26 | : pkg_sexplib.syntax 27 | : use_tftp-wire 28 | # Library tftp-mirage 29 | "mirage/tftp-mirage.cmxs": use_tftp-mirage 30 | : pkg_cstruct 31 | : pkg_cstruct.syntax 32 | : pkg_io-page 33 | : pkg_logs 34 | : pkg_lwt 35 | : pkg_mirage 36 | : pkg_mirage-types 37 | : pkg_sexplib.syntax 38 | : use_tftp 39 | : use_tftp-wire 40 | # OASIS_STOP 41 | -------------------------------------------------------------------------------- /bin/.merlin: -------------------------------------------------------------------------------- 1 | REC 2 | -------------------------------------------------------------------------------- /bin/config.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Richard Mortier 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 Mirage 18 | 19 | (** Mirage environment. Remove once parameter passing / `Mirage_env` is 20 | accepted. *) 21 | 22 | let err fmt = 23 | Printf.ksprintf (fun str -> 24 | Printf.eprintf ("\027[31m[ERROR]\027[m %s\n") str; 25 | exit 1 26 | ) fmt 27 | 28 | let env_info fmt = Printf.printf ("\027[33mENV\027[m " ^^ fmt ^^ "\n%!") 29 | 30 | let split c s = 31 | let rec aux c s ri acc = 32 | (* half-closed intervals. [ri] is the open end, the right-fencepost. 33 | [li] is the closed end, the left-fencepost. either [li] is 34 | + negative (outside [s]), or 35 | + equal to [ri] ([c] not found in remainder of [s]) -> 36 | take everything from [ s[0], s[ri] ) 37 | + else inside [s], thus an instance of the separator -> 38 | accumulate from the separator to [ri]: [ s[li+1], s[ri] ) 39 | and move [ri] inwards to the discovered separator [li] 40 | *) 41 | let li = try String.rindex_from s (ri-1) c with Not_found -> -1 in 42 | if li < 0 || li == ri then (String.sub s 0 ri) :: acc 43 | else begin 44 | let len = ri-1 - li in 45 | let rs = String.sub s (li+1) len in 46 | aux c s li (rs :: acc) 47 | end 48 | in 49 | aux c s (String.length s) [] 50 | 51 | let ips_of_env x = split ':' x |> List.map Ipaddr.V4.of_string_exn 52 | let bool_of_env = function "1" | "true" | "yes" -> true | _ -> false 53 | let net_of_env = function "socket" -> `Socket | _ -> `Direct 54 | let fs_of_env = function "fat" -> `Fat | "direct" -> `Direct | _ -> `Crunch 55 | let opt_string_of_env x = Some x 56 | let string_of_env x = x 57 | 58 | let get_env name fn = 59 | let res = Sys.getenv name in 60 | env_info "%s => %s" name res; 61 | fn (String.lowercase res) 62 | 63 | let get_exn name fn = 64 | try get_env name fn 65 | with Not_found -> 66 | err "%s is not set." name 67 | 68 | let get ~default name fn = 69 | try get_env name fn 70 | with Not_found -> 71 | env_info "%s unset => %s" name default; 72 | fn (String.lowercase default) 73 | 74 | let fs = get "FS" ~default:"crunch" fs_of_env 75 | let deploy = get "DEPLOY" ~default:"false" bool_of_env 76 | let net = get "NET" ~default:"socket" net_of_env 77 | let dhcp = get "DHCP" ~default:"false" bool_of_env 78 | 79 | let blocks = ref 0 80 | let mkfs fs path = 81 | let fat_of_files dir = kv_ro_of_fs (fat_of_files ~dir ()) in 82 | let fat_of_device device = 83 | let block = block_of_file (string_of_int device) in 84 | let fat = fat block in 85 | kv_ro_of_fs fat 86 | in 87 | match fs, get_mode () with 88 | | `Fat , `Xen -> incr blocks; fat_of_device (51711 + !blocks) 89 | | `Fat , _ -> fat_of_files path 90 | | `Crunch, _ -> crunch path 91 | | `Direct, `Xen -> crunch path 92 | | `Direct, _ -> direct_kv_ro path 93 | 94 | let cons0 = default_console 95 | 96 | let stack = match deploy with 97 | | true -> 98 | let staticip = 99 | let address = get_exn "IP" Ipaddr.V4.of_string_exn in 100 | let netmask = get_exn "NETMASK" Ipaddr.V4.of_string_exn in 101 | let gateways = get_exn "GATEWAYS" ips_of_env in 102 | { address; netmask; gateways } 103 | in 104 | direct_stackv4_with_static_ipv4 cons0 tap0 staticip 105 | | false -> 106 | match net, dhcp with 107 | | `Direct, false -> direct_stackv4_with_default_ipv4 cons0 tap0 108 | | `Direct, true -> direct_stackv4_with_dhcp cons0 tap0 109 | | `Socket, _ -> socket_stackv4 cons0 [Ipaddr.V4.any] 110 | 111 | (** *) 112 | 113 | let files = mkfs fs "./files" 114 | 115 | let main = 116 | let libraries = [ "tftp.wire"; "tftp"; "tftp.mirage"; "mirage-logs" ] in 117 | let packages = [ "mirage-logs" ] in 118 | foreign ~libraries ~packages "Tftpd.Main" 119 | (clock @-> kv_ro @-> stackv4 @-> job) 120 | 121 | let () = 122 | let tracing = None in 123 | (* let tracing = mprof_trace ~size:10000 () in *) 124 | register ?tracing "tftpd" [ main $ default_clock $ files $ stack ] 125 | -------------------------------------------------------------------------------- /bin/tftpd.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Richard Mortier 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 | let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" 18 | module Log = (val Logs.src_log src : Logs.LOG) 19 | 20 | module Main (C: V1.CLOCK) (FS: V1_LWT.KV_RO) (S: V1_LWT.STACKV4) = struct 21 | module Logs_reporter = Mirage_logs.Make(Clock) 22 | 23 | module T = Tftp_mirage.S.Make(FS)(S) 24 | 25 | let start () fs s = 26 | Logs.(set_level (Some Info)); 27 | Logs_reporter.(create () |> run) @@ fun () -> 28 | let files = "./files" in 29 | let config = Tftp_config.make files in 30 | let port = Tftp_config.port config in 31 | let server = Tftp.S.make config in 32 | S.listen_udpv4 s ~port T.(callback ~port { server; fs; s }); 33 | S.listen s 34 | end 35 | -------------------------------------------------------------------------------- /lib/.merlin: -------------------------------------------------------------------------------- 1 | REC 2 | -------------------------------------------------------------------------------- /lib/META: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a56126c24f69e9ae596441f0427eb1d9) 3 | version = "0.1.4" 4 | description = "Trivial FTP" 5 | requires = "mirage lwt tftp.wire io-page" 6 | archive(byte) = "tftp.cma" 7 | archive(byte, plugin) = "tftp.cma" 8 | archive(native) = "tftp.cmxa" 9 | archive(native, plugin) = "tftp.cmxs" 10 | exists_if = "tftp.cma" 11 | package "wire" ( 12 | version = "0.1.4" 13 | description = "Trivial FTP" 14 | requires = "cstruct cstruct.syntax sexplib.syntax" 15 | archive(byte) = "tftp-wire.cma" 16 | archive(byte, plugin) = "tftp-wire.cma" 17 | archive(native) = "tftp-wire.cmxa" 18 | archive(native, plugin) = "tftp-wire.cmxs" 19 | exists_if = "tftp-wire.cma" 20 | ) 21 | 22 | package "mirage" ( 23 | version = "0.1.4" 24 | description = "Trivial FTP" 25 | requires = "mirage-types lwt tftp logs" 26 | archive(byte) = "tftp-mirage.cma" 27 | archive(byte, plugin) = "tftp-mirage.cma" 28 | archive(native) = "tftp-mirage.cmxa" 29 | archive(native, plugin) = "tftp-mirage.cmxs" 30 | exists_if = "tftp-mirage.cma" 31 | ) 32 | # OASIS_STOP 33 | 34 | -------------------------------------------------------------------------------- /lib/tftp-wire.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 2debba36a47223ea9c1164f513d82a4b) 3 | Tftp_wire 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /lib/tftp-wire.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 2debba36a47223ea9c1164f513d82a4b) 3 | Tftp_wire 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /lib/tftp.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Richard Mortier 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 Sexplib.Std 18 | open Sexplib.Conv 19 | 20 | module Wire = Tftp_wire 21 | 22 | module Hashtbl = struct 23 | include Hashtbl 24 | 25 | let get t ?default k = 26 | try Some (Hashtbl.find t k) 27 | with 28 | | Not_found -> 29 | (match default with None -> () | Some v -> Hashtbl.replace t k v); 30 | default 31 | 32 | end 33 | 34 | module Tid = struct 35 | 36 | type t = Ipaddr.V4.t * int * int with sexp 37 | (** source IP, source port, destination port *) 38 | 39 | let to_string t = t |> sexp_of_t |> Sexplib.Sexp.to_string_hum 40 | 41 | end 42 | 43 | module S = struct 44 | 45 | type t = { 46 | port: int; 47 | conns: (Tid.t, string * int64 * int64) Hashtbl.t; 48 | tids: (Ipaddr.V4.t * int, int) Hashtbl.t; 49 | files: (string, int64 * Cstruct.t) Hashtbl.t; 50 | } with sexp 51 | 52 | let to_string t = t |> sexp_of_t |> Sexplib.Sexp.to_string_hum 53 | 54 | let make config = 55 | let port = Tftp_config.port config in 56 | let conns = Hashtbl.create 16 in 57 | let tids = Hashtbl.create 16 in 58 | let files = Hashtbl.create 16 in 59 | { port; conns; tids; files } 60 | 61 | end 62 | 63 | type mode = 64 | | Octet 65 | | Netascii 66 | | Mail 67 | | Unknown of string 68 | with sexp 69 | 70 | let mode_of_string = function 71 | | "octet" -> Octet 72 | | "netascii" -> Netascii 73 | | "mail" -> Mail 74 | | mode -> Unknown mode 75 | 76 | let mode_to_string = function 77 | | Octet -> "octet" 78 | | Netascii -> "netascii" 79 | | Mail -> "mail" 80 | | Unknown mode -> mode 81 | 82 | module Success = struct 83 | type t = 84 | | Packet of Cstruct.t 85 | | Retx of int64 * Cstruct.t 86 | | Ack_of_error 87 | | Ack_of_eof 88 | | Error of Tftp_wire.errorcode * string 89 | | Request of string * mode 90 | with sexp 91 | 92 | let to_string t = t |> sexp_of_t |> Sexplib.Sexp.to_string_hum 93 | end 94 | 95 | module Failure = struct 96 | type t = 97 | | Unknown_tid 98 | | File_not_found of string 99 | | Invalid_packet 100 | | Unsupported_mode of mode 101 | | Rrq_refused 102 | | Unsupported_op of Tftp_wire.opcode 103 | with sexp 104 | 105 | let to_string t = t |> sexp_of_t |> Sexplib.Sexp.to_string_hum 106 | end 107 | 108 | type ret = 109 | | Ok of S.t * Tid.t * Success.t 110 | | Fail of S.t * Tid.t * Cstruct.t * Failure.t 111 | 112 | let obuf len = Cstruct.set_len (Io_page.get_buf ~n:1 ()) len 113 | 114 | let errorp ?msg error = 115 | let msg = match msg with 116 | | None -> Wire.errorcode_to_string error 117 | | Some m -> m 118 | in 119 | let msglen = String.length msg in 120 | let obuf = obuf (Wire.sizeof_herr + msglen + 1) in 121 | Wire.(set_herr_opcode obuf (opcode_to_int ERROR)); 122 | Wire.(set_herr_errorcode obuf (errorcode_to_int error)); 123 | Cstruct.blit_from_string msg 0 obuf Wire.sizeof_herr msglen; 124 | Cstruct.set_char obuf (Wire.sizeof_herr + msglen) '\x00'; 125 | obuf 126 | 127 | let datap server tid filename blockno f = 128 | Hashtbl.get server.S.files filename |> function 129 | | None -> 130 | let errp = errorp ~msg:filename Wire.FILE_NOT_FOUND in 131 | Fail (server, tid, errp, Failure.File_not_found filename) 132 | | Some (filesize, data) -> 133 | let srcoff = Int64.(mul blockno 512L) in 134 | let datlen = Int64.(to_int (min 512L (sub filesize srcoff))) in 135 | let obuf = obuf (Wire.sizeof_hdat + datlen) in 136 | Wire.(set_hdat_opcode obuf (opcode_to_int DATA)); 137 | Wire.(set_hdat_blockno obuf (Int64.to_int blockno)); 138 | Cstruct.blit data (Int64.to_int srcoff) obuf Wire.sizeof_hdat datlen; 139 | Ok (server, tid, f obuf) 140 | 141 | let handle_ack server tid inp = 142 | Hashtbl.get server.S.conns tid |> function 143 | | None -> 144 | let errp = errorp ~msg:(Tid.to_string tid) Wire.UNKNOWN_TID in 145 | Fail (server, tid, errp, Failure.Unknown_tid) 146 | | Some (filename, filesize, blockno) -> 147 | let ackno = Wire.get_hdat_blockno inp |> Int64.of_int in 148 | if blockno < 0L then 149 | Ok (server, tid, Success.Ack_of_error) 150 | else if ackno < blockno then 151 | datap server tid filename ackno (fun p -> Success.Retx (ackno, p)) 152 | else if filesize < Int64.mul blockno 512L then 153 | Ok (server, tid, Success.Ack_of_eof) 154 | else 155 | datap server tid filename blockno (fun p -> Success.Packet p) 156 | 157 | let handle_error server tid inp = 158 | let error = Wire.( 159 | inp |> get_herr_errorcode |> Wire.int_to_errorcode |> function 160 | | None -> UNDEFINED 161 | | Some c -> c 162 | ) 163 | in 164 | let (msg, _) = Cstruct.shift inp Wire.sizeof_herr |> Wire.string0 in 165 | Ok (server, tid, Success.Error (error, msg)) 166 | 167 | let handle_rrq server tid inp = 168 | let (filename, inp) = Cstruct.shift inp Wire.sizeof_hreq |> Wire.string0 in 169 | let (mode, _inp) = Wire.string0 inp in 170 | match mode_of_string mode with 171 | | Unknown m as mode -> 172 | let errp = errorp ~msg:"unknown mode" Wire.ILLEGAL_OP in 173 | Fail (server, tid, errp, Failure.Unsupported_mode mode) 174 | 175 | | Octet -> 176 | if not (Hashtbl.mem server.S.files filename) then 177 | let errp = errorp ~msg:filename Wire.FILE_NOT_FOUND in 178 | Fail (server, tid, errp, Failure.File_not_found filename) 179 | else ( 180 | let (sip, spt, _tftp_port) = tid in 181 | Hashtbl.get server.S.tids ~default:Tftp_config.min_port (sip,spt) |> function 182 | | None -> 183 | let errp = errorp ~msg:"TID failure" Wire.UNDEFINED in 184 | Fail (server, tid, errp, Failure.Rrq_refused) 185 | | Some local_port -> 186 | let tid = (sip,spt, local_port) in 187 | Ok (server, tid, Success.Request (filename, Octet)) 188 | ) 189 | | mode -> 190 | let errp = errorp ~msg:"unsupported mode" Wire.ILLEGAL_OP in 191 | Fail (server, tid, errp, Failure.Unsupported_mode mode) 192 | 193 | let handle server sip spt dpt inp = 194 | let tid = Tid.(sip, spt, dpt) in 195 | Wire.(inp |> get_hreq_opcode |> int_to_opcode |> function 196 | | None -> Fail (server, tid, inp, Failure.Invalid_packet) 197 | | Some o -> match o with 198 | | ACK -> handle_ack server tid inp 199 | | ERROR -> handle_error server tid inp 200 | | RRQ -> handle_rrq server tid inp 201 | | WRQ | DATA -> 202 | let errp = errorp ~msg:(Wire.opcode_to_string o) Wire.ILLEGAL_OP in 203 | Fail (server, tid, errp, Failure.Unsupported_op o) 204 | ) 205 | -------------------------------------------------------------------------------- /lib/tftp.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 636258dbc11341254a492eba06c0bbb0) 3 | Tftp 4 | Tftp_config 5 | # OASIS_STOP 6 | -------------------------------------------------------------------------------- /lib/tftp.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 636258dbc11341254a492eba06c0bbb0) 3 | Tftp 4 | Tftp_config 5 | # OASIS_STOP 6 | -------------------------------------------------------------------------------- /lib/tftp.odocl: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: e4be668c76dddf2b7db2eda23562f3d4) 3 | Tftp_wire 4 | Tftp 5 | Tftp_config 6 | # OASIS_STOP 7 | -------------------------------------------------------------------------------- /lib/tftp_S.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Richard Mortier 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.Infix 18 | module Wire = Tftp_wire 19 | 20 | let sp = Printf.sprintf 21 | 22 | module Hashtbl = struct 23 | include Hashtbl 24 | 25 | let get t ?default k = 26 | try Some (Hashtbl.find t k) 27 | with 28 | | Not_found -> 29 | (match default with None -> () | Some v -> Hashtbl.replace t k v); 30 | default 31 | 32 | end 33 | 34 | module Make(FS:V1_LWT.KV_RO)(S:V1_LWT.STACKV4) = struct 35 | 36 | module U = S.UDPV4 37 | 38 | type tid = U.ipaddr * int * int 39 | let tid_to_string (rip,rpt, lpt) = 40 | sp "(%s,%d, %d)" (Ipaddr.V4.to_string rip) rpt lpt 41 | 42 | type t = { 43 | c: C.t; 44 | fs: FS.t; 45 | s: S.t; 46 | 47 | conns: (tid, string * int64 * int64) Hashtbl.t; 48 | tids: (U.ipaddr * int, int) Hashtbl.t; 49 | files: (string, Cstruct.t) Hashtbl.t; 50 | } 51 | 52 | let default_port = 69 53 | let min_port = 32768 54 | 55 | let make ~c ~fs ~s () = 56 | let conns = Hashtbl.create 16 in 57 | let tids = Hashtbl.create 16 in 58 | let files = Hashtbl.create 16 in 59 | { c; fs; s; conns; tids; files } 60 | 61 | let error { c; _ } msg = 62 | let msg = sp "ERROR: %s" msg in 63 | C.log_s c msg >>= fun () -> Lwt.fail (Failure msg) 64 | 65 | let obuf len = Cstruct.set_len (Io_page.get_buf ~n:1 ()) len 66 | 67 | let tx_errp ~t ~tid e msg = 68 | let msglen = String.length msg in 69 | let obuf = obuf (Wire.sizeof_herr + msglen + 1) in 70 | Wire.(set_herr_opcode obuf (opcode_to_int ERROR)); 71 | Wire.(set_herr_errorcode obuf (errorcode_to_int e)); 72 | Cstruct.blit_from_string msg 0 obuf Wire.sizeof_herr msglen; 73 | Cstruct.set_char obuf (Wire.sizeof_herr + msglen) '\x00'; 74 | let (dest_ip, dest_port, source_port) = tid in 75 | U.write ~source_port ~dest_ip ~dest_port (S.udpv4 t.s) obuf 76 | 77 | let tx_datap ~t ~tid filename = 78 | Hashtbl.get t.conns tid 79 | |> function 80 | | None -> 81 | C.log t.c (sp "tx_datap! unknown tid %s" filename); 82 | tx_errp ~t ~tid Wire.UNKNOWN_TID (tid_to_string tid) 83 | 84 | | Some (filename, filesize, blockno) -> 85 | Hashtbl.get t.files filename 86 | |> function 87 | | None -> 88 | C.log t.c (sp "tx_datap! file not found %s" filename); 89 | tx_errp ~t ~tid Wire.FILE_NOT_FOUND filename 90 | 91 | | Some data -> 92 | let srcoff = Int64.(mul blockno 512L) in 93 | let datlen = Int64.(to_int (min 512L (sub filesize srcoff))) in 94 | let blockno = Int64.add blockno 1L in 95 | let obuf = 96 | let buf = Io_page.get_buf ~n:1 () in 97 | Cstruct.set_len buf (Wire.sizeof_hdat + datlen) 98 | in 99 | Wire.(set_hdat_opcode obuf (opcode_to_int DATA)); 100 | Wire.(set_hdat_blockno obuf (Int64.to_int blockno)); 101 | Hashtbl.replace t.conns tid (filename, filesize, blockno); 102 | Cstruct.blit 103 | data (Int64.to_int srcoff) obuf Wire.sizeof_hdat datlen; 104 | let (dest_ip, dest_port, source_port) = tid in 105 | U.write ~source_port ~dest_ip ~dest_port (S.udpv4 t.s) obuf 106 | 107 | (** *) 108 | 109 | let handle_rrq t tid buf = 110 | C.log t.c (sp "RRQ %s" (tid_to_string tid)); 111 | let (sip, spt, _) = tid in 112 | let (filename, buf) = Cstruct.shift buf Wire.sizeof_hreq |> Wire.string0 in 113 | C.log t.c (sp "filename=%s" filename); 114 | 115 | let (mode, _buf) = Wire.string0 buf in 116 | 117 | match mode with 118 | | "octet" -> ( 119 | FS.size t.fs filename >>= (function 120 | | `Error (FS.Unknown_key s) -> error t (sp "unknown key %s" s) 121 | | `Ok filesize -> Lwt.return filesize 122 | ) 123 | 124 | >>= fun filesize -> 125 | Hashtbl.get t.tids ~default:min_port (sip,spt) 126 | |> function 127 | | None -> 128 | C.log t.c (sp "rrq! failed to get tid (%s,%d)" 129 | (Ipaddr.V4.to_string sip) spt); 130 | tx_errp ~t ~tid Wire.UNDEFINED (sp "failed to get tid %d" spt) 131 | >>= fun () -> Lwt.return_none 132 | 133 | | Some source_port -> 134 | FS.read t.fs filename 0 (Int64.to_int filesize) >>= (function 135 | | `Error (FS.Unknown_key s) -> 136 | error t (sp "read! unknown key %s" s) 137 | | `Ok pages -> 138 | let data = Cstruct.(pages |> copyv |> of_string) in 139 | let tid = (sip,spt, source_port) in 140 | Hashtbl.replace t.files filename data; 141 | Hashtbl.replace t.conns tid (filename, filesize, 0L); 142 | Hashtbl.replace t.tids (sip,spt) (source_port + 1); 143 | Lwt.return tid 144 | ) 145 | >>= fun tid -> tx_datap ~t ~tid filename 146 | >>= fun () -> 147 | Lwt.return (Some tid) 148 | ) 149 | | _ -> 150 | C.log t.c (sp "rrq! unsupported mode %s" mode); 151 | Hashtbl.replace t.conns tid (filename, 0L, -1L); 152 | tx_errp ~t ~tid Wire.ILLEGAL_OP (sp "mode:%s" mode) 153 | >>= fun () -> Lwt.return_none 154 | 155 | let handle_ack t tid buf = 156 | let (sip, spt, dpt) = tid in 157 | let ackno = Wire.get_hdat_blockno buf |> Int64.of_int in 158 | Hashtbl.get t.conns tid 159 | |> function 160 | | None -> 161 | C.log t.c (sp "ack! unknown tid %s" (tid_to_string tid)); 162 | tx_errp ~t ~tid Wire.UNKNOWN_TID (tid_to_string tid) 163 | 164 | | Some (filename, filesize, blockno) -> 165 | C.log t.c 166 | (sp "ACK: filename=%s ackno=%Ld blockno=%Ld" filename ackno blockno); 167 | 168 | if blockno < 0L then ( 169 | C.log t.c "ACK: of errp"; 170 | Hashtbl.remove t.conns (sip,spt,dpt); 171 | Lwt.return_unit 172 | 173 | ) else if ackno < blockno then ( 174 | C.log t.c (sp "ACK: retx of %Ld requested!" ackno); 175 | Lwt.return_unit 176 | 177 | ) else if filesize < Int64.mul blockno 512L then ( 178 | C.log t.c "ACK: end-of-file!"; 179 | Hashtbl.remove t.conns (sip,spt,dpt); 180 | Lwt.return_unit 181 | 182 | ) else ( 183 | C.log t.c "ACK: ok!"; 184 | tx_datap ~t ~tid filename 185 | 186 | ) 187 | 188 | let handle_error { c; _ } _buf = 189 | C.log_s c "ERROR" 190 | 191 | let unhandled t tid opcode = 192 | C.log t.c (sp "%s unhandled!" (Wire.opcode_to_string opcode)); 193 | tx_errp ~t ~tid Wire.ILLEGAL_OP (Wire.opcode_to_string opcode) 194 | 195 | let rec callback ~port t = 196 | let { c; _ } = t in 197 | C.log c "Tftp: starting"; 198 | (fun ~src ~dst ~src_port buf -> 199 | C.log c 200 | (sp "Tftp: rx %s.%d > %s.%d" 201 | (Ipaddr.V4.to_string src) src_port (Ipaddr.V4.to_string dst) port 202 | ); 203 | 204 | Wire.(buf |> get_hreq_opcode |> int_to_opcode |> function 205 | | None -> error t (Cstruct.debug buf) 206 | | Some o -> match o with 207 | | RRQ -> ( 208 | handle_rrq t (src,src_port, port) buf 209 | >>= function 210 | | None -> Lwt.return_unit 211 | | Some (_rip,_rpt, port) -> 212 | S.listen_udpv4 t.s ~port (callback ~port t); 213 | Lwt.return_unit 214 | ) 215 | | ACK -> handle_ack t (src,src_port, port) buf 216 | | ERROR -> handle_error t buf 217 | | WRQ | DATA -> unhandled t (src, src_port, port) o 218 | ) 219 | ) 220 | 221 | end 222 | -------------------------------------------------------------------------------- /lib/tftp_S.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Richard Mortier 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 Mirage 18 | 19 | (** Server implementation of TFTP 20 | @see , "RFC 1350" *) 21 | 22 | module Make(FS:V1_LWT.KV_RO)(S:V1_LWT.STACKV4) : sig 23 | 24 | type t 25 | (** Server state record. *) 26 | 27 | val make: fs:FS.t -> s:S.t -> unit -> t 28 | (** [make ~fs ~s] creates a server state record from 29 | a {! V1_LWT.KV_RO} containing the files to serve, and 30 | a {! V1_LWT.STACKV4} IPv4 stack. *) 31 | 32 | val default_port: int 33 | (** Default listen port, [69/UDP]. Note that this is just for receiving the 34 | initial [RRQ]/[WRQ] -- data transfer will take place between a pair of 35 | ephemeral UDP ports. *) 36 | 37 | val callback: port:int -> t -> S.UDPV4.callback 38 | (** [callback ~port t] returns a {! S.UDPV4} callback handler listening on 39 | [port]. *) 40 | 41 | end 42 | -------------------------------------------------------------------------------- /lib/tftp_config.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Richard Mortier 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 Sexplib.Conv 18 | 19 | type t = { 20 | port: int; 21 | files: string; 22 | } with sexp 23 | 24 | let default_port = 69 25 | let min_port = 32768 26 | 27 | let make ?port files = { 28 | port= (match port with None -> default_port | Some p -> p); 29 | files; 30 | } 31 | 32 | let port t = t.port 33 | -------------------------------------------------------------------------------- /lib/tftp_wire.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Richard Mortier 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 Cstruct 18 | 19 | cenum errorcode { 20 | UNDEFINED = 0; 21 | FILE_NOT_FOUND; 22 | ACCESS_VIOLATION; 23 | DISK_FULL; 24 | ILLEGAL_OP; 25 | UNKNOWN_TID; 26 | FILE_EXISTS; 27 | UNKNOWN_USER 28 | } as uint8_t(sexp) 29 | 30 | cenum opcode { 31 | RRQ = 1; 32 | WRQ; 33 | DATA; 34 | ACK; 35 | ERROR 36 | } as uint16_t(sexp) 37 | 38 | cstruct hreq { 39 | uint16_t opcode 40 | } as big_endian 41 | 42 | cstruct hdat { 43 | uint16_t opcode; 44 | uint16_t blockno 45 | } as big_endian 46 | 47 | cstruct herr { 48 | uint16_t opcode; 49 | uint16_t errorcode 50 | } as big_endian 51 | 52 | let string0 buf = 53 | let rec aux s i buf = 54 | let c = Cstruct.get_char buf i in 55 | if c = '\x00' then 56 | let string = s |> List.rev |> String.concat "" in 57 | (string, Cstruct.shift buf (i+1)) 58 | else 59 | aux (Char.escaped c :: s) (i+1) buf 60 | in 61 | aux [] 0 buf 62 | -------------------------------------------------------------------------------- /lib/tftp_wire.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Richard Mortier 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 TFTP wire parsers} *) 18 | 19 | (** {2 TFTP error codes} *) 20 | 21 | type errorcode = 22 | | UNDEFINED (** operation undefined, e.g., couldn't create [TID] *) 23 | | FILE_NOT_FOUND (** file not found in store *) 24 | | ACCESS_VIOLATION 25 | | DISK_FULL 26 | | ILLEGAL_OP (** unsupported operation, e.g., unsupported [mode] *) 27 | | UNKNOWN_TID 28 | | FILE_EXISTS 29 | | UNKNOWN_USER 30 | 31 | (** Conversion to/from {! errorcode}s. *) 32 | 33 | val int_to_errorcode: int -> errorcode option 34 | val errorcode_to_int: errorcode -> int 35 | val errorcode_to_string: errorcode -> string 36 | val string_to_errorcode: string -> errorcode option 37 | val errorcode_of_sexp: Sexplib.Sexp.t -> errorcode 38 | val sexp_of_errorcode: errorcode -> Sexplib.Sexp.t 39 | 40 | (** {2 TFTP opcodes} *) 41 | 42 | type opcode = 43 | | RRQ (** read request *) 44 | | WRQ (** write request *) 45 | | DATA (** data block *) 46 | | ACK (** acknowledgement *) 47 | | ERROR (** error indication *) 48 | 49 | (** Conversion to/from {! opcode}s. *) 50 | 51 | val int_to_opcode: int -> opcode option 52 | val opcode_to_int: opcode -> int 53 | val opcode_to_string: opcode -> string 54 | val string_to_opcode: string -> opcode option 55 | val opcode_of_sexp: Sexplib.Sexp.t -> opcode 56 | val sexp_of_opcode: opcode -> Sexplib.Sexp.t 57 | 58 | (** {2 Request packets, {! opcode.RRQ}/{! opcode.WRQ}} *) 59 | 60 | val sizeof_hreq: int 61 | val get_hreq_opcode: Cstruct.t -> Cstruct.uint16 62 | val set_hreq_opcode: Cstruct.t -> Cstruct.uint16 -> unit 63 | val hexdump_hreq_to_buffer: Buffer.t -> Cstruct.t -> unit 64 | val hexdump_hreq: Cstruct.t -> unit 65 | 66 | (** {2 Data packets, {! opcode.DATA}/{! opcode.ACK}} *) 67 | 68 | val sizeof_hdat: int 69 | val get_hdat_opcode: Cstruct.t -> Cstruct.uint16 70 | val set_hdat_opcode: Cstruct.t -> Cstruct.uint16 -> unit 71 | val get_hdat_blockno: Cstruct.t -> Cstruct.uint16 72 | val set_hdat_blockno: Cstruct.t -> Cstruct.uint16 -> unit 73 | val hexdump_hdat_to_buffer: Buffer.t -> Cstruct.t -> unit 74 | val hexdump_hdat: Cstruct.t -> unit 75 | 76 | (** {2 Error packets, {! opcode.ERROR}} *) 77 | 78 | val sizeof_herr: int 79 | val get_herr_opcode: Cstruct.t -> Cstruct.uint16 80 | val set_herr_opcode: Cstruct.t -> Cstruct.uint16 -> unit 81 | val get_herr_errorcode: Cstruct.t -> Cstruct.uint16 82 | val set_herr_errorcode: Cstruct.t -> Cstruct.uint16 -> unit 83 | val hexdump_herr_to_buffer: Buffer.t -> Cstruct.t -> unit 84 | val hexdump_herr: Cstruct.t -> unit 85 | 86 | (** {2 Utility functions} *) 87 | 88 | (** [string0 buf] extracts a [NUL] terminated ASCII string from [buf], shifts 89 | [buf] past it, and returns the pair. *) 90 | val string0: Cstruct.t -> string * Cstruct.t 91 | -------------------------------------------------------------------------------- /mirage/.merlin: -------------------------------------------------------------------------------- 1 | REC 2 | -------------------------------------------------------------------------------- /mirage/tftp-mirage.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 71e5f67206e6b7aa2ecfa953ecdc9f32) 3 | Tftp_mirage 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /mirage/tftp-mirage.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 71e5f67206e6b7aa2ecfa953ecdc9f32) 3 | Tftp_mirage 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /mirage/tftp_mirage.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Richard Mortier 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.Infix 18 | 19 | let src = Logs.Src.create "tftp" ~doc:"tftp-mirage" 20 | module Log = (val Logs.src_log src : Logs.LOG) 21 | 22 | let sp = Printf.sprintf 23 | 24 | module S = struct 25 | 26 | module Make (FS: V1_LWT.KV_RO) (STACK: V1_LWT.STACKV4) 27 | = struct 28 | 29 | module U = STACK.UDPV4 30 | 31 | type t = { 32 | server: Tftp.S.t; 33 | fs: FS.t; 34 | s: STACK.t; 35 | } 36 | 37 | let handle_failure { server; fs; s } (sip,spt,dpt) = 38 | Tftp.Failure.(function 39 | | Unknown_tid -> Lwt.return_unit 40 | | File_not_found filename -> Lwt.return_unit 41 | | Invalid_packet -> Lwt.return_unit 42 | | Unsupported_mode mode -> Lwt.return_unit 43 | | Rrq_refused -> Lwt.return_unit 44 | | Unsupported_op opcode -> Lwt.return_unit 45 | ) 46 | 47 | let handle_success { server; fs; s } (sip,spt,dpt) = 48 | Tftp.Success.(function 49 | | Packet p -> Lwt.return_unit 50 | | Retx (blockno, p) -> Lwt.return_unit 51 | | Ack_of_error -> Lwt.return_unit 52 | | Ack_of_eof -> Lwt.return_unit 53 | | Error (errorcode, msg) -> Lwt.return_unit 54 | | Request (filename, mode) -> Lwt.return_unit 55 | ) 56 | 57 | let rec callback ~port t = 58 | let { server; s; _ } = t in 59 | Log.info (fun f -> f "Tftp: starting"); 60 | (fun ~src ~dst ~src_port buf -> 61 | Log.info (fun f -> 62 | f "Tftp: rx %s.%d > %s.%d" 63 | (Ipaddr.V4.to_string src) src_port (Ipaddr.V4.to_string dst) port 64 | ); 65 | 66 | Tftp.(match handle t.server src src_port port buf with 67 | | Ok (server, tid, success) -> 68 | Log.info (fun f -> f "Tftp: Ok: tid:%s server:%s" 69 | (Tid.to_string tid) (Tftp.S.to_string server) 70 | ); 71 | 72 | handle_success t tid success 73 | | Fail (server, tid, outp, failure) -> 74 | Log.info (fun f -> f "Tftp: Fail: tid:%s server:%s failure:%s" 75 | (Tid.to_string tid) (Tftp.S.to_string server) 76 | "fail!" 77 | ); 78 | 79 | handle_failure t tid failure >>= fun () -> 80 | let (sip,spt,dpt) = tid in 81 | let source_port = dpt in 82 | let dest_ip = sip in 83 | let dest_port = spt in 84 | U.write ~source_port ~dest_ip ~dest_port (STACK.udpv4 s) outp 85 | ) 86 | ) 87 | end 88 | end 89 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: 7c6d9fd8aa347a065803dc18271b9400) *) 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 = 611 | [ 612 | ("tftp-wire", ["lib"], []); 613 | ("tftp", ["lib"], []); 614 | ("tftp-mirage", ["mirage"], []) 615 | ]; 616 | lib_c = []; 617 | flags = []; 618 | includes = [("mirage", ["lib"])] 619 | } 620 | ;; 621 | 622 | let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} 623 | 624 | let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; 625 | 626 | # 627 "myocamlbuild.ml" 627 | (* OASIS_STOP *) 628 | Ocamlbuild_plugin.dispatch dispatch_default;; 629 | -------------------------------------------------------------------------------- /tftp.opam/descr: -------------------------------------------------------------------------------- 1 | A TFTP library and Mirage unikernel 2 | 3 | A basic implementation of the [Trivial FTP](https://tools.ietf.org/html/rfc1350) 4 | protocol. Provides separate wire parsing and server libraries, plus a 5 | [MirageOS](https://mirage.io/) unikernel server implementation. 6 | -------------------------------------------------------------------------------- /tftp.opam/install: -------------------------------------------------------------------------------- 1 | bin: ["?bin/tftpd"] 2 | -------------------------------------------------------------------------------- /tftp.opam/opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | license: "ISC" 3 | maintainer: "mort@cantab.net" 4 | authors: "Richard Mortier " 5 | homepage: "https://github.com/mor1/ocaml-tftp" 6 | bug-reports: "https://github.com/mor1/ocaml-tftp/issues" 7 | dev-repo: "https://github.com/mor1/ocaml-tftp.git" 8 | 9 | build: [ 10 | [make "configure"] 11 | [make "build"] 12 | ["cp" "./tftp.opam/install" "./tftp.install"] 13 | ] 14 | 15 | install: [ 16 | [make "install"] 17 | ] 18 | 19 | build-test: [make "test"] 20 | 21 | remove: [ 22 | ["ocamlfind" "remove" "tftp"] 23 | ] 24 | 25 | depends: [ 26 | "ocamlfind" {build} 27 | "alcotest" {test} 28 | "camlp4" 29 | "lwt" {>= "2.4.7"} 30 | "cstruct" {>= "1.0.1"} 31 | "mirage" {>= "2.5.0"} 32 | "io-page" 33 | "mirage-console" 34 | "mirage-fs-unix" 35 | "tcpip" 36 | "mirage-logs" 37 | ] 38 | 39 | available: [ocaml-version >= "4.01.0"] 40 | --------------------------------------------------------------------------------