├── .gitignore ├── LICENSE ├── README.markdown ├── client.ml ├── client.mli ├── colour.ml ├── colour.mli ├── config.ml ├── env └── tls │ ├── server.key │ └── server.pem ├── hostmask.ml ├── hostmask.mli ├── listener.ml ├── listener.mli ├── log.ml ├── log.mli ├── message.ml ├── message.mli ├── protocol.ml ├── scylla.ml ├── scylla.mli ├── settings.ml ├── settings.mli ├── unikernel.ml ├── utils.ml └── utils.mli /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | _build/ 3 | log 4 | main.ml 5 | main.native 6 | mir-scylla 7 | scylla.xe 8 | scylla.xl 9 | scylla.xl.in 10 | scylla_libvirt.xml 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Alexander Færøy. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 15 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 16 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 18 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 20 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 21 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 22 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 23 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # Scylla 2 | 3 | Scylla is a Unikernel IRC daemon for MirageOS. 4 | 5 | ## Building and Running 6 | 7 | $ mirage configure --unix 8 | $ make 9 | $ ./mir-scylla 10 | 11 | Now connect your IRC client to 127.0.0.1:6697 using TLS. 12 | -------------------------------------------------------------------------------- /client.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | open Lwt 8 | 9 | open V1 10 | open V1_LWT 11 | 12 | module Make (C : CONSOLE) (S : STACKV4) (KV : KV_RO) = 13 | struct 14 | module TLS = Tls_mirage.Make (S.TCPV4) 15 | module Scylla = Scylla.Make (C) (S) (KV) 16 | module Settings = Settings.Make (C) 17 | module Log = Log.Make (C) 18 | 19 | type write_command = Stop | Message of string 20 | 21 | type t = 22 | { 23 | scylla : Scylla.t; 24 | 25 | mutable nickname : string; 26 | mutable username : string; 27 | mutable realname : string; 28 | 29 | hostname : string; 30 | 31 | mutable tls : TLS.flow; 32 | 33 | ip : S.TCPV4.ipaddr; 34 | port : int; 35 | 36 | cont : string; 37 | 38 | registered : bool; 39 | 40 | mailbox : write_command Lwt_mvar.t; 41 | } 42 | 43 | let create scylla ip port tls = 44 | let mailbox = Lwt_mvar.create_empty () in 45 | { 46 | scylla = scylla; 47 | 48 | nickname = "*"; 49 | username = "*"; 50 | realname = ""; 51 | 52 | hostname = Ipaddr.V4.to_string ip; 53 | 54 | tls = tls; 55 | 56 | ip = ip; 57 | port = port; 58 | 59 | cont = ""; 60 | 61 | registered = false; 62 | 63 | mailbox = mailbox; 64 | } 65 | 66 | let log t log_level s = 67 | Scylla.log t.scylla log_level "Client %s!%s@%s:%d: %s" t.nickname t.username t.hostname t.port s 68 | 69 | let connected t = 70 | log t Log.Level.Info "Connected ..." 71 | 72 | let disconnected t = 73 | log t Log.Level.Info "Disconnected ..." 74 | 75 | let write_command t cmd = 76 | let _ = Lwt_mvar.put t.mailbox cmd in 77 | () 78 | 79 | let write t m = 80 | write_command t (Message m) 81 | 82 | let close_writer t = 83 | write_command t Stop 84 | 85 | let maybe_register_client t = 86 | let settings = Scylla.settings t.scylla in 87 | let server_name = Settings.name settings in 88 | let username = t.username in 89 | let nickname = t.nickname in 90 | match (username, nickname) with 91 | | ("*", _) -> t 92 | | (_, "*") -> t 93 | | _ -> 94 | log t Log.Level.Info "Registered ..."; 95 | write t (Printf.sprintf ":%s 001 %s :Welcome to the IRC network, %s" server_name nickname nickname); 96 | { t with registered = true } 97 | 98 | let handle_registered_message t m = 99 | let settings = Scylla.settings t.scylla in 100 | let server_name = Settings.name settings in 101 | let command = Message.command m in 102 | match command with 103 | | "PING" -> 104 | (match (Message.arguments m) with 105 | | d :: [] -> 106 | write t (Printf.sprintf ":%s PONG :%s" server_name d); 107 | t 108 | | _ -> 109 | t) 110 | | _ -> 111 | write t (Printf.sprintf ":%s 421 %s %s :Unknown command" server_name t.nickname command); 112 | t 113 | 114 | let handle_unregistered_message t m = 115 | let new_t = match (Message.command m) with 116 | | "NICK" -> 117 | (match (Message.arguments m) with 118 | | nick :: [] -> 119 | t.nickname <- nick; 120 | t 121 | | _ -> 122 | t) 123 | | "USER" -> 124 | (match (Message.arguments m) with 125 | | user :: _ :: _ :: real :: [] -> 126 | t.username <- "~" ^ user; 127 | t.realname <- real; 128 | t 129 | | _ -> 130 | t) 131 | | _ -> 132 | t in 133 | maybe_register_client new_t 134 | 135 | let handle_message t message = 136 | match t.registered with 137 | | true -> 138 | handle_registered_message t message 139 | | false -> 140 | handle_unregistered_message t message 141 | 142 | let handle_line t line = 143 | log t Log.Level.Debug ("<< " ^ line); 144 | try 145 | let message = Message.parse line in 146 | handle_message t message 147 | with (Message.ParseError e) -> 148 | log t Log.Level.Error e; 149 | t 150 | 151 | let rec handle_data t data = 152 | match (String.contains data '\n') with 153 | | true -> 154 | let line, rest = Utils.split data '\n' in 155 | let new_t = handle_line t (String.trim line) in 156 | handle_data new_t rest 157 | | false -> 158 | { t with cont = data } 159 | 160 | let rec handle_write client = 161 | lwt command = Lwt_mvar.take client.mailbox in 162 | match command with 163 | | Message message -> 164 | log client Log.Level.Debug (">> " ^ message); 165 | (lwt res = TLS.write client.tls (Cstruct.of_string (message ^ "\r\n")) in 166 | match res with 167 | | `Error e -> log client Log.Level.Error ("Write error: " ^ (TLS.error_message e)); 168 | return_unit 169 | | `Eof -> return_unit 170 | | `Ok _ -> handle_write client) 171 | | Stop -> return_unit 172 | 173 | let rec handle_read client = 174 | lwt res = TLS.read client.tls in 175 | match res with 176 | | `Error e -> log client Log.Level.Error ("Read error: " ^ (TLS.error_message e)); 177 | close_writer client; 178 | return_unit 179 | | `Eof -> close_writer client; 180 | return_unit 181 | | `Ok buffer -> 182 | let message = client.cont ^ (Cstruct.to_string buffer) in 183 | let new_client = handle_data client message in 184 | handle_read new_client 185 | 186 | let handle client = 187 | connected client; 188 | join [ 189 | handle_read client; 190 | handle_write client 191 | ] >|= fun () -> disconnected client 192 | end 193 | -------------------------------------------------------------------------------- /client.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | module Make (C : V1_LWT.CONSOLE) (S : V1_LWT.STACKV4) (KV : V1_LWT.KV_RO) : 8 | sig 9 | module Scylla : module type of Scylla.Make (C) (S) (KV) 10 | module TLS : module type of Tls_mirage.Make (S.TCPV4) 11 | 12 | type t 13 | 14 | val create : Scylla.t -> S.TCPV4.ipaddr -> int -> TLS.flow -> t 15 | val handle : t -> unit Lwt.t 16 | end 17 | -------------------------------------------------------------------------------- /colour.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | type t = 8 | | Red 9 | | Green 10 | | Yellow 11 | | Cyan 12 | | Purple 13 | | Gray 14 | 15 | let format colour s = 16 | match colour with 17 | | Red -> "\027[31m" ^ s ^ "\027[m" 18 | | Green -> "\027[32m" ^ s ^ "\027[m" 19 | | Yellow -> "\027[33m" ^ s ^ "\027[m" 20 | | Cyan -> "\027[36m" ^ s ^ "\027[m" 21 | | Purple -> "\027[35m" ^ s ^ "\027[m" 22 | | Gray -> "\027[37m" ^ s ^ "\027[m" 23 | -------------------------------------------------------------------------------- /colour.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | type t = 8 | | Red 9 | | Green 10 | | Yellow 11 | | Cyan 12 | | Purple 13 | | Gray 14 | 15 | val format : t -> string -> string 16 | -------------------------------------------------------------------------------- /config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let env_dir = "env" 4 | 5 | let disk = 6 | match get_mode () with 7 | | `Unix -> direct_kv_ro env_dir 8 | | `MacOSX -> direct_kv_ro env_dir 9 | | `Xen -> crunch env_dir 10 | 11 | let net = 12 | try 13 | match Sys.getenv "NET" with 14 | | "direct" -> `Direct 15 | | _ -> `Socket 16 | with Not_found -> 17 | match get_mode () with 18 | | `Unix -> `Socket 19 | | `MacOSX -> `Socket 20 | | `Xen -> `Direct 21 | 22 | let dhcp = 23 | try 24 | match Sys.getenv "ADDR" with 25 | | "dhcp" -> `Dhcp 26 | | "static" -> `Static 27 | with Not_found -> `Static 28 | 29 | let stack console = 30 | match net, dhcp with 31 | | `Direct, `Dhcp -> direct_stackv4_with_dhcp console tap0 32 | | `Direct, `Static -> direct_stackv4_with_default_ipv4 console tap0 33 | | `Socket, _ -> socket_stackv4 console [Ipaddr.V4.any] 34 | 35 | let server = 36 | foreign "Unikernel.Main" @@ console @-> stackv4 @-> kv_ro @-> job 37 | 38 | let () = 39 | let platform = 40 | match get_mode () with 41 | | `Unix -> "unix" 42 | | `MacOSX -> "unix" 43 | | `Xen -> "xen" in 44 | add_to_opam_packages [ "mirage-clock-" ^ platform; "tls" ] ; 45 | add_to_ocamlfind_libraries [ "mirage-clock-" ^ platform; "tls"; "tls.mirage"; "sexplib"; "sexplib.syntax" ] ; 46 | register "scylla" [ server $ default_console $ stack default_console $ disk ] 47 | -------------------------------------------------------------------------------- /env/tls/server.key: -------------------------------------------------------------------------------- 1 | -----BEGIN RSA PRIVATE KEY----- 2 | MIICXQIBAAKBgQC2QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJv 3 | K+aOANKIsOOr9v4RiEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTRE 4 | BE/t1soVT3a/vVJWCLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQAB 5 | AoGAd/CShG8g/JBMh9Nz/8KAuKHRHc2BvysIM1C62cSosgaFmdRrazJfBrEv3Nlc 6 | 2/0uc2dVYIxuvm8bIFqi2TWOdX9jWJf6oXwEPXCD0SaDbJTaoh0b+wjyHuaGlttY 7 | Ztvmf8mK1BOhyl3vNMxh/8Re0dGvGgPZHpn8zanaqfGVz+ECQQDngieUpwzxA0QZ 8 | GZKRYhHoLEaPiQzBaXphqWcCLLN7oAKxZlUCUckxRRe0tKINf0cB3Kr9gGQjPpm0 9 | YoqXo8mNAkEAyYgdd+JDi9FH3Cz6ijvPU0hYkriwTii0V09+Ar5DvYQNzNEIEJu8 10 | Q3Yte/TPRuK8zhnp97Bsy9v/Ji/LSWbtZQJBAJe9y8u3otfmWCBLjrIUIcCYJLe4 11 | ENBFHp4ctxPJ0Ora+mjkthuLF+BfdSZQr1dBcX1a8giuuvQO+Bgv7r9t75ECQC7F 12 | omEyaA7JEW5uGe9/Fgz0G2ph5rkdBU3GKy6jzcDsJu/EC6UfH8Bgawn7tSd0c/E5 13 | Xm2Xyog9lKfeK8XrV2kCQQCTico5lQPjfIwjhvn45ALc/0OrkaK0hQNpXgUNFJFQ 14 | tuX2WMD5flMyA5PCx5XBU8gEMHYa8Kr5d6uoixnbS0cZ 15 | -----END RSA PRIVATE KEY----- 16 | -------------------------------------------------------------------------------- /env/tls/server.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIICYzCCAcwCCQDLbE6ES1ih1DANBgkqhkiG9w0BAQUFADB2MQswCQYDVQQGEwJB 3 | VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0 4 | cyBQdHkgTHRkMRUwEwYDVQQDDAxZT1VSIE5BTUUhISExGDAWBgkqhkiG9w0BCQEW 5 | CW1lQGJhci5kZTAeFw0xNDAyMTcyMjA4NDVaFw0xNTAyMTcyMjA4NDVaMHYxCzAJ 6 | BgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5l 7 | dCBXaWRnaXRzIFB0eSBMdGQxFTATBgNVBAMMDFlPVVIgTkFNRSEhITEYMBYGCSqG 8 | SIb3DQEJARYJbWVAYmFyLmRlMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC2 9 | QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJvK+aOANKIsOOr9v4R 10 | iEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTREBE/t1soVT3a/vVJW 11 | CLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQABMA0GCSqGSIb3DQEB 12 | BQUAA4GBAIo4ZppIlp3JRyltRC1/AyCC0tsh5TdM3W7258wdoP3lEe08UlLwpnPc 13 | aJ/cX8rMG4Xf4it77yrbVrU3MumBEGN5TW4jn4+iZyFbp6TT3OUF55nsXDjNHBbu 14 | deDVpGuPTI6CZQVhU5qEMF3xmlokG+VV+HCDTglNQc+fdLM0LoNF 15 | -----END CERTIFICATE----- 16 | -------------------------------------------------------------------------------- /hostmask.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | type t = 8 | { 9 | nickname : string; 10 | username : string; 11 | hostname : string; 12 | } 13 | 14 | let create nickname username hostname = 15 | { 16 | nickname; 17 | username; 18 | hostname; 19 | } 20 | 21 | let nickname { nickname; _ } = 22 | nickname 23 | 24 | let username { username; _ } = 25 | username 26 | 27 | let hostname { hostname; _ } = 28 | hostname 29 | 30 | let to_string { nickname; username; hostname } = 31 | nickname ^ "!" ^ username ^ "@" ^ hostname 32 | 33 | exception ParseError of string 34 | 35 | let parse s = 36 | try 37 | let at = String.index s '@' in 38 | let exclamation_mark = String.index s '!' in 39 | let length = String.length s in 40 | { 41 | nickname = String.sub s 0 exclamation_mark; 42 | username = String.sub s (exclamation_mark + 1) (at - exclamation_mark - 1); 43 | hostname = String.sub s (at + 1) (length - at - 1); 44 | } 45 | with Not_found -> 46 | raise (ParseError s) 47 | -------------------------------------------------------------------------------- /hostmask.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | type t 8 | 9 | val create : string -> string -> string -> t 10 | 11 | val nickname : t -> string 12 | val username : t -> string 13 | val hostname : t -> string 14 | 15 | val to_string : t -> string 16 | 17 | val parse : string -> t 18 | 19 | exception ParseError of string 20 | -------------------------------------------------------------------------------- /listener.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | open Lwt 8 | 9 | open V1 10 | open V1_LWT 11 | 12 | module Make (C : CONSOLE) (S : STACKV4) (KV : KV_RO) = 13 | struct 14 | module TLS = Tls_mirage.Make (S.TCPV4) 15 | module X509 = Tls_mirage.X509 (KV) (Clock) 16 | module Scylla = Scylla.Make (C) (S) (KV) 17 | module Client = Client.Make (C) (S) (KV) 18 | module Settings = Settings.Make (C) 19 | module Log = Log.Make (C) 20 | 21 | let accept scylla conf flow = 22 | TLS.server_of_flow conf flow >>= function 23 | | `Error _ | `Eof -> fail (Failure "tls init") 24 | | `Ok tls -> 25 | let ip, port = S.TCPV4.get_dest flow in 26 | let client = Client.create scylla ip port tls in 27 | Client.handle client 28 | 29 | let listen scylla = 30 | let stack = Scylla.stack scylla in 31 | let kv = Scylla.kv scylla in 32 | let settings = Scylla.settings scylla in 33 | let port = Settings.port settings in 34 | lwt cert = X509.certificate kv `Default in 35 | let conf = Tls.Config.server ~certificates:(`Single cert) () in 36 | Scylla.log scylla Log.Level.Info "Listening on port: %d" port; 37 | S.listen_tcpv4 stack port (accept scylla conf) ; 38 | S.listen stack 39 | end 40 | -------------------------------------------------------------------------------- /listener.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | module Make (C : V1_LWT.CONSOLE) (S : V1_LWT.STACKV4) (KV : V1_LWT.KV_RO) : 8 | sig 9 | module Scylla : module type of Scylla.Make (C) (S) (KV) 10 | 11 | val listen : Scylla.t -> unit Lwt.t 12 | end 13 | -------------------------------------------------------------------------------- /log.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | open Sexplib.Std 8 | 9 | module Make (C : V1_LWT.CONSOLE) = 10 | struct 11 | module Level = 12 | struct 13 | type t = 14 | | Debug 15 | | Info 16 | | Notice 17 | | Warning 18 | | Error 19 | 20 | let to_string log_level = 21 | match log_level with 22 | | Debug -> "debug" 23 | | Info -> "info" 24 | | Notice -> "notice" 25 | | Warning -> "warning" 26 | | Error -> "error" 27 | 28 | exception LogLevelError of string 29 | 30 | let from_string s = 31 | match (String.lowercase s) with 32 | | "debug" -> Debug 33 | | "info" -> Info 34 | | "notice" -> Notice 35 | | "warning" -> Warning 36 | | "error" -> Error 37 | | _ -> raise (LogLevelError s) 38 | 39 | let to_colour log_level = 40 | match log_level with 41 | | Debug -> Colour.Gray 42 | | Info -> Colour.Cyan 43 | | Notice -> Colour.Purple 44 | | Warning -> Colour.Yellow 45 | | Error -> Colour.Red 46 | 47 | let to_integer log_level = 48 | match log_level with 49 | | Debug -> 0 50 | | Info -> 1 51 | | Notice -> 2 52 | | Warning -> 3 53 | | Error -> 4 54 | end 55 | 56 | open Clock 57 | 58 | type t = 59 | { 60 | min_level : Level.t; 61 | console : C.t; 62 | } 63 | 64 | let create min_level console = { 65 | min_level; 66 | console 67 | } 68 | 69 | let log log level fmt = 70 | let f = fun s -> 71 | let level_int = Level.to_integer level in 72 | let min_level_int = Level.to_integer log.min_level in 73 | if level_int >= min_level_int then 74 | let t = Clock.gmtime (Clock.time ()) in 75 | let timestamp = Printf.sprintf "%02d/%02d/%d %02d:%02d:%02d" t.tm_mday (t.tm_mon + 1) (t.tm_year + 1900) t.tm_hour t.tm_min t.tm_sec in 76 | let colour = Level.to_colour level in 77 | let message = Printf.sprintf "%s [%s] %s" timestamp (Level.to_string level) (Colour.format colour s) in 78 | C.log log.console message in 79 | Printf.ksprintf f fmt 80 | end 81 | -------------------------------------------------------------------------------- /log.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | module Make (C : V1_LWT.CONSOLE) : 8 | sig 9 | module Level : 10 | sig 11 | type t = 12 | | Debug 13 | | Info 14 | | Notice 15 | | Warning 16 | | Error 17 | 18 | exception LogLevelError of string 19 | 20 | val to_string : t -> string 21 | val from_string : string -> t 22 | 23 | val to_colour : t -> Colour.t 24 | 25 | val to_integer : t -> int 26 | end 27 | 28 | type t 29 | 30 | val create : Level.t -> C.t -> t 31 | val log : t -> Level.t -> ('a, unit, string, unit) format4 -> 'a 32 | end 33 | -------------------------------------------------------------------------------- /message.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | type t = 8 | { 9 | prefix : string option; 10 | command : string; 11 | arguments : string list; 12 | } 13 | 14 | let prefix { prefix; _ } = 15 | prefix 16 | 17 | let command { command; _ } = 18 | command 19 | 20 | let arguments { arguments; _ } = 21 | arguments 22 | 23 | exception ParseError of string 24 | 25 | let rec parse_one_argument s l = 26 | match (Utils.prefix s ':') with 27 | | true -> 28 | (String.sub s 1 (String.length s - 1)) :: l 29 | | false -> 30 | match (String.contains s ' ') with 31 | | true -> 32 | let argument, rest = Utils.split s ' ' in 33 | parse_one_argument rest (argument :: l) 34 | | false -> 35 | s :: l 36 | 37 | let parse_arguments s = 38 | List.rev (parse_one_argument s []) 39 | 40 | let parse_command prefix s = 41 | match (String.contains s ' ') with 42 | | true -> 43 | let command, rest = Utils.split s ' ' in 44 | { 45 | prefix = prefix; 46 | command = String.uppercase command; 47 | arguments = parse_arguments rest; 48 | } 49 | | false -> 50 | { 51 | prefix = prefix; 52 | command = String.uppercase s; 53 | arguments = []; 54 | } 55 | 56 | let parse_prefix s = 57 | match (String.contains s ' ') with 58 | | true -> 59 | let prefix, rest = Utils.split s ' ' in 60 | parse_command (Some prefix) rest 61 | | false -> 62 | raise (ParseError s) 63 | 64 | let parse s = 65 | try 66 | match (Utils.prefix s ':') with 67 | | true -> parse_prefix (String.sub s 1 ((String.length s) - 1)) 68 | | false -> parse_command None s 69 | with _ -> 70 | raise (ParseError s) 71 | 72 | let to_string { prefix; command; arguments; } = 73 | let p = 74 | match prefix with 75 | | Some v -> (String.concat "" ["'"; v; "'"]) 76 | | None -> "N/A" in 77 | Printf.sprintf "Prefix: %s, Command: '%s', Arguments: '%s'" p command (String.concat "', '" arguments) 78 | -------------------------------------------------------------------------------- /message.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | type t 8 | 9 | val prefix : t -> string option 10 | val command : t -> string 11 | val arguments : t -> string list 12 | 13 | exception ParseError of string 14 | 15 | val parse : string -> t 16 | 17 | val to_string : t -> string 18 | -------------------------------------------------------------------------------- /protocol.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | type t = 8 | | Nick of string 9 | | User of string * string 10 | | UnknownCommand of string 11 | -------------------------------------------------------------------------------- /scylla.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | open Lwt 8 | 9 | open V1 10 | open V1_LWT 11 | 12 | module Make (C : CONSOLE) (S : STACKV4) (KV : KV_RO) = 13 | struct 14 | module Log = Log.Make (C) 15 | module Settings = Settings.Make (C) 16 | 17 | type t = { 18 | log : Log.t; 19 | settings : Settings.t; 20 | kv : KV.t; 21 | stack : S.t; 22 | } 23 | 24 | let create console settings kv stack = 25 | let log_level = Settings.log_level settings in 26 | let log = Log.create log_level console in 27 | { 28 | log; 29 | settings; 30 | kv; 31 | stack; 32 | } 33 | 34 | let log t level s = 35 | Log.log t.log level s 36 | 37 | let kv t = 38 | t.kv 39 | 40 | let stack t = 41 | t.stack 42 | 43 | let settings t = 44 | t.settings 45 | end 46 | -------------------------------------------------------------------------------- /scylla.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | module Make (C : V1_LWT.CONSOLE) (S : V1_LWT.STACKV4) (KV : V1_LWT.KV_RO) : 8 | sig 9 | module Settings : module type of Settings.Make (C) 10 | module Log : module type of Log.Make (C) 11 | 12 | type t 13 | 14 | val create : C.t -> Settings.t -> KV.t -> S.t -> t 15 | 16 | val log : t -> Log.Level.t -> ('a, unit, string, unit) format4 -> 'a 17 | 18 | val kv : t -> KV.t 19 | val stack : t -> S.t 20 | val settings : t -> Settings.t 21 | end 22 | -------------------------------------------------------------------------------- /settings.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | module Make (C : V1_LWT.CONSOLE) = 8 | struct 9 | module Log = Log.Make (C) 10 | 11 | type t = { 12 | name : string; 13 | port : int; 14 | log_level : Log.Level.t; 15 | } 16 | 17 | let create name port log_level = { 18 | name; 19 | port; 20 | log_level; 21 | } 22 | 23 | let name { name; _ } = 24 | name 25 | 26 | let port { port; _ } = 27 | port 28 | 29 | let log_level { log_level; _ } = 30 | log_level 31 | end 32 | -------------------------------------------------------------------------------- /settings.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | module Make (C : V1_LWT.CONSOLE) : 8 | sig 9 | module Log : module type of Log.Make (C) 10 | 11 | type t 12 | 13 | val create : string -> int -> Log.Level.t -> t 14 | 15 | val name : t -> string 16 | val port : t -> int 17 | val log_level : t -> Log.Level.t 18 | end 19 | -------------------------------------------------------------------------------- /unikernel.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | open Lwt 8 | 9 | open V1 10 | open V1_LWT 11 | 12 | module Main (C : CONSOLE) (S : STACKV4) (KV : KV_RO) = 13 | struct 14 | module Scylla = Scylla.Make (C) (S) (KV) 15 | module Listener = Listener.Make (C) (S) (KV) 16 | module Settings = Settings.Make (C) 17 | module Log = Log.Make (C) 18 | 19 | let start console stack kv = 20 | let settings = Settings.create "scylla.0x90.dk" 6697 Log.Level.Debug in 21 | let scylla = Scylla.create console settings kv stack in 22 | Scylla.log scylla Log.Level.Info "Starting Scylla"; 23 | Listener.listen scylla 24 | end 25 | -------------------------------------------------------------------------------- /utils.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | let rec intersperse list element = 8 | match list with 9 | | [] | [_] -> list 10 | | a :: b :: tail -> a :: element :: intersperse (b :: tail) element 11 | 12 | let split s c = 13 | let p = String.index s c in 14 | let l = String.length s in 15 | let first = String.sub s 0 p in 16 | let second = String.sub s (p + 1) (l - p - 1) in 17 | (first, second) 18 | 19 | let prefix s c = 20 | match (String.length s) with 21 | | 0 -> false 22 | | _ -> (String.get s 0) == c 23 | 24 | let split_all s c = 25 | let rec aux i acc = 26 | match String.contains i c with 27 | | true -> 28 | let head, rest = split i c in 29 | aux rest (head :: acc) 30 | | false -> 31 | List.rev (i :: acc) in 32 | aux s [] 33 | -------------------------------------------------------------------------------- /utils.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Alexander Færøy. All rights reserved. 3 | * Use of this source code is governed by a BSD-style 4 | * license that can be found in the LICENSE file. 5 | *) 6 | 7 | val intersperse : 'a list -> 'a -> 'a list 8 | val split : string -> char -> string * string 9 | val prefix : string -> char -> bool 10 | val split_all : string -> char -> string list 11 | --------------------------------------------------------------------------------