path: root/Presence/Chat.hs

{-# LANGUAGE LambdaCase #-}
module Chat where

import Debug.Trace
import Control.Concurrent.STM
import Control.Monad
import qualified Data.Map as Map
         ;import Data.Map (Map)
import Data.Text (Text)
import Data.Word

import Util (stripResource)

-- To join a chat room, add a 'ClientRoomLink' to 'roomDesiredLink' with
-- 'desireStreamEvent' set to 'Nothing'.
--
-- To leave a chat room, remove the 'ClientRoomLink' from the map.

data Room k = Room
    { roomDesiredTransaction :: TVar (Map k (TVar (Maybe ChatTransaction)))
    , roomChan               :: TChan ChatTransaction
    , roomFutureSeqNo        :: TVar Word64
    , roomMembers            :: TVar (Map Text{-nick-} (PerMember k))
    , roomAffiliations       :: TVar (Map Text{-jid-} Affiliation)
    , roomReservations       :: TVar (Map Text{-nick-} Text{-jid-})
    }

newtype PerMember k = PerMember
    { memberKey :: k
    }

newtype Affiliation = Affiliation
    { reservedNick :: Text
    }

data ChatEvent = Join | Part | Action Text | Talk Text -- | NickChange Text
 deriving (Eq,Ord,Show)

data Membership = Outside | Inside
 deriving (Eq,Ord,Read,Show)

data MembershipEffect = MembershipEffect { fromMembership :: Membership
                                         , toMembership   :: Membership
                                         }
                      | NoMembershipEffect
                      | InvalidMembershipEffect
 deriving (Eq,Ord,Read,Show)

instance Monoid MembershipEffect where
    mempty = NoMembershipEffect
    MembershipEffect a x `mappend` MembershipEffect y b
        | x == y    = MembershipEffect a b
        | otherwise = InvalidMembershipEffect
    NoMembershipEffect `mappend` b                  = b
    a                  `mappend` NoMembershipEffect = a
    _                  `mappend` _                  = InvalidMembershipEffect

chatEffect :: ChatEvent -> MembershipEffect
chatEffect Join = MembershipEffect Outside Inside
chatEffect Part = MembershipEffect Inside  Outside
chatEffect _    = MembershipEffect Inside  Inside

membershipEffect :: [ChatEvent] -> MembershipEffect
membershipEffect xs =  foldMap chatEffect xs


data ChatTransaction = ChatTransaction
    { chatSeqNo     :: Word64
    , chatSenderJID :: Maybe Text
    , chatSender    :: Text
    , chatMessage   :: [ChatEvent]
    }
 deriving (Eq,Ord,Show)

newtype RoomHandle = RH (TVar (Maybe ChatTransaction))

data JoinedRoom k = JoinedRoom
    { joinedRoom :: Room k
    , joinedNick :: Text
    , roomHandle :: RoomHandle
    , roomTransactions :: TChan ChatTransaction
    }

newRoom :: STM (Room k)
newRoom = do
    m <- newTVar Map.empty
    c <- newTChan -- newBroadcastTChan
    n <- newTVar 0
    cs <- newTVar Map.empty
    as <- newTVar Map.empty
    rs <- newTVar Map.empty
    return Room
        { roomDesiredTransaction = m
        , roomChan               = c
        , roomFutureSeqNo        = n
        , roomMembers            = cs
        , roomAffiliations       = as
        , roomReservations       = rs
        }


--- Client interface

joinRoom :: Ord k => k
                     -> Room k
                     -> Maybe Text
                     -> Text
                     -> STM (JoinedRoom k)
joinRoom k room jid nick = do
    no <- readTVar $ roomFutureSeqNo room
    v <- newTVar (Just $ ChatTransaction no jid nick [Join])
    modifyTVar' (roomDesiredTransaction room) $ Map.insert k v
    c <- dupTChan (roomChan room)
    return $ JoinedRoom room nick (RH v) c

partRoom :: JoinedRoom k -> Maybe Text -> STM ()
partRoom (JoinedRoom room nick (RH v) c) jid = do
    writeTVar v Nothing -- Cancel pending chat.
    sendChat (JoinedRoom room nick (RH v) c) jid [Part]
    return ()

sendChat :: JoinedRoom k -> Maybe Text -> [ChatEvent] -> STM Bool
sendChat (JoinedRoom room nick (RH v) _) jid chat = do
    mpending <- readTVar v
    no <- readTVar $ roomFutureSeqNo room
    case mpending of
        Just (ChatTransaction no' _ _ _) | no' >= no -> return False
        _ -> do
            writeTVar v (Just $ ChatTransaction no jid nick chat)
            return True

-- | Blocks until a transaction occurs.  Optionally, a failed transaction will
-- be automatically renewed.
readRoom :: Ord k => k -> JoinedRoom k -> STM (Bool, ChatTransaction)
readRoom k (JoinedRoom room _ (RH v) c) = do
    mpending <- readTVar v
    final <- readTChan c
    case mpending of
        Just pending -> do
            if pending == final
                then do
                    writeTVar v Nothing
                    when (Part `elem` chatMessage final) $ do
                        modifyTVar' (roomDesiredTransaction room)
                            $ Map.delete k
                    return (True,final)
                else do
                    no <- readTVar $ roomFutureSeqNo room
                    writeTVar v $ Just pending { chatSeqNo = no }
                    return (False,final)
        Nothing -> return (False,final)

roomOccupants :: Room k-> STM [(Text{-nick-},Maybe Text{-friendly name-})]
roomOccupants room = do
    ns <- Map.keys <$> readTVar (roomMembers room)
    return $ map (\n -> (n,Just n)) ns

roomReservedNick :: Room k -> Text{-JID-} -> STM (Maybe Text{-nick-})
roomReservedNick room jid = do
    a <- Map.lookup jid <$> readTVar (roomAffiliations room)
    return $ reservedNick <$> a

roomFriendlyName :: Room k -> STM (Maybe Text)
roomFriendlyName _ = return Nothing

-- Room implementation interface

data Validation = Malformed | Requires Membership | Denied | Valid Membership Membership
 deriving (Eq,Ord,Show,Read)

validateTransaction :: Ord k => Room k -> k -> ChatTransaction -> STM Validation
validateTransaction room k t@(ChatTransaction no mjid nick xs)
    | null xs   = return Malformed
    | otherwise = case membershipEffect xs of
        MembershipEffect Inside what ->
            Map.lookup nick <$> readTVar (roomMembers room) >>= \case
                Nothing                   -> return (Requires Inside)
                Just p | memberKey p /= k -> return Denied
                _                         -> return (Valid Inside what)
        MembershipEffect Outside what -> do
            Map.lookup k <$> return Map.empty {- readTVar (roomDesiredTransaction room) -} >>= \case
                Nothing -> Map.lookup nick <$> readTVar (roomMembers room) >>= \case
                            Nothing -> Map.lookup nick <$> readTVar (roomReservations room) >>= \case
                                        Just rjid | Just jid <- mjid
                                                  , stripResource jid == rjid
                                                 -> return (Valid Outside what)
                                        Just _   -> return Denied
                                        Nothing  -> return (Valid Outside what)
                            Just _  -> return Denied -- Nick already taken.
                Just _ -> return (Requires Outside)
        _ -> return Malformed


roomCommit :: Ord k => Room k -> k -> ChatTransaction -> STM ()
roomCommit room k t = do
    let fin = do
            trace "increment seqno!" $ return ()
            modifyTVar' (roomFutureSeqNo room) succ
            writeTChan (roomChan room) t
    v <- validateTransaction room k t
    trace ("roomCommit " ++ show v ++ " " ++ show t) $ return ()
    case v of
        Valid Outside Inside -> do
            modifyTVar' (roomMembers room) $ Map.insert (chatSender t) PerMember
                { memberKey = k
                }
            fin
        Valid Inside Outside -> do
            modifyTVar' (roomMembers room) $ Map.delete (chatSender t)
            fin
        Valid _ _ -> fin
        bad -> trace ("validateTransaction: " ++ show bad) $ return ()

roomPending :: Ord k => Room k -> STM (Map k ChatTransaction)
roomPending room = do
    no <- readTVar $ roomFutureSeqNo room
    m <- Map.mapMaybe (>>= \t -> do guard (chatSeqNo t == no)
                                    return t)
          <$> do readTVar (roomDesiredTransaction room)
                    >>= mapM readTVar
    fmap (Map.mapMaybe id)
        $ sequence $ Map.mapWithKey (\k t -> validateTransaction room k t >>= \case
                        Valid _ _ -> return (Just t)
                        _         -> return Nothing) m