├── .gitignore ├── Horse_greeter.ml ├── Horse_manager.ml ├── README.md ├── config.ml ├── session.ml └── unikernel.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | Makefile 3 | _build/ 4 | horseos.xe 5 | mir-horseos.xen 6 | horseos.xl 7 | horseos_libvirt.xml 8 | log 9 | main.ml 10 | main.native 11 | mir-horseos 12 | Vagrantfile 13 | .vagrant 14 | -------------------------------------------------------------------------------- /Horse_greeter.ml: -------------------------------------------------------------------------------- 1 | let ascii = "welcome to HorseOS 0.02 |\\ /|\n ___| \\,,/_/\n ---__/ \\/ \\\n __--/ (D) \\\n _ -/ (_ \\\n // / \\_ / ==\\\n __-------_____--___--/ / \\_ O o)\n / / \\==/`\n / /\n|| ) \\_/\\\n|| / _ / |\n| | /--______ ___\\ /\\ :\n| / __- - _/ ------ | | \\ \\\n | - - / | | \\ )\n | | - | | ) | |\n | | | | | | | |\n | | < | | | |_/\n < | /__\\ < \\\n /__\\ /___\\\n\nplease enter a username: " 2 | -------------------------------------------------------------------------------- /Horse_manager.ml: -------------------------------------------------------------------------------- 1 | type t = { messages : bytes Lwt_condition.t; users : (bytes, unit) Hashtbl.t } 2 | 3 | let create = { messages = Lwt_condition.create () ; users = Hashtbl.create 10 } 4 | 5 | let broadcast_message os username message = 6 | Lwt_condition.broadcast (os.messages) (Printf.sprintf "%s: %s\n" username message); 7 | Lwt.return_unit 8 | 9 | let wait_for_messages os = Lwt_condition.wait os.messages 10 | 11 | let get_userinfo os = Hashtbl.fold ( fun user _ acc -> Printf.sprintf "%s * %s \n" acc user ) os.users "Horses in the stable:\n" 12 | 13 | let user_exists os username = Hashtbl.mem os.users username 14 | 15 | let remove_user os username = 16 | Lwt_condition.broadcast os.messages "%s has quit...\n"; 17 | Hashtbl.remove os.users username 18 | 19 | let add_user os username = 20 | Hashtbl.add os.users username (); 21 | Lwt_condition.broadcast os.messages (Printf.sprintf "%s joined\n" username) 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | HorseOS 2 | ======= 3 | 4 | Horsing around with OCaml and MirageOS (http://openmirage.org) 5 | 6 | Features 7 | -------- 8 | * Receives TCP connections on port 4444 9 | * Prints an ascii picture of a horse 10 | * Chat with other people connected to HorseOS 11 | -------------------------------------------------------------------------------- /config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let main = foreign "Unikernel.Main" (console @-> stackv4 @-> job) 4 | 5 | let xen = 6 | try match Sys.getenv "XEN" with 7 | | "" -> false 8 | | _ -> true 9 | with Not_found -> false 10 | 11 | let stackv4 = 12 | if xen then 13 | direct_stackv4_with_dhcp default_console tap0 14 | else 15 | socket_stackv4 default_console [Ipaddr.V4.any] 16 | 17 | let () = 18 | register "horseos" [ 19 | main $ default_console $ stackv4 20 | ] 21 | -------------------------------------------------------------------------------- /session.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | 3 | module Tcp (S: V1_LWT.STACKV4) = struct 4 | 5 | type t = { flow: S.TCPV4.flow; on_close: ( string -> unit ) } 6 | 7 | let of_flow f = { flow = f; on_close = fun _ -> () } 8 | 9 | let on_close session closer = { session with on_close = closer } 10 | 11 | let close session reason = 12 | session.on_close reason; 13 | S.TCPV4.close session.flow 14 | 15 | let write session message = 16 | S.TCPV4.write session.flow ( Cstruct.of_string message ) >>= function 17 | | `Eof -> close session "write: eof" 18 | | `Error _ -> close session "write: error" 19 | | `Ok () -> Lwt.return_unit 20 | 21 | let read session message_handler = 22 | let clean_buf buf = Cstruct.to_string buf |> String.trim |> String.escaped in 23 | S.TCPV4.read session.flow >>= function 24 | | `Eof -> close session "read: eof" 25 | | `Error _ -> close session "read: error" 26 | | `Ok buf -> match Cstruct.get_uint8 buf 0, Cstruct.get_uint8 buf 1 with 27 | | 255, 244 -> close session "quit" 28 | | 255, _ -> return () 29 | | _ -> match clean_buf buf with 30 | | "" -> return () 31 | | m -> message_handler m 32 | end 33 | -------------------------------------------------------------------------------- /unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Session 3 | open Horse_manager 4 | open Horse_greeter 5 | 6 | module Main (C: V1_LWT.CONSOLE) (S: V1_LWT.STACKV4) = struct 7 | 8 | module Session = Session.Tcp(S) 9 | 10 | let horseos = Horse_manager.create 11 | 12 | let start c s = 13 | 14 | let log message = C.log c message in 15 | 16 | let rec listen_input session username = 17 | Session.read session (Horse_manager.broadcast_message horseos username) 18 | >> listen_input session username in 19 | 20 | let rec relay_messages session = 21 | Horse_manager.wait_for_messages horseos 22 | >>= fun message -> Session.write session message 23 | >> relay_messages session in 24 | 25 | let write_userinfo session = Session.write session (Horse_manager.get_userinfo horseos) in 26 | 27 | let main session_initial = 28 | Session.read session_initial ( fun username -> 29 | if Horse_manager.user_exists horseos username then 30 | Session.write session_initial (Printf.sprintf "There's already a user called %s please try again.\n" username) >> 31 | Session.close session_initial "bad username" 32 | else 33 | ( 34 | let on_close reason = log (Printf.sprintf "%s has quit (%s)\n" username reason); 35 | Horse_manager.remove_user horseos username in 36 | let session = Session.on_close session_initial on_close in 37 | log (Printf.sprintf "%s joined" username); 38 | Horse_manager.add_user horseos username; 39 | write_userinfo session 40 | >> join [ listen_input session username; relay_messages session ] 41 | ) 42 | ) in 43 | 44 | log "HorseOS is starting."; 45 | 46 | S.listen_tcpv4 s ~port:4444 (fun flow -> 47 | 48 | let dst, dst_port = S.TCPV4.get_dest flow in 49 | let message = Printf.sprintf ("Got a connection from %s on port %d") (Ipaddr.V4.to_string dst) dst_port in 50 | log message; 51 | 52 | let session_initial = Session.of_flow flow in 53 | Session.write session_initial Horse_greeter.ascii 54 | >> main session_initial 55 | ); 56 | 57 | S.listen s; 58 | end 59 | --------------------------------------------------------------------------------