├── .gitignore ├── .merlin ├── config.ml ├── disk └── secret ├── logger ├── build ├── log-runner ├── logger.ml └── simple-logger ├── opam-full.txt ├── page.ml ├── pinata.ukvm.xz ├── test.ml └── unikernel.ml /.gitignore: -------------------------------------------------------------------------------- 1 | /_build 2 | 3 | /log 4 | /Makefile 5 | /main.ml 6 | /static*.ml* 7 | /key_gen.ml 8 | /main.native 9 | /mir-* 10 | /*.xen 11 | 12 | /*.xml 13 | /*.xe 14 | /*.xl 15 | /*.xl.in 16 | 17 | /*-mellon 18 | 19 | /tls 20 | 21 | /logger/logger.cmi 22 | /logger/logger.cmx 23 | /logger/logger.o 24 | /logger/logger 25 | /logger/logger.xz 26 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | B _build/** 2 | 3 | PKG cstruct lwt tls tls.mirage tyxml tcpip mirage mirage-types 4 | PKG ptime logs-syslog logs-syslog.mirage x509 5 | -------------------------------------------------------------------------------- /config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let net = 4 | if_impl Key.is_unix 5 | (socket_stackv4 [Ipaddr.V4.any]) 6 | (static_ipv4_stack ~arp:farp default_network) 7 | 8 | let secret_k = 9 | let doc = Key.Arg.info ~doc:"Secret" ["s"; "secret"] in 10 | Key.(create "secret" Arg.(opt string ".oO( SEKRIT )Oo." doc)) 11 | 12 | let test_k = 13 | let doc = Key.Arg.info ~doc:"test mode" ["test"] in 14 | Key.(create "test" Arg.(flag doc)) 15 | 16 | let logger = syslog_udp ~config:(syslog_config ~truncate:1484 "pinata") net 17 | 18 | let () = 19 | let keys = Key.([ abstract secret_k ; abstract test_k ]) 20 | and packages = [ 21 | package ~sublibs:["mirage"] "tls"; 22 | package "tyxml"; 23 | package "logs"; 24 | package "ptime"] 25 | in 26 | register "btc-piñata" [ 27 | foreign 28 | ~deps:[ abstract nocrypto ; abstract logger ; abstract app_info ] 29 | ~keys 30 | ~packages 31 | "Unikernel.Main" 32 | (stackv4 @-> pclock @-> job) 33 | $ net 34 | $ default_posix_clock 35 | ] 36 | -------------------------------------------------------------------------------- /disk/secret: -------------------------------------------------------------------------------- 1 | .oO( SEKRIT )Oo. 2 | -------------------------------------------------------------------------------- /logger/build: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | ocamlfind ocamlopt \ 6 | -linkpkg \ 7 | -syntax camlp4o \ 8 | -package lwt.syntax,lwt.unix \ 9 | logger.ml -o logger 10 | 11 | xz < logger > logger.xz 12 | -------------------------------------------------------------------------------- /logger/log-runner: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | cat >> "tcp-${TCPREMOTEIP}:${TCPREMOTEPORT}.log" 3 | -------------------------------------------------------------------------------- /logger/logger.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | 3 | let string_of_sockaddr = function 4 | | Unix.ADDR_UNIX addr -> addr 5 | | Unix.ADDR_INET (addr, port) -> 6 | Unix.string_of_inet_addr addr ^ ":" ^ string_of_int port 7 | 8 | let listen ~addr:(host, port) = 9 | let open Lwt_unix in 10 | let s = socket PF_INET SOCK_STREAM 0 in 11 | setsockopt s SO_REUSEADDR true; 12 | bind s (ADDR_INET (host, port)); 13 | listen s 10; 14 | s 15 | 16 | let accept socket = 17 | Lwt_unix.accept socket >|= fun (s, peer) -> 18 | (Lwt_io.(of_fd ~mode:input s, of_fd ~mode:output s), peer) 19 | 20 | let logger ~file = 21 | let (stream, push) = Lwt_stream.create () in 22 | let write msg = 23 | try_lwt 24 | lwt ch = 25 | Lwt_io.open_file 26 | ~flags:Lwt_unix.([O_WRONLY; O_APPEND; O_CREAT]) 27 | ~mode:Lwt_io.output 28 | file in 29 | Lwt_io.write_line ch msg >> Lwt_io.close ch 30 | with exn -> 31 | Lwt_io.printf "ERROR writing message: %s\n%!" msg in 32 | async (fun () -> Lwt_stream.iter_s write stream); 33 | return (fun msg -> push (Some msg)) 34 | 35 | let rec forever act = act () >> forever act 36 | 37 | let main ~addr ~file = 38 | let server = listen ~addr in 39 | lwt sink = logger ~file in 40 | forever @@ fun () -> 41 | lwt ((ic, _), peer) = accept server in 42 | Lwt_io.printf "[accept] %s\n%!" (string_of_sockaddr peer) 43 | >|= fun () -> 44 | async (fun () -> 45 | Lwt_stream.iter sink (Lwt_io.read_lines ic)) 46 | 47 | let () = 48 | let (port, file) = 49 | Sys.(int_of_string argv.(1), argv.(2)) in 50 | Lwt_main.run (main ~addr:(Unix.inet_addr_any, port) ~file) 51 | 52 | -------------------------------------------------------------------------------- /logger/simple-logger: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | tcpserver -H -R -v 0 12345 `dirname $0`/log-runner 3 | -------------------------------------------------------------------------------- /opam-full.txt: -------------------------------------------------------------------------------- 1 | asn1-combinators 0.2.0 2 | arp 0.2.0 3 | cpuid 0.1.1 4 | cstruct 3.2.1 5 | cstruct-lwt 3.2.1 6 | duration 0.1.1 7 | fmt 0.8.5 8 | io-page 2.0.1 9 | logs 0.6.2 10 | logs-syslog 0.1.0 11 | lwt 3.2.0 12 | mirage-block 1.1.0 13 | mirage-block-lwt 1.1.0 14 | mirage-bootvar-solo5 0.2.0 15 | mirage-channel 3.1.0 16 | mirage-channel-lwt 3.1.0 17 | mirage-clock 1.3.0 18 | mirage-clock-freestanding 1.3.0 19 | mirage-clock-lwt 1.3.0 20 | mirage-console 2.3.5 21 | mirage-console-lwt 2.3.5 22 | mirage-console-solo5 0.2.0 23 | mirage-device 1.1.0 24 | mirage-entropy 0.4.0 25 | mirage-flow 1.3.0 26 | mirage-flow-lwt 1.4.0 27 | mirage-fs 1.1.1 28 | mirage-fs-lwt 1.1.1 29 | mirage-kv 1.1.1 30 | mirage-kv-lwt 1.1.0 31 | mirage-logs 0.3.0 32 | mirage-net 1.1.1 33 | mirage-net-lwt 1.1.0 34 | mirage-net-solo5 0.2.0 35 | mirage-profile 0.8.2 36 | mirage-protocols 1.2.0 37 | mirage-protocols-lwt 1.2.0 38 | mirage-random 1.1.0 39 | mirage-runtime 3.0.7 40 | mirage-solo5 0.2.1 41 | mirage-stack 1.1.0 42 | mirage-stack-lwt 1.1.0 43 | mirage-time 1.1.0 44 | mirage-time-lwt 1.1.0 45 | mirage-types 3.0.7 46 | mirage-types-lwt 3.0.7 47 | nocrypto 0.5.4 48 | ocaml-freestanding 0.2.3 49 | ocplib-endian 1.0 50 | parse-argv 0.1.0 51 | ptime 0.8.3 52 | randomconv 0.1.0 53 | syslog-message 0.0.2 54 | tcpip 3.3.1 55 | tyxml 4.1.0 56 | zarith-freestanding 1.7 57 | 58 | gmp 6.1.2 59 | ocaml 4.06.0 60 | 61 | mirage-os-shim https://github.com/hannesm/mirage-os-shim.git#4.06 62 | solo5-kernel-ukvm https://github.com/solo5/Solo5#62aa72aec39dbfc129496de083852b8639f9b4d3 63 | tls https://github.com/mirleft/ocaml-tls.git#pinata 64 | x509 https://github.com/mirleft/ocaml-x509.git#pinata 65 | 66 | -------------------------------------------------------------------------------- /page.ml: -------------------------------------------------------------------------------- 1 | open Tyxml.Html 2 | 3 | let btc_address = "183XuXTTgnfYfKcHbJ4sZeF46a49Fnihdh" 4 | 5 | let header t = 6 | head 7 | (title (pcdata t)) 8 | ([meta ~a:[a_charset "utf-8"] () ; 9 | style [pcdata 10 | {___|body { 11 | font-family: monospace; 12 | color: #333; 13 | } 14 | .content { 15 | margin: 10% 0 10% 15%; 16 | width: 45%; 17 | } 18 | .content h3 { 19 | font-size: 35px; 20 | } 21 | a, a:visited { 22 | color: #333; 23 | text-decoration: none; 24 | font-weight: bold; 25 | } 26 | #logo { 27 | z-index: -1; 28 | opacity: 0.9; 29 | position: fixed; 30 | width: 40%; 31 | top: 0; 32 | right: 0; 33 | }|___} ] 34 | ]) 35 | 36 | let link ~href child = a ~a:[a_href href] [pcdata child ] 37 | 38 | let content ca_root = 39 | let a_chain = link 40 | ~href:("https://blockchain.info/address/" ^ btc_address) 41 | btc_address 42 | and a_mirage = link ~href:"https://mirage.io" "MirageOS" 43 | and a_solo5 = link ~href:"https://github.com/solo5/Solo5" "Solo5" 44 | and a_pinata = link ~href:"https://github.com/mirleft/btc-pinata" "BTC Piñata" 45 | and a_tls = link ~href:"https://github.com/mirleft/ocaml-tls" "TLS" 46 | and a_x509 = link ~href:"https://github.com/mirleft/ocaml-x509" "X.509" 47 | and a_path_val = link 48 | ~href:"https://tools.ietf.org/html/rfc5280#page-71" 49 | "path validation" 50 | and a_ipredator = link ~href:"https://www.ipredator.se" "IPredator" 51 | and a_full_list = link ~href:"https://raw.githubusercontent.com/mirleft/btc-pinata/master/opam-full.txt" "full list" 52 | and a_unikernel = link ~href:"https://raw.githubusercontent.com/mirleft/btc-pinata/master/pinata.ukvm.xz" "toy unikernel" 53 | and a_31c3 = link ~href:"http://media.ccc.de/browse/congress/2014/31c3_-_6443_-_en_-_saal_2_-_201412271245_-_trustworthy_secure_modular_operating_system_engineering_-_hannes_-_david_kaloper.html#video" "31c3 talk" 54 | and a_schneier = link ~href:"https://www.schneier.com/crypto-gram/archives/1998/1215.html#contests" "bounties" 55 | and a_https = link ~href:"https://ownme.ipredator.se" "HTTPS" 56 | and a_recap = link ~href:"https://mirage.io/blog/bitcoin-pinata-results" "first five months of the Piñata" 57 | and a_nqsb = link ~href:"https://nqsb.io" "not quite so broken" 58 | and a_not = link ~href:"https://nqsb.io" "https://nqsb.io" 59 | in 60 | let ca = pre [ pcdata (Cstruct.to_string ca_root) ] 61 | in 62 | 63 | div ~a:[a_class ["content"]] [ 64 | h3 [ pcdata "You have reached the BTC Piñata." ] ; 65 | br () ; 66 | p [ pcdata "BTC Piñata knows the private key to the bitcoin address " ; a_chain ; pcdata ". If you break the Piñata, you get to keep what's inside." ] ; 67 | p [ pcdata "Here are the rules of the game:" ] ; 68 | ul [ 69 | li [ p [ pcdata "You can connect to port 10000 using TLS. Piñata will send the key and hang up." ] ] ; 70 | li [ p [ pcdata "You can connect to port 10001 using TCP. Piñata will immediately close the connection and connect back over TLS to port 40001 on the initiating host, send the key, and hang up." ] ] ; 71 | li [ p [ pcdata "You can connect to port 10002 using TCP. Piñata will initiate a TLS handshake over that channel serving as a client, send the key over TLS, and hang up." ] ] 72 | ] ; 73 | p [ pcdata "And here's the kicker: in both the client and server roles, Piñata requires the other end to present a certificate. Authentication is performed using standard " ; a_path_val ; pcdata " with a single certificate as the trust anchor. And no, you can't have the certificate key." ] ; 74 | p [ pcdata "It follows that it should be impossible to successfully establish a TLS connection as long as Piñata is working properly. To get the spoils, you have to smash it." ] ; 75 | p [ pcdata "Before you ask: yes, Piñata will talk to itself and you can enjoy watching it do so." ] ; 76 | br () ; 77 | p [ a_pinata ; pcdata " is a " ; a_mirage ; pcdata " unikernel using " ; a_nqsb ; pcdata " software. It is written in OCaml, runs directly on FreeBSD VMM (using " ; a_solo5 ; pcdata "), and is using native OCaml " ; a_tls ; pcdata " and " ; a_x509 ; pcdata " implementations." ] ; 78 | p [ pcdata "The " ; a_full_list ; pcdata " of installed software and a " ; a_unikernel ; pcdata " without secrets are available. There is no need to use the old automated tools on Piñata - roll your own instead. This challenge started in February 2015, and will run until the above address no longer contains the 10 bitcoins it started with, or until we lose interest. Update from March 2018: our donors transferred nearly all the bitcoins to other projects." ] ; 79 | p [ pcdata "Why are we doing this? At the beginning of 2014 we started to develop a " ; a_nqsb ; pcdata " TLS implementation from scratch. You can read more about it on " ; a_not ; pcdata " or watch our " ; a_31c3 ; pcdata " about it. We want to boost our confidence in the TLS implementation we've developed and show that robust systems software can be written in a functional language. We recapitulated the " ; a_recap ; pcdata "." ] ; 80 | p [ pcdata "We are well aware that " ; a_schneier ; pcdata " can only disprove the security of a system, and never prove it. We won't take home the message that we are 'unbreakable', 'correct', and especially not 'secure'. But we don't rely on obscurity and have a fully transparent implementation of a well-known protocol. Our prize is publicly observable in the blockchain. If you observe a transaction, it is taken. So if this contest attracts attention and we are still standing at the end of it, we will gain that extra inch of confidence in our work." ] ; 81 | p [ pcdata "This page is also available via " ; a_https ; pcdata ". It will present a certificate signed by the same authority that Piñata expects to sign all of the incoming requests, so your browser will complain. The purpose of HTTPS is to allow checking of interoperability with our TLS implementation." ] ; 82 | br () ; 83 | p [ pcdata "Bitcoins and the hosting for this challenge are sponsored by " ; a_ipredator ; pcdata ", a friendly virtual private network provider!" ] ; 84 | p [ pcdata "If you have any results or further questions, don't hesitate to contact us. Address is anything at nqsb dot io." ] ; 85 | br () ; 86 | p [ pcdata "This is the CA:" ] ; 87 | ca 88 | ] 89 | 90 | let logo = 91 | {___||___} 110 | 111 | let render ca_root = 112 | let buf = Buffer.create 500 in 113 | let fmt = Format.formatter_of_buffer buf in 114 | pp () fmt @@ 115 | html 116 | (header "BTC Piñata") 117 | (body [Unsafe.data logo ; content ca_root]) ; 118 | Cstruct.of_string @@ Buffer.contents buf 119 | -------------------------------------------------------------------------------- /pinata.ukvm.xz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mirleft/btc-pinata/9e091512abca8b4578bc41bf64576499f1c8f07f/pinata.ukvm.xz -------------------------------------------------------------------------------- /test.ml: -------------------------------------------------------------------------------- 1 | 2 | let testkey = 3 | {___|-----BEGIN RSA PRIVATE KEY----- 4 | MIIJKQIBAAKCAgEA6NYWGUldfWh2MTdQaUB+G0+EDZn6TWF0K6TMObd2mhe1r4YI 5 | 2h+Q9cep85f97yWug6dr2l9LUCqPLuvL7U3rmd5g2LIUab46ryegxBEn9Sg4jq3v 6 | eWBAajZ6vsNqFaLMTVQ4a12TZn81GxQQOg3JWE1snDEm9JwH1P1dj0hd0uNff4Ff 7 | /Zz+KoopHcPdQh/sB3wVl2w7IGu2cEVK2xUuHgTpY8eJl32JTWojYtYtRs9tSuOg 8 | 5vAJ/Zz1cyBjxct1BvO74nibTSrbsYVikh1fs4IJHQTJYpFyX0eEdUb72MKj2TcE 9 | 3z5LVXc04/oNhnmQF6rUHxj5s54L0Ginuu7T8yywLvfbB/VpNqz0QpHMYheEfnye 10 | vYBDffOePHNBYfSMowjiOTAaACbA1A/2k8rG7bscybaDnrWPLZHJPcKIZQ0IBBlI 11 | Mfj6GAEWmxurgzGDl+cBGfMyjGbCk35ouplSX5sEsOc+ctk8p1Yo/3UbVhkNCOpO 12 | y7wyS5N5j+C0p1064sBOduehll+RKY8k4krG3HDn13+a32kuuCd1pMOYNRDrGbC/ 13 | RO/jNjV8FqqAikmJrIBaH4ajZXW6J0Y6oLOUMpVoM+/2HZqsYjTeo8hGnrHWzWL0 14 | qQEBnBlYtGmxHQCy5WEWvmZZpUAVTjR5ETvGFGr/ZVDvvWGYDTMtcvfeYFMCAwEA 15 | AQKCAgEA3/5VdC4oSqVcTyyvpxHsP8nXeF5Rdm/ymqoH7t6YstVsbFe93FnR0yEq 16 | VrY6DP9rTCycjZBvm8fVx4YAwWLc7UIKWW24RaJEQo0VFIqMrkTrZBfg8huu3H9c 17 | xniobfgYI6yKOn/jdg+av1ol4jOxJ8oUWo7OszQINNcqUtWDrYYgMUH9XrbRrYsM 18 | 0x3ClgKvxuOQwgPVPfNhp9CBmxJdM3P2M4+axqp2lIsvT75MAHs84XbrLEBw3BNL 19 | 7l2Sno6FHxMMBWuRvEMm5zkzAu5PSxomOkyIkNLr/M2ImGqZjoZxql5LyZjcUHRF 20 | 5ayBpoT8IkitmN0mG65IH08PTb7FFq55E2rX/5SoHlP6zaVCEkizxGRlBgcQ18wG 21 | rc4bbUz9nDRH5kYnYQSExFinQJv6VYsn+P92Doafa+LawJtMDRuaGlstJNNg+xG4 22 | ITaJMoYrNqY+U+rpjWH7FKlu06F7abEHnaSS7bx5dyn61dAu2mD730BfJ7Toggff 23 | UdwRyOUp1+qkHzETxTrrMYLtFrfY4EcjxInOxoHEHs+I3Ec5/cgUJgPrGifJDoN8 24 | 7K7GR+BqBzGIb0iF2aNx2+Ji2bszGvnH/xX3UTGUwwkDcwWoq6S9FxyEPqwgwZUr 25 | n8VSTlbfUDTyt1Wf2Am/z671UfTJ1/Fq85HoppOgPZIzy/2sBIECggEBAPafoJX4 26 | QtV9AaprlyYXPNTPIHrWlSLkNZnjOpgod9v8tEg1tMzdyX/TSOoKb8y5oxdLQ2IN 27 | 4cCrfseQBWP7dwC1LBegeMorgc/BbBi77JqfOQiw9G2v/xwhhI+ATrfZtBb6Ksoj 28 | sdJtw4VWIwwINhkGrY0ezz8ZUqSTTlnMsNjwKIpXwzCUM3s2yvMnCyYrnMxY7FJU 29 | gzO358ENd9xGNG4MEPNJ0VG995wf5oRwLi2SGWfIFpeEY41mnhGhgy3vxS13q0JE 30 | zc8R7JCD2qbOekj/jGPtJ16bksxCJfSW4FeaIwE1oqVVSvPCDWaSNizJM19WSYJt 31 | kvr97ain7dKW2CkCggEBAPGwRLHQJbX2uDFeuir4Qfbmjv2u6I0YNsoxh+1QvTwm 32 | 6N2ROIwbzHLdySLzq+vhwgacI1LOnssPMzbzRRQD4bS4O2qDT0kYQ83r1ClSPEGZ 33 | tGQGsXyODL2/ZzRHHy/Kzpywxzm4ScAxZYoh1BUehCV8LCYR6BKd5d0wzD+4fB/X 34 | v66noWfpRZj1Mu1VzFaqKGrRuL2E6+mKTTfTzyghnVvz3RUYCa2ozu+WyXyem/Gq 35 | jv0XV7OwQ3QOBlA/FnLY7XemPcfQypQAHPjRK6XSw9j4Rg6bjUMHvzckDKaZMukp 36 | wHDS3QcN2OlAiXlkh4kkQxEKgWT0FQq+kIH5EfRLdBsCggEAATcqMHMHyUuTbYaY 37 | ORzWNOpMa66RD5n2VarUCBny9Ueaj9yL5pKVQqcE7fpdMLIdhqjdTSdqXGu79TnV 38 | fPepT3yVGgy1a7GpMx/t63VJpj1wp4VPvxal+DqGD7r/KFLPW2miOlrQrovR8d9J 39 | zu5fbeIlitODC/mQ+bSsJy8mE/ujB4OFN8ETO+E6QNaJbIe8fxlVGNbHysJ2RvJN 40 | C+3gpkYy8zAC8xcvmDpkBXUUFS9qJqPK0LZbU0AVOVsFbX2ICEBVvL7gEMwy0UeF 41 | FVthKOjxhTCPCB1WLOGKlFkGBAiDcacVBSGVe/wR2taPo8reEPM464akuc30lOc2 42 | +dm6eQKCAQEAnGpFqwZYwZDw2BLETXbpyg6g0BFYs6fOHcE8hRvRvJI59ts7S4Ha 43 | KSTcPWCSDVDIL1rxiW/rWON3c8KxHCj+8+Sfn2ln8JhhmW1cm3l7QcFl+65RQ5jz 44 | KgIrmqvExTttx/6okPRx1o6hdmo6RYjAYTohoGnKVfIWh7ZDGaIdwsXwaepXDVbt 45 | EfbuhKcYXaY2Dhu4gf76ZuR44P6VfRV0L8R9el9aNCeh9XES6TIFHrwRWj63JbWX 46 | kg5Zi6mor58w4FSYey7nTC1ekrFcnC7xTQQw4tdM7uqel+MexNs1Fa1NvDbbkOsn 47 | TJ3V2thy1xC+ztKLt3g3/gIip9s4AXCrrQKCAQBaLYP9Z4MAYemFjd/SxwAzTtEf 48 | qeWFyGKZ0ZSdr2lgJ76KiNAjJqDc0VYAhi+3Qwavb31EcSgSRwg//C1jJhBO7IHp 49 | zsKXU0CI3ZAixkvMw0EyBD/9KWVatb/WpJbLaGd3Yom9/QDAWI5Q8lDtlp2qY76W 50 | 5KLfHPkCEUKK2MtMinhCJ2aVhIXXF0dh272gJnOOZ5fxOV3nvQjWofoc6DlVkHF1 51 | YGSCvGASwvB8g/vhU+6Z4eJTTAzEjPzrV1DrGmutZaSThbjeW3UNFdPEchhIndXv 52 | oz/WhWiGgMGbDVHPVRp/1BAU1Czehc8iFtTeRmIpTJ+y2r0BghA2eb74Shfa 53 | -----END RSA PRIVATE KEY-----|___} 54 | 55 | let testcert = 56 | {___|-----BEGIN CERTIFICATE----- 57 | MIIE2DCCAsCgAwIBAgIIXAI6qAIsyrYwDQYJKoZIhvcNAQELBQAwGDEWMBQGA1UE 58 | AwwNQlRDIFBpbmF0YSBDQTAeFw0xNjA0MjMxODU2MzZaFw0xNzA0MjMxODU2MzZa 59 | MBgxFjAUBgNVBAMMDUJUQyBQaW5hdGEgQ0EwggIiMA0GCSqGSIb3DQEBAQUAA4IC 60 | DwAwggIKAoICAQDo1hYZSV19aHYxN1BpQH4bT4QNmfpNYXQrpMw5t3aaF7Wvhgja 61 | H5D1x6nzl/3vJa6Dp2vaX0tQKo8u68vtTeuZ3mDYshRpvjqvJ6DEESf1KDiOre95 62 | YEBqNnq+w2oVosxNVDhrXZNmfzUbFBA6DclYTWycMSb0nAfU/V2PSF3S419/gV/9 63 | nP4qiikdw91CH+wHfBWXbDsga7ZwRUrbFS4eBOljx4mXfYlNaiNi1i1Gz21K46Dm 64 | 8An9nPVzIGPFy3UG87vieJtNKtuxhWKSHV+zggkdBMlikXJfR4R1RvvYwqPZNwTf 65 | PktVdzTj+g2GeZAXqtQfGPmzngvQaKe67tPzLLAu99sH9Wk2rPRCkcxiF4R+fJ69 66 | gEN98548c0Fh9IyjCOI5MBoAJsDUD/aTysbtuxzJtoOetY8tkck9wohlDQgEGUgx 67 | +PoYARabG6uDMYOX5wEZ8zKMZsKTfmi6mVJfmwSw5z5y2TynVij/dRtWGQ0I6k7L 68 | vDJLk3mP4LSnXTriwE5256GWX5EpjyTiSsbccOfXf5rfaS64J3Wkw5g1EOsZsL9E 69 | 7+M2NXwWqoCKSYmsgFofhqNldbonRjqgs5QylWgz7/YdmqxiNN6jyEaesdbNYvSp 70 | AQGcGVi0abEdALLlYRa+ZlmlQBVONHkRO8YUav9lUO+9YZgNMy1y995gUwIDAQAB 71 | oyYwJDASBgNVHRMBAf8ECDAGAQH/AgEBMA4GA1UdDwEB/wQEAwICBDANBgkqhkiG 72 | 9w0BAQsFAAOCAgEA4xVBlQIHI4VQHVkl4Xk9gnoZ/kKbyKs8N+SVoekWCGI8MLNk 73 | ThTD5hdEXzLpXheS+qWrKeLO0zpC8j2dZ5wRgtGvbmsN0nrnPSXS8AKwDOOLQc9X 74 | T/OVQ31UVEx80+R+FBo3FDbO0mTgvKHEXlOXDyBvo+WkY4L5HvydBfSqrrGXqOwA 75 | ij6PQHMzL2EeNOVvgjQ4M5Y+Pe57DdjC6DGMY66nK2+t1iMPNk9xTZYoWmScFg3R 76 | 191IUuCRvFTHmDV3sBX8MJjzjyd4NWEhSaNQSsMRFPYF+FPOs4Lro38MhezCQ38j 77 | IrVGHSKWoyAt3qo5vnsujqONhPwXhyKrUfyfpO/26jDPiFcHxUalsjwichrUBY7t 78 | ijOxF18Qh0EiS/UIyTwgtD2q7IrG9nDs9iiptuxoihnNzLYBdBvAgZsKscpsUAsV 79 | XxDk9G49ylYyCDL9MF9kIG75l5IfoiZkiXb1NljOkiiWJ0i74NNQB0gLtJYhN3dj 80 | Ay1vvsXQXAPN3pEvVSddBLCpbzXtASzHbt8kcE7vJRIN+5vzvViZ8DOW7ytkk8mo 81 | eUknbBpAGKMrOWSGYAYsXU6du5UkZh5HLMhVxIrXZKR4ZmsoQUg2sgb+Qb1OgyWX 82 | vBVnNQufMzcPTFs03ZnKB6RhwVrCYXO9vFkGgM+jBPr3lAANnTtuyptcpfk= 83 | -----END CERTIFICATE-----|___} 84 | 85 | let ca = 86 | let open X509.Encoding.Pem in 87 | (Private_key.of_pem_cstruct1 (Cstruct.of_string testkey), 88 | Certificate.of_pem_cstruct1 (Cstruct.of_string testcert)) 89 | -------------------------------------------------------------------------------- /unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Mirage_types_lwt 3 | 4 | module Main (S : STACKV4) (CLOCK : PCLOCK) = 5 | struct 6 | 7 | module TCP = S.TCPV4 8 | module TLS = Tls_mirage.Make (TCP) 9 | 10 | let prefix tag (ip, port) = 11 | Printf.sprintf "[%s] %s:%d" tag (Ipaddr.V4.to_string ip) port 12 | 13 | let log prefix msg = 14 | Logs.info (fun m -> m "%s %s" prefix msg) 15 | 16 | let tls_accept ~tag ?(trace=false) cfg tcp ~f = 17 | let pre = prefix tag (TCP.dst tcp) in 18 | let log = log pre in 19 | let with_tls_server k = 20 | match trace with 21 | | true -> 22 | let trace s = log (Sexplib.Sexp.to_string s) in 23 | TLS.server_of_flow ~trace cfg tcp >>= k 24 | | false -> TLS.server_of_flow cfg tcp >>= k 25 | in 26 | with_tls_server @@ function 27 | | Error e -> Logs.warn (fun f -> f "%s TLS failed %a" pre TLS.pp_write_error e) ; TCP.close tcp 28 | | Ok tls -> log "TLS ok" ; f tls >>= fun _ -> TLS.close tls 29 | 30 | let tls_connect ~tag stack cfg addr ~f = 31 | let pre = prefix tag addr in 32 | let log = log pre in 33 | TCP.create_connection (S.tcpv4 stack) addr >>= function 34 | | Error e -> Logs.warn (fun f -> f "%s connection failed %a" pre TCP.pp_error e) ; return_unit 35 | | Ok tcp -> 36 | let trace s = log (Sexplib.Sexp.to_string s) in 37 | TLS.client_of_flow ~trace cfg tcp >>= function 38 | | Error e -> Logs.warn (fun f -> f "%s TLS failed %a" pre TLS.pp_write_error e) ; TCP.close tcp 39 | | Ok tls -> log "TLS ok" ; f tls >>= fun _ -> TLS.close tls 40 | 41 | let h_as_server secret cfg = 42 | tls_accept ~trace:true ~tag:"server" cfg 43 | ~f:(fun tls -> TLS.write tls secret) 44 | 45 | let h_as_client stack secret cfg tcp = 46 | let (ip, _) as addr = TCP.dst tcp in 47 | let tag = "client" in 48 | let pre = prefix tag addr in 49 | log pre "received TCP" ; 50 | TCP.close tcp >>= fun () -> 51 | tls_connect ~tag stack cfg (ip, 40001) ~f:(fun tls -> TLS.write tls secret) 52 | 53 | let h_as_rev_client secret cfg tcp = 54 | let pre = prefix "rev-client" (TCP.dst tcp) in 55 | let log = log pre in 56 | let trace s = log (Sexplib.Sexp.to_string s) in 57 | TLS.client_of_flow ~trace cfg tcp >>= function 58 | | Error e -> Logs.warn (fun f -> f "%s TLS failed %a" pre TLS.pp_write_error e) ; TCP.close tcp 59 | | Ok tls -> log "TLS ok" ; TLS.write tls secret >>= fun _ -> TLS.close tls 60 | 61 | let http_header ~status xs = 62 | let headers = List.map (fun (k, v) -> k ^ ": " ^ v) xs in 63 | let lines = status :: headers @ [ "\r\n" ] in 64 | Cstruct.of_string (String.concat "\r\n" lines) 65 | 66 | let header len = http_header 67 | ~status:"HTTP/1.1 200 OK" 68 | [ ("Content-Type", "text/html; charset=UTF-8") ; 69 | ("Content-lengt", string_of_int len) ; 70 | ("Connection", "close") ] 71 | 72 | let h_notice data tcp = 73 | let pre = prefix "web" (TCP.dst tcp) in 74 | let log = log pre in 75 | let len = Cstruct.len data in 76 | TCP.writev tcp [ header len; data ] >>= function 77 | | Error e -> Logs.warn (fun f -> f "%s tcp error %a" pre TCP.pp_write_error e) ; TCP.close tcp 78 | | Ok () -> log "responded" ; TCP.close tcp 79 | 80 | let h_as_web_server data cfg = 81 | let len = Cstruct.len data in 82 | tls_accept ~tag:"web-server" cfg 83 | ~f:(fun tls -> TLS.writev tls [ header len; data ] ) 84 | 85 | let valid days now = 86 | match Ptime.(add_span now (Span.unsafe_of_d_ps (days, 0L))) with 87 | | Some expire -> (now, expire) 88 | | None -> assert false 89 | 90 | let rsa_key ?(bits = 4096) () = 91 | `RSA (Nocrypto.Rsa.generate bits) 92 | 93 | let generate_ca now () = 94 | let valid_from, valid_until = valid 365 now 95 | and cakey = rsa_key ~bits:4096 () 96 | and caname = [`CN "BTC Piñata CA"] in 97 | let req = X509.CA.request caname cakey in 98 | let extensions = [(true, `Basic_constraints (true, Some 1)); 99 | (true, `Key_usage [`Key_cert_sign])] 100 | in 101 | (cakey, 102 | X509.CA.sign req ~valid_from ~valid_until ~extensions cakey caname) 103 | 104 | let generate_certs now (cakey, cacert) () = 105 | let valid_from, valid_until = valid 365 now 106 | and caname = X509.subject cacert in 107 | let gen_cert name extensions = 108 | let key = rsa_key () in 109 | let req = X509.CA.request [`CN name] key in 110 | let cert = X509.CA.sign req ~valid_from ~valid_until ~extensions cakey caname in 111 | ([cert; cacert], match key with `RSA k -> k) 112 | and extensions eku = 113 | [(true, `Key_usage [ `Digital_signature ; `Key_encipherment ]); 114 | (true, `Basic_constraints (false, None)) ; 115 | (true, `Ext_key_usage [eku])] 116 | in 117 | (cacert, 118 | gen_cert "BTC Piñata server" (extensions `Server_auth), 119 | gen_cert "BTC Piñata client" (extensions `Client_auth), 120 | gen_cert "ownme.ipredator.se" (extensions `Server_auth)) 121 | 122 | let tls_init clock = 123 | let now = Ptime.v (CLOCK.now_d_ps clock) in 124 | let cacert, s_cert, c_cert, w_cert = 125 | if Key_gen.test () then 126 | generate_certs now Test.ca () 127 | else 128 | generate_certs now (generate_ca now ()) () 129 | in 130 | let authenticator = X509.Authenticator.chain_of_trust ~time:now [cacert] in 131 | let cacert = X509.Encoding.Pem.Certificate.to_pem_cstruct1 cacert in 132 | Tls.Config.( 133 | cacert, 134 | server ~authenticator ~certificates:(`Single s_cert) (), 135 | client ~authenticator ~certificates:(`Single c_cert) (), 136 | server ~certificates:(`Single w_cert) () 137 | ) 138 | 139 | let start stack clock _ _ info = 140 | Logs.info (fun m -> m "used packages: %a" 141 | Fmt.(Dump.list @@ pair ~sep:(unit ".") string string) 142 | info.Mirage_info.packages) ; 143 | Logs.info (fun m -> m "used libraries: %a" 144 | Fmt.(Dump.list string) info.Mirage_info.libraries) ; 145 | let ca_root, s_cfg, c_cfg, w_cfg = tls_init clock in 146 | let secret = Cstruct.of_string (Key_gen.secret ()) in 147 | let web_data = Page.render ca_root in 148 | S.listen_tcpv4 stack ~port:80 (h_notice web_data) ; 149 | S.listen_tcpv4 stack ~port:443 (h_as_web_server web_data w_cfg) ; 150 | S.listen_tcpv4 stack ~port:10000 (h_as_server secret s_cfg) ; 151 | S.listen_tcpv4 stack ~port:10001 (h_as_client stack secret c_cfg) ; 152 | S.listen_tcpv4 stack ~port:10002 (h_as_rev_client secret c_cfg) ; 153 | S.listen stack 154 | end 155 | --------------------------------------------------------------------------------