1 files changed, 227 insertions, 0 deletions

diff --git a/dht/Presence/Chat.hs b/dht/Presence/Chat.hs
new file mode 100644
index 00000000..03bea44b
--- /dev/null
+++ b/dht/Presence/Chat.hs
@@ -0,0 +1,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