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.

5 files changed, 308 insertions, 0 deletions

diff --git a/mock/.gitignore b/mock/.gitignore
new file mode 100644
index 0000000..c33954f
--- /dev/null
+++ b/mock/.gitignore
@@ -0,0 +1 @@
+dist-newstyle/
diff --git a/mock/Main.hs b/mock/Main.hs
new file mode 100644
index 0000000..0848f95
--- /dev/null
+++ b/mock/Main.hs
@@ -0,0 +1,5 @@
+module Main where
+
+
+main :: IO ()
+main = return ()
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'')
diff --git a/mock/Types.hs b/mock/Types.hs
new file mode 100644
index 0000000..be73231
--- /dev/null
+++ b/mock/Types.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Types where
+
+import Prelude hiding (Word)
+
+import Data.List (find)
+
+
+kPROTOCOL_VERSION :: Int
+kPROTOCOL_VERSION = 3
+
+
+newtype Word = Word_ String
+  deriving (Show, Eq, Ord)
+
+pattern Word :: String -> Word
+pattern Word s <- Word_ s
+  where Word = Word_ . assertIsWord "Word"
+
+newtype Line = Line_ String
+  deriving (Show, Eq, Ord)
+
+pattern Line :: String -> Line
+pattern Line s <- Line_ s
+  where Line = Line_ . assertIsLine "Line"
+
+newtype User = User { fromUser :: Word }
+  deriving (Show, Eq, Ord)
+
+newtype Room = Room { fromRoom :: Word }
+  deriving (Show, Eq, Ord)
+
+newtype Id = Id_ { fromId :: Int }
+  deriving (Show, Eq, Ord)
+
+pattern Id :: Int -> Id
+pattern Id i <- Id_ i
+  where Id = Id_ . assertPositive "Id"
+
+data Response
+    = ROk
+    | RNumber Int
+    | RError String
+    | RName Word
+    | RList [Word]
+    | RPong
+    | RHistory Int
+    | RHistoryMessage Int Message
+    | RMessage Message
+  deriving (Show)
+
+data Push
+    = POnline Int User
+    | PMessage Message
+    | PInvite Room User
+    | PJoin Room User
+    | PLeave Room User
+    | PPing
+  deriving (Show)
+
+data Message
+    = Message { msgRoom :: Room
+              , msgUser :: User
+              , msgTimestamp :: Int
+              , msgId :: Id
+              , msgReplyId :: Maybe Id
+              , msgLine :: Line }
+  deriving (Show)
+
+-- Firebase-related commands elided
+data Cmd
+    = CVersion Word
+    | CRegister User Line
+    | CLogin User Line
+    | CChangePassword Line
+    | CLogout
+    | CListRooms
+    | CListMembers Room
+    | CCreateRoom
+    | CLeaveRoom Room
+    | CInvite Room User
+    | CSend Room (Maybe Id) Line
+    | CHistory Room Int
+    | CHistoryBefore Room Int Id
+    | CGetMessage Id
+    | CPing
+    | CIsOnline User
+    | CUserActive Bool
+  deriving (Show)
+
+assertIsWord :: String -> String -> String
+assertIsWord typ s | Nothing <- find (\c -> c == ' ' || c == '\n') s = s
+                   | otherwise = error ("Value put in " ++ typ ++ " is not a word")
+
+assertIsLine :: String -> String -> String
+assertIsLine typ s | Nothing <- find (== '\n') s = s
+                   | otherwise = error ("Value put in " ++ typ ++ " is not a line")
+
+assertPositive :: String -> Int -> Int
+assertPositive typ i | i >= 0 = i
+                     | otherwise = error ("Value put in " ++ typ ++ " is not positive")
diff --git a/mock/tomsg-mock.cabal b/mock/tomsg-mock.cabal
new file mode 100644
index 0000000..8a5efe5
--- /dev/null
+++ b/mock/tomsg-mock.cabal
@@ -0,0 +1,20 @@
+cabal-version:       >=1.10
+name:                tomsg-mock
+synopsis:            Mock server implementation for tomsg
+version:             0.1.0.0
+license:             MIT
+author:              Tom Smeding
+maintainer:          tom.smeding@gmail.com
+build-type:          Simple
+
+executable tomsg-mock
+  main-is:             Main.hs
+  other-modules:       Types, Server
+  build-depends:       base >= 4.13 && < 4.15,
+                       containers >= 0.6.4 && < 0.7,
+                       monad-loops >= 0.4.3 && < 0.5,
+                       stm >= 2.5 && < 2.6,
+                       random >= 1.2 && < 1.3
+  hs-source-dirs:      .
+  default-language:    Haskell2010
+  ghc-options:         -Wall -O2 -threaded