mock: Start writing a mock server implementation

This is intended to be used for property testing later. Doing this in
Haskell should make it easy enough that maintaining a double
implementation is not _too_ bad.

1 files changed, 181 insertions, 0 deletions

diff --git a/mock/Server.hs b/mock/Server.hs
new file mode 100644
index 0000000..d77ae84
--- /dev/null
+++ b/mock/Server.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+module Server where
+
+import Prelude hiding (Word)
+
+import Control.Concurrent.STM
+import Control.Monad (void)
+import Control.Monad.Loops (iterateUntilM)
+import Data.List (delete)
+import qualified Data.Map.Strict as Map
+import Data.Map.Strict (Map)
+import System.Random
+
+import Types
+
+
+data ServerIn = ServerIn ServerIn' (TMVar [ServerOut])
+
+data ServerIn'
+    = IAnon Cmd
+    | IAs User Cmd
+  deriving (Show)
+
+data ServerOut
+    = OResponse Response
+    | OLogin User
+    | OLogout
+    | ODisconnect
+  deriving (Show)
+
+data ClientAction
+    = CAResponse Response
+    | CAPush Push
+    | CADisconnect
+  deriving (Show)
+
+data ClientState
+    = CSDisconnected
+    | CSAnon
+    | CSUser User
+    | CSVersionWait
+  deriving (Show)
+
+clientGate :: TQueue ServerIn -> TQueue (Maybe Cmd) -> TQueue ClientAction -> IO ()
+clientGate server clientIn clientOut =
+    void $ iterateUntilM (\case CSDisconnected -> True ; _ -> False) body CSVersionWait
+  where
+    body state = do
+        atomically (readTQueue clientIn) >>= \case
+            Nothing -> return CSDisconnected
+            Just (CVersion (Word "3")) -> do
+                atomically (writeTQueue clientOut (CAResponse ROk))
+                case state of
+                    CSVersionWait -> return CSAnon
+                    _ -> return state
+            Just (CVersion _) -> do
+                atomically (writeTQueue clientOut (CAResponse (RError "Version not supported")))
+                return CSVersionWait
+            Just cmd -> do
+                let msg = case state of CSAnon -> IAnon cmd
+                                        CSUser u -> IAs u cmd
+                                        _ -> error "impossible"
+                resVar <- newEmptyTMVarIO
+                atomically (writeTQueue server (ServerIn msg resVar))
+                outs <- atomically (readTMVar resVar)
+                loopM outs state $ curry $ \case
+                    (CSDisconnected, _) -> return CSDisconnected
+                    (state', OResponse res) -> do
+                        atomically (writeTQueue clientOut (CAResponse res))
+                        return state'
+                    (_, OLogin u) -> return (CSUser u)
+                    (_, OLogout) -> return CSAnon
+                    (_, ODisconnect) -> return CSDisconnected
+
+data ServerState
+    = ServerState { ssRooms :: Map Room RoomState
+                  , ssUsers :: Map User UserData
+                  , ssRNG :: StdGen }
+  deriving (Show)
+
+data RoomState
+    = RoomState { rsHistory :: Map Id HistoryItem
+                , rsMembers :: [User] }
+  deriving (Show)
+
+data UserData
+    = UserData { udPassword :: Line }
+  deriving (Show)
+
+data HistoryItem
+    = HIMsg { hiId :: Id
+            , hiTimestamp :: Int
+            , hiUser :: User
+            , hiReplyId :: Maybe Id
+            , hiLine :: Line }
+  deriving (Show)
+
+initialServerState :: ServerState
+initialServerState =
+    ServerState { ssRooms = mempty
+                , ssUsers = mempty
+                , ssRNG = mkStdGen 1234 }
+
+emptyRoomState :: RoomState
+emptyRoomState =
+    RoomState { rsHistory = mempty
+              , rsMembers = [] }
+
+serverHandleEvent :: ServerState -> ServerIn' -> (ServerState, [ServerOut])
+serverHandleEvent state = \case
+    IAnon (CRegister u p)
+      | u `Map.member` ssUsers state -> (state, [OResponse (RError "User already exists")])
+      | otherwise -> (state { ssUsers = Map.insert u (UserData p) (ssUsers state) }
+                     ,[OResponse ROk])
+
+    IAnon (CLogin u p)
+      | Just ud <- Map.lookup u (ssUsers state)
+      , p == udPassword ud
+      -> (state, [OResponse ROk, OLogin u])
+      | otherwise -> (state, [OResponse (RError "Invalid password")])
+
+    IAnon _ -> (state, [OResponse (RError "Not logged in")])
+
+    IAs user cmd -> case cmd of
+        CChangePassword p ->
+            (state { ssUsers = Map.adjust (\ud -> ud { udPassword = p }) user (ssUsers state) }
+            ,[OResponse ROk])
+
+        CLogout -> (state, [OResponse ROk, OLogout])
+
+        CListRooms -> (state, [OResponse (RList (map fromRoom (Map.keys (ssRooms state))))])
+
+        CListMembers r
+          | Just (RoomState { rsMembers = mbs }) <- Map.lookup r (ssRooms state)
+          , user `elem` mbs
+          -> (state, [OResponse (RList (map fromUser mbs))])
+          | otherwise
+          -> (state, [OResponse (RError "Room not found")])
+
+        CCreateRoom ->
+            let (rng', roomid) = genRoomId (ssRNG state)
+            in (state { ssRooms = Map.insert roomid emptyRoomState (ssRooms state)
+                      , ssRNG = rng' }
+               ,[OResponse (RName (fromRoom roomid))])
+
+        CLeaveRoom r
+          | Just rs@(RoomState { rsMembers = mbs }) <- Map.lookup r (ssRooms state)
+          , user `elem` mbs
+          -> (state { ssRooms = Map.insert r (rs { rsMembers = delete user mbs }) (ssRooms state) }
+             ,[OResponse ROk])
+          | otherwise
+          -> (state, [OResponse (RError "Not in that room")])
+
+        CInvite r u
+          | Just (RoomState { rsMembers = mbs }) <- Map.lookup r (ssRooms state)
+          , user `elem` mbs
+          -> if | user `Map.notMember` ssUsers state -> (state, [OResponse (RError "User not found")])
+                | user `elem` mbs -> (state, [OResponse (RError "User already in room")])
+                | otherwise ->
+                    (state { ssRooms = Map.adjust (\rs -> rs { rsMembers = u : rsMembers rs })
+                                                  r (ssRooms state) }
+                    ,[OResponse ROk, push_to_u_something, broadcast_something])
+         | otherwise
+         -> (state, [OResponse (RError "Not in that room")])
+
+loopM :: Monad m => [a] -> s -> (s -> a -> m s) -> m s
+loopM [] s _ = return s
+loopM (x:xs) s f = f s x >>= \s' -> loopM xs s' f
+
+genRoomId :: RandomGen g => g -> (g, Room)
+genRoomId gen =
+    let (is, gen') = uniformRN 8 (0, 2 * 26) gen
+    in (gen', Room (Word (map ((['a'..'z'] ++ ['A'..'Z']) !!) is)))
+  where
+    uniformRN :: (RandomGen g, UniformRange a) => Int -> (a, a) -> g -> ([a], g)
+    uniformRN 0 r g = let (x, g') = uniformR r g
+                      in ([x], g')
+    uniformRN n r g = let (x, g') = uniformR r g
+                          (xs, g'') = uniformRN (n-1) r g'
+                      in (x:xs, g'')