summaryrefslogtreecommitdiff
path: root/Presence/Chat.hs
blob: 03bea44b697564923e81e1bf22e32651363dca9f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
{-# LANGUAGE LambdaCase #-}
module Chat where

import Debug.Trace
import Data.Semigroup
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 Semigroup MembershipEffect

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