Add server to general repository

Idea: have all components of this program in one repository

1 files changed, 0 insertions, 216 deletions

diff --git a/Main.lhs b/Main.lhs
deleted file mode 100644
index 3586795..0000000
--- a/Main.lhs
+++ /dev/null
@@ -1,216 +0,0 @@
-Picarones
-=========
-
-This is a test implementation using literate haskell, loosely based on jaspervdj's
-example of the haskell websockets library.
-
-
-> {-# LANGUAGE OverloadedStrings #-}
-> {-# LANGUAGE DeriveGeneric #-}
-> {-# LANGUAGE DeriveAnyClass #-}
-> module Main where
-> import Data.Aeson
-> import GHC.Generics
-> import Data.Text (Text)
-> import Data.HashMap.Strict (HashMap)
-> import Control.Exception (finally)
-> import Control.Monad (forM_, forever, mplus, mzero)
-> import Control.Concurrent (MVar, newMVar, modifyMVar_, modifyMVar, readMVar, takeMVar, putMVar)
-> import qualified Data.Text as T
-> import qualified Data.Text.Encoding as T
-> import qualified Data.Text.IO as T
-> import qualified Data.ByteString.Lazy as LB
-> import qualified Data.HashMap.Strict as M
-> import qualified Network.WebSockets as WS
-
-Application State
-=================
-
-We only show slides, so clients can be represented entirely by their
-websocket connection and some id, which is only necessarry for bookkeeping
-purporses, since WS.Connection apparently doesn't have Eq.
-
-> type Client = (Int, WS.Connection)
-
-Each room is then a list of clients, together with the slide currently
-on display there (represented as Int — there is a Data.Nat, but it
-doesn't look like it's very efficient, so let's just make sure we don't
-end up with invalid values).
-
-> type Room = ([Client], Int)
-
-The entire server state is a map of room names to rooms, which are each
-wrapped in a MVar, so we can change room states without touching the
-global server state:
-
-> type ServerState = HashMap Text (MVar Room)
-
-Since rooms are created dynamically, the initial server state is just
-an empty map:
-
-> initialState :: ServerState
-> initialState = M.empty
-
-
-Protocol
-========
-
-Clients communicate by sending strings containing json over websockets.
-
-Upon establishing a connection, clients declare which room they wish
-to join:
-
-> data Join = Join { room :: !Text }
->       deriving (Show, Generic, FromJSON)
-
-After joining, clients can either change the room state, or point at
-some particular position on that room's canvas:
-
-> data ClientMsg = ClientState Int | ClientPointAt Point
->       deriving (Show)
-
-> data Point = Point { x :: Int, y :: Int }
->       deriving (Show, Generic, FromJSON, ToJSON)
-
-Parsing these incoming messages correctly requires a bit of boilerplate
-(or at least I've not yet found out how to get Aeson and Generics or
-TemplateHaskell to do this automatically):
-
-> instance FromJSON ClientMsg where
->   parseJSON (Object v) = parseState `mplus` parsePointAt
->     where
->       parseState = ClientState <$> v .: "state"
->       parsePointAt = ClientPointAt <$> v .: "pointat"
->   parseJSON _ = mzero
-
-The protocol for incoming messages is therefore that '{"state":2}' should
-set the room state to 2, and that '{"pointat":{"x":10,"y":20}}' points
-at position (10,20).
-
-The server replies (and broadcasts to other clients) in similar json
-messages which are constructed ad-hoc and don't have their own types
-(for now).
-
-
-
-Server Startup & Joining Clients
-================================
-
-The main function first creates a new state for the server, then spawns the
-actual server. For this purpose, we use the simple server provided by
-`WS.runServer`.
-
-> main :: IO ()
-> main = do
->     putStrLn "Starting Server!"
->     state <- newMVar initialState
->     WS.runServer "127.0.0.1" 9160 $ application state
-
-Whenever we get a new connection, we accept the request, read a first
-message (which must be a `join`-message, otherwise the connection is
-dropped), and then start processing:
-
-> application :: MVar ServerState -> WS.ServerApp
-> application state pending = do
->     conn <- WS.acceptRequest pending
->     msg <- WS.receiveData conn
->     let d = (eitherDecode msg) :: (Either String Join)
->     case d of
->       Left err -> putStrLn $ "error while join: " <> err
->       Right join -> do
-
-Once we now that a new client wants to join, we can start actually
-processing the connection. First, we can fork a pinging thread to
-the background:
-
->         WS.withPingThread conn 30 (return ()) $ do
-
-Then we can retrieve the global server state. Note that rooms are
-ephemeral — they just get created as soon as someone joins them;
-so we also have to check if the room already exists, and, if not,
-create a new MVar to store that room's state.
-
->           s <- takeMVar state
->           (i,n, roomstate) <- case M.lookup (room join) s of
->             Nothing -> do
->               room' <- newMVar ([(0,conn)],0)
->               let s' = M.insert (room join) room' s
->               putMVar state s'
->               return (0,0, room')
->             Just room' -> do
->               (i,n) <- modifyMVar room' (\state -> return $ insertClient conn state)
->               putMVar state s
->               return (i,n, room')
-
-Now the client has joined, and we can print some debug output, send the
-new client the current state so it can update its view, and hand over
-to the usual message handling loop, which just needs the room's state,
-not the server's global state:
-
->           putStrLn $ show i <> " joined room " <> (show $ room join)
->           WS.sendTextData conn $ encode (object ["state" .= n])
->           talk (i, conn) roomstate
-
-Only one thing is still left to do, which is to define the `insertClient`
-function that was used above for brevity. It gets an already-existing
-room, adds a client to it, and then returns the new room along with
-the new client's index and the room's current slide, to make the call
-of `modifyMVar` above look nicer.
-
->         where
->           insertClient :: WS.Connection -> Room -> (Room, (Int,Int))
->           insertClient client room = case room of
->             ([],n) -> (([(0,client)], 0), (0,0))
->             ((i,conn'):cs,n) -> (((i+1,conn):(i,conn'):cs, n), (i+1,n))
-
-
-
-Message Loop
-============
-
-Before we start the message loop, we first set up a disconnect handler
-which will remove the client from the room's state once the socket closes.
-
-After that, we just read in new messages, parse them as json messages,
-and change the room's state accordingly (note: currently, this server is
-"nice" and does not drop clients which send garbage instead of json; this
-isn't really much of a concern here, but it would probably be better if
-it did drop them).
-
-> talk :: Client -> MVar Room -> IO ()
-> talk (i,conn) roomstate = flip finally (disconnect i) $ forever $ do
->     msg <- WS.receiveData conn
->     let d = (eitherDecode msg) :: (Either String ClientMsg)
->     case d of
->       Left err -> putStrLn $ "json malformed: " <> err
->       Right msg -> case msg of 
->         ClientState new -> do
->           clients <- modifyMVar roomstate $ \(cs,n) -> return ((cs, new), cs)
->           broadcast (encode $ object ["state" .= new]) clients
->         ClientPointAt point -> do 
->           (clients,_) <- readMVar roomstate
->           let peers = filter (\(i',_) -> i' /= i) clients
->           putStrLn $ "client points at " <> show point
->           broadcast (encode $ object ["point" .= point, "id" .= i]) peers
->     where
->       disconnect i = do
->         modifyMVar_ roomstate (\room -> return $ removeClient i room)
->         putStrLn $ show i <> " disconnected"
->       removeClient :: Int -> Room -> Room
->       removeClient i (cs,n) = (filter ((/= i) . fst) cs, n)
-
-Broadcasting is equivalent to just going through the list of clients.
-Note that this is a linked list (i.e. may be slow and cause some cache
-misses while iterating), but it's probably going to be fine unless there's
-a couple thousand clients in a room.
-
-> broadcast :: LB.ByteString -> [Client] -> IO ()
-> broadcast message cs = do
->     LB.putStrLn message -- log messages
->     forM_ cs $ \(_,conn) -> WS.sendTextData conn message
-
-
-
-
-
-