diff options
Diffstat (limited to 'mock/Server.hs')
| -rw-r--r-- | mock/Server.hs | 181 |
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'') |