├── .merlin ├── .gitignore ├── attic ├── putget.sh ├── scheduler_test.ml ├── copy_test.ml └── upload_test_server.ml ├── src ├── lfs_config.ml ├── lfs_aux.ml └── lfs_server.ml ├── scripts ├── lfs_server.sh ├── lfs_server-osx.sh ├── build.sh ├── test_build.sh ├── check_pam.sh ├── make_release_pkg_osx.sh ├── make_release_pkg_linux.sh └── run_tests.sh ├── tests ├── test_method_not_allowed.ml ├── test_post_empty_json.ml ├── test_head_metadata.ml ├── test_head_object.ml ├── test_no_host.ml ├── test_get_uppercase_oid_rejected.ml ├── test_post_uppercase_oid_rejected.ml ├── test_post_existing_object_wrong_size.ml ├── test_post_existing_object.ml ├── test_get_metadata.ml ├── test_post_new_object.ml ├── test.ml ├── .lfs │ └── objects │ │ └── eb │ │ └── da │ │ └── ebdaa749534bbbf8e1fc02c4f634648d749d5401e09b11fefbe283fe913b7d39 ├── test_get_object.ml ├── test_put_3_existing_file.ml ├── test_put_2_new_file_correct_content.ml └── test_put_1_new_file_wrong_content.ml ├── .travis.yml ├── LICENSE ├── opam ├── Dockerfile └── README.md /.merlin: -------------------------------------------------------------------------------- 1 | PKG core async cohttp.async yojson cryptokit simple_pam 2 | S src 3 | B _build/src 4 | 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | _build 3 | *.native 4 | *.byte 5 | *.docdir 6 | 7 | setup.data 8 | setup.log 9 | 10 | -------------------------------------------------------------------------------- /attic/putget.sh: -------------------------------------------------------------------------------- 1 | 2 | time curl -X PUT http://127.0.0.1:8080/objects/$1 --upload-file $2 3 | time curl -O http://127.0.0.1:8080/data/objects/$1 4 | 5 | -------------------------------------------------------------------------------- /src/lfs_config.ml: -------------------------------------------------------------------------------- 1 | 2 | 3 | let version = "0.3.1" 4 | 5 | let () = 6 | if Array.length Sys.argv >= 2 && Sys.argv.(1) = "version" 7 | then Printf.printf "%s" version 8 | else () 9 | 10 | -------------------------------------------------------------------------------- /attic/scheduler_test.ml: -------------------------------------------------------------------------------- 1 | 2 | open Core.Std 3 | open Async.Std 4 | 5 | let () = 6 | every (Time.Span.create ~sec:1 ()) (fun () -> 7 | eprintf "(Alloc %f)\n" (Gc.allocated_bytes ()) 8 | ); 9 | never_returns (Scheduler.go ()) 10 | 11 | -------------------------------------------------------------------------------- /scripts/lfs_server.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | PREFIX=$(dirname $(dirname $0)) 4 | 5 | export LD_LIBRARY_PATH=${PREFIX}/lib 6 | 7 | if [ -f ${PREFIX}/bin/lfs_server ]; then 8 | ${PREFIX}/bin/lfs_server $@ 9 | else 10 | echo "No Git LFS server installed" 11 | fi 12 | 13 | -------------------------------------------------------------------------------- /scripts/lfs_server-osx.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | PREFIX=$(dirname $(dirname $0)) 4 | 5 | export DYLD_LIBRARY_PATH=${PREFIX}/lib 6 | 7 | if [ -f ${PREFIX}/bin/lfs_server ]; then 8 | ${PREFIX}/bin/lfs_server $@ 9 | else 10 | echo "No Git LFS server installed" 11 | fi 12 | 13 | -------------------------------------------------------------------------------- /scripts/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ocamlbuild \ 4 | -use-ocamlfind \ 5 | -pkg core,async,async_ssl,cohttp,cohttp.async,yojson,cryptokit,simple_pam \ 6 | -tag thread \ 7 | -tag bin_annot \ 8 | -tag short_paths \ 9 | -cflags "-w A-4-33-40-41-42-43-34-44" \ 10 | -cflags -strict-sequence \ 11 | -cflags -principal \ 12 | $@ 13 | 14 | -------------------------------------------------------------------------------- /scripts/test_build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ocamlbuild \ 4 | -use-ocamlfind \ 5 | -pkg core,async,async_ssl,cohttp,cohttp.async,yojson,cryptokit,simple_pam \ 6 | -pkg bisect \ 7 | -tag debug \ 8 | -tag thread \ 9 | -tag bin_annot \ 10 | -tag short_paths \ 11 | -cflags "-w A-4-33-40-41-42-43-34-44" \ 12 | -cflags -strict-sequence \ 13 | -cflags -principal \ 14 | $@ 15 | 16 | -------------------------------------------------------------------------------- /tests/test_method_not_allowed.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | LINK /objects/ebdaa749534bbbf8e1fc02c4f634648d749d5401e09b11fefbe283fe913b7d39 HTTP/1.1 7 | Host: localhost 8 | 9 | |} 10 | 11 | let response = {| 12 | HTTP/1.1 405 Method Not Allowed 13 | connection: keep-alive 14 | content-length: 0 15 | 16 | |} 17 | 18 | let () = 19 | Test.netcat request response 20 | 21 | -------------------------------------------------------------------------------- /scripts/check_pam.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | USER=`whoami` 4 | 5 | read -s -p "Password: " PWD 6 | echo "" 7 | if echo "#require \"simple_pam\";; Simple_pam.authenticate \"login\" \"$USER\" \"$PWD\";;" | utop -stdin; then 8 | echo "PAM is available" 9 | else 10 | echo "Error: you entered wrong password, or PAM is not available. Install pam-devel and reinstall simple_pam if the password is correct" 11 | exit 2 12 | fi 13 | 14 | -------------------------------------------------------------------------------- /tests/test_post_empty_json.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | POST /objects HTTP/1.1 7 | Host: localhost 8 | 9 | |} 10 | 11 | let response = {| 12 | HTTP/1.1 400 Bad Request 13 | connection: keep-alive 14 | content-length: 29 15 | content-type: application/vnd.git-lfs+json 16 | 17 | { "message": "Invalid body" } 18 | |} 19 | 20 | let () = 21 | Test.netcat request response 22 | 23 | -------------------------------------------------------------------------------- /tests/test_head_metadata.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | HEAD /objects/ebdaa749534bbbf8e1fc02c4f634648d749d5401e09b11fefbe283fe913b7d39 HTTP/1.1 7 | Host: localhost 8 | 9 | |} 10 | 11 | let response = {| 12 | HTTP/1.1 200 OK 13 | connection: keep-alive 14 | content-length: 0 15 | content-type: application/vnd.git-lfs+json 16 | 17 | |} 18 | 19 | let () = 20 | Test.netcat request response 21 | 22 | -------------------------------------------------------------------------------- /tests/test_head_object.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | HEAD /data/objects/ebdaa749534bbbf8e1fc02c4f634648d749d5401e09b11fefbe283fe913b7d39 HTTP/1.1 7 | Host: localhost 8 | 9 | |} 10 | 11 | let response = {| 12 | HTTP/1.1 200 OK 13 | connection: keep-alive 14 | content-length: 0 15 | content-type: application/octet-stream 16 | 17 | |} 18 | 19 | let () = 20 | Test.netcat request response 21 | 22 | -------------------------------------------------------------------------------- /tests/test_no_host.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | GET /objects/ebdaa749534bbbf8e1fc02c4f634648d749d5401e09b11fefbe283fe913b7d39 HTTP/1.1 7 | 8 | |} 9 | 10 | let response = {| 11 | HTTP/1.1 400 Bad Request 12 | connection: keep-alive 13 | content-length: 27 14 | content-type: application/vnd.git-lfs+json 15 | 16 | { "message": "Wrong host" } 17 | |} 18 | 19 | let () = 20 | Test.netcat request response 21 | 22 | -------------------------------------------------------------------------------- /tests/test_get_uppercase_oid_rejected.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | GET /objects/EBDAA749534BBBF8E1FC02C4F634648D749D5401E09B11FEFBE283FE913B7D39 HTTP/1.1 7 | Host: localhost 8 | 9 | |} 10 | 11 | let response = {| 12 | HTTP/1.1 404 Not Found 13 | connection: keep-alive 14 | content-length: 27 15 | content-type: application/vnd.git-lfs+json 16 | 17 | { "message": "Wrong path" } 18 | |} 19 | 20 | let () = 21 | Test.netcat request response 22 | 23 | -------------------------------------------------------------------------------- /attic/copy_test.ml: -------------------------------------------------------------------------------- 1 | 2 | open Core.Std 3 | open Async.Std 4 | 5 | let run () = 6 | let input = Filename.concat "." Sys.argv.(1) in 7 | let output = Filename.concat "." Sys.argv.(2) in 8 | Reader.with_file input ~f:(fun r -> 9 | Writer.with_file output ~f:(fun w -> 10 | Pipe.transfer (Reader.pipe r) (Writer.pipe w) ~f:(fun s -> 11 | eprintf "Transfered: %d\n" (String.length s); 12 | s))) 13 | >>| fun () -> (Shutdown.shutdown 0) 14 | 15 | let () = 16 | every (Time.Span.create ~sec:1 ()) (fun () -> 17 | eprintf "Mem %f\n" (Gc.allocated_bytes ())); 18 | ignore (run ()); 19 | never_returns (Scheduler.go ()) 20 | 21 | -------------------------------------------------------------------------------- /tests/test_post_uppercase_oid_rejected.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | POST /objects HTTP/1.1 7 | Host: localhost 8 | Accept: application/vnd.git-lfs+json 9 | Content-Type: application/vnd.git-lfs+json 10 | Content-Length: 95 11 | 12 | { 13 | "oid" : "73BCC5E2FDB23B560E112BE22C901379BF9CE3A1F9CA32ACD92BC6BA5667A0AE", 14 | "size" : 7170 15 | } 16 | 17 | |} 18 | 19 | let response = {| 20 | HTTP/1.1 400 Bad Request 21 | connection: keep-alive 22 | content-length: 29 23 | content-type: application/vnd.git-lfs+json 24 | 25 | { "message": "Invalid body" } 26 | |} 27 | 28 | let () = 29 | Test.netcat request response 30 | 31 | -------------------------------------------------------------------------------- /tests/test_post_existing_object_wrong_size.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | POST /objects HTTP/1.1 7 | Host: localhost 8 | Accept: application/vnd.git-lfs+json 9 | Content-Type: application/vnd.git-lfs+json 10 | Content-Length: 96 11 | 12 | { 13 | "oid" : "ebdaa749534bbbf8e1fc02c4f634648d749d5401e09b11fefbe283fe913b7d39", 14 | "size" : 12345 15 | } 16 | 17 | |} 18 | 19 | let response = {| 20 | HTTP/1.1 400 Bad Request 21 | connection: keep-alive 22 | content-length: 34 23 | content-type: application/vnd.git-lfs+json 24 | 25 | { "message": "Wrong object size" } 26 | |} 27 | 28 | let () = 29 | Test.netcat request response 30 | 31 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | before_install: 4 | - echo "yes" | sudo add-apt-repository ppa:avsm/ppa 5 | - sudo apt-get update -qq 6 | - sudo apt-get install -qq m4 pkg-config libssl-dev libgmp-dev 7 | - sudo apt-get install -qq ocaml ocaml-native-compilers camlp4-extra opam 8 | 9 | install: 10 | - export OPAMYES=1 11 | 12 | - opam init 13 | - opam switch 4.04.2 14 | - eval `opam config env` 15 | - opam update 16 | - opam install async async_ssl cohttp cohttp-async cryptokit yojson simple_pam 17 | - opam install bisect ocveralls ocamldiff 18 | 19 | script: 20 | - opam pin add . 21 | - opam unpin git-lfs-server 22 | - ./scripts/run_tests.sh 23 | 24 | after_success: 25 | - ocveralls --prefix _build _build/coverage*.out --send 26 | 27 | -------------------------------------------------------------------------------- /scripts/make_release_pkg_osx.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ocamlbuild -clean 4 | ./scripts/build.sh src/lfs_config.native 5 | ./scripts/build.sh src/lfs_server.native 6 | 7 | rm -rf lfs_server 8 | mkdir lfs_server 9 | mkdir lfs_server/bin 10 | mkdir lfs_server/lib 11 | cp scripts/lfs_server-osx.sh lfs_server/lfs_server.sh 12 | cp lfs_server.native lfs_server/bin/lfs_server 13 | strip lfs_server/bin/lfs_server 14 | cp `otool -L lfs_server/bin/lfs_server | grep libssl | cut -d ' ' -f1` lfs_server/lib/ 15 | cp `otool -L lfs_server/bin/lfs_server | grep libcrypto | cut -d ' ' -f1` lfs_server/lib/ 16 | cp `otool -L lfs_server/bin/lfs_server | grep libffi | cut -d ' ' -f1` lfs_server/lib/ 17 | 18 | VERSION=`./lfs_config.native version` 19 | tar cvf - lfs_server | gzip -9 - > lfs_server-${VERSION}-osx.x64.tar.gz 20 | 21 | -------------------------------------------------------------------------------- /tests/test_post_existing_object.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | POST /objects HTTP/1.1 7 | Host: localhost 8 | Accept: application/vnd.git-lfs+json 9 | Content-Type: application/vnd.git-lfs+json 10 | Content-Length: 95 11 | 12 | { 13 | "oid" : "ebdaa749534bbbf8e1fc02c4f634648d749d5401e09b11fefbe283fe913b7d39", 14 | "size" : 4090 15 | } 16 | 17 | |} 18 | 19 | let response = {| 20 | HTTP/1.1 200 OK 21 | connection: keep-alive 22 | content-length: 169 23 | content-type: application/vnd.git-lfs+json 24 | 25 | { 26 | "_links": { 27 | "download": { 28 | "href": 29 | "http://localhost:8080/data/objects/ebdaa749534bbbf8e1fc02c4f634648d749d5401e09b11fefbe283fe913b7d39" 30 | } 31 | } 32 | } 33 | |} 34 | 35 | let () = 36 | Test.netcat request response 37 | 38 | 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Stanislav Artemkin 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 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "git-lfs-server" 3 | version: "0.3.1" 4 | maintainer: "Stanislav Artemkin " 5 | authors: [ "Stanislav Artemkin" ] 6 | license: "ISC" 7 | homepage: "https://github.com/artemkin/git-lfs-server" 8 | bug-reports: "https://github.com/artemkin/git-lfs-server/issues" 9 | dev-repo: "https://github.com/artemkin/git-lfs-server.git" 10 | build: [ 11 | ["./scripts/build.sh" "src/lfs_server.native"] 12 | ] 13 | install: ["cp" "lfs_server.native" "%{bin}%/git-lfs-server"] 14 | remove: [ 15 | ["ocamlfind" "remove" "git-lfs-server"] 16 | ["rm" "-f" "%{bin}%/git-lfs-server"] 17 | ] 18 | depends: [ 19 | "ocamlfind" {build} 20 | "async" 21 | "async_ssl" 22 | "base-threads" 23 | "cohttp" {>= "0.17.1"} 24 | "cohttp-async" 25 | "core" 26 | "cryptokit" 27 | "ocamlfind" 28 | "sexplib" 29 | "yojson" 30 | "simple_pam" 31 | ] 32 | -------------------------------------------------------------------------------- /tests/test_get_metadata.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | GET /objects/ebdaa749534bbbf8e1fc02c4f634648d749d5401e09b11fefbe283fe913b7d39 HTTP/1.1 7 | Host: localhost 8 | 9 | |} 10 | 11 | let response = {| 12 | HTTP/1.1 200 OK 13 | connection: keep-alive 14 | content-length: 402 15 | content-type: application/vnd.git-lfs+json 16 | 17 | { 18 | "oid": "ebdaa749534bbbf8e1fc02c4f634648d749d5401e09b11fefbe283fe913b7d39", 19 | "size": 4090, 20 | "_links": { 21 | "self": { 22 | "href": 23 | "http://localhost:8080/objects/ebdaa749534bbbf8e1fc02c4f634648d749d5401e09b11fefbe283fe913b7d39" 24 | }, 25 | "download": { 26 | "href": 27 | "http://localhost:8080/data/objects/ebdaa749534bbbf8e1fc02c4f634648d749d5401e09b11fefbe283fe913b7d39" 28 | } 29 | } 30 | } 31 | |} 32 | 33 | let () = 34 | Test.netcat request response 35 | 36 | -------------------------------------------------------------------------------- /scripts/make_release_pkg_linux.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | set -o pipefail 5 | 6 | # check pam-devel is installed 7 | # echo "#include " | gcc -E - &> /dev/null; echo $? 8 | ./scripts/check_pam.sh 9 | 10 | ocamlbuild -clean 11 | ./scripts/build.sh src/lfs_config.native 12 | ./scripts/build.sh src/lfs_server.native 13 | 14 | rm -rf lfs_server 15 | mkdir lfs_server 16 | mkdir lfs_server/bin 17 | mkdir lfs_server/lib 18 | cp scripts/lfs_server.sh lfs_server/ 19 | cp lfs_server.native lfs_server/bin/lfs_server 20 | strip lfs_server/bin/lfs_server 21 | cp `ldd lfs_server/bin/lfs_server | grep libssl | cut -d ' ' -f3` lfs_server/lib/ 22 | cp `ldd lfs_server/bin/lfs_server | grep libcrypto | cut -d ' ' -f3` lfs_server/lib/ 23 | cp `ldd lfs_server/bin/lfs_server | grep libffi | cut -d ' ' -f3` lfs_server/lib/ 24 | 25 | VERSION=`./lfs_config.native version` 26 | tar cvf - lfs_server | gzip -9 - > lfs_server-${VERSION}-linux.x64.tar.gz 27 | 28 | -------------------------------------------------------------------------------- /tests/test_post_new_object.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | POST /objects HTTP/1.1 7 | Host: localhost 8 | Accept: application/vnd.git-lfs+json 9 | Content-Type: application/vnd.git-lfs+json 10 | Content-Length: 95 11 | 12 | { 13 | "oid" : "73bcc5e2fdb23b560e112be22c901379bf9ce3a1f9ca32acd92bc6ba5667a0ae", 14 | "size" : 7170 15 | } 16 | 17 | |} 18 | 19 | let response = {| 20 | HTTP/1.1 202 Accepted 21 | connection: keep-alive 22 | content-length: 304 23 | content-type: application/vnd.git-lfs+json 24 | 25 | { 26 | "_links": { 27 | "upload": { 28 | "href": 29 | "http://localhost:8080/objects/73bcc5e2fdb23b560e112be22c901379bf9ce3a1f9ca32acd92bc6ba5667a0ae" 30 | }, 31 | "verify": { 32 | "href": 33 | "http://localhost:8080/objects/73bcc5e2fdb23b560e112be22c901379bf9ce3a1f9ca32acd92bc6ba5667a0ae" 34 | } 35 | } 36 | } 37 | |} 38 | 39 | let () = 40 | Test.netcat request response 41 | 42 | -------------------------------------------------------------------------------- /scripts/run_tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | echo Build from scratch 6 | rm -rf .lfs 7 | ocamlbuild -clean 8 | ./scripts/test_build.sh src/lfs_server.native 9 | 10 | echo Copy test .lfs folder 11 | cp -R tests/.lfs . 12 | 13 | echo Run server 14 | export BISECT_FILE=_build/coverage 15 | ./lfs_server.native -verbose & 16 | LFS_SERVER_PID=$! 17 | sleep 2 18 | 19 | echo Run tests 20 | cd tests 21 | 22 | echo Test GET method 23 | ./test_get_metadata.ml 24 | ./test_get_object.ml 25 | ./test_get_uppercase_oid_rejected.ml 26 | 27 | echo Test HEAD method 28 | ./test_head_metadata.ml 29 | ./test_head_object.ml 30 | 31 | ./test_method_not_allowed.ml 32 | ./test_no_host.ml 33 | 34 | echo Test POST method 35 | ./test_post_empty_json.ml 36 | ./test_post_existing_object.ml 37 | ./test_post_existing_object_wrong_size.ml 38 | ./test_post_new_object.ml 39 | ./test_post_uppercase_oid_rejected.ml 40 | 41 | echo Test PUT method 42 | ./test_put_1_new_file_wrong_content.ml 43 | ./test_put_2_new_file_correct_content.ml 44 | ./test_put_3_existing_file.ml 45 | 46 | echo Stop server 47 | kill $LFS_SERVER_PID 48 | sleep 2 49 | 50 | echo Generate code coverage report 51 | cd ../_build 52 | bisect-report -html report coverage*.out 53 | cd .. 54 | 55 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | # Create image 2 | # docker build -t git-lfs-server . 3 | 4 | # Create container 5 | # docker run -it --name git-lfs-server -u test -v `pwd`:/home/test/git-lfs-server git-lfs-server 6 | 7 | FROM ubuntu:trusty 8 | 9 | MAINTAINER Stanislav Artemkin 10 | 11 | ARG DEBIAN_FRONTEND=noninteractive 12 | 13 | RUN apt-get update 14 | RUN apt-get install -qq software-properties-common 15 | 16 | RUN echo "yes" | add-apt-repository ppa:avsm/ppa 17 | RUN apt-get update 18 | 19 | RUN apt-get install -qq apt-utils 20 | RUN apt-get install -qq man 21 | RUN apt-get install -qq sudo 22 | RUN apt-get install -qq m4 pkg-config libssl-dev libgmp-dev 23 | RUN apt-get install -qq curl 24 | RUN apt-get install -qq make 25 | RUN apt-get install -qq git 26 | RUN apt-get install -qq g++ 27 | RUN apt-get install -qq unzip 28 | RUN apt-get install -qq ocaml ocaml-native-compilers camlp4-extra opam 29 | 30 | # pam-devel on CentOS 31 | RUN apt-get install -qq libpam0g-dev 32 | 33 | # Create user 34 | RUN adduser test --gecos "First Last,RoomNumber,WorkPhone,HomePhone" --disabled-password 35 | RUN echo "test:test" | chpasswd 36 | RUN echo "test ALL=(ALL:ALL) ALL" >> /etc/sudoers 37 | 38 | RUN su - test -c 'echo export OPAMYES=1 >> ~/.profile' 39 | RUN su - test -c 'opam init' 40 | RUN su - test -c 'opam switch 4.04.2' 41 | RUN su - test -c 'opam update' 42 | RUN su - test -c 'opam install async async_ssl cohttp cohttp-async cryptokit yojson simple_pam utop' 43 | RUN su - test -c 'opam install bisect ocveralls ocamldiff' 44 | 45 | -------------------------------------------------------------------------------- /attic/upload_test_server.ml: -------------------------------------------------------------------------------- 1 | 2 | open Core.Std 3 | open Async.Std 4 | open Cohttp 5 | open Cohttp_async 6 | 7 | let handle_put uri body = 8 | let path = Uri.path uri in 9 | try_with (fun () -> 10 | let filename = Filename.concat "." path in 11 | Writer.with_file filename ~f:(fun w -> 12 | Pipe.transfer_id (Body.to_pipe body) (Writer.pipe w))) 13 | >>= function 14 | | Ok _ -> Server.respond `Created 15 | | Error _ -> Server.respond `Internal_server_error 16 | 17 | let serve_client ~body _sock req = 18 | let uri = Request.uri req in 19 | match Request.meth req with 20 | | `PUT -> handle_put uri body 21 | | _ -> Server.respond `Method_not_allowed 22 | 23 | let start_server ~host ~port () = 24 | eprintf "Listening for HTTP on port %d\n" port; 25 | Unix.Inet_addr.of_string_or_getbyname host 26 | >>= fun host -> 27 | let listen_on = Tcp.Where_to_listen.create 28 | ~socket_type:Socket.Type.tcp 29 | ~address:(`Inet (host, port)) 30 | ~listening_on:(fun _ -> port) 31 | in 32 | Server.create 33 | ~on_handler_error:`Raise 34 | listen_on 35 | (serve_client) 36 | >>= fun _ -> Deferred.never () 37 | 38 | let () = 39 | every (Time.Span.create ~sec:3 ()) (fun () -> 40 | Gc.full_major (); 41 | let stat = Gc.stat () in 42 | let used = stat.live_words in 43 | eprintf "(Used %d) (Alloc %f)\n" used (Gc.allocated_bytes ()) 44 | ); 45 | ignore (start_server ~host:"localhost" ~port:8080 ()); 46 | never_returns (Scheduler.go ()) 47 | 48 | -------------------------------------------------------------------------------- /tests/test.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "topfind" 4 | #thread 5 | #require "diff" 6 | 7 | module Test : sig 8 | 9 | val netcat: string -> string -> unit 10 | 11 | end = struct 12 | 13 | let drop_first_lf s = 14 | if s.[0] <> '\n' then s else String.sub s 1 (String.length s - 1) 15 | 16 | let drop_last_lf s = 17 | let len = String.length s in 18 | let last = s.[len - 1] = '\n' in 19 | let before_last = len > 1 && s.[len - 2] = '\r' in 20 | if (not last) || before_last then s else String.sub s 0 (len - 1) 21 | 22 | let get_diff a b = Odiff.string_of_diffs (Odiff.strings_diffs a b) 23 | 24 | let netcat request response = 25 | request |> drop_first_lf |> fun request -> 26 | response |> drop_first_lf |> drop_last_lf |> fun response -> 27 | let fd_in, fd_out = Unix.open_process "nc 127.0.0.1 8080" in 28 | output_bytes fd_out request; 29 | flush fd_out; 30 | Thread.delay 0.1; (* TODO wait for process completion *) 31 | let len = 1000 * 1024 in 32 | let buf = Bytes.make len '\000' in 33 | let read_bytes = input fd_in buf 0 len in 34 | let error msg = 35 | Printf.eprintf "%s: %s\n%!" Sys.argv.(0) msg; 36 | exit 1 37 | in 38 | match Unix.close_process (fd_in, fd_out) with 39 | | Unix.WSTOPPED _ | Unix.WSIGNALED _ -> error "Process stopped/signaled" 40 | | Unix.WEXITED code when code <> 0 -> error "Wrong exit code" 41 | | Unix.WEXITED _ -> 42 | let response' = String.sub buf 0 read_bytes in 43 | if response <> response' then 44 | error ("Wrong response\n\n" ^ (get_diff response response')) 45 | 46 | end 47 | 48 | -------------------------------------------------------------------------------- /src/lfs_aux.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Stanislav Artemkin 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Core 19 | open Async 20 | module Core_unix = Core.Unix 21 | 22 | module SHA256 : sig 23 | 24 | type t 25 | 26 | val create : unit -> t 27 | val feed : t -> string -> unit 28 | val hexdigest : t -> string 29 | 30 | end = struct 31 | 32 | type t = { hash: Cryptokit.hash; mutable valid: bool } 33 | 34 | let create () = { hash = Cryptokit.Hash.sha256 (); valid = true } 35 | 36 | let feed t str = 37 | if not t.valid then failwith "Wrong SHA256 internal state" 38 | else 39 | t.hash#add_string str 40 | 41 | let hexdigest t = 42 | if not t.valid then failwith "Wrong SHA256 internal state" 43 | else 44 | t.valid <- false; 45 | let sum = t.hash#result in 46 | Cryptokit.transform_string (Cryptokit.Hexa.encode ()) sum 47 | end 48 | 49 | let is_sha256_hex_digest str = 50 | if String.length str <> 64 then false 51 | else String.for_all str ~f:(fun ch -> Char.(is_lowercase ch || is_digit ch)) 52 | 53 | let getumask () = 54 | let umask = Core_unix.umask 0 in 55 | ignore (Core_unix.umask umask); 56 | umask 57 | 58 | let with_file_atomic ?temp_file file ~f = 59 | Unix.mkstemp (Option.value temp_file ~default:file) 60 | >>= fun (temp_file, fd) -> 61 | let t = Writer.create fd in 62 | Writer.with_close t ~f:(fun () -> 63 | f t 64 | >>= fun result -> 65 | let perm = 0o666 land (lnot (getumask ())) in 66 | Unix.fchmod fd ~perm 67 | >>= fun () -> 68 | Writer.fsync t (* make sure file content is flushed to disk *) 69 | >>| fun () -> 70 | result) 71 | >>= function 72 | | Error _ as result -> 73 | don't_wait_for (Unix.unlink temp_file); 74 | return result 75 | | Ok _ as result -> 76 | Monitor.try_with (fun () -> Unix.rename ~src:temp_file ~dst:file) 77 | >>| function 78 | | Ok () -> result 79 | | Error _ (* exn *) -> 80 | don't_wait_for (Unix.unlink temp_file); 81 | failwith "with_file_atomic could not create file" 82 | (* FIXME (file, exn) <:sexp_of< string * exn >> *) 83 | 84 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # Git LFS server 3 | 4 | [![Project frozen](https://img.shields.io/badge/status-frozen-blue.png)]() 5 | [![Project unmaintained](https://img.shields.io/badge/project-unmaintained-red.svg)]() 6 | [![Build Status](https://travis-ci.org/artemkin/git-lfs-server.svg?branch=master)](https://travis-ci.org/artemkin/git-lfs-server) 7 | [![Coverage Status](https://coveralls.io/repos/artemkin/git-lfs-server/badge.png?branch=master)](https://coveralls.io/r/artemkin/git-lfs-server?branch=master) 8 | 9 | Simple HTTP(S) server for [Git Large File Storage](https://git-lfs.github.com) with [PAM](https://en.wikipedia.org/wiki/Pluggable_authentication_module) authentication. 10 | 11 | ``` 12 | $ ./lfs_server.sh -help 13 | Start Git LFS server 14 | 15 | lfs_server [ROOT] 16 | 17 | === flags === 18 | 19 | [-cert file] File of certificate for https 20 | [-key file] File of private key for https 21 | [-p port] TCP port to listen on 22 | [-pam service] PAM service name for user authentication 23 | [-s address] IP address to listen on 24 | [-verbose] Verbose logging 25 | [-build-info] print info about this build and exit 26 | [-version] print the version of this build and exit 27 | [-help] print this help text and exit 28 | (alias: -?) 29 | ``` 30 | By default, it starts on `http://localhost:8080` and treats current directory as `ROOT`. All object files are stored locally in `ROOT/.lfs/objects` directory. 31 | 32 | ## INSTALL 33 | 34 | From binary packages: 35 | * [Linux x64](https://github.com/artemkin/git-lfs-server/releases/download/v0.3.1/lfs_server-0.3.1-linux.x64.tar.gz) 36 | * [Mac OS X x64](https://github.com/artemkin/git-lfs-server/releases/download/v0.3.0/lfs_server-0.3.0-osx.x64.tar.gz) 37 | 38 | 39 | 40 | ## RUN 41 | 42 | **HTTP server without authentication** 43 | 44 | ``` 45 | ./lfs_server.sh -verbose -s IP_ADDRESS -p PORT 46 | ``` 47 | A server will ignore credentials passed by LFS client, and accept all connections. To enable authentication, you need to specify PAM service. 48 | 49 | **HTTP server with PAM authentication** 50 | ``` 51 | ./lfs_server.sh -verbose -pam login -s IP_ADDRESS -p PORT 52 | ``` 53 | It will use built-in `login` PAM service defined in `/etc/pam.d/login` file. 54 | 55 | Warning: LFS client uses HTTP basic authentication, so using **HTTPS** is a must! 56 | 57 | **HTTPS server with PAM authentication** 58 | ``` 59 | ./lfs_server.sh -verbose -pam login -s IP_ADDRESS -p PORT -cert domain.crt -key domain.key 60 | ``` 61 | 62 | ## Example 63 | 64 | Download and install the LFS server as described above. You will also need to install the [GIT LFS client](https://git-lfs.github.com/). 65 | 66 | ``` 67 | # Start a LFS server 68 | ./lfs_server.sh 69 | 70 | # Clone a repo 71 | git clone .... 72 | cd repo 73 | 74 | # Add a normal file 75 | touch test.txt 76 | git add test.txt 77 | git commit -m "normal file" 78 | 79 | # Add a lfs file 80 | git lfs install 81 | dd if=/dev/zero of=test.bin count=10240 bs=1024 # Create a file which is 10MB 82 | git lfs track test.bin 83 | git add .gitattributes test.bin 84 | git commit -m "lfs file" 85 | 86 | # Configure lfs remote to local server 87 | git config -f .lfsconfig lfs.url http://localhost:8080 88 | git add .lfsconfig 89 | git commit -m "lfs config" 90 | 91 | # Push changes 92 | git push 93 | ``` 94 | 95 | ## TODO 96 | * Multi server support 97 | * Create OPAM package 98 | * Add max file size option 99 | * Add connection timeouts 100 | * ~~Authentication~~ 101 | * ~~Automated tests~~ 102 | * ~~Setup Travis continuous builds~~ 103 | * ~~Setup Coverals~~ 104 | * ~~Remove incomplete/broken temporary files~~ 105 | * ~~Upload validation (calculate SHA-256 digest)~~ 106 | * ~~Reject uppercase SHA-256 hex digests~~ 107 | * ~~Fix HTTPS urls~~ 108 | * ~~Rearrange files in release package and remove redundant libs~~ 109 | * ~~Add logging~~ 110 | * ~~Check SIGQUIT and SIGINT are handled correctly~~ 111 | * ~~HTTPS support (trivial to add)~~ 112 | * ~~Speed-up uploading~~ (fixed in `cohttp`, see [#330](https://github.com/mirage/ocaml-cohttp/pull/330)) 113 | 114 | -------------------------------------------------------------------------------- /tests/.lfs/objects/eb/da/ebdaa749534bbbf8e1fc02c4f634648d749d5401e09b11fefbe283fe913b7d39: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Stanislav Artemkin 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Core.Std 19 | open Async.Std 20 | open Cohttp 21 | open Cohttp_async 22 | 23 | module Json = struct 24 | let error msg = 25 | let msg = `Assoc [ "message", `String msg ] in 26 | Yojson.Basic.pretty_to_string msg 27 | 28 | let metadata ~oid ~size ~self_url ~download_url = 29 | let msg = `Assoc [ 30 | "oid", `String oid; 31 | "size", `Int size; 32 | "_links", `Assoc [ 33 | "self", `Assoc [ "href", `String self_url ]; 34 | "download", `Assoc [ "href", `String download_url ] 35 | ] 36 | ] in 37 | Yojson.Basic.pretty_to_string msg 38 | end 39 | 40 | let is_sha256_hex_digest str = 41 | if String.length str <> 64 then false 42 | else String.for_all str ~f:Char.is_alphanum 43 | 44 | let respond_with_string ?(headers=Header.init ()) = 45 | let headers = Header.add headers "Content-Type" "application/vnd.git-lfs+json" in 46 | Server.respond_with_string ~headers 47 | 48 | let respond_not_found ~msg = 49 | respond_with_string 50 | ~code:`Not_found @@ Json.error msg 51 | 52 | let respond_not_implemented () = 53 | respond_with_string 54 | ~code:`Not_implemented @@ Json.error "Not implemented" 55 | 56 | let get_oid_path ~oid = 57 | let oid02 = String.prefix oid 2 in 58 | let oid24 = String.sub oid ~pos:2 ~len:2 in 59 | Filename.of_parts [oid02; oid24; oid] 60 | 61 | let get_object_path ~root ~oid = 62 | Filename.of_parts [root; "/data/objects"; get_oid_path ~oid] 63 | 64 | let respond_object_metadata ~root ~meth ~oid = 65 | let file = get_object_path ~root ~oid in 66 | Unix.access file [`Exists;`Read] >>= function 67 | | Error _ -> respond_not_found ~msg:"Object not found" 68 | | Ok _ -> 69 | respond_with_string ~code:`OK 70 | @@ Json.metadata ~oid ~size:12345 ~self_url:"self_url" ~download_url:"download_url" 71 | 72 | let oid_from_path path = 73 | match String.rsplit2 path ~on:'/' with 74 | | Some ("/objects", oid) -> 75 | if is_sha256_hex_digest oid then Some (oid, `Metadata) else None 76 | | Some ("/data/objects", oid) -> 77 | if is_sha256_hex_digest oid then Some (oid, `Object) else None 78 | | _ -> None 79 | 80 | let serve_client ~root ~body:_ _sock req = 81 | let uri = Request.uri req in 82 | let path = Uri.path uri in 83 | let meth = Request.meth req in 84 | let oid = oid_from_path path in 85 | match meth, oid with 86 | | `GET, Some (oid, `Metadata) | `HEAD, Some (oid, `Metadata) -> 87 | respond_object_metadata ~root ~meth ~oid 88 | | `GET, Some (oid, `Object) | `HEAD, Some (oid, `Object) -> 89 | respond_not_implemented () 90 | | `GET, None | `HEAD, None -> respond_not_found ~msg:"Wrong path" 91 | | `POST, _ -> respond_not_implemented () 92 | | _ -> respond_not_implemented () 93 | 94 | let start_server ~root ~host ~port () = 95 | eprintf "Listening for HTTP on port %d\n" port; 96 | Unix.Inet_addr.of_string_or_getbyname host 97 | >>= fun host -> 98 | let listen_on = Tcp.Where_to_listen.create 99 | ~socket_type:Socket.Type.tcp 100 | ~address:(`Inet (host, port)) 101 | ~listening_on:(fun _ -> port) 102 | in 103 | Server.create 104 | ~on_handler_error:`Raise 105 | listen_on 106 | (serve_client ~root) 107 | >>= fun _ -> Deferred.never () 108 | 109 | let () = 110 | Command.async_basic 111 | ~summary:"Start a Git LFS server" 112 | Command.Spec.( 113 | empty 114 | +> anon (maybe_with_default "./lfs" ("root" %: string)) 115 | +> flag "-s" (optional_with_default "127.0.0.1" string) ~doc:"address IP address to listen on" 116 | +> flag "-p" (optional_with_default 8080 int) ~doc:"port TCP port to listen on" 117 | ) 118 | (fun root host port -> start_server ~root ~host ~port) 119 | |> Command.run 120 | 121 | -------------------------------------------------------------------------------- /tests/test_get_object.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | GET /data/objects/ebdaa749534bbbf8e1fc02c4f634648d749d5401e09b11fefbe283fe913b7d39 HTTP/1.1 7 | Host: localhost 8 | 9 | |} 10 | 11 | let response = {| 12 | HTTP/1.1 200 OK 13 | connection: keep-alive 14 | content-type: application/octet-stream 15 | transfer-encoding: chunked 16 | 17 | ffa 18 | (* 19 | * Copyright (c) 2015 Stanislav Artemkin 20 | * 21 | * Permission to use, copy, modify, and distribute this software for any 22 | * purpose with or without fee is hereby granted, provided that the above 23 | * copyright notice and this permission notice appear in all copies. 24 | * 25 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 26 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 27 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 28 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 29 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 30 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 31 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 32 | * 33 | *) 34 | 35 | open Core.Std 36 | open Async.Std 37 | open Cohttp 38 | open Cohttp_async 39 | 40 | module Json = struct 41 | let error msg = 42 | let msg = `Assoc [ "message", `String msg ] in 43 | Yojson.Basic.pretty_to_string msg 44 | 45 | let metadata ~oid ~size ~self_url ~download_url = 46 | let msg = `Assoc [ 47 | "oid", `String oid; 48 | "size", `Int size; 49 | "_links", `Assoc [ 50 | "self", `Assoc [ "href", `String self_url ]; 51 | "download", `Assoc [ "href", `String download_url ] 52 | ] 53 | ] in 54 | Yojson.Basic.pretty_to_string msg 55 | end 56 | 57 | let is_sha256_hex_digest str = 58 | if String.length str <> 64 then false 59 | else String.for_all str ~f:Char.is_alphanum 60 | 61 | let respond_with_string ?(headers=Header.init ()) = 62 | let headers = Header.add headers "Content-Type" "application/vnd.git-lfs+json" in 63 | Server.respond_with_string ~headers 64 | 65 | let respond_not_found ~msg = 66 | respond_with_string 67 | ~code:`Not_found @@ Json.error msg 68 | 69 | let respond_not_implemented () = 70 | respond_with_string 71 | ~code:`Not_implemented @@ Json.error "Not implemented" 72 | 73 | let get_oid_path ~oid = 74 | let oid02 = String.prefix oid 2 in 75 | let oid24 = String.sub oid ~pos:2 ~len:2 in 76 | Filename.of_parts [oid02; oid24; oid] 77 | 78 | let get_object_path ~root ~oid = 79 | Filename.of_parts [root; "/data/objects"; get_oid_path ~oid] 80 | 81 | let respond_object_metadata ~root ~meth ~oid = 82 | let file = get_object_path ~root ~oid in 83 | Unix.access file [`Exists;`Read] >>= function 84 | | Error _ -> respond_not_found ~msg:"Object not found" 85 | | Ok _ -> 86 | respond_with_string ~code:`OK 87 | @@ Json.metadata ~oid ~size:12345 ~self_url:"self_url" ~download_url:"download_url" 88 | 89 | let oid_from_path path = 90 | match String.rsplit2 path ~on:'/' with 91 | | Some ("/objects", oid) -> 92 | if is_sha256_hex_digest oid then Some (oid, `Metadata) else None 93 | | Some ("/data/objects", oid) -> 94 | if is_sha256_hex_digest oid then Some (oid, `Object) else None 95 | | _ -> None 96 | 97 | let serve_client ~root ~body:_ _sock req = 98 | let uri = Request.uri req in 99 | let path = Uri.path uri in 100 | let meth = Request.meth req in 101 | let oid = oid_from_path path in 102 | match meth, oid with 103 | | `GET, Some (oid, `Metadata) | `HEAD, Some (oid, `Metadata) -> 104 | respond_object_metadata ~root ~meth ~oid 105 | | `GET, Some (oid, `Object) | `HEAD, Some (oid, `Object) -> 106 | respond_not_implemented () 107 | | `GET, None | `HEAD, None -> respond_not_found ~msg:"Wrong path" 108 | | `POST, _ -> respond_not_implemented () 109 | | _ -> respond_not_implemented () 110 | 111 | let start_server ~root ~host ~port () = 112 | eprintf "Listening for HTTP on port %d\n" port; 113 | Unix.Inet_addr.of_string_or_getbyname host 114 | >>= fun host -> 115 | let listen_on = Tcp.Where_to_listen.create 116 | ~socket_type:Socket.Type.tcp 117 | ~address:(`Inet (host, port)) 118 | ~listening_on:(fun _ -> port) 119 | in 120 | Server.create 121 | ~on_handler_error:`Raise 122 | listen_on 123 | (serve_client ~root) 124 | >>= fun _ -> Deferred.never () 125 | 126 | let () = 127 | Command.async_basic 128 | ~summary:"Start a Git LFS server" 129 | Command.Spec.( 130 | empty 131 | +> anon (maybe_with_default "./lfs" ("root" %: string)) 132 | +> flag "-s" (optional_with_default "127.0.0.1" string) ~doc:"address IP address to listen on" 133 | +> flag "-p" (optional_with_default 8080 int) ~doc:"port TCP port to listen on" 134 | ) 135 | (fun root host port -> start_server ~root ~host ~port) 136 | |> Command.run 137 | 138 | 139 | 0 140 | 141 | |} 142 | 143 | let () = 144 | Test.netcat request response 145 | 146 | -------------------------------------------------------------------------------- /tests/test_put_3_existing_file.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | PUT /objects/73bcc5e2fdb23b560e112be22c901379bf9ce3a1f9ca32acd92bc6ba5667a0ae HTTP/1.1 7 | Host: localhost 8 | Content-Length: 7170 9 | 10 | (* 11 | * Copyright (c) 2015 Stanislav Artemkin 12 | * 13 | * Permission to use, copy, modify, and distribute this software for any 14 | * purpose with or without fee is hereby granted, provided that the above 15 | * copyright notice and this permission notice appear in all copies. 16 | * 17 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 18 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 19 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 20 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 21 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 22 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 23 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 24 | * 25 | *) 26 | 27 | open Core.Std 28 | open Async.Std 29 | open Cohttp 30 | open Cohttp_async 31 | 32 | let is_sha256_hex_digest str = 33 | if String.length str <> 64 then false 34 | else String.for_all str ~f:Char.is_alphanum 35 | 36 | module Json = struct 37 | let error msg = 38 | let msg = `Assoc [ "message", `String msg ] in 39 | Yojson.pretty_to_string msg 40 | 41 | let metadata ~oid ~size ~self_url ~download_url = 42 | let msg = `Assoc [ 43 | "oid", `String oid; 44 | "size", `Intlit (Int64.to_string size); 45 | "_links", `Assoc [ 46 | "self", `Assoc [ "href", `String (Uri.to_string self_url) ]; 47 | "download", `Assoc [ "href", `String (Uri.to_string download_url) ] 48 | ] 49 | ] in 50 | Yojson.pretty_to_string msg 51 | 52 | let download url = 53 | let msg = `Assoc [ 54 | "_links", `Assoc [ 55 | "download", `Assoc [ "href", `String (Uri.to_string url) ] 56 | ] 57 | ] in 58 | Yojson.pretty_to_string msg 59 | 60 | let upload url = 61 | let url = Uri.to_string url in 62 | let msg = `Assoc [ 63 | "_links", `Assoc [ 64 | "upload", `Assoc [ "href", `String url ]; 65 | "verify", `Assoc [ "href", `String url ] 66 | ] 67 | ] in 68 | Yojson.pretty_to_string msg 69 | 70 | let parse_oid_size str = 71 | try_with (fun () -> return @@ Yojson.Safe.from_string str) >>= function 72 | | Error _ -> return None 73 | | Ok (`Assoc ["oid", `String oid; "size", `Int size]) -> 74 | if is_sha256_hex_digest oid then 75 | return (Some (oid, Int64.of_int size)) 76 | else return None 77 | | Ok (`Assoc ["oid", `String oid; "size", `Intlit size]) -> 78 | let oid = if is_sha256_hex_digest oid then Some oid else None in 79 | let size = Option.try_with (fun () -> Int64.of_string size) in 80 | return @@ Option.both oid size 81 | | Ok _ -> return None 82 | 83 | end 84 | 85 | let add_content_type headers content_type = 86 | Header.add headers "content-type" content_type 87 | 88 | let respond_with_string ~meth ~code str = 89 | let headers = add_content_type (Header.init ()) "application/vnd.git-lfs+json" in 90 | let body = match meth with `GET | `POST -> `String str | `HEAD -> `Empty in 91 | Server.respond ~headers ~body code 92 | 93 | let respond_error ~meth ~code msg = 94 | respond_with_string ~meth ~code @@ Json.error msg 95 | 96 | let get_oid_path ~oid = 97 | let oid02 = String.prefix oid 2 in 98 | let oid24 = String.sub oid ~pos:2 ~len:2 in 99 | Filename.of_parts [oid02; oid24; oid] 100 | 101 | let get_object_filename ~root ~oid = 102 | Filename.of_parts [root; "/objects"; get_oid_path ~oid] 103 | 104 | let check_object_file_stat ~root ~oid = 105 | let path = get_object_filename ~root ~oid in 106 | try_with (fun () -> Unix.stat path) 107 | 108 | let get_download_url uri oid = 109 | Uri.with_path uri @@ Filename.concat "/data/objects" oid 110 | 111 | let respond_object_metadata ~root ~meth ~uri ~oid = 112 | check_object_file_stat ~root ~oid >>= function 113 | | Error _ -> respond_error ~meth ~code:`Not_found "Object not found" 114 | | Ok stat -> 115 | let download_url = get_download_url uri oid in 116 | respond_with_string ~meth ~code:`OK 117 | @@ Json.metadata ~oid ~size:(Unix.Stats.size stat) ~self_url:uri ~download_url 118 | 119 | let respond_object ~root ~meth ~oid = 120 | let filename = get_object_filename ~root ~oid in 121 | try_with ~run:`Now 122 | (fun () -> 123 | Reader.open_file filename 124 | >>= fun rd -> 125 | let headers = add_content_type (Header.init ()) "application/octet-stream" in 126 | match meth with 127 | | `GET -> 128 | Server.respond ~headers ~body:(`Pipe (Reader.pipe rd)) `OK 129 | | `HEAD -> 130 | Reader.close rd >>= fun () -> 131 | Server.respond ~headers ~body:`Empty `OK) 132 | >>= function 133 | | Ok res -> return res 134 | | Error _ -> respond_error ~meth ~code:`Not_found "Object not found" 135 | 136 | let oid_from_path path = 137 | match String.rsplit2 path ~on:'/' with 138 | | Some ("/objects", oid) -> 139 | if is_sha256_hex_digest oid then `Metadata oid else `Empty 140 | | Some ("/data/objects", oid) -> 141 | if is_sha256_hex_digest oid then `Object oid else `Empty 142 | | _ -> `Empty 143 | 144 | (* TODO fix this *) 145 | let fix_uri port uri = 146 | let uri = Uri.with_scheme uri (Some "http") in 147 | Uri.with_port uri (if port = 80 then None else Some port) 148 | 149 | let handle_get root meth uri = 150 | let path = Uri.path uri in 151 | match oid_from_path path with 152 | | `Metadata oid -> respond_object_metadata ~root ~meth ~uri ~oid 153 | | `Object oid -> respond_object ~root ~meth ~oid 154 | | `Empty -> respond_error ~meth ~code:`Not_found "Wrong path" 155 | 156 | let handle_post root meth uri body = 157 | let path = Uri.path uri in 158 | if path <> "/objects" then 159 | respond_error ~meth ~code:`Not_found "Wrong path" 160 | else 161 | Body.to_string body >>= fun body -> 162 | Json.parse_oid_size body >>= function 163 | | None -> respond_error ~meth ~code:`Bad_request "Invalid body" 164 | | Some (oid, size) -> 165 | check_object_file_stat ~root ~oid >>= function 166 | | Ok stat when (Unix.Stats.size stat = size) -> 167 | let url = get_download_url uri oid in 168 | respond_with_string ~meth ~code:`OK @@ Json.download url 169 | | Ok _ -> 170 | respond_error ~meth ~code:`Bad_request "Wrong object size" 171 | | Error _ -> 172 | let url = Uri.with_path uri @@ Filename.concat "/upload/objects" oid in 173 | respond_with_string ~meth ~code:`Accepted @@ Json.upload url 174 | 175 | let serve_client ~root ~port ~body _sock req = 176 | let uri = Request.uri req in 177 | if Option.is_none (Uri.host uri) then 178 | respond_with_string ~meth:`GET 179 | ~code:`Bad_request @@ Json.error "Wrong host" 180 | else 181 | let uri = fix_uri port uri in 182 | match Request.meth req with 183 | | (`GET as meth) | (`HEAD as meth) -> handle_get root meth uri 184 | | (`POST as meth) -> handle_post root meth uri body 185 | | _ -> Server.respond `Method_not_allowed 186 | 187 | let start_server ~root ~host ~port () = 188 | eprintf "Listening for HTTP on port %d\n" port; 189 | Unix.Inet_addr.of_string_or_getbyname host 190 | >>= fun host -> 191 | let listen_on = Tcp.Where_to_listen.create 192 | ~socket_type:Socket.Type.tcp 193 | ~address:(`Inet (host, port)) 194 | ~listening_on:(fun _ -> port) 195 | in 196 | Server.create 197 | ~on_handler_error:`Raise 198 | listen_on 199 | (serve_client ~root ~port) 200 | >>= fun _ -> Deferred.never () 201 | 202 | let () = 203 | Command.async_basic 204 | ~summary:"Start a Git LFS server" 205 | Command.Spec.( 206 | empty 207 | +> anon (maybe_with_default "./.lfs" ("root" %: string)) 208 | +> flag "-s" (optional_with_default "127.0.0.1" string) ~doc:"address IP address to listen on" 209 | +> flag "-p" (optional_with_default 8080 int) ~doc:"port TCP port to listen on" 210 | ) 211 | (fun root host port -> start_server ~root ~host ~port) 212 | |> Command.run 213 | 214 | |} 215 | 216 | let response = {| 217 | HTTP/1.1 200 OK 218 | connection: keep-alive 219 | content-length: 0 220 | 221 | |} 222 | 223 | let () = 224 | Test.netcat request response 225 | 226 | -------------------------------------------------------------------------------- /tests/test_put_2_new_file_correct_content.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | PUT /objects/73bcc5e2fdb23b560e112be22c901379bf9ce3a1f9ca32acd92bc6ba5667a0ae HTTP/1.1 7 | Host: localhost 8 | Content-Length: 7170 9 | 10 | (* 11 | * Copyright (c) 2015 Stanislav Artemkin 12 | * 13 | * Permission to use, copy, modify, and distribute this software for any 14 | * purpose with or without fee is hereby granted, provided that the above 15 | * copyright notice and this permission notice appear in all copies. 16 | * 17 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 18 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 19 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 20 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 21 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 22 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 23 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 24 | * 25 | *) 26 | 27 | open Core.Std 28 | open Async.Std 29 | open Cohttp 30 | open Cohttp_async 31 | 32 | let is_sha256_hex_digest str = 33 | if String.length str <> 64 then false 34 | else String.for_all str ~f:Char.is_alphanum 35 | 36 | module Json = struct 37 | let error msg = 38 | let msg = `Assoc [ "message", `String msg ] in 39 | Yojson.pretty_to_string msg 40 | 41 | let metadata ~oid ~size ~self_url ~download_url = 42 | let msg = `Assoc [ 43 | "oid", `String oid; 44 | "size", `Intlit (Int64.to_string size); 45 | "_links", `Assoc [ 46 | "self", `Assoc [ "href", `String (Uri.to_string self_url) ]; 47 | "download", `Assoc [ "href", `String (Uri.to_string download_url) ] 48 | ] 49 | ] in 50 | Yojson.pretty_to_string msg 51 | 52 | let download url = 53 | let msg = `Assoc [ 54 | "_links", `Assoc [ 55 | "download", `Assoc [ "href", `String (Uri.to_string url) ] 56 | ] 57 | ] in 58 | Yojson.pretty_to_string msg 59 | 60 | let upload url = 61 | let url = Uri.to_string url in 62 | let msg = `Assoc [ 63 | "_links", `Assoc [ 64 | "upload", `Assoc [ "href", `String url ]; 65 | "verify", `Assoc [ "href", `String url ] 66 | ] 67 | ] in 68 | Yojson.pretty_to_string msg 69 | 70 | let parse_oid_size str = 71 | try_with (fun () -> return @@ Yojson.Safe.from_string str) >>= function 72 | | Error _ -> return None 73 | | Ok (`Assoc ["oid", `String oid; "size", `Int size]) -> 74 | if is_sha256_hex_digest oid then 75 | return (Some (oid, Int64.of_int size)) 76 | else return None 77 | | Ok (`Assoc ["oid", `String oid; "size", `Intlit size]) -> 78 | let oid = if is_sha256_hex_digest oid then Some oid else None in 79 | let size = Option.try_with (fun () -> Int64.of_string size) in 80 | return @@ Option.both oid size 81 | | Ok _ -> return None 82 | 83 | end 84 | 85 | let add_content_type headers content_type = 86 | Header.add headers "content-type" content_type 87 | 88 | let respond_with_string ~meth ~code str = 89 | let headers = add_content_type (Header.init ()) "application/vnd.git-lfs+json" in 90 | let body = match meth with `GET | `POST -> `String str | `HEAD -> `Empty in 91 | Server.respond ~headers ~body code 92 | 93 | let respond_error ~meth ~code msg = 94 | respond_with_string ~meth ~code @@ Json.error msg 95 | 96 | let get_oid_path ~oid = 97 | let oid02 = String.prefix oid 2 in 98 | let oid24 = String.sub oid ~pos:2 ~len:2 in 99 | Filename.of_parts [oid02; oid24; oid] 100 | 101 | let get_object_filename ~root ~oid = 102 | Filename.of_parts [root; "/objects"; get_oid_path ~oid] 103 | 104 | let check_object_file_stat ~root ~oid = 105 | let path = get_object_filename ~root ~oid in 106 | try_with (fun () -> Unix.stat path) 107 | 108 | let get_download_url uri oid = 109 | Uri.with_path uri @@ Filename.concat "/data/objects" oid 110 | 111 | let respond_object_metadata ~root ~meth ~uri ~oid = 112 | check_object_file_stat ~root ~oid >>= function 113 | | Error _ -> respond_error ~meth ~code:`Not_found "Object not found" 114 | | Ok stat -> 115 | let download_url = get_download_url uri oid in 116 | respond_with_string ~meth ~code:`OK 117 | @@ Json.metadata ~oid ~size:(Unix.Stats.size stat) ~self_url:uri ~download_url 118 | 119 | let respond_object ~root ~meth ~oid = 120 | let filename = get_object_filename ~root ~oid in 121 | try_with ~run:`Now 122 | (fun () -> 123 | Reader.open_file filename 124 | >>= fun rd -> 125 | let headers = add_content_type (Header.init ()) "application/octet-stream" in 126 | match meth with 127 | | `GET -> 128 | Server.respond ~headers ~body:(`Pipe (Reader.pipe rd)) `OK 129 | | `HEAD -> 130 | Reader.close rd >>= fun () -> 131 | Server.respond ~headers ~body:`Empty `OK) 132 | >>= function 133 | | Ok res -> return res 134 | | Error _ -> respond_error ~meth ~code:`Not_found "Object not found" 135 | 136 | let oid_from_path path = 137 | match String.rsplit2 path ~on:'/' with 138 | | Some ("/objects", oid) -> 139 | if is_sha256_hex_digest oid then `Metadata oid else `Empty 140 | | Some ("/data/objects", oid) -> 141 | if is_sha256_hex_digest oid then `Object oid else `Empty 142 | | _ -> `Empty 143 | 144 | (* TODO fix this *) 145 | let fix_uri port uri = 146 | let uri = Uri.with_scheme uri (Some "http") in 147 | Uri.with_port uri (if port = 80 then None else Some port) 148 | 149 | let handle_get root meth uri = 150 | let path = Uri.path uri in 151 | match oid_from_path path with 152 | | `Metadata oid -> respond_object_metadata ~root ~meth ~uri ~oid 153 | | `Object oid -> respond_object ~root ~meth ~oid 154 | | `Empty -> respond_error ~meth ~code:`Not_found "Wrong path" 155 | 156 | let handle_post root meth uri body = 157 | let path = Uri.path uri in 158 | if path <> "/objects" then 159 | respond_error ~meth ~code:`Not_found "Wrong path" 160 | else 161 | Body.to_string body >>= fun body -> 162 | Json.parse_oid_size body >>= function 163 | | None -> respond_error ~meth ~code:`Bad_request "Invalid body" 164 | | Some (oid, size) -> 165 | check_object_file_stat ~root ~oid >>= function 166 | | Ok stat when (Unix.Stats.size stat = size) -> 167 | let url = get_download_url uri oid in 168 | respond_with_string ~meth ~code:`OK @@ Json.download url 169 | | Ok _ -> 170 | respond_error ~meth ~code:`Bad_request "Wrong object size" 171 | | Error _ -> 172 | let url = Uri.with_path uri @@ Filename.concat "/upload/objects" oid in 173 | respond_with_string ~meth ~code:`Accepted @@ Json.upload url 174 | 175 | let serve_client ~root ~port ~body _sock req = 176 | let uri = Request.uri req in 177 | if Option.is_none (Uri.host uri) then 178 | respond_with_string ~meth:`GET 179 | ~code:`Bad_request @@ Json.error "Wrong host" 180 | else 181 | let uri = fix_uri port uri in 182 | match Request.meth req with 183 | | (`GET as meth) | (`HEAD as meth) -> handle_get root meth uri 184 | | (`POST as meth) -> handle_post root meth uri body 185 | | _ -> Server.respond `Method_not_allowed 186 | 187 | let start_server ~root ~host ~port () = 188 | eprintf "Listening for HTTP on port %d\n" port; 189 | Unix.Inet_addr.of_string_or_getbyname host 190 | >>= fun host -> 191 | let listen_on = Tcp.Where_to_listen.create 192 | ~socket_type:Socket.Type.tcp 193 | ~address:(`Inet (host, port)) 194 | ~listening_on:(fun _ -> port) 195 | in 196 | Server.create 197 | ~on_handler_error:`Raise 198 | listen_on 199 | (serve_client ~root ~port) 200 | >>= fun _ -> Deferred.never () 201 | 202 | let () = 203 | Command.async_basic 204 | ~summary:"Start a Git LFS server" 205 | Command.Spec.( 206 | empty 207 | +> anon (maybe_with_default "./.lfs" ("root" %: string)) 208 | +> flag "-s" (optional_with_default "127.0.0.1" string) ~doc:"address IP address to listen on" 209 | +> flag "-p" (optional_with_default 8080 int) ~doc:"port TCP port to listen on" 210 | ) 211 | (fun root host port -> start_server ~root ~host ~port) 212 | |> Command.run 213 | 214 | |} 215 | 216 | let response = {| 217 | HTTP/1.1 201 Created 218 | connection: keep-alive 219 | content-length: 0 220 | 221 | |} 222 | 223 | let () = 224 | Test.netcat request response 225 | 226 | -------------------------------------------------------------------------------- /tests/test_put_1_new_file_wrong_content.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "test.ml" 4 | 5 | let request = {| 6 | PUT /objects/73bcc5e2fdb23b560e112be22c901379bf9ce3a1f9ca32acd92bc6ba5667a0ae HTTP/1.1 7 | Host: localhost 8 | Content-Length: 7170 9 | 10 | (* 11 | * ERRORight (c) 2015 Stanislav Artemkin 12 | * 13 | * Permission to use, copy, modify, and distribute this software for any 14 | * purpose with or without fee is hereby granted, provided that the above 15 | * copyright notice and this permission notice appear in all copies. 16 | * 17 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 18 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 19 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 20 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 21 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 22 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 23 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 24 | * 25 | *) 26 | 27 | open Core.Std 28 | open Async.Std 29 | open Cohttp 30 | open Cohttp_async 31 | 32 | let is_sha256_hex_digest str = 33 | if String.length str <> 64 then false 34 | else String.for_all str ~f:Char.is_alphanum 35 | 36 | module Json = struct 37 | let error msg = 38 | let msg = `Assoc [ "message", `String msg ] in 39 | Yojson.pretty_to_string msg 40 | 41 | let metadata ~oid ~size ~self_url ~download_url = 42 | let msg = `Assoc [ 43 | "oid", `String oid; 44 | "size", `Intlit (Int64.to_string size); 45 | "_links", `Assoc [ 46 | "self", `Assoc [ "href", `String (Uri.to_string self_url) ]; 47 | "download", `Assoc [ "href", `String (Uri.to_string download_url) ] 48 | ] 49 | ] in 50 | Yojson.pretty_to_string msg 51 | 52 | let download url = 53 | let msg = `Assoc [ 54 | "_links", `Assoc [ 55 | "download", `Assoc [ "href", `String (Uri.to_string url) ] 56 | ] 57 | ] in 58 | Yojson.pretty_to_string msg 59 | 60 | let upload url = 61 | let url = Uri.to_string url in 62 | let msg = `Assoc [ 63 | "_links", `Assoc [ 64 | "upload", `Assoc [ "href", `String url ]; 65 | "verify", `Assoc [ "href", `String url ] 66 | ] 67 | ] in 68 | Yojson.pretty_to_string msg 69 | 70 | let parse_oid_size str = 71 | try_with (fun () -> return @@ Yojson.Safe.from_string str) >>= function 72 | | Error _ -> return None 73 | | Ok (`Assoc ["oid", `String oid; "size", `Int size]) -> 74 | if is_sha256_hex_digest oid then 75 | return (Some (oid, Int64.of_int size)) 76 | else return None 77 | | Ok (`Assoc ["oid", `String oid; "size", `Intlit size]) -> 78 | let oid = if is_sha256_hex_digest oid then Some oid else None in 79 | let size = Option.try_with (fun () -> Int64.of_string size) in 80 | return @@ Option.both oid size 81 | | Ok _ -> return None 82 | 83 | end 84 | 85 | let add_content_type headers content_type = 86 | Header.add headers "content-type" content_type 87 | 88 | let respond_with_string ~meth ~code str = 89 | let headers = add_content_type (Header.init ()) "application/vnd.git-lfs+json" in 90 | let body = match meth with `GET | `POST -> `String str | `HEAD -> `Empty in 91 | Server.respond ~headers ~body code 92 | 93 | let respond_error ~meth ~code msg = 94 | respond_with_string ~meth ~code @@ Json.error msg 95 | 96 | let get_oid_path ~oid = 97 | let oid02 = String.prefix oid 2 in 98 | let oid24 = String.sub oid ~pos:2 ~len:2 in 99 | Filename.of_parts [oid02; oid24; oid] 100 | 101 | let get_object_filename ~root ~oid = 102 | Filename.of_parts [root; "/objects"; get_oid_path ~oid] 103 | 104 | let check_object_file_stat ~root ~oid = 105 | let path = get_object_filename ~root ~oid in 106 | try_with (fun () -> Unix.stat path) 107 | 108 | let get_download_url uri oid = 109 | Uri.with_path uri @@ Filename.concat "/data/objects" oid 110 | 111 | let respond_object_metadata ~root ~meth ~uri ~oid = 112 | check_object_file_stat ~root ~oid >>= function 113 | | Error _ -> respond_error ~meth ~code:`Not_found "Object not found" 114 | | Ok stat -> 115 | let download_url = get_download_url uri oid in 116 | respond_with_string ~meth ~code:`OK 117 | @@ Json.metadata ~oid ~size:(Unix.Stats.size stat) ~self_url:uri ~download_url 118 | 119 | let respond_object ~root ~meth ~oid = 120 | let filename = get_object_filename ~root ~oid in 121 | try_with ~run:`Now 122 | (fun () -> 123 | Reader.open_file filename 124 | >>= fun rd -> 125 | let headers = add_content_type (Header.init ()) "application/octet-stream" in 126 | match meth with 127 | | `GET -> 128 | Server.respond ~headers ~body:(`Pipe (Reader.pipe rd)) `OK 129 | | `HEAD -> 130 | Reader.close rd >>= fun () -> 131 | Server.respond ~headers ~body:`Empty `OK) 132 | >>= function 133 | | Ok res -> return res 134 | | Error _ -> respond_error ~meth ~code:`Not_found "Object not found" 135 | 136 | let oid_from_path path = 137 | match String.rsplit2 path ~on:'/' with 138 | | Some ("/objects", oid) -> 139 | if is_sha256_hex_digest oid then `Metadata oid else `Empty 140 | | Some ("/data/objects", oid) -> 141 | if is_sha256_hex_digest oid then `Object oid else `Empty 142 | | _ -> `Empty 143 | 144 | (* TODO fix this *) 145 | let fix_uri port uri = 146 | let uri = Uri.with_scheme uri (Some "http") in 147 | Uri.with_port uri (if port = 80 then None else Some port) 148 | 149 | let handle_get root meth uri = 150 | let path = Uri.path uri in 151 | match oid_from_path path with 152 | | `Metadata oid -> respond_object_metadata ~root ~meth ~uri ~oid 153 | | `Object oid -> respond_object ~root ~meth ~oid 154 | | `Empty -> respond_error ~meth ~code:`Not_found "Wrong path" 155 | 156 | let handle_post root meth uri body = 157 | let path = Uri.path uri in 158 | if path <> "/objects" then 159 | respond_error ~meth ~code:`Not_found "Wrong path" 160 | else 161 | Body.to_string body >>= fun body -> 162 | Json.parse_oid_size body >>= function 163 | | None -> respond_error ~meth ~code:`Bad_request "Invalid body" 164 | | Some (oid, size) -> 165 | check_object_file_stat ~root ~oid >>= function 166 | | Ok stat when (Unix.Stats.size stat = size) -> 167 | let url = get_download_url uri oid in 168 | respond_with_string ~meth ~code:`OK @@ Json.download url 169 | | Ok _ -> 170 | respond_error ~meth ~code:`Bad_request "Wrong object size" 171 | | Error _ -> 172 | let url = Uri.with_path uri @@ Filename.concat "/upload/objects" oid in 173 | respond_with_string ~meth ~code:`Accepted @@ Json.upload url 174 | 175 | let serve_client ~root ~port ~body _sock req = 176 | let uri = Request.uri req in 177 | if Option.is_none (Uri.host uri) then 178 | respond_with_string ~meth:`GET 179 | ~code:`Bad_request @@ Json.error "Wrong host" 180 | else 181 | let uri = fix_uri port uri in 182 | match Request.meth req with 183 | | (`GET as meth) | (`HEAD as meth) -> handle_get root meth uri 184 | | (`POST as meth) -> handle_post root meth uri body 185 | | _ -> Server.respond `Method_not_allowed 186 | 187 | let start_server ~root ~host ~port () = 188 | eprintf "Listening for HTTP on port %d\n" port; 189 | Unix.Inet_addr.of_string_or_getbyname host 190 | >>= fun host -> 191 | let listen_on = Tcp.Where_to_listen.create 192 | ~socket_type:Socket.Type.tcp 193 | ~address:(`Inet (host, port)) 194 | ~listening_on:(fun _ -> port) 195 | in 196 | Server.create 197 | ~on_handler_error:`Raise 198 | listen_on 199 | (serve_client ~root ~port) 200 | >>= fun _ -> Deferred.never () 201 | 202 | let () = 203 | Command.async_basic 204 | ~summary:"Start a Git LFS server" 205 | Command.Spec.( 206 | empty 207 | +> anon (maybe_with_default "./.lfs" ("root" %: string)) 208 | +> flag "-s" (optional_with_default "127.0.0.1" string) ~doc:"address IP address to listen on" 209 | +> flag "-p" (optional_with_default 8080 int) ~doc:"port TCP port to listen on" 210 | ) 211 | (fun root host port -> start_server ~root ~host ~port) 212 | |> Command.run 213 | 214 | |} 215 | 216 | let response = {| 217 | HTTP/1.1 400 Bad Request 218 | connection: keep-alive 219 | content-length: 125 220 | content-type: application/vnd.git-lfs+json 221 | 222 | { 223 | "message": 224 | "Content doesn't match SHA-256 digest: 73bcc5e2fdb23b560e112be22c901379bf9ce3a1f9ca32acd92bc6ba5667a0ae" 225 | } 226 | |} 227 | 228 | let () = 229 | Test.netcat request response 230 | 231 | -------------------------------------------------------------------------------- /src/lfs_server.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Stanislav Artemkin 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Core 19 | open Async 20 | open Cohttp 21 | open Cohttp_async 22 | 23 | open Lfs_aux 24 | 25 | module Json = struct 26 | let from_string str = 27 | try Some (Yojson.Safe.from_string str) with _ -> None 28 | 29 | let to_string json = 30 | Yojson.pretty_to_string json 31 | 32 | let get_value assoc_lst key = 33 | List.Assoc.find assoc_lst ~equal:String.equal key 34 | 35 | let get_string assoc_lst key = 36 | match get_value assoc_lst key with 37 | | Some (`String str) -> Some str 38 | | _ -> None 39 | 40 | let get_int assoc_lst key = 41 | match get_value assoc_lst key with 42 | | Some (`Int i) -> Some (Int64.of_int i) 43 | | Some (`Intlit str) -> Option.try_with (fun () -> Int64.of_string str) 44 | | _ -> None 45 | 46 | let error msg = 47 | let msg = `Assoc [ "message", `String msg ] in 48 | to_string msg 49 | 50 | let metadata ~oid ~size ~self_url ~download_url = 51 | let msg = `Assoc [ 52 | "oid", `String oid; 53 | "size", `Intlit (Int64.to_string size); 54 | "_links", `Assoc [ 55 | "self", `Assoc [ "href", `String (Uri.to_string self_url) ]; 56 | "download", `Assoc [ "href", `String (Uri.to_string download_url) ] 57 | ] 58 | ] in 59 | to_string msg 60 | 61 | let download url = 62 | let msg = `Assoc [ 63 | "_links", `Assoc [ 64 | "download", `Assoc [ "href", `String (Uri.to_string url) ] 65 | ] 66 | ] in 67 | to_string msg 68 | 69 | let upload url = 70 | let url = Uri.to_string url in 71 | let msg = `Assoc [ 72 | "_links", `Assoc [ 73 | "upload", `Assoc [ "href", `String url ]; 74 | "verify", `Assoc [ "href", `String url ] 75 | ] 76 | ] in 77 | to_string msg 78 | 79 | let batch_error ~oid ~size ~code ~msg = 80 | `Assoc [ 81 | "oid", `String oid; 82 | "size", `Intlit (Int64.to_string size); 83 | "error", `Assoc [ 84 | "code", `Int code; 85 | "message", `String msg 86 | ] 87 | ] 88 | 89 | let batch_download_ok oid size url = 90 | let url = Uri.to_string url in 91 | `Assoc [ 92 | "oid", `String oid; 93 | "size", `Intlit (Int64.to_string size); 94 | "actions", `Assoc [ 95 | "download", `Assoc [ "href", `String url ]; 96 | ] 97 | ] 98 | 99 | let batch_upload_ok oid size url = 100 | let url = Uri.to_string url in 101 | `Assoc [ 102 | "oid", `String oid; 103 | "size", `Intlit (Int64.to_string size); 104 | "actions", `Assoc [ 105 | "upload", `Assoc [ "href", `String url ]; 106 | "verify", `Assoc [ "href", `String url ] 107 | ] 108 | ] 109 | 110 | let batch_upload_exists oid size = 111 | `Assoc [ 112 | "oid", `String oid; 113 | "size", `Intlit (Int64.to_string size); 114 | ] 115 | 116 | let parse_operation = function 117 | | "download" -> Some `Download 118 | | "upload" -> Some `Upload 119 | | _ -> None 120 | 121 | let parse_object = function 122 | | `Assoc lst -> 123 | let oid = Option.filter (get_string lst "oid") ~f:is_sha256_hex_digest in 124 | let size = get_int lst "size" in 125 | Option.both oid size 126 | | _ -> None 127 | 128 | let parse_objects = function 129 | | `List lst -> Option.all (List.map lst ~f:parse_object) 130 | | _ -> None 131 | 132 | let parse_batch_req str = 133 | match from_string str with 134 | | Some (`Assoc lst) -> 135 | let operation = (Option.find_map (get_string lst "operation") ~f:parse_operation) in 136 | let objects = (Option.find_map (get_value lst "objects") ~f:parse_objects) in 137 | Option.both operation objects 138 | | _ -> None 139 | 140 | let parse_oid_size str = 141 | match from_string str with 142 | | Some json -> parse_object json 143 | | _ -> None 144 | 145 | end 146 | 147 | let add_content_type headers content_type = 148 | Header.add headers "content-type" content_type 149 | 150 | let respond ~headers ~body ~code = 151 | Server.respond ~headers ~body code >>| fun resp -> 152 | resp, `Log_ok code 153 | 154 | let respond_ok ~code = 155 | Server.respond code >>| fun resp -> 156 | resp, `Log_ok code 157 | 158 | let respond_error ~code = 159 | Server.respond code >>| fun resp -> 160 | resp, `Log_error (code, "") 161 | 162 | let prepare_string_respond ~meth ~code msg = 163 | let headers = add_content_type (Header.init ()) "application/vnd.git-lfs+json" in 164 | let body = match meth with `HEAD -> `Empty | _ -> `String msg in 165 | Server.respond ~headers ~body code 166 | 167 | let respond_with_string ~meth ~code msg = 168 | prepare_string_respond ~meth ~code msg >>| fun resp -> 169 | resp, `Log_ok code 170 | 171 | let respond_error_with_message ~meth ~code msg = 172 | prepare_string_respond ~meth ~code @@ Json.error msg >>| fun resp -> 173 | resp, `Log_error (code, msg) 174 | 175 | let mkdir_if_needed dirname = 176 | try_with ~run:`Now (fun () -> Unix.stat dirname) >>= function 177 | | Ok _ -> Deferred.unit 178 | | Error _ -> 179 | try_with ~run:`Now (fun () -> Unix.mkdir dirname) 180 | >>= fun _ -> Deferred.unit 181 | 182 | let get_oid_prefixes ~oid = 183 | (String.prefix oid 2, String.sub oid ~pos:2 ~len:2) 184 | 185 | let make_objects_dir_if_needed ~root ~oid = 186 | let (oid02, oid24) = get_oid_prefixes ~oid in 187 | let dir02 = Filename.of_parts [root; "/objects"; oid02] in 188 | let dir24 = Filename.concat dir02 oid24 in 189 | mkdir_if_needed dir02 >>= fun () -> 190 | mkdir_if_needed dir24 191 | 192 | let get_object_filename ~root ~oid = 193 | let (oid02, oid24) = get_oid_prefixes ~oid in 194 | let oid_path = Filename.of_parts [oid02; oid24; oid] in 195 | Filename.of_parts [root; "/objects"; oid_path] 196 | 197 | let get_temp_filename ~root ~oid = 198 | Filename.of_parts [root; "/temp"; oid] 199 | 200 | let check_object_file_stat ~root ~oid = 201 | let filename = get_object_filename ~root ~oid in 202 | try_with ~run:`Now (fun () -> Unix.stat filename) 203 | 204 | let get_download_url uri oid = 205 | Uri.with_path uri @@ Filename.concat "/data/objects" oid 206 | 207 | let respond_object_metadata ~root ~meth ~uri ~oid = 208 | check_object_file_stat ~root ~oid >>= function 209 | | Error _ -> respond_error_with_message ~meth ~code:`Not_found "Object not found" 210 | | Ok stat -> 211 | let download_url = get_download_url uri oid in 212 | respond_with_string ~meth ~code:`OK 213 | @@ Json.metadata ~oid ~size:(Unix.Stats.size stat) ~self_url:uri ~download_url 214 | 215 | let respond_object ~root ~meth ~oid = 216 | let filename = get_object_filename ~root ~oid in 217 | try_with ~run:`Now 218 | (fun () -> 219 | Reader.open_file filename 220 | >>= fun rd -> 221 | let headers = add_content_type (Header.init ()) "application/octet-stream" in 222 | match meth with 223 | | `GET -> 224 | respond ~headers ~body:(`Pipe (Reader.pipe rd)) ~code:`OK 225 | | `HEAD -> 226 | Reader.close rd >>= fun () -> 227 | respond ~headers ~body:`Empty ~code:`OK) 228 | >>= function 229 | | Ok res -> return res 230 | | Error _ -> respond_error_with_message ~meth ~code:`Not_found "Object not found" 231 | 232 | let parse_path path = 233 | match String.rsplit2 path ~on:'/' with 234 | | Some ("/objects", "batch") -> `Batch_path 235 | | Some ("/objects", oid) -> 236 | if is_sha256_hex_digest oid then `Default_path oid else `Wrong_path 237 | | Some ("/data/objects", oid) -> 238 | if is_sha256_hex_digest oid then `Download_path oid else `Wrong_path 239 | | Some ("", "objects") -> `Post_path 240 | | _ -> `Wrong_path 241 | 242 | let handle_get root meth uri = 243 | let path = Uri.path uri in 244 | match parse_path path with 245 | | `Default_path oid -> respond_object_metadata ~root ~meth ~uri ~oid 246 | | `Download_path oid -> respond_object ~root ~meth ~oid 247 | | `Post_path | `Wrong_path | `Batch_path -> 248 | respond_error_with_message ~meth ~code:`Not_found "Wrong path" 249 | 250 | let handle_verify root meth oid = 251 | check_object_file_stat ~root ~oid 252 | >>= function 253 | | Ok _ -> respond_ok ~code:`OK 254 | | Error _ -> 255 | respond_error_with_message ~meth ~code:`Not_found 256 | "Verification failed: object not found" 257 | 258 | let handle_batch_download root meth uri objects = 259 | let aux (oid, size) = 260 | check_object_file_stat ~root ~oid >>= function 261 | | Ok stat when (Unix.Stats.size stat = size) -> 262 | let url = get_download_url uri oid in 263 | return (Json.batch_download_ok oid size url) 264 | | Ok _ -> 265 | return (Json.batch_error ~oid ~size ~code:422 ~msg:"Wrong object size") 266 | | Error _ -> 267 | return (Json.batch_error ~oid ~size ~code:404 ~msg:"Object does not exist") 268 | in 269 | let lst = List.map objects ~f:aux in 270 | Deferred.all lst >>= fun objects -> 271 | let json = 272 | `Assoc [ 273 | "transfer", `String "basic"; 274 | "objects", `List objects 275 | ] 276 | in 277 | respond_with_string ~meth ~code:`OK @@ Json.to_string json 278 | 279 | let handle_batch_upload root meth uri objects = 280 | let aux (oid, size) = 281 | check_object_file_stat ~root ~oid >>= function 282 | | Ok stat when (Unix.Stats.size stat = size) -> 283 | return (Json.batch_upload_exists oid size) 284 | | Ok _ -> 285 | return (Json.batch_error ~oid ~size ~code:422 ~msg:"Wrong object size") 286 | | Error _ -> 287 | let url = Uri.with_path uri @@ Filename.concat "/objects" oid in 288 | return (Json.batch_upload_ok oid size url) 289 | in 290 | let lst = List.map objects ~f:aux in 291 | Deferred.all lst >>= fun objects -> 292 | let json = 293 | `Assoc [ 294 | "transfer", `String "basic"; 295 | "objects", `List objects 296 | ] 297 | in 298 | respond_with_string ~meth ~code:`OK @@ Json.to_string json 299 | 300 | let handle_batch root meth uri body = 301 | Body.to_string body >>= fun body -> 302 | match Json.parse_batch_req body with 303 | | None -> 304 | respond_error_with_message ~meth ~code:`Bad_request "Invalid body" 305 | | Some (operation, objects) -> 306 | match operation with 307 | | `Download -> handle_batch_download root meth uri objects 308 | | `Upload -> handle_batch_upload root meth uri objects 309 | 310 | let handle_post root meth uri body = 311 | let path = Uri.path uri in 312 | match parse_path path with 313 | | `Download_path _ | `Wrong_path -> 314 | respond_error_with_message ~meth ~code:`Not_found "Wrong path" 315 | | `Default_path oid -> handle_verify root meth oid 316 | | `Batch_path -> handle_batch root meth uri body 317 | | `Post_path -> 318 | Body.to_string body >>= fun body -> 319 | match Json.parse_oid_size body with 320 | | None -> respond_error_with_message ~meth ~code:`Bad_request "Invalid body" 321 | | Some (oid, size) -> 322 | check_object_file_stat ~root ~oid >>= function 323 | | Ok stat when (Unix.Stats.size stat = size) -> 324 | let url = get_download_url uri oid in 325 | respond_with_string ~meth ~code:`OK @@ Json.download url 326 | | Ok _ -> 327 | respond_error_with_message ~meth ~code:`Bad_request "Wrong object size" 328 | | Error _ -> 329 | let url = Uri.with_path uri @@ Filename.concat "/objects" oid in 330 | respond_with_string ~meth ~code:`Accepted @@ Json.upload url 331 | 332 | let handle_put root meth uri body req = 333 | let path = Uri.path uri in 334 | let headers = Request.headers req in 335 | match Header.get_content_range headers with 336 | | None -> respond_error ~code:`Bad_request 337 | | Some bytes_to_read -> 338 | match parse_path path with 339 | | `Download_path _ | `Post_path | `Wrong_path | `Batch_path -> 340 | respond_error_with_message ~meth ~code:`Not_found "Wrong path" 341 | | `Default_path oid -> 342 | check_object_file_stat ~root ~oid >>= function 343 | | Ok _ -> respond_ok ~code:`OK (* already exist *) 344 | | Error _ -> 345 | let filename = get_object_filename ~root ~oid in 346 | let temp_file = get_temp_filename ~root ~oid in 347 | make_objects_dir_if_needed ~root ~oid >>= fun () -> 348 | with_file_atomic ~temp_file filename ~f:(fun w -> 349 | let hash = SHA256.create () in 350 | Pipe.transfer (Body.to_pipe body) (Writer.pipe w) ~f:(fun str -> 351 | SHA256.feed hash str; 352 | str) >>| fun () -> 353 | let bytes_received = Int63.to_int64 (Writer.bytes_received w) in 354 | let hexdigest = SHA256.hexdigest hash in 355 | if bytes_received <> bytes_to_read 356 | then Error (sprintf "Incomplete upload of %s" oid) 357 | else if hexdigest <> oid 358 | then Error (sprintf "Content doesn't match SHA-256 digest: %s" oid) 359 | else (Ok ())) 360 | >>= function 361 | | Ok () -> respond_ok ~code:`Created 362 | | Error msg -> respond_error_with_message ~meth ~code:`Bad_request msg 363 | 364 | let serve_client ~root ~fix_uri ~auth ~body ~req = 365 | let uri = Request.uri req in 366 | let meth = Request.meth req in 367 | if Option.is_none (Uri.host uri) then 368 | respond_error_with_message ~meth ~code:`Bad_request "Wrong host" 369 | else if not (auth req) then 370 | respond_error_with_message ~meth ~code:`Unauthorized "The authentication credentials are incorrect" 371 | else 372 | let uri = fix_uri uri in 373 | match meth with 374 | | (`GET as meth) | (`HEAD as meth) -> handle_get root meth uri 375 | | `POST -> handle_post root meth uri body 376 | | `PUT -> handle_put root meth uri body req 377 | | _ -> respond_error ~code:`Method_not_allowed 378 | 379 | let serve_client_and_log_respond ~root ~fix_uri ~auth ~logger ~body (`Inet (client_host, _)) req = 380 | serve_client ~root ~fix_uri ~auth ~body ~req >>| fun (resp, log_info) -> 381 | let client_host = UnixLabels.string_of_inet_addr client_host in 382 | let meth = Code.string_of_method @@ Request.meth req in 383 | let path = Uri.path @@ Request.uri req in 384 | let version = Code.string_of_version @@ Request.version req in 385 | (match log_info with 386 | | `Log_ok status -> 387 | let status = Code.string_of_status status in 388 | Log.info logger "%s \"%s %s %s\" %s" client_host meth path version status 389 | | `Log_error (status, msg) -> 390 | let status = Code.string_of_status status in 391 | Log.error logger "%s \"%s %s %s\" %s \"%s\"" client_host meth path version status msg); 392 | resp 393 | 394 | let determine_mode cert key = 395 | match (cert, key) with 396 | | Some c, Some k -> return (`OpenSSL (`Crt_file_path c, `Key_file_path k)) 397 | | None, None -> return `TCP 398 | | _ -> 399 | eprintf "Error: must specify both certificate and key for HTTPS\n"; 400 | shutdown 0; 401 | Deferred.never () 402 | 403 | let mode_to_string = function 404 | | `OpenSSL _ -> "HTTPS" 405 | | `TCP -> "HTTP" 406 | 407 | let scheme_and_port mode port = 408 | let with_default_port default_port = 409 | if port = default_port then None else Some port 410 | in 411 | match mode with 412 | | `OpenSSL _ -> Some "https", (with_default_port 443) 413 | | `TCP -> Some "http", (with_default_port 80) 414 | 415 | let authorize_with_pam pam req = 416 | match Request.headers req |> Header.get_authorization with 417 | | Some `Basic (user, passwd) -> 418 | (try Simple_pam.authenticate pam user passwd; true with _ -> false) 419 | | None | Some `Other _ -> false 420 | 421 | let start_server root host port cert key pam verbose () = 422 | let root = Filename.concat root "/.lfs" in 423 | mkdir_if_needed root >>= fun () -> 424 | mkdir_if_needed @@ Filename.concat root "/objects" >>= fun () -> 425 | mkdir_if_needed @@ Filename.concat root "/temp" >>= fun () -> 426 | determine_mode cert key >>= fun mode -> 427 | let logging_level = if verbose then `Info else `Error in 428 | let logger = 429 | Log.create 430 | ~on_error:`Raise 431 | ~output:[Log.Output.stdout ()] 432 | ~level:logging_level in 433 | Log.raw logger "Listening for %s on %s:%d" (mode_to_string mode) host port; 434 | Unix.Inet_addr.of_string_or_getbyname host 435 | >>= fun host -> 436 | let listen_on = Tcp.Where_to_listen.create 437 | ~socket_type:Socket.Type.tcp 438 | ~address:(`Inet (host, port)) 439 | ~listening_on:(fun _ -> port) 440 | in 441 | let handle_error address ex = 442 | match address with 443 | | `Unix _ -> assert false 444 | | `Inet (client_host, _) -> 445 | let client_host = UnixLabels.string_of_inet_addr client_host in 446 | match Monitor.extract_exn ex with 447 | | Failure err -> Log.error logger "%s Failure: %s" client_host err 448 | | Unix.Unix_error (_, err, _) -> Log.error logger "%s Unix_error: %s" client_host err 449 | | ex -> Log.error logger "%s Exception: %s" client_host (Exn.to_string ex) 450 | in 451 | let fix_uri = 452 | let scheme, port = scheme_and_port mode port in 453 | fun uri -> 454 | let uri = Uri.with_scheme uri scheme in 455 | Uri.with_port uri port 456 | in 457 | let auth = match pam with 458 | | None -> (fun _req -> true) 459 | | Some pam -> authorize_with_pam pam 460 | in 461 | Signal.handle [Signal.term; Signal.int] ~f:(fun _ -> 462 | Log.raw logger "Shutting down..."; 463 | Shutdown.shutdown 0); 464 | Server.create 465 | ~on_handler_error:(`Call handle_error) 466 | ~mode:(mode :> Conduit_async.server) 467 | listen_on 468 | (serve_client_and_log_respond ~root ~fix_uri ~auth ~logger) 469 | >>= fun _ -> Deferred.never () 470 | 471 | let () = 472 | Command.async_spec 473 | ~summary:"Start Git LFS server" 474 | ~readme:(fun () -> "") 475 | ~extract_exn:false 476 | Command.Spec.( 477 | empty 478 | +> anon (maybe_with_default "." ("root" %: string)) 479 | +> flag "-s" (optional_with_default "127.0.0.1" string) ~doc:"address IP address to listen on" 480 | +> flag "-p" (optional_with_default 8080 int) ~doc:"port TCP port to listen on" 481 | +> flag "-cert" (optional file) ~doc:"file File of certificate for https" 482 | +> flag "-key" (optional file) ~doc:"file File of private key for https" 483 | +> flag "-pam" (optional string) ~doc:"service PAM service name for user authentication" 484 | +> flag "-verbose" (no_arg) ~doc:" Verbose logging" 485 | ) 486 | start_server 487 | |> fun command -> Command.run ~version:Lfs_config.version ~build_info:"Master" command 488 | 489 | --------------------------------------------------------------------------------