Initial commit

You can log in and chat, but it's broken in many ways.
This commit is contained in:
Reynir Björnsson 2023-05-03 15:43:23 +02:00
commit a82fe0107a
2 changed files with 110 additions and 0 deletions

21
config.ml Normal file
View file

@ -0,0 +1,21 @@
open Mirage
let port =
let doc = Key.Arg.info ~doc:"The TCP port for listening for SSH connections" ["port"] in
Key.(create "port" Arg.(opt int 22 doc))
let hostkey =
let doc = Key.Arg.info ~doc:"SSH host key" ["hostkey"] in
Key.(create "hostkey" Arg.(required string doc))
let main =
let packages = [
package "banawa-mirage" ~pin:"git+https://github.com/sorbusursina/banawa-ssh.git";
] in
let keys = [ Key.v port ; Key.v hostkey ] in
foreign ~keys ~packages "Unikernel.Main" (random @-> time @-> mclock @-> stackv4v6 @-> job)
let () =
register "banawa-chat" [
main $ default_random $ default_time $ default_monotonic_clock $ generic_stackv4v6 default_network
]

89
unikernel.ml Normal file
View file

@ -0,0 +1,89 @@
open Lwt.Syntax
module Main (_ : Mirage_random.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) (Stack : Tcpip.Stack.V4V6) = struct
module Ssh = Banawa_mirage.Make(Stack.TCP)(T)(M)
type message =
| Message of { sender : string; message : string }
| Join of string
| Part of string
let c : message Lwt_condition.t = Lwt_condition.create ()
let read username ic =
let rec loop () =
let* r = ic () in
match r with
| `Data d ->
let message = Cstruct.to_string d in
if String.equal message "" then
loop ()
else
let m = Message {
sender = username;
message = String.trim message;
} in
Lwt_condition.broadcast c m;
loop ()
| `Eof ->
Lwt_condition.broadcast c (Part username);
Lwt.return_unit
in
loop ()
let rec write me oc =
let* m = Lwt_condition.wait c in
match m with
| Message { sender; message=_ } when String.equal sender me ->
write me oc
| Message { sender; message } ->
let* () = oc (Printf.ksprintf Cstruct.of_string "%s: %s\r\n" sender message) in
write me oc
| Join username ->
let* () = oc (Printf.ksprintf Cstruct.of_string "--> %s joined!\r\n" username) in
write me oc
| Part username ->
let* () = oc (Printf.ksprintf Cstruct.of_string "<-- %s left\r\n" username) in
write me oc
let chat flow stop username ic oc =
Lwt_condition.broadcast c (Join username);
let* () =
Lwt.pick [
read username ic;
write username oc;
]
in
let* () = Lwt_switch.turn_off stop in
Stack.TCP.close flow
let callback flow stop ~username r =
match r with
| Ssh.Pty_req _ | Ssh.Pty_set _ | Ssh.Set_env _ ->
Lwt.return_unit
| Ssh.Channel { cmd; ic; oc; ec; } ->
let* () = oc (Cstruct.of_string (Printf.sprintf "Hello, %s!\r\n" username)) in
chat flow stop username ic oc
| Ssh.Shell { ic; oc; ec; } ->
let* () = oc (Cstruct.of_string (Printf.sprintf "Hello, %s!\r\n" username)) in
chat flow stop username ic oc
let start _random _time _mtime stack =
let port = Key_gen.port () in
let user_db = Banawa.Auth.Db.create 20 in
let hostkey = Key_gen.hostkey () in
let hostkey =
match Banawa.Keys.of_string hostkey with
| Ok k -> k
| Error `Msg e ->
Logs.err (fun m -> m "%s" e); exit 1
in
let server, msgs = Banawa.Server.make hostkey user_db in
Stack.TCP.listen (Stack.tcp stack) ~port
(fun flow ->
let stop = Lwt_switch.create () in
let _ssh = Ssh.spawn_server ~stop server msgs flow (callback flow stop) in
Lwt.return_unit);
fst (Lwt.wait ())
end