├── .ocamlformat ├── LICENSE.md ├── README.md ├── etc ├── README.md └── auto.sshfs └── src ├── config.ml ├── fs.ml ├── helpers.ml ├── sshfs.ml ├── sshfs_tag.ml └── unikernel.ml /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.24.1 2 | profile = conventional 3 | break-infix = fit-or-vertical 4 | parse-docstrings = true 5 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2021 Pierre Alain 2 | 3 | Permission to use, copy, modify, and distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. 4 | 5 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # mirage-sshfs 2 | 3 | Warning: WIP! 4 | 5 | [mirage-sshfs][] is an _ISC-licensed_ SSHFS server implementation in ocaml. 6 | 7 | This unikernel can be seen as a "super chrooted" SSHFS mount point or be 8 | used as a VM that provides a common disk for other VMs. 9 | 10 | ## Public/Private key access 11 | As we use ssh for communication, we first need to have a public/private key pair. 12 | We will later add the public key to the disk image file (the pubkey must be 13 | present at the root of the filesystem or must be given to the unikernel through 14 | the `--user` and `--key` options). 15 | ``` 16 | ssh-keygen -t ed25519 -C mirage_sshfs -f username -N '' && \ 17 | chmod 600 username 18 | ``` 19 | Note that the empty passphrase is not mandatory (it's currently not supported by 20 | [awa-ssh]() but the passphrase will be supported by the sshfs client). 21 | 22 | ## Filesystem creation 23 | This unikernel can be used with persistent (but that's not mandatory if you 24 | want to simply share some files) storage layer. 25 | 26 | ### Not persistent storage layer 27 | If you don't want to have persistent data, you can modify `src/config.ml` to 28 | comment out the section talking about `chamelon` and `aes-ccm`, and simply use 29 | ``` 30 | let my_fs = kv_rw_mem () 31 | ``` 32 | 33 | In this case, you must add the `--key 'ssh-ed25519\ AAAA....xyz\ mirage_sshfs` for 34 | starting the server and defining the `--user` public key. 35 | 36 | ### Persistent storage layer 37 | If you prefer to save data persistently, you must create a disk file that will be 38 | shared with SSHFS. It currently uses a [chamelon][] Ocaml implementation of 39 | [littlefs][]. 40 | 41 | ``` 42 | opam install chamelon-unix -y && \ 43 | dd if=/dev/zero of=disk.img bs=1M count=32 && \ 44 | chamelon format disk.img 512 45 | ``` 46 | 47 | Any kind of filesystem should be ok to use as it will be seen on the client 48 | side via the sshfs protocol. In the previous instructions, we also add the public 49 | key at the root of the filesystem in order to be able to connect without having to 50 | use the `--key` option. 51 | 52 | ## Filesystem encryption layer 53 | If you want to use an enryption layer under the filesystem's structure, this 54 | unikernel uses the AES-CCM encrypted [mirage-block-ccm][] storage. You may 55 | want to convert an non-encrypted image (as the one previously created) to an 56 | encrypted one with the following: 57 | ``` 58 | opam install mirage-block-ccm -y && \ 59 | ccmblock enc --in=disk.img --out=encrypted.img --key=1234567890ABCDEF1234567890ABCDEF 60 | ``` 61 | 62 | In this case, you must add the `--aes-ccm-key 1234567890ABCDEF1234567890ABCDEF` in 63 | the commands and use the encrypted image file. 64 | 65 | ## The User/Key database 66 | You can specify users and public keys with any one of the following methods. The user 67 | database is constructed in such a way that a user account cannot be redefined. So 68 | there is a priority in taking users into account: 69 | - command line option, 70 | - then `*.pub` files at the root level of the KV store, 71 | - then `authorized_keys` at the root level of the KV store. 72 | 73 | Of course you can add users and public keys when the unikernel is alive and you may 74 | only need one of the following method to add your first user (in particular when using 75 | `kv_mem` backend for storage). 76 | 77 | ### As a command line option 78 | The first way is to use the `--user` and `--key` command line option. The easiest way 79 | to do that is the following: 80 | ``` 81 | ./src/dist/mirage_sshfs --user username --key "$(cat username.pub | sed 's/ /\\ /g')" 82 | ``` 83 | 84 | ### With public key files at the root of the KV store 85 | You can add any public key file at the root level of the KV store, for example with 86 | chamelon you can do this: 87 | ``` 88 | chamelon write ./disk.img 512 /username.pub "$(cat username.pub)" 89 | ``` 90 | 91 | ### With an authorized_keys file at the root of the KV store 92 | You can add an `authorized_keys` file at the root level as you can do with an ssh server: 93 | ``` 94 | chamelon write ./disk.img 512 /authorized_keys "$(cat ~/.ssh/authorized_keys)" 95 | ``` 96 | 97 | ## Running Unix "chrooted" SSHFS 98 | ``` 99 | mirage configure -t unix -f src/config.ml && \ 100 | make depend && \ 101 | dune build && \ 102 | ./src/dist/mirage_sshfs --port 22022 --user username --seed 111213 103 | ``` 104 | 105 | The server gives access to the content of the mirage-kv store with the user 106 | `username` and a key associated with that user (as defined on the command line 107 | with option `--key` or at the root level `disk.img/username.pub` or in 108 | `disk.img/authorized_keys`). The default values for port and username are 109 | `18022` and `mirage`, the default key is not a valid publickey and cannot be used. 110 | 111 | ## Running Hvt SSHFS VM 112 | ``` 113 | mirage configure -t hvt -f src/config.ml && \ 114 | make depend && \ 115 | dune build 116 | ``` 117 | 118 | You have to set up the solo5-hvt environment as described in the [solo5][] 119 | setup page. Then you can run the unikernel with solo5: 120 | ``` 121 | solo5-hvt --net:service=tap100 \ 122 | --block:storage=disk.img \ 123 | ./src/dist/mirage_sshfs.hvt \ 124 | --port 22022 --user username --seed 111213 125 | ``` 126 | 127 | ## Running Qubes SSHFS VM 128 | ``` 129 | mirage configure -t qubes -f src/config.ml && \ 130 | make depend && \ 131 | dune build 132 | ``` 133 | 134 | To create a VM using the new unikernel, you can run the following commands in 135 | `dom0`. Here `mirage-sshfs` stands for the name of your new VM, `dev_VM` for 136 | the name of the VM in which you compile your unikernel. 137 | 138 | You can look into qubes-test-mirage to upload your unikernel to `dom0` 139 | [qubes-test-mirage][]. 140 | 141 | ``` 142 | qvm-create \ 143 | --property kernel=mirage-sshfs \ 144 | --property kernelopts='' \ 145 | --property memory=32 \ 146 | --property maxmem=32 \ 147 | --property netvm=sys-firewall \ 148 | --property provides_network=False \ 149 | --property vcpus=1 \ 150 | --property virt_mode=pvh \ 151 | --label=gray \ 152 | --standalone \ 153 | mirage-sshfs 154 | 155 | qvm-features mirage-sshfs no-default-kernelopts 1 156 | qvm-run -p dev_VM 'cat /path/to/mirage-sshfs/disk.img' > /home/user/Desktop/disk.img 157 | qvm-volume import mirage-sshfs:private /home/user/Desktop/disk.img 158 | qvm-prefs -- mirage-sshfs kernelopts '--seed 111213' 159 | ``` 160 | 161 | If you want to enable debug tracing, you can also run: 162 | ``` 163 | qvm-prefs -- mirage-sshfs kernelopts '-l "*:debug" --seed 111213' 164 | ``` 165 | 166 | And finally you will have to add rules in your connecting firewall VM to 167 | support communication between the unikernel_sshfs VM and your clients VMs. 168 | 169 | ## Connecting to the unikernel 170 | 171 | Once the server is running, you can mount the disk with the sshfs command: 172 | ``` 173 | sshfs username@hostserver:/ \ 174 | /path/mount/ \ 175 | -p 22022 \ 176 | -o IdentityFile=/absolute/path/to/username && \ 177 | ls -l /path/mount/ && \ 178 | cat /path/mount/username.pub 179 | ``` 180 | 181 | ## (Auto-)Connecting to the unikernel 182 | 183 | See `etc/README.md`. 184 | 185 | [mirage-sshfs]: https://github.com/palainp/mirage-sshfs 186 | [awa-ssh]: https://github.com/mirage/awa-ssh 187 | [chamelon]: https://github.com/yomimono/chamelon/ 188 | [littlefs]: https://github.com/littlefs-project/littlefs 189 | [mirage-block-ccm]: https://github.com/sg2342/mirage-block-ccm 190 | [solo5]: https://github.com/Solo5/solo5/blob/master/docs/building.md#setting-up 191 | [qubes-test-mirage]: https://github.com/talex5/qubes-test-mirage 192 | -------------------------------------------------------------------------------- /etc/README.md: -------------------------------------------------------------------------------- 1 | # auto sshfs 2 | 3 | In order to use this unikernel with autofs, you should: 4 | * install your distribution's `autofs+sshfs` packages 5 | * edit the `/etc/auto.master` file to add something like 6 | ``` 7 | /mnt/sshfs /etc/auto.sshfs uid=1000,gid=1000,--timeout=30,--ghost 8 | ``` 9 | and adapt your uid/gid 10 | * add a new `/etc/auto.sshfs` file: 11 | ``` 12 | local -fstype=fuse,allow_other,port=22022,IdentityFile=/path/to/keyfile :sshfs\#username@127.0.0.1:/ 13 | ``` 14 | and adapt the running port, the path for the private key and the 15 | ssh username. 16 | * start the autofs service 17 | 18 | Note that the keyfile must be owned by root (or the user running 19 | the autofs daemon), and must have the `rw-------` (600) permissions 20 | otherwise ssh may consider that the keyfile is not safe enough. 21 | 22 | Also note that root must accept the server fingerprint prior any 23 | autofs connexion, the easiest way to do that is to connect to the 24 | server a first time before using autofs. 25 | Another, discouraged, option can be to add `StrictHostKeyChecking=no` 26 | in the `auto.sshfs` file. 27 | 28 | This will automount the block when you move to `/mnt/sshfs/local` 29 | and unmount it after a desired timeout. 30 | You still have to manually start the SSHFS server with the command 31 | line provided in the main `README.md`. 32 | -------------------------------------------------------------------------------- /etc/auto.sshfs: -------------------------------------------------------------------------------- 1 | local -fstype=fuse,allow_other,port=22022,IdentityFile=/root/username :sshfs\#username@127.0.0.1:/ 2 | -------------------------------------------------------------------------------- /src/config.ml: -------------------------------------------------------------------------------- 1 | (* mirage >= 4.9.0 & < 4.10.0 *) 2 | open Mirage 3 | 4 | let main = 5 | main 6 | ~packages: 7 | [ 8 | package ~min:"6.0.0" "cstruct"; 9 | package ~min:"0.5.1" "awa-mirage"; 10 | package "ethernet"; 11 | package "io-page"; 12 | package ~min:"6.1.1" "mirage-kv"; 13 | package ~min:"6.0.0" "mirage-protocols"; 14 | package ~min:"0.8.7" "fmt"; 15 | package ~build:true "bos"; 16 | package ~build:true "fpath"; 17 | ] 18 | "Unikernel.Main" 19 | (stackv4v6 @-> kv_rw @-> job) 20 | 21 | let stack = generic_stackv4v6 default_network 22 | 23 | (* *** *) 24 | 25 | (* The following is using mirage-kv-mem as the disk layer, the data shared with sshfs won't 26 | resist to shutdown but this scenario can be convenient for a simple sharing method... *) 27 | 28 | (* let my_fs = kv_rw_mem () *) 29 | 30 | (* If you prefer to have a persistent storage layer you can use the following (chamelon as 31 | the filesystem, and ccm for encryption layer for your disk) 32 | FIXME: outdated 33 | let aes_ccm_key = 34 | let doc = 35 | Key.Arg.info [ "aes-ccm-key" ] 36 | ~doc:"The key of the block device (hex formatted)" 37 | in 38 | Key.(create "aes-ccm-key" Arg.(required string doc)) 39 | *) 40 | 41 | let my_fs = 42 | let program_block_size = 43 | Runtime_arg.create ~pos:__POS__ "Unikernel.program_block_size" 44 | in 45 | (* is_xen = Qubes target, is_solo5 = Spt or Hvt target, else = Unix target *) 46 | let block = 47 | Key.( 48 | if_impl is_xen (block_of_file "private") 49 | (if_impl is_solo5 (block_of_file "storage") 50 | (block_of_file "disk.img"))) 51 | in 52 | (*let encrypted_block = ccm_block aes_ccm_key block 53 | let my_fs = chamelon ~program_block_size encrypted_block*) 54 | chamelon ~program_block_size block 55 | 56 | (* *** *) 57 | 58 | let () = 59 | register "mirage_sshfs" 60 | [ 61 | main 62 | $ stack 63 | $ my_fs 64 | ] 65 | -------------------------------------------------------------------------------- /src/fs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2022 Pierre Alain 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 | open Helpers 19 | open Sshfs_tag 20 | 21 | module Make (KV : Mirage_kv.RW) = struct 22 | let log_src = Logs.Src.create "sshfs_fs" ~doc:"Helper fs functions" 23 | 24 | module Log = (val Logs.src_log log_src : Logs.LOG) 25 | 26 | let fail pp e = Lwt.fail_with (Format.asprintf "%a" pp e) 27 | let fail_read = fail KV.pp_error 28 | let fail_write = fail KV.pp_write_error 29 | let ( >>+= ) m f = m >>= function Error e -> fail_read e | Ok x -> f x 30 | let ( >>*= ) m f = m >>= function Error e -> fail_write e | Ok x -> f x 31 | 32 | type file_pflags = 33 | | SSH_FXF_READ 34 | | SSH_FXF_WRITE 35 | | SSH_FXF_APPEND 36 | | SSH_FXF_CREAT 37 | | SSH_FXF_TRUNC 38 | | SSH_FXF_EXCL 39 | | SSH_FXF_UNDEF 40 | 41 | let file_pflags_of_int = function 42 | | 0x00000001 -> SSH_FXF_READ 43 | | 0x00000002 -> SSH_FXF_WRITE 44 | | 0x00000004 -> SSH_FXF_APPEND 45 | | 0x00000008 -> SSH_FXF_CREAT 46 | | 0x00000010 -> SSH_FXF_TRUNC 47 | | 0x00000020 -> SSH_FXF_EXCL 48 | | _ -> SSH_FXF_UNDEF 49 | 50 | let file_pflags_to_int = function 51 | | SSH_FXF_READ -> 0x00000001 52 | | SSH_FXF_WRITE -> 0x00000002 53 | | SSH_FXF_APPEND -> 0x00000004 54 | | SSH_FXF_CREAT -> 0x00000008 55 | | SSH_FXF_TRUNC -> 0x00000010 56 | | SSH_FXF_EXCL -> 0x00000020 57 | | SSH_FXF_UNDEF -> 0 58 | 59 | (* for now paths and handles are id but we can change that here *) 60 | let path_to_handle _ path = 61 | let handle = String.map (fun c -> if c=='/' then '\\' else c) path in 62 | Logs.info(fun f -> f "path to handle %s -> %s" path handle); 63 | Lwt.return handle 64 | 65 | let path_of_handle _ handle = 66 | let path = String.map (fun c -> if c=='\\' then '/' else c) handle in 67 | Logs.info(fun f -> f "handle to path %s -> %s" handle path); 68 | Lwt.return path 69 | 70 | (* silently discard the error if the key is absent *) 71 | let is_present root pathkey = 72 | KV.exists root pathkey >>+= function 73 | | None -> Lwt.return false 74 | | Some _ -> Lwt.return true 75 | 76 | let is_file root pathkey = 77 | KV.exists root pathkey >>+= function 78 | | None -> Lwt.return false 79 | | Some `Dictionary -> Lwt.return false 80 | | Some `Value -> Lwt.return true 81 | 82 | let is_directory root pathkey = 83 | KV.exists root pathkey >>+= function 84 | | None -> Lwt.return false 85 | | Some `Dictionary -> Lwt.return true 86 | | Some `Value -> Lwt.return false 87 | 88 | let remove_if_present root pathkey = 89 | is_present root pathkey >>= function 90 | | true -> KV.remove root pathkey >>*= fun () -> Lwt.return_unit 91 | | false -> Lwt.return_unit 92 | 93 | let create_if_absent root pathkey = 94 | is_present root pathkey >>= function 95 | | true -> Lwt.return_unit 96 | | false -> KV.set root pathkey "" >>*= fun () -> Lwt.return_unit 97 | 98 | let flush_file_if pflags root pathkey = 99 | if 100 | pflags land file_pflags_to_int SSH_FXF_TRUNC 101 | == file_pflags_to_int SSH_FXF_TRUNC 102 | then ( 103 | Log.debug (fun f -> 104 | f "[flush_file_if] SSH_FXF_TRUNC `%s`\n%!" 105 | (Mirage_kv.Key.to_string pathkey)); 106 | remove_if_present root pathkey >>= fun () -> create_if_absent root pathkey) 107 | else Lwt.return_unit 108 | 109 | let create_file_if pflags root pathkey = 110 | if 111 | pflags land file_pflags_to_int SSH_FXF_CREAT 112 | == file_pflags_to_int SSH_FXF_CREAT 113 | then ( 114 | Log.debug (fun f -> 115 | f "[create_file_if] SSH_FXF_CREAT `%s`\n%!" 116 | (Mirage_kv.Key.to_string pathkey)); 117 | create_if_absent root pathkey) 118 | else Lwt.return_unit 119 | 120 | let touch_file_if pflags root pathkey = 121 | if 122 | pflags land file_pflags_to_int SSH_FXF_APPEND 123 | == file_pflags_to_int SSH_FXF_APPEND 124 | then ( 125 | Log.debug (fun f -> 126 | f "[touch_file_if] SSH_FXF_APPEND `%s`\n%!" 127 | (Mirage_kv.Key.to_string pathkey)); 128 | create_if_absent root pathkey) 129 | else Lwt.return_unit 130 | 131 | let instruct_pflags pflags root path = 132 | let pathkey = Mirage_kv.Key.v path in 133 | flush_file_if pflags root pathkey >>= fun () -> 134 | create_file_if pflags root pathkey >>= fun () -> 135 | touch_file_if pflags root pathkey 136 | 137 | let mtime root pathkey = 138 | KV.last_modified root pathkey >>= function 139 | | Error _ -> Lwt.return 0.0 140 | | Ok s -> 141 | let s = Ptime.to_span s in 142 | Lwt.return (Ptime.Span.to_float_s s) 143 | 144 | let size_key root pathkey = 145 | KV.size root pathkey >>= function 146 | | Error `Not_found k -> Log.err (fun f -> f "size: '%s' isn't found" (Mirage_kv.Key.to_string k)); Lwt.return 0 147 | | Error _ -> Log.err (fun f -> f "connot get size for '%s'" (Mirage_kv.Key.to_string pathkey)); Lwt.return 0 148 | | Ok s -> Lwt.return (Optint.Int63.to_int s) 149 | 150 | let size root path = 151 | let pathkey = Mirage_kv.Key.v path in 152 | size_key root pathkey 153 | 154 | (* permissions: 155 | * p:4096, d:16384, -:32768 156 | * 256+128+64 : rwx for user 157 | * 32+16+8 : rwx for group 158 | * 4+2+1 : rws for others 159 | *) 160 | let permission root path = 161 | let pathkey = Mirage_kv.Key.v path in 162 | if String.equal path "/" then 163 | (* permissions for / *) 164 | mtime root pathkey >>= fun time -> 165 | size_key root pathkey >>= fun s -> 166 | let payload = 167 | Cstruct.concat 168 | [ 169 | uint32_to_cs 5l; 170 | (* SSH_FILEXFER_ATTR_SIZE(1) + ~SSH_FILEXFER_ATTR_UIDGID(2) + SSH_FILEXFER_ATTR_PERMISSIONS(4) + ~SSH_FILEXFER_ATTR_ACMODTIME(8) *) 171 | uint64_to_cs (Int64.of_int s); 172 | (* size value *) 173 | uint32_to_cs (Int32.of_int (16384 + 448 + 56 + 7)); 174 | (* perm: drwxrwxrwx *) 175 | uint32_to_cs (Int32.of_float time); 176 | (* atime *) 177 | uint32_to_cs (Int32.of_float time) (* mtime *); 178 | ] 179 | in 180 | Lwt.return (SSH_FXP_ATTRS, payload) 181 | else 182 | (* path exists? and is a folder or a file? *) 183 | is_present root pathkey >>= function 184 | | false -> 185 | Lwt.return 186 | ( SSH_FXP_STATUS, 187 | uint32_to_cs (sshfs_errcode_to_uint32 SSH_FX_NO_SUCH_FILE) ) 188 | | true -> ( 189 | mtime root pathkey >>= fun time -> 190 | size_key root pathkey >>= fun s -> 191 | is_file root pathkey >>= function 192 | | true -> 193 | (* This is a file *) 194 | let payload = 195 | Cstruct.concat 196 | [ 197 | uint32_to_cs 13l; 198 | (* SSH_FILEXFER_ATTR_SIZE(1) + ~SSH_FILEXFER_ATTR_UIDGID(2) + SSH_FILEXFER_ATTR_PERMISSIONS(4) + SSH_FILEXFER_ATTR_ACMODTIME(8) *) 199 | uint64_to_cs (Int64.of_int s); 200 | uint32_to_cs (Int32.of_int (32768 + 448 + 56 + 7)); 201 | (* perm: -rwxrwxrwx *) 202 | uint32_to_cs (Int32.of_float time); 203 | (* atime *) 204 | uint32_to_cs (Int32.of_float time) (* mtime *); 205 | ] 206 | in 207 | Lwt.return (SSH_FXP_ATTRS, payload) 208 | | false -> 209 | (* This is a folder *) 210 | let payload = 211 | Cstruct.concat 212 | [ 213 | uint32_to_cs 13l; 214 | (* SSH_FILEXFER_ATTR_SIZE(1) + ~SSH_FILEXFER_ATTR_UIDGID(2) + SSH_FILEXFER_ATTR_PERMISSIONS(4) + SSH_FILEXFER_ATTR_ACMODTIME(8) *) 215 | uint64_to_cs (Int64.of_int s); 216 | uint32_to_cs (Int32.of_int (16384 + 448 + 56 + 7)); 217 | (* perm: drwxrwxrwx *) 218 | uint32_to_cs (Int32.of_float time); 219 | (* atime *) 220 | uint32_to_cs (Int32.of_float time) (* mtime *); 221 | ] 222 | in 223 | Lwt.return (SSH_FXP_ATTRS, payload)) 224 | 225 | let read_key root pathkey ~offset ~length = 226 | KV.get_partial root pathkey ~offset ~length >>= function 227 | | Error e -> Lwt.return (Error e) 228 | | Ok data -> Lwt.return (Ok data) 229 | 230 | let read root path ~offset ~length = 231 | let pathkey = Mirage_kv.Key.v path in 232 | read_key root pathkey ~offset ~length 233 | 234 | (** pre: path is the key for [data(0..data_length-1)] post: path is the key 235 | for 236 | [data(0..offset-1), newdata(offset..offset+newdata_length-1), data(offset+newdata_length..data_length-1)] 237 | Q: take care when data_length < offset Q: take care when offset < 0 *) 238 | let write root path ~offset _newdata_length newdata = 239 | let pathkey = Mirage_kv.Key.v path in 240 | let data = Cstruct.to_string newdata in 241 | KV.set_partial root pathkey ~offset data >>= function 242 | | Error e -> Lwt.return (Error e) 243 | | Ok () -> Lwt.return (Ok ()) 244 | 245 | (* TODO: deal remove directories... *) 246 | let remove root path = 247 | let pathkey = Mirage_kv.Key.v path in 248 | KV.remove root pathkey 249 | 250 | (* TODO: deal rename directories... *) 251 | let rename root oldpath newpath = 252 | let source = Mirage_kv.Key.v oldpath in 253 | let dest = Mirage_kv.Key.v newpath in 254 | KV.rename root ~source ~dest 255 | 256 | (* list the path but eventually exclude . as it's only used to create directories *) 257 | let lsdir root path = 258 | let pathkey = Mirage_kv.Key.v path in 259 | KV.list root pathkey >>+= fun res -> 260 | let names = List.filter (fun (k, _) -> (Mirage_kv.Key.basename k) <> ".") res in 261 | Lwt.return names 262 | 263 | let mkdir root path = 264 | (* it seems that we cannot create empty directory, so I try to add a empty . file which must 265 | be returned when lsidr is called *) 266 | let dummy = String.concat "/" [ path; "." ] in 267 | let dummykey = Mirage_kv.Key.v dummy in 268 | KV.set root dummykey "" 269 | end 270 | -------------------------------------------------------------------------------- /src/helpers.ml: -------------------------------------------------------------------------------- 1 | let uint8_to_cs i = 2 | let cs = Cstruct.create 1 in 3 | Cstruct.set_uint8 cs 0 i; 4 | cs 5 | 6 | let uint32_to_cs i = 7 | let cs = Cstruct.create 4 in 8 | Cstruct.BE.set_uint32 cs 0 i; 9 | cs 10 | 11 | let uint32_of_cs cs = Cstruct.BE.get_uint32 cs 0 12 | 13 | let uint64_to_cs i = 14 | let cs = Cstruct.create 8 in 15 | Cstruct.BE.set_uint64 cs 0 i; 16 | cs 17 | 18 | let uint64_of_cs cs = Cstruct.BE.get_uint64 cs 0 19 | -------------------------------------------------------------------------------- /src/sshfs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2021 Pierre Alain 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 | open Helpers 19 | 20 | module Make (KV : Mirage_kv.RW) = struct 21 | let log_src = 22 | Logs.Src.create "sshfs_protocol" ~doc:"Protocol dealer for sshfs" 23 | 24 | module Log = (val Logs.src_log log_src : Logs.LOG) 25 | module FS = Fs.Make (KV) 26 | 27 | let fail fmt = Fmt.kstr Lwt.fail_with fmt 28 | let get_list_key disk = FS.lsdir disk "/" 29 | 30 | let get_disk_key disk filename = 31 | FS.size disk filename >>= fun s -> 32 | FS.read disk filename ~offset:(Optint.Int63.of_int 0) ~length:s >>= function 33 | | Error _ -> Lwt.return "" 34 | | Ok data -> Lwt.return data 35 | 36 | let payload_of_string s = 37 | Cstruct.concat 38 | [ uint32_to_cs (Int32.of_int (String.length s)); Cstruct.of_string s ] 39 | 40 | (* sftp message is length(4 bytes) + type(1 byte) + data (length-1 bytes, starting with request-id:4 bytes) *) 41 | let to_client typ payload = 42 | Cstruct.concat 43 | [ 44 | uint32_to_cs (Int32.of_int (1 + Cstruct.length payload)); 45 | uint8_to_cs (Sshfs_tag.sshfs_packtype_to_uint8 typ); 46 | payload; 47 | ] 48 | 49 | let from_client msg = 50 | let typ = Sshfs_tag.sshfs_packtype_of_uint8 (Cstruct.get_uint8 msg 0) in 51 | let dat = Cstruct.sub msg 1 (Cstruct.length msg - 1) in 52 | (typ, dat) 53 | 54 | let reply_handle root path = 55 | FS.path_to_handle root path >>= fun handle -> 56 | Lwt.return (handle, Sshfs_tag.SSH_FXP_HANDLE, payload_of_string handle) 57 | 58 | (* version 3 used by openssh : https://filezilla-project.org/specs/draft-ietf-secsh-filexfer-02.txt *) 59 | let reply message sshout _ssherror working_table root () = 60 | let request_type, data = from_client message in 61 | let id = uint32_of_cs (Cstruct.sub data 0 4) in 62 | (* request-id *) 63 | Log.debug (fun f -> 64 | f "[%ld received: raw type is %d]\n%!" id 65 | (Sshfs_tag.sshfs_packtype_to_uint8 request_type)); 66 | match request_type with 67 | (* 4. Protocol Initialization *) 68 | | SSH_FXP_INIT -> 69 | Log.debug (fun f -> f "[SSH_FXP_INIT with version %ld]\n%!" id); 70 | sshout 71 | (to_client SSH_FXP_VERSION 72 | (uint32_to_cs (min 3l (uint32_of_cs data)))) 73 | >>= fun () -> Lwt.return working_table 74 | (* 6.8 Retrieving File Attributes *) 75 | | SSH_FXP_STAT 76 | | SSH_FXP_LSTAT -> (* So far we don't bother with symlinks... *) 77 | let path_length = Int32.to_int (uint32_of_cs (Cstruct.sub data 4 4)) in 78 | let path = Cstruct.to_string (Cstruct.sub data 8 path_length) in 79 | Log.debug (fun f -> f "[SSH_FXP_?STAT %ld] for '%s'\n%!" id path); 80 | FS.permission root path >>= fun (reply_type, payload) -> 81 | sshout 82 | (to_client reply_type (Cstruct.concat [ uint32_to_cs id; payload ])) 83 | >>= fun () -> 84 | Lwt.return working_table 85 | (* 6.8 Retrieving File Attributes *) 86 | | SSH_FXP_FSTAT -> 87 | let handle_length = 88 | Int32.to_int (uint32_of_cs (Cstruct.sub data 4 4)) 89 | in 90 | let handle = Cstruct.to_string (Cstruct.sub data 8 handle_length) in 91 | FS.path_of_handle root handle >>= fun path -> 92 | Log.debug (fun f -> f "[SSH_FXP_FSTAT %ld] for %s\n%!" id path); 93 | FS.permission root path >>= fun (reply_type, payload) -> 94 | sshout 95 | (to_client reply_type (Cstruct.concat [ uint32_to_cs id; payload ])) 96 | >>= fun () -> Lwt.return working_table 97 | (* 6.7 Scanning Directories *) 98 | | SSH_FXP_OPENDIR -> ( 99 | (* TODO: find a better way to deal with handles and file/dirnames *) 100 | let path_length = Int32.to_int (uint32_of_cs (Cstruct.sub data 4 4)) in 101 | let path = Cstruct.to_string (Cstruct.sub data 8 path_length) in 102 | Log.debug (fun f -> f "[SSH_FXP_OPENDIR %ld] for '%s'\n%!" id path); 103 | 104 | match Hashtbl.find_opt working_table path with 105 | | None -> 106 | (* if the handle is not already opened -> open it and add content of this directory into the working table *) 107 | reply_handle root path >>= fun (handle, reply_type, payload) -> 108 | Log.debug (fun f -> 109 | f "[SSH_FXP_OPENDIR %ld] handle is '%s'\n%!" id handle); 110 | sshout 111 | (to_client reply_type 112 | (Cstruct.concat [ uint32_to_cs id; payload ])) 113 | >>= fun () -> 114 | (* Puts every item as Mirage_kv.Key.t in the hash table *) 115 | FS.lsdir root path >>= fun names -> 116 | Hashtbl.add working_table handle names; 117 | Lwt.return working_table 118 | | _ -> 119 | (* if the handle is already opened -> error *) 120 | let payload = 121 | uint32_to_cs 122 | (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_OP_UNSUPPORTED) 123 | in 124 | sshout 125 | (to_client SSH_FXP_STATUS 126 | (Cstruct.concat [ uint32_to_cs id; payload ])) 127 | >>= fun () -> Lwt.return working_table) 128 | (* 6.7 Scanning Directories *) 129 | | SSH_FXP_READDIR -> ( 130 | (* TODO: remove the ugly long-name constant... *) 131 | let handle_length = 132 | Int32.to_int (uint32_of_cs (Cstruct.sub data 4 4)) 133 | in 134 | let handle = Cstruct.to_string (Cstruct.sub data 8 handle_length) in 135 | Log.debug (fun f -> f "[SSH_FXP_READDIR %ld] for '%s'\n%!" id handle); 136 | 137 | match Hashtbl.find_opt working_table handle with 138 | | None -> 139 | (* if the handle is not already opened -> error *) 140 | let payload = 141 | uint32_to_cs 142 | (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_INVALID_HANDLE) 143 | in 144 | sshout 145 | (to_client SSH_FXP_STATUS 146 | (Cstruct.concat [ uint32_to_cs id; payload ])) 147 | >>= fun () -> Lwt.return working_table 148 | | remaining_list -> ( 149 | (* if the handle is already opened -> reply to the client or EOF *) 150 | let remaining_list = Option.get remaining_list in 151 | match remaining_list with 152 | | [] -> 153 | (* if we exhausted the list of files/folder inside the requested handle *) 154 | Log.debug (fun f -> 155 | f "[SSH_FXP_READDIR %ld] for '%s' no more content\n%!" id 156 | handle); 157 | let payload = 158 | uint32_to_cs (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_EOF) 159 | in 160 | sshout 161 | (to_client SSH_FXP_STATUS 162 | (Cstruct.concat [ uint32_to_cs id; payload ])) 163 | >>= fun () -> Lwt.return working_table 164 | | (head, _) :: tail -> 165 | (* if we still have something to give: it's a Mirage_kv.Key.t *) 166 | let name = Mirage_kv.Key.basename head in 167 | let path = Mirage_kv.Key.to_string head in 168 | Log.debug (fun f -> 169 | f "[SSH_FXP_READDIR %ld] for '%s' giving '%s'\n%!" id handle 170 | name); 171 | FS.permission root path >>= fun (_, stats) -> 172 | let payload = 173 | Cstruct.concat 174 | [ 175 | uint32_to_cs 1l; 176 | (* count the number of names returned *) 177 | payload_of_string name; 178 | (* short-name *) 179 | payload_of_string 180 | "1234567890123123456781234567812345678123456789012"; 181 | (* FIXME: long-name *) 182 | stats; 183 | ] 184 | in 185 | sshout 186 | (to_client SSH_FXP_NAME 187 | (Cstruct.concat [ uint32_to_cs id; payload ])) 188 | >>= fun () -> 189 | Hashtbl.replace working_table handle tail; 190 | Lwt.return working_table)) 191 | (* 6.3 Opening, Creating, and Closing Files *) 192 | | SSH_FXP_OPEN -> ( 193 | let path_length = Int32.to_int (uint32_of_cs (Cstruct.sub data 4 4)) in 194 | let path = Cstruct.to_string (Cstruct.sub data 8 path_length) in 195 | let pflags = 196 | Int32.to_int (uint32_of_cs (Cstruct.sub data (8 + path_length) 4)) 197 | in 198 | let attrs = 199 | Int32.to_int (uint32_of_cs (Cstruct.sub data (8 + path_length + 4) 4)) 200 | in 201 | Log.debug (fun f -> 202 | f "[SSH_FXP_OPEN %ld] for '%s' pflags=%d attrs=%d\n%!" id path 203 | pflags attrs); 204 | 205 | reply_handle root path >>= fun (handle, reply_type, payload) -> 206 | match Hashtbl.find_opt working_table handle with 207 | | None -> 208 | (* if the handle is not already opened *) 209 | FS.instruct_pflags pflags root path >>= fun () -> 210 | sshout 211 | (to_client reply_type 212 | (Cstruct.concat [ uint32_to_cs id; payload ])) 213 | >>= fun () -> 214 | Hashtbl.add working_table handle []; 215 | Lwt.return working_table 216 | | _ -> 217 | (* if the handle is already opened -> error *) 218 | let payload = 219 | uint32_to_cs 220 | (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_OP_UNSUPPORTED) 221 | in 222 | sshout 223 | (to_client SSH_FXP_STATUS 224 | (Cstruct.concat [ uint32_to_cs id; payload ])) 225 | >>= fun () -> Lwt.return working_table) 226 | (* 6.4 Reading and Writing *) 227 | | SSH_FXP_READ -> ( 228 | let handle_length = 229 | Int32.to_int (uint32_of_cs (Cstruct.sub data 4 4)) 230 | in 231 | let handle = Cstruct.to_string (Cstruct.sub data 8 handle_length) in 232 | let offset = 233 | Int64.to_int (uint64_of_cs (Cstruct.sub data (8 + handle_length) 8)) 234 | in 235 | let length = 236 | Int32.to_int 237 | (uint32_of_cs (Cstruct.sub data (8 + handle_length + 8) 4)) 238 | in 239 | 240 | FS.path_of_handle root handle >>= fun path -> 241 | Log.debug (fun f -> 242 | f "[SSH_FXP_READ %ld] for '%s' @%d (%d)\n%!" id path offset length); 243 | FS.read root path ~offset:(Optint.Int63.of_int offset) ~length >>= function 244 | | Error _ -> 245 | let payload = 246 | uint32_to_cs (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_EOF) 247 | in 248 | sshout 249 | (to_client SSH_FXP_STATUS 250 | (Cstruct.concat [ uint32_to_cs id; payload ])) 251 | >>= fun () -> Lwt.return working_table 252 | | Ok data -> 253 | let payload = Cstruct.of_string data in 254 | sshout 255 | (to_client SSH_FXP_DATA 256 | (Cstruct.concat 257 | [ 258 | uint32_to_cs id; 259 | uint32_to_cs (Int32.of_int (Cstruct.length payload)); 260 | payload; 261 | ])) 262 | >>= fun () -> Lwt.return working_table) 263 | (* 6.3 Opening, Creating, and Closing Files *) 264 | | SSH_FXP_CLOSE -> ( 265 | let handle_length = 266 | Int32.to_int (uint32_of_cs (Cstruct.sub data 4 4)) 267 | in 268 | let handle = Cstruct.to_string (Cstruct.sub data 8 handle_length) in 269 | Log.debug (fun f -> f "[SSH_FXP_CLOSE %ld] for %s\n%!" id handle); 270 | 271 | match Hashtbl.find_opt working_table handle with 272 | | None -> 273 | (* if the handle is not already opened -> error *) 274 | let payload = 275 | uint32_to_cs 276 | (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_INVALID_HANDLE) 277 | in 278 | sshout 279 | (to_client SSH_FXP_STATUS 280 | (Cstruct.concat [ uint32_to_cs id; payload ])) 281 | >>= fun () -> Lwt.return working_table 282 | | _ -> 283 | (* if the handle is already opened -> remove the handle entry in the hash table *) 284 | let payload = 285 | uint32_to_cs (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_OK) 286 | in 287 | sshout 288 | (to_client SSH_FXP_STATUS 289 | (Cstruct.concat [ uint32_to_cs id; payload ])) 290 | >>= fun () -> 291 | Hashtbl.remove working_table handle; 292 | Lwt.return working_table) 293 | (* 6.6 Creating and Deleting Directories *) 294 | | SSH_FXP_RMDIR 295 | (* TODO: check for the result & reply error when dir is not empty... *) 296 | | SSH_FXP_REMOVE -> 297 | (* TODO: check for the result *) 298 | let path_length = Int32.to_int (uint32_of_cs (Cstruct.sub data 4 4)) in 299 | let path = Cstruct.to_string (Cstruct.sub data 8 path_length) in 300 | Log.debug (fun f -> f "[SSH_FXP_REMOVE %ld] for %s\n%!" id path); 301 | 302 | FS.remove root path >>= fun _ -> 303 | (* FIXME: we always reply with status ok... *) 304 | let payload = 305 | uint32_to_cs (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_OK) 306 | in 307 | sshout 308 | (to_client SSH_FXP_STATUS 309 | (Cstruct.concat [ uint32_to_cs id; payload ])) 310 | >>= fun () -> Lwt.return working_table 311 | (* 6.5 Removing and Renaming Files *) 312 | | SSH_FXP_RENAME -> 313 | let path_length = Int32.to_int (uint32_of_cs (Cstruct.sub data 4 4)) in 314 | let path = Cstruct.to_string (Cstruct.sub data 8 path_length) in 315 | let newpath_length = 316 | Int32.to_int (uint32_of_cs (Cstruct.sub data (8 + path_length) 4)) 317 | in 318 | let newpath = 319 | Cstruct.to_string 320 | (Cstruct.sub data (8 + path_length + 4) newpath_length) 321 | in 322 | Log.debug (fun f -> 323 | f "[SSH_FXP_RENAME %ld] for %s->%s\n%!" id path newpath); 324 | 325 | (* FIXME: we always reply with status ok... Deal with possible returned errors *) 326 | FS.rename root path newpath >>= fun _ -> 327 | let payload = 328 | uint32_to_cs (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_OK) 329 | in 330 | sshout 331 | (to_client SSH_FXP_STATUS 332 | (Cstruct.concat [ uint32_to_cs id; payload ])) 333 | >>= fun () -> Lwt.return working_table 334 | (* 6.6 Creating and Deleting Directories *) 335 | | SSH_FXP_MKDIR -> 336 | (* TODO: check for the result *) 337 | let path_length = Int32.to_int (uint32_of_cs (Cstruct.sub data 4 4)) in 338 | let path = Cstruct.to_string (Cstruct.sub data 8 path_length) in 339 | Log.debug (fun f -> f "[SSH_FXP_MKDIR %ld] for %s\n%!" id path); 340 | 341 | FS.mkdir root path >>= fun _ -> 342 | (* FIXME: we always reply with status ok... *) 343 | let payload = 344 | uint32_to_cs (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_OK) 345 | in 346 | sshout 347 | (to_client SSH_FXP_STATUS 348 | (Cstruct.concat [ uint32_to_cs id; payload ])) 349 | >>= fun () -> Lwt.return working_table 350 | (* 6.9 Setting File Attributes *) 351 | | SSH_FXP_SETSTAT -> 352 | (* TODO: ex: touch, for now we do not much with this kind of informations *) 353 | let path_length = Int32.to_int (uint32_of_cs (Cstruct.sub data 4 4)) in 354 | let path = Cstruct.to_string (Cstruct.sub data 8 path_length) in 355 | (* let attrs = ??? *) 356 | Log.debug (fun f -> f "[SSH_FXP_SETSTAT %ld] for %s\n%!" id path); 357 | 358 | (* FIXME: we always reply with status ok... *) 359 | let payload = 360 | uint32_to_cs (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_OK) 361 | in 362 | sshout 363 | (to_client SSH_FXP_STATUS 364 | (Cstruct.concat [ uint32_to_cs id; payload ])) 365 | >>= fun () -> Lwt.return working_table 366 | (* 6.9 Setting File Attributes *) 367 | | SSH_FXP_FSETSTAT -> ( 368 | (* TODO: ex: touch, for now we do not much with this kind of informations *) 369 | let handle_length = 370 | Int32.to_int (uint32_of_cs (Cstruct.sub data 4 4)) 371 | in 372 | let handle = Cstruct.to_string (Cstruct.sub data 8 handle_length) in 373 | (* let attrs = ??? *) 374 | Log.debug (fun f -> f "[SSH_FXP_FSETSTAT %ld] for %s\n%!" id handle); 375 | 376 | match Hashtbl.find_opt working_table handle with 377 | | None -> 378 | (* if the handle is not already opened -> error *) 379 | let payload = 380 | uint32_to_cs 381 | (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_INVALID_HANDLE) 382 | in 383 | sshout 384 | (to_client SSH_FXP_STATUS 385 | (Cstruct.concat [ uint32_to_cs id; payload ])) 386 | >>= fun () -> Lwt.return working_table 387 | | _ -> 388 | (* if the handle is already opened -> remove the handle entry in the hash table *) 389 | let _ = FS.path_of_handle root handle in 390 | (* FIXME: we always reply with status ok... *) 391 | let payload = 392 | uint32_to_cs (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_OK) 393 | in 394 | sshout 395 | (to_client SSH_FXP_STATUS 396 | (Cstruct.concat [ uint32_to_cs id; payload ])) 397 | >>= fun () -> 398 | Hashtbl.remove working_table handle; 399 | Lwt.return working_table) 400 | (* 6.4 Reading and Writing *) 401 | | SSH_FXP_WRITE -> 402 | (* TODO: what to do with the end of the file if we were asked to write in the middle of the file *) 403 | let handle_length = 404 | Int32.to_int (uint32_of_cs (Cstruct.sub data 4 4)) 405 | in 406 | let handle = Cstruct.to_string (Cstruct.sub data 8 handle_length) in 407 | let offset = uint64_of_cs (Cstruct.sub data (8 + handle_length) 8) in 408 | let newdata_length = 409 | Int32.to_int 410 | (uint32_of_cs (Cstruct.sub data (8 + handle_length + 8) 4)) 411 | in 412 | let newdata = 413 | Cstruct.sub data (8 + handle_length + 8 + 4) newdata_length 414 | in 415 | 416 | FS.path_of_handle root handle >>= fun path -> 417 | Log.debug (fun f -> 418 | f "[SSH_FXP_WRITE %ld] '%s' @%Ld (%d)\n%!" id path offset 419 | newdata_length); 420 | (* FIXME: we always reply with status ok... Deal with possible returned errors *) 421 | let offset = Int64.to_int offset in 422 | FS.write root path ~offset:(Optint.Int63.of_int offset) newdata_length newdata >>= fun _ -> 423 | let payload = 424 | uint32_to_cs (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_OK) 425 | in 426 | sshout 427 | (to_client SSH_FXP_STATUS 428 | (Cstruct.concat [ uint32_to_cs id; payload ])) 429 | >>= fun () -> Lwt.return working_table 430 | (* Not implemented yet :) *) 431 | | _ -> 432 | Log.info (fun f -> f "[UNKNOWN id %ld (not implemented?)]\n%!" id); 433 | Cstruct.hexdump message; 434 | (let payload = 435 | Cstruct.concat 436 | [ 437 | uint32_to_cs id; 438 | uint32_to_cs 439 | (Sshfs_tag.sshfs_errcode_to_uint32 SSH_FX_OP_UNSUPPORTED); 440 | ] 441 | in 442 | sshout (to_client SSH_FXP_STATUS payload)) 443 | >>= fun () -> Lwt.return working_table 444 | end 445 | -------------------------------------------------------------------------------- /src/sshfs_tag.ml: -------------------------------------------------------------------------------- 1 | (* version 3 used by openssh : https://filezilla-project.org/specs/draft-ietf-secsh-filexfer-02.txt *) 2 | 3 | (* 4 | 5 | 4bytes errcodes of message 6 | 7 | #define SSH_FX_FAILURE 4 8 | #define SSH_FX_BAD_MESSAGE 5 9 | #define SSH_FX_NO_CONNECTION 6 10 | #define SSH_FX_CONNECTION_LOST 7 11 | #define SSH_FX_OP_UNSUPPORTED 8 12 | 13 | *) 14 | type sshfs_errcode = 15 | | SSH_FX_OK 16 | | SSH_FX_EOF 17 | | SSH_FX_NO_SUCH_FILE 18 | | SSH_FX_PERMISSION_DENIED 19 | | SSH_FX_INVALID_HANDLE 20 | | SSH_FX_NO_SUCH_PATH 21 | | SSH_FX_FILE_IS_A_DIRECTORY 22 | | SSH_FX_OP_UNSUPPORTED 23 | 24 | let sshfs_errcode_to_uint32 = function 25 | | SSH_FX_OK -> 0l 26 | | SSH_FX_EOF -> 1l 27 | | SSH_FX_NO_SUCH_FILE -> 2l 28 | | SSH_FX_PERMISSION_DENIED -> 3l 29 | | SSH_FX_INVALID_HANDLE -> 9l 30 | | SSH_FX_NO_SUCH_PATH -> 10l 31 | | SSH_FX_FILE_IS_A_DIRECTORY -> 24l 32 | | SSH_FX_OP_UNSUPPORTED -> 31l 33 | 34 | (*1 byte type of messages 35 | | SSH_FXP_REALPATH 16 36 | | SSH_FXP_STAT 17 37 | | SSH_FXP_READLINK 19 38 | | SSH_FXP_LINK 21 39 | | SSH_FXP_BLOCK 22 40 | | SSH_FXP_UNBLOCK 23 41 | 42 | | SSH_FXP_EXTENDED 200 43 | | SSH_FXP_EXTENDED_REPLY 201 44 | *) 45 | 46 | type sshfs_packtype = 47 | | SSH_FXP_INIT 48 | | SSH_FXP_VERSION 49 | | SSH_FXP_OPEN 50 | | SSH_FXP_CLOSE 51 | | SSH_FXP_READ 52 | | SSH_FXP_WRITE 53 | | SSH_FXP_LSTAT 54 | | SSH_FXP_FSTAT 55 | | SSH_FXP_SETSTAT 56 | | SSH_FXP_FSETSTAT 57 | | SSH_FXP_OPENDIR 58 | | SSH_FXP_READDIR 59 | | SSH_FXP_REMOVE 60 | | SSH_FXP_MKDIR 61 | | SSH_FXP_RMDIR 62 | | SSH_FXP_STAT 63 | | SSH_FXP_RENAME 64 | | SSH_FXP_STATUS 65 | | SSH_FXP_HANDLE 66 | | SSH_FXP_DATA 67 | | SSH_FXP_NAME 68 | | SSH_FXP_ATTRS 69 | | UNDEF_SSHFS_PACKTYPE 70 | 71 | let sshfs_packtype_of_uint8 = function 72 | | 1 -> SSH_FXP_INIT 73 | | 2 -> SSH_FXP_VERSION 74 | | 3 -> SSH_FXP_OPEN 75 | | 4 -> SSH_FXP_CLOSE 76 | | 5 -> SSH_FXP_READ 77 | | 6 -> SSH_FXP_WRITE 78 | | 7 -> SSH_FXP_LSTAT 79 | | 8 -> SSH_FXP_FSTAT 80 | | 9 -> SSH_FXP_SETSTAT 81 | | 10 -> SSH_FXP_FSETSTAT 82 | | 11 -> SSH_FXP_OPENDIR 83 | | 12 -> SSH_FXP_READDIR 84 | | 13 -> SSH_FXP_REMOVE 85 | | 14 -> SSH_FXP_MKDIR 86 | | 15 -> SSH_FXP_RMDIR 87 | | 17 -> SSH_FXP_STAT 88 | | 18 -> SSH_FXP_RENAME 89 | | 101 -> SSH_FXP_STATUS 90 | | 102 -> SSH_FXP_HANDLE 91 | | 103 -> SSH_FXP_DATA 92 | | 104 -> SSH_FXP_NAME 93 | | 105 -> SSH_FXP_ATTRS 94 | | _ -> UNDEF_SSHFS_PACKTYPE 95 | 96 | let sshfs_packtype_to_uint8 = function 97 | | SSH_FXP_INIT -> 1 98 | | SSH_FXP_VERSION -> 2 99 | | SSH_FXP_OPEN -> 3 100 | | SSH_FXP_CLOSE -> 4 101 | | SSH_FXP_READ -> 5 102 | | SSH_FXP_WRITE -> 6 103 | | SSH_FXP_LSTAT -> 7 104 | | SSH_FXP_FSTAT -> 8 105 | | SSH_FXP_SETSTAT -> 9 106 | | SSH_FXP_FSETSTAT -> 10 107 | | SSH_FXP_OPENDIR -> 11 108 | | SSH_FXP_READDIR -> 12 109 | | SSH_FXP_REMOVE -> 13 110 | | SSH_FXP_MKDIR -> 14 111 | | SSH_FXP_RMDIR -> 15 112 | | SSH_FXP_STAT -> 17 113 | | SSH_FXP_RENAME -> 18 114 | | SSH_FXP_STATUS -> 101 115 | | SSH_FXP_HANDLE -> 102 116 | | SSH_FXP_DATA -> 103 117 | | SSH_FXP_NAME -> 104 118 | | SSH_FXP_ATTRS -> 105 119 | | _ -> 0 120 | -------------------------------------------------------------------------------- /src/unikernel.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2021 Pierre Alain 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 | open Cmdliner 19 | 20 | let user = 21 | let doc = Arg.info ~doc:"The default username." [ "user" ] in 22 | Mirage_runtime.register_arg Arg.(value & opt string "mirage" doc) 23 | 24 | let key = 25 | let doc = 26 | Arg.info ~doc:"The pubkey for the default username." [ "key" ] 27 | in 28 | Mirage_runtime.register_arg Arg.(value & opt string "xxx" doc) 29 | (* the default key means that it is impossible to connect with this user *) 30 | 31 | let port = 32 | let doc = 33 | Arg.info ~doc:"The port number to listen for connections." [ "port" ] 34 | in 35 | Mirage_runtime.register_arg Arg.(value & opt int 18022 doc) 36 | 37 | let program_block_size = 38 | Arg.(value & opt int 16 & info [ "program-block-size" ]) 39 | 40 | module Main 41 | (S : Tcpip.Stack.V4V6) 42 | (KV : Mirage_kv.RW) = 43 | struct 44 | let log_src = Logs.Src.create "sshfs_server" ~doc:"Server for sshfs" 45 | 46 | module Log = (val Logs.src_log log_src : Logs.LOG) 47 | module Awa_auth = Awa_mirage.Auth 48 | module Awa_mirage = Awa_mirage.Make (S.TCP) 49 | module Sshfs = Sshfs.Make (KV) 50 | 51 | (* this funtion adds the user/key in the authorized user/key db. 52 | The server will consider only the first occurence, not adding any duplicate *) 53 | let add_key_of_string db user key = 54 | match Awa_auth.lookup_user user db with 55 | | Some _ -> 56 | Log.debug (fun f -> 57 | f "Trying to add user `%s` but is already present..." user); 58 | Lwt.return db 59 | | None -> 60 | Log.debug (fun f -> 61 | f "Trying to add user `%s` with pubkey (`%s`)..." user key); 62 | let sshkey = Awa.Wire.pubkey_of_openssh (Cstruct.of_string key) in 63 | if Result.is_ok sshkey then ( 64 | Log.debug (fun f -> f "Adding user `%s` with pubkey (`%s`)" user key); 65 | let db = 66 | List.cons (Awa_auth.make_user user [ Result.get_ok sshkey ]) db 67 | in 68 | Lwt.return db) 69 | else Lwt.return db 70 | 71 | (* this populates the db of authorized users/keys *) 72 | let user_db disk = 73 | let db = [] in 74 | 75 | (* first we add the user/key taken from command line, this way the command line option 76 | will have the higher priority *) 77 | let default_user = user () in 78 | let default_key = key () in 79 | add_key_of_string db default_user default_key >>= fun db -> 80 | Log.debug (fun f -> f "default user %s added with default key %s" default_user default_key); 81 | (* then we scan the root directory for .pub files *) 82 | Sshfs.get_list_key disk >>= fun flist -> 83 | let rec add_pubkey_files db l = 84 | match l with 85 | | [] -> Lwt.return db 86 | | (key, typ) :: t -> ( 87 | match typ with 88 | | `Value -> 89 | let file = Mirage_kv.Key.basename key in 90 | (* we need real files ending with .pub *) 91 | if String.ends_with ~suffix:".pub" file then 92 | (* we can sub 4 to the length as we know that the filename ends with ".pub" *) 93 | let len = String.length file - 4 in 94 | let user = String.sub file 0 len in 95 | Sshfs.get_disk_key disk file >>= fun key -> 96 | add_key_of_string db user key >>= fun db -> 97 | add_pubkey_files db t 98 | else add_pubkey_files db t 99 | | _ -> add_pubkey_files db t) 100 | in 101 | add_pubkey_files db flist >>= fun db -> 102 | (* then we scan the authorized_keys file. Warning the name is set in the stone here *) 103 | Sshfs.get_disk_key disk "authorized_keys" >>= fun keys -> 104 | let rec add_authorized_keys db l = 105 | match l with 106 | | [] -> Lwt.return db 107 | | k :: t -> 108 | (* format should be "type key information" (with type like rsa, ed, etc), 109 | key the hex string, and information any comment to the pubkey, here used as 110 | a user *) 111 | let toklist = String.split_on_char ' ' k in 112 | if List.length toklist >= 3 then 113 | let user = List.nth toklist 2 in 114 | add_key_of_string db user k >>= fun db -> add_authorized_keys db t 115 | else add_authorized_keys db t 116 | in 117 | let keys = String.split_on_char '\n' keys in 118 | add_authorized_keys db keys 119 | 120 | let rec sshfs_communication sshin sshout ssherror prev_data working_table 121 | disk () = 122 | (* here we can have multiple messages in the queue *) 123 | let rec consume_messages input sshout ssherror working_table disk () = 124 | (* if the message is empty *) 125 | if Cstruct.length input == 0 then Lwt.return (Cstruct.empty, working_table) 126 | else 127 | let len = 128 | Int32.to_int (Cstruct.BE.get_uint32 (Cstruct.sub input 0 4) 0) 129 | in 130 | (* if the message is too long for one sshin message *) 131 | if Cstruct.length input < len + 4 then Lwt.return (input, working_table) 132 | else 133 | (* in the other cases we can deal with it *) 134 | let data = Cstruct.sub input 4 len in 135 | Sshfs.reply data sshout ssherror working_table 136 | (* internal structure, list open handles and associated datas *) 137 | disk () 138 | >>= fun new_table -> 139 | consume_messages 140 | (Cstruct.sub input (len + 4) (Cstruct.length input - len - 4)) 141 | sshout ssherror new_table disk () 142 | in 143 | sshin () >>= function 144 | | `Eof -> Lwt.return_unit 145 | | `Data input -> 146 | consume_messages 147 | (Cstruct.append prev_data input) 148 | sshout ssherror working_table disk () 149 | >>= fun (remaining_data, new_table) -> 150 | sshfs_communication sshin sshout ssherror remaining_data new_table disk 151 | () 152 | 153 | let exec addr disk req = 154 | match req with 155 | | Awa_mirage.Channel {cmd; ic; oc; ec; } -> 156 | Log.info (fun f -> f "[%s] executing `%s`\n%!" addr cmd); 157 | (match cmd with 158 | | "sftp" -> 159 | sshfs_communication ic oc ec Cstruct.empty 160 | (Hashtbl.create 10) disk () 161 | | _ -> 162 | Log.info (fun f -> f "*** Subsystem %s is not implemented\n%!" cmd); 163 | Lwt.return_unit) 164 | >>= fun () -> 165 | Log.info (fun f -> f "[%s] execution of `%s` finished\n%!" addr cmd); 166 | Lwt.return_unit 167 | | _ -> 168 | Lwt.return_unit 169 | 170 | let serve priv_key flow addr disk = 171 | Log.info (fun f -> f "[%s] initiating connexion\n%!" addr); 172 | user_db disk >>= fun users -> 173 | Log.info (fun f -> f "We have %d possible users" (List.length users)); 174 | let server, msgs = Awa.Server.make priv_key in 175 | Awa_mirage.spawn_server server users msgs flow (exec addr disk) >>= fun _t -> 176 | Log.info (fun f -> f "[%s] finished\n%!" addr); 177 | Lwt.return_unit 178 | 179 | let start stack disk = 180 | let g = 181 | Mirage_crypto_rng.create ~seed:"123456" (module Mirage_crypto_rng.Fortuna) 182 | in 183 | let ec_priv, _ = Mirage_crypto_ec.Ed25519.generate ~g () in 184 | let priv_key = Awa.Hostkey.Ed25519_priv ec_priv in 185 | let port = port () in 186 | S.TCP.listen (S.tcp stack) ~port (fun flow -> 187 | let dst, _ (*dst_port*) = S.TCP.dst flow in 188 | let addr = Ipaddr.to_string dst in 189 | serve priv_key flow addr disk >>= fun () -> S.TCP.close flow); 190 | 191 | Log.info (fun f -> f "SSHFS server waiting connections on port %d\n%!" port); 192 | S.listen stack 193 | end 194 | --------------------------------------------------------------------------------