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_, 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,
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
> instance ToJSON 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, 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 State { 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
============

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

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 State)
>     case d of
>       Left err -> putStrLn $ "json malformed" <> err
>       Right new -> do
>         peers <- modifyMVar roomstate $ \(cs,n) -> return ((cs, state new), cs)
>         broadcast (encode $ State { state = state new }) 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