path: root/mock/Server.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
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
import Util


newtype ConnId = ConnId Int
  deriving (Show)

data ServerIn
    = IOpen ConnId
    | IClose ConnId
    | ICmd ConnId Cmd
  deriving (Show)

data ServerOutAction
    = OClose ConnId
    | OResponse ConnId Response
    | OPush ConnId Push
  deriving (Show)

newtype ServerOut = ServerOut [ServerOutAction]
  deriving (Show)

data ClientState
    = CSDisconnected
    | CSAnon
    | CSUser User
    | CSVersionWait
  deriving (Show)

-- TODO: Make this act upon OBroadcast outputs. One way to do that is to create
-- a new worker, say pushHub, on which clientGate's register, login, logout and
-- deregister. Additionally, clientGate's can tell pushHub to broadcast a
-- message to a particular audience (which should then exclude the connection
-- that the concerned clientGate is responsible for).
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
                  , ssNextId :: Id }
  deriving (Show)

data RoomState
    = RoomState { -- | Because Id's are strictly increasing, this is also chronological
                  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)

messageToHIMsg :: Message -> HistoryItem
messageToHIMsg msg =
    HIMsg { hiId = msgId msg
          , hiTimestamp = msgTimestamp msg
          , hiUser = msgUser msg
          , hiReplyId = msgReplyId msg
          , hiLine = msgLine msg }

hiMsgToMessage :: Room -> HistoryItem -> Message
hiMsgToMessage r hi =
    Message { msgRoom = r
            , msgId = hiId hi
            , msgTimestamp = hiTimestamp hi
            , msgUser = hiUser hi
            , msgReplyId = hiReplyId hi
            , msgLine = hiLine hi }

initialServerState :: ServerState
initialServerState =
    ServerState { ssRooms = mempty
                , ssUsers = mempty
                , ssRNG = mkStdGen 1234
                , ssNextId = Id 1 }

emptyRoomState :: RoomState
emptyRoomState =
    RoomState { rsHistory = mempty
              , rsMembers = [] }

serverHandleEvent :: Int -> ServerState -> ServerIn' -> (ServerState, [ServerOut])
serverHandleEvent currentTimestamp 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
                     ,OBroadcast (AudUser u) (PInvite r user)
                     ,OBroadcast (AudRoom r) (PJoin r u)])
          | otherwise
          -> (state, [OResponse (RError "Not in that room")])

        CSend r mreply line
          | Just (RoomState { rsMembers = mbs, rsHistory = hist }) <- Map.lookup r (ssRooms state)
          , user `elem` mbs
          , let msgid = ssNextId state
                msg = Message { msgRoom = r
                              , msgId = msgid
                              , msgTimestamp = currentTimestamp
                              , msgUser = user
                              , msgReplyId = mreply
                              , msgLine = line }
                hitem = messageToHIMsg msg
          -> case mreply of
               Just reply | reply `Map.notMember` hist ->
                   (state, [OResponse (RError "Replied-to message doesn't exist")])
               _ ->
                   let insertMsg rs = rs { rsHistory = Map.insert msgid hitem (rsHistory rs) }
                   in (state { ssRooms = Map.adjust insertMsg r (ssRooms state) }
                      ,[OResponse (RNumber (fromId msgid)), OBroadcast (AudRoom r) (PMessage msg)])
          | otherwise
          -> (state, [OResponse (RError "Not in that room")])

        CHistory r num
          | Just (RoomState { rsMembers = mbs, rsHistory = hist }) <- Map.lookup r (ssRooms state)
          , user `elem` mbs
          , let msgs = reverse (map (hiMsgToMessage r . snd) (take num (Map.toDescList hist)))
          -> (state
             ,OResponse (RHistory (length msgs))
                  : [OResponse (RHistoryMessage i msg) | (i, msg) <- zip [0..] msgs])
          | otherwise
          -> (state, [OResponse (RError "Not in that room")])

        CHistoryBefore r num beforeId
          | Just (RoomState { rsMembers = mbs, rsHistory = hist }) <- Map.lookup r (ssRooms state)
          , user `elem` mbs
          -> case Map.lookup beforeId hist of
               Just hitem ->
                   let beforeStamp = hiTimestamp hitem
                       msgs = reverse  -- to chronological order again
                              . map (hiMsgToMessage r)  -- convert to messages
                              . take num  -- limit to the number of items requested
                              . dropWhile ((>= beforeStamp) . hiTimestamp)  -- spec-strict filter
                              . map snd  -- only the history items, not the id keys
                              . Map.toDescList  -- get a list of the earlier ones, reverse chronological
                              . Map.takeWhileAntitone (< beforeId)  -- first, drop all certainly later
                              $ hist
                   in (state
                      ,OResponse (RHistory (length msgs))
                           : [OResponse (RHistoryMessage i msg) | (i, msg) <- zip [0..] msgs])
               Nothing ->
                   (state, [OResponse (RError "Message not found")])
          | 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'')