Picarones
=========

This is a test implementation using literate haskell, loosely based on jaspervdj's
example of the haskell websockets library.


> {-# LANGUAGE OverloadedStrings #-}
> {-# LANGUAGE DeriveGeneric #-}
> 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)
> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar)
> 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


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:

> type ServerState = HashMap Text Room

Since rooms are created dynamically, the initial server state is just
an empty map:

> initialState :: ServerState
> initialState = M.empty

Since all clients should be notified of all state changes, we define
a function to broadcast messages to all clients in one room:

> broadcast :: Text -> [Client] -> IO ()
> broadcast message cs = do
>     --T.putStrLn message
>     forM_ cs $ \(_,conn) -> WS.sendTextData conn message




Then there are some bookkeeping functions:

> addClient :: Client -> Maybe Room -> Room
> addClient c room = case room of
>   Nothing -> ([c],0)
>   Just (cs,n) -> (c:cs,n)

> removeClient :: Int -> Room -> Room
> removeClient i (cs,n) = (filter ((/= i) . fst) cs, n)




Protocol
========

Clients communicate by sending strings containing json over websockets,
though there are currently only two possible messages, both of which
are pretty boring:

> data Join = Join { room :: !Text } deriving (Show, Generic)
> data State = State { state :: Int } deriving (Show, Generic)
> instance FromJSON Join
> instance FromJSON State

Join is sent after a connection is established to indicate which room
should be joined, State to indicate a state change



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, retrieve the current slide
number and a new, free index, perform some housekeeping, and send the
new client the current state.

Additionally, we can fork a pinging thread to the background:

>         s <- readMVar state
>         let (i,n) = getNewIndex s
>         WS.withPingThread conn 30 (return ()) $ flip finally (disconnect i) $ do
>           putStrLn $ show i <> " joined room " <> (show $ room join)
>           WS.sendTextData conn (T.pack $ "state " <> show n)
>           modifyMVar_ state $ \map -> return (M.insert (room join) (addClient (i,conn) $ M.lookup (room join) map) map)
>           talk (i,conn) (room join) state
>         where
>           getNewIndex :: ServerState -> (Int, Int)
>           getNewIndex s = case M.lookup (room join) s of
>               Nothing -> (0,0)
>               Just (cs,n) -> case cs of
>                 []      -> (0,0)
>                 (i,c):_ -> (i+1,n)
>           disconnect i = do
>             modifyMVar_ state $ \map -> return (M.adjust (removeClient i) (room join) map)
>             putStrLn $ show i <> " disconnected"



Message Loop
============

Still todo: how to dynamically handle different incoming data types via Aeson?

> talk :: Client -> Text -> MVar ServerState -> IO ()
> talk (i,conn) room s = forever $ do
>     msg <- WS.receiveData conn
>     let d = (eitherDecode msg) :: (Either String State)
>     case d of
>       Left err -> putStrLn $ "json malformed" <> err
>       Right new -> do
>         modifyMVar_ s $ \map -> return $ M.adjust (\(cs,_) -> (cs, state new)) room map
>         state <- readMVar s
>         case M.lookup room state of
>           Nothing -> putStrLn $ "whoops, room " <> show room <> " somehow got lost"
>           Just (cs,n) -> broadcast ("state " <> (T.pack $ show n)) cs