aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--mock/.gitignore1
-rw-r--r--mock/Main.hs5
-rw-r--r--mock/Server.hs181
-rw-r--r--mock/Types.hs101
-rw-r--r--mock/tomsg-mock.cabal20
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
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-21 21:15:31 +0100