Chatroom.hs

module Erebos.Chatroom (
    Chatroom(..),
    ChatroomData(..),
    validateChatroom,

    ChatroomState(..),
    ChatroomStateData(..),
    createChatroom,
    updateChatroomByStateData,
    listChatrooms,
    findChatroomByRoomData,
    findChatroomByStateData,
    chatroomSetSubscribe,
    getMessagesSinceState,

    ChatroomSetChange(..),
    watchChatrooms,

    ChatMessage,
    cmsgFrom, cmsgReplyTo, cmsgTime, cmsgText, cmsgLeave,
    cmsgRoom, cmsgRoomData,
    ChatMessageData(..),
    sendChatroomMessage,
    sendChatroomMessageByStateData,

    ChatroomService(..),
) where

import Control.Arrow
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class

import Data.Bool
import Data.Either
import Data.IORef
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Ord
import Data.Set qualified as S
import Data.Text (Text)
import Data.Time

import Erebos.Identity
import Erebos.PubKey
import Erebos.Service
import Erebos.Set
import Erebos.State
import Erebos.Storage
import Erebos.Storage.Merge
import Erebos.Util


data ChatroomData = ChatroomData
    { rdPrev :: [Stored (Signed ChatroomData)]
    , rdName :: Maybe Text
    , rdDescription :: Maybe Text
    , rdKey :: Stored PublicKey
    }

data Chatroom = Chatroom
    { roomData :: [Stored (Signed ChatroomData)]
    , roomName :: Maybe Text
    , roomDescription :: Maybe Text
    , roomKey :: Stored PublicKey
    }

instance Storable ChatroomData where
    store' ChatroomData {..} = storeRec $ do
        mapM_ (storeRef "SPREV") rdPrev
        storeMbText "name" rdName
        storeMbText "description" rdDescription
        storeRef "key" rdKey

    load' = loadRec $ do
        rdPrev <- loadRefs "SPREV"
        rdName <- loadMbText "name"
        rdDescription <- loadMbText "description"
        rdKey <- loadRef "key"
        return ChatroomData {..}

validateChatroom :: [Stored (Signed ChatroomData)] -> Except String Chatroom
validateChatroom roomData = do
    when (null roomData) $ throwError "null data"
    when (not $ getAll $ walkAncestors verifySignatures roomData) $ do
        throwError "signature verification failed"

    let roomName = findPropertyFirst (rdName . fromStored . signedData) roomData
        roomDescription = findPropertyFirst (rdDescription . fromStored . signedData) roomData
    roomKey <- maybe (throwError "missing key") return $
        findPropertyFirst (Just . rdKey . fromStored . signedData) roomData
    return Chatroom {..}
  where
    verifySignatures sdata =
        let rdata = fromSigned sdata
            required = concat
                [ [ rdKey rdata ]
                , map (rdKey . fromSigned) $ rdPrev rdata
                ]
         in All $ all (fromStored sdata `isSignedBy`) required


data ChatMessageData = ChatMessageData
    { mdPrev :: [Stored (Signed ChatMessageData)]
    , mdRoom :: [Stored (Signed ChatroomData)]
    , mdFrom :: ComposedIdentity
    , mdReplyTo :: Maybe (Stored (Signed ChatMessageData))
    , mdTime :: ZonedTime
    , mdText :: Maybe Text
    , mdLeave :: Bool
    }

data ChatMessage = ChatMessage
    { cmsgData :: Stored (Signed ChatMessageData)
    }

validateSingleMessage :: Stored (Signed ChatMessageData) -> Maybe ChatMessage
validateSingleMessage sdata = do
    guard $ fromStored sdata `isSignedBy` idKeyMessage (mdFrom (fromSigned sdata))
    return $ ChatMessage sdata

cmsgFrom :: ChatMessage -> ComposedIdentity
cmsgFrom = mdFrom . fromSigned . cmsgData

cmsgReplyTo :: ChatMessage -> Maybe ChatMessage
cmsgReplyTo = fmap ChatMessage . mdReplyTo . fromSigned . cmsgData

cmsgTime :: ChatMessage -> ZonedTime
cmsgTime = mdTime . fromSigned . cmsgData

cmsgText :: ChatMessage -> Maybe Text
cmsgText = mdText . fromSigned . cmsgData

cmsgLeave :: ChatMessage -> Bool
cmsgLeave = mdLeave . fromSigned . cmsgData

cmsgRoom :: ChatMessage -> Maybe Chatroom
cmsgRoom = either (const Nothing) Just . runExcept . validateChatroom . cmsgRoomData

cmsgRoomData :: ChatMessage -> [ Stored (Signed ChatroomData) ]
cmsgRoomData = concat . findProperty ((\case [] -> Nothing; xs -> Just xs) . mdRoom . fromStored . signedData) . (: []) . cmsgData

instance Storable ChatMessageData where
    store' ChatMessageData {..} = storeRec $ do
        mapM_ (storeRef "SPREV") mdPrev
        mapM_ (storeRef "room") mdRoom
        mapM_ (storeRef "from") $ idExtDataF mdFrom
        storeMbRef "reply-to" mdReplyTo
        storeDate "time" mdTime
        storeMbText "text" mdText
        when mdLeave $ storeEmpty "leave"

    load' = loadRec $ do
        mdPrev <- loadRefs "SPREV"
        mdRoom <- loadRefs "room"
        mdFrom <- loadIdentity "from"
        mdReplyTo <- loadMbRef "reply-to"
        mdTime <- loadDate "time"
        mdText <- loadMbText "text"
        mdLeave <- isJust <$> loadMbEmpty "leave"
        return ChatMessageData {..}

threadToListSince :: [ Stored (Signed ChatMessageData) ] -> [ Stored (Signed ChatMessageData) ] -> [ ChatMessage ]
threadToListSince since thread = helper (S.fromList since) thread
  where
    helper :: S.Set (Stored (Signed ChatMessageData)) -> [Stored (Signed ChatMessageData)] -> [ChatMessage]
    helper seen msgs
        | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs =
            maybe id (:) (validateSingleMessage msg) $
               helper (S.insert msg seen) (msgs' ++ mdPrev (fromSigned msg))
        | otherwise = []
    cmpView msg = (zonedTimeToUTC $ mdTime $ fromSigned msg, msg)

sendChatroomMessage
    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
    => ChatroomState -> Text -> m ()
sendChatroomMessage rstate msg = sendChatroomMessageByStateData (head $ roomStateData rstate) msg

sendChatroomMessageByStateData
    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
    => Stored ChatroomStateData -> Text -> m ()
sendChatroomMessageByStateData lookupData msg = void $ findAndUpdateChatroomState $ \cstate -> do
    guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate
    Just $ do
        self <- finalOwner . localIdentity . fromStored <$> getLocalHead
        secret <- loadKey $ idKeyMessage self
        time <- liftIO getZonedTime
        mdata <- mstore =<< sign secret =<< mstore ChatMessageData
            { mdPrev = roomStateMessageData cstate
            , mdRoom = if null (roomStateMessageData cstate)
                          then maybe [] roomData (roomStateRoom cstate)
                          else []
            , mdFrom = self
            , mdReplyTo = Nothing
            , mdTime = time
            , mdText = Just msg
            , mdLeave = False
            }
        mergeSorted . (:[]) <$> mstore ChatroomStateData
            { rsdPrev = roomStateData cstate
            , rsdRoom = []
            , rsdSubscribe = Just True
            , rsdMessages = [ mdata ]
            }


data ChatroomStateData = ChatroomStateData
    { rsdPrev :: [Stored ChatroomStateData]
    , rsdRoom :: [Stored (Signed ChatroomData)]
    , rsdSubscribe :: Maybe Bool
    , rsdMessages :: [Stored (Signed ChatMessageData)]
    }

data ChatroomState = ChatroomState
    { roomStateData :: [Stored ChatroomStateData]
    , roomStateRoom :: Maybe Chatroom
    , roomStateMessageData :: [Stored (Signed ChatMessageData)]
    , roomStateSubscribe :: Bool
    , roomStateMessages :: [ChatMessage]
    }

instance Storable ChatroomStateData where
    store' ChatroomStateData {..} = storeRec $ do
        forM_ rsdPrev $ storeRef "PREV"
        forM_ rsdRoom $ storeRef "room"
        forM_ rsdSubscribe $ storeInt "subscribe" . bool @Int 0 1
        forM_ rsdMessages $ storeRef "msg"

    load' = loadRec $ do
        rsdPrev <- loadRefs "PREV"
        rsdRoom <- loadRefs "room"
        rsdSubscribe <- fmap ((/=) @Int 0) <$> loadMbInt "subscribe"
        rsdMessages <- loadRefs "msg"
        return ChatroomStateData {..}

instance Mergeable ChatroomState where
    type Component ChatroomState = ChatroomStateData

    mergeSorted roomStateData =
        let roomStateRoom = either (const Nothing) Just $ runExcept $
                validateChatroom $ concat $ findProperty ((\case [] -> Nothing; xs -> Just xs) . rsdRoom) roomStateData
            roomStateMessageData = filterAncestors $ concat $ flip findProperty roomStateData $ \case
                ChatroomStateData {..} | null rsdMessages -> Nothing
                                       | otherwise        -> Just rsdMessages
            roomStateSubscribe = fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData
            roomStateMessages = threadToListSince [] $ concatMap (rsdMessages . fromStored) roomStateData
         in ChatroomState {..}

    toComponents = roomStateData

instance SharedType (Set ChatroomState) where
    sharedTypeID _ = mkSharedTypeID "7bc71cbf-bc43-42b1-b413-d3a2c9a2aae0"

createChatroom :: (MonadStorage m, MonadHead LocalState m, MonadIO m, MonadError String m) => Maybe Text -> Maybe Text -> m ChatroomState
createChatroom rdName rdDescription = do
    (secret, rdKey) <- liftIO . generateKeys =<< getStorage
    let rdPrev = []
    rdata <- mstore =<< sign secret =<< mstore ChatroomData {..}
    cstate <- mergeSorted . (:[]) <$> mstore ChatroomStateData
        { rsdPrev = []
        , rsdRoom = [ rdata ]
        , rsdSubscribe = Just True
        , rsdMessages = []
        }

    updateLocalHead $ updateSharedState $ \rooms -> do
        st <- getStorage
        (, cstate) <$> storeSetAdd st cstate rooms

findAndUpdateChatroomState
    :: (MonadStorage m, MonadHead LocalState m)
    => (ChatroomState -> Maybe (m ChatroomState))
    -> m (Maybe ChatroomState)
findAndUpdateChatroomState f = do
    updateLocalHead $ updateSharedState $ \roomSet -> do
        let roomList = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet
        case catMaybes $ map (\x -> (x,) <$> f x) roomList of
            ((orig, act) : _) -> do
                upd <- act
                if roomStateData orig /= roomStateData upd
                  then do
                    st <- getStorage
                    roomSet' <- storeSetAdd st upd roomSet
                    return (roomSet', Just upd)
                  else do
                    return (roomSet, Just upd)
            [] -> return (roomSet, Nothing)

updateChatroomByStateData
    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
    => Stored ChatroomStateData
    -> Maybe Text
    -> Maybe Text
    -> m (Maybe ChatroomState)
updateChatroomByStateData lookupData newName newDesc = findAndUpdateChatroomState $ \cstate -> do
    guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate
    room <- roomStateRoom cstate
    Just $ do
        secret <- loadKey $ roomKey room
        rdata <- mstore =<< sign secret =<< mstore ChatroomData
            { rdPrev = roomData room
            , rdName = newName
            , rdDescription = newDesc
            , rdKey = roomKey room
            }
        mergeSorted . (:[]) <$> mstore ChatroomStateData
            { rsdPrev = roomStateData cstate
            , rsdRoom = [ rdata ]
            , rsdSubscribe = Just True
            , rsdMessages = []
            }


listChatrooms :: MonadHead LocalState m => m [ChatroomState]
listChatrooms = fromSetBy (comparing $ roomName <=< roomStateRoom) .
    lookupSharedValue . lsShared . fromStored <$> getLocalHead

findChatroom :: MonadHead LocalState m => (ChatroomState -> Bool) -> m (Maybe ChatroomState)
findChatroom p = do
    list <- map snd . chatroomSetToList . lookupSharedValue . lsShared . fromStored <$> getLocalHead
    return $ find p list

findChatroomByRoomData :: MonadHead LocalState m => Stored (Signed ChatroomData) -> m (Maybe ChatroomState)
findChatroomByRoomData cdata = findChatroom $
    maybe False (any (cdata `precedesOrEquals`) . roomData) . roomStateRoom

findChatroomByStateData :: MonadHead LocalState m => Stored ChatroomStateData -> m (Maybe ChatroomState)
findChatroomByStateData cdata = findChatroom $ any (cdata `precedesOrEquals`) . roomStateData

chatroomSetSubscribe
    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
    => Stored ChatroomStateData -> Bool -> m ()
chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $ \cstate -> do
    guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate
    Just $ do
        mergeSorted . (:[]) <$> mstore ChatroomStateData
            { rsdPrev = roomStateData cstate
            , rsdRoom = []
            , rsdSubscribe = Just subscribe
            , rsdMessages = []
            }

getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage]
getMessagesSinceState cur old = threadToListSince (roomStateMessageData old) (roomStateMessageData cur)


data ChatroomSetChange = AddedChatroom ChatroomState
                       | RemovedChatroom ChatroomState
                       | UpdatedChatroom ChatroomState ChatroomState

watchChatrooms :: MonadIO m => Head LocalState -> (Set ChatroomState -> Maybe [ChatroomSetChange] -> IO ()) -> m WatchedHead
watchChatrooms h f = liftIO $ do
    lastVar <- newIORef Nothing
    watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \cur -> do
        let curList = chatroomSetToList cur
        mbLast <- readIORef lastVar
        writeIORef lastVar $ Just curList
        f cur $ do
            lastList <- mbLast
            return $ makeChatroomDiff lastList curList

chatroomSetToList :: Set ChatroomState -> [(Stored ChatroomStateData, ChatroomState)]
chatroomSetToList = map (cmp &&& id) . fromSetBy (comparing cmp)
  where
    cmp :: ChatroomState -> Stored ChatroomStateData
    cmp = head . filterAncestors . concatMap storedRoots . toComponents

makeChatroomDiff
    :: [(Stored ChatroomStateData, ChatroomState)]
    -> [(Stored ChatroomStateData, ChatroomState)]
    -> [ChatroomSetChange]
makeChatroomDiff (x@(cx, vx) : xs) (y@(cy, vy) : ys)
    | cx < cy = RemovedChatroom vx : makeChatroomDiff xs (y : ys)
    | cx > cy = AddedChatroom vy : makeChatroomDiff (x : xs) ys
    | roomStateData vx /= roomStateData vy = UpdatedChatroom vx vy : makeChatroomDiff xs ys
    | otherwise = makeChatroomDiff xs ys
makeChatroomDiff xs [] = map (RemovedChatroom . snd) xs
makeChatroomDiff [] ys = map (AddedChatroom . snd) ys


data ChatroomService = ChatroomService
    { chatRoomQuery :: Bool
    , chatRoomInfo :: [Stored (Signed ChatroomData)]
    , chatRoomSubscribe :: [Stored (Signed ChatroomData)]
    , chatRoomUnsubscribe :: [Stored (Signed ChatroomData)]
    , chatRoomMessage :: [Stored (Signed ChatMessageData)]
    }
    deriving (Eq)

emptyPacket :: ChatroomService
emptyPacket = ChatroomService
    { chatRoomQuery = False
    , chatRoomInfo = []
    , chatRoomSubscribe = []
    , chatRoomUnsubscribe = []
    , chatRoomMessage = []
    }

instance Storable ChatroomService where
    store' ChatroomService {..} = storeRec $ do
        when  chatRoomQuery $ storeEmpty "room-query"
        forM_ chatRoomInfo $ storeRef "room-info"
        forM_ chatRoomSubscribe $ storeRef "room-subscribe"
        forM_ chatRoomUnsubscribe $ storeRef "room-unsubscribe"
        forM_ chatRoomMessage $ storeRef "room-message"

    load' = loadRec $ do
        chatRoomQuery <- isJust <$> loadMbEmpty "room-query"
        chatRoomInfo <- loadRefs "room-info"
        chatRoomSubscribe <- loadRefs "room-subscribe"
        chatRoomUnsubscribe <- loadRefs "room-unsubscribe"
        chatRoomMessage <- loadRefs "room-message"
        return ChatroomService {..}

data PeerState = PeerState
    { psSendRoomUpdates :: Bool
    , psLastList :: [(Stored ChatroomStateData, ChatroomState)]
    , psSubscribedTo :: [ Stored (Signed ChatroomData) ] -- least root for each room
    }

instance Service ChatroomService where
    serviceID _ = mkServiceID "627657ae-3e39-468a-8381-353395ef4386"

    type ServiceState ChatroomService = PeerState
    emptyServiceState _ = PeerState
        { psSendRoomUpdates = False
        , psLastList = []
        , psSubscribedTo = []
        }

    serviceHandler spacket = do
        let ChatroomService {..} = fromStored spacket

        previouslyUpdated <- psSendRoomUpdates <$> svcGet
        svcModify $ \s -> s { psSendRoomUpdates = True }

        when (not previouslyUpdated) $ do
            syncChatroomsToPeer . lookupSharedValue . lsShared . fromStored =<< getLocalHead

        when chatRoomQuery $ do
            rooms <- listChatrooms
            replyPacket emptyPacket
                { chatRoomInfo = concatMap roomData $ catMaybes $ map roomStateRoom rooms
                }

        when (not $ null chatRoomInfo) $ do
            updateLocalHead_ $ updateSharedState_ $ \roomSet -> do
                let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet
                    upd set (roomInfo :: Stored (Signed ChatroomData)) = do
                        let currentRoots = storedRoots roomInfo
                            isCurrentRoom = any ((`intersectsSorted` currentRoots) . storedRoots) .
                                maybe [] roomData . roomStateRoom

                        let prev = concatMap roomStateData $ filter isCurrentRoom rooms
                            prevRoom = filterAncestors $ concat $ findProperty ((\case [] -> Nothing; xs -> Just xs) . rsdRoom) prev
                            room = filterAncestors $ (roomInfo : ) prevRoom

                        -- update local state only if we got roomInfo not present there
                        if roomInfo `notElem` prevRoom && roomInfo `elem` room
                          then do
                            sdata <- mstore ChatroomStateData
                                { rsdPrev = prev
                                , rsdRoom = room
                                , rsdSubscribe = Nothing
                                , rsdMessages = []
                                }
                            storeSetAddComponent sdata set
                          else return set
                foldM upd roomSet chatRoomInfo

        forM_ chatRoomSubscribe $ \subscribeData -> do
            mbRoomState <- findChatroomByRoomData subscribeData
            forM_ mbRoomState $ \roomState ->
                forM (roomStateRoom roomState) $ \room -> do
                    let leastRoot = head . filterAncestors . concatMap storedRoots . roomData $ room
                    svcModify $ \ps -> ps { psSubscribedTo = leastRoot : psSubscribedTo ps }
                    replyPacket emptyPacket
                        { chatRoomMessage = roomStateMessageData roomState
                        }

        forM_ chatRoomUnsubscribe $ \unsubscribeData -> do
            mbRoomState <- findChatroomByRoomData unsubscribeData
            forM_ (mbRoomState >>= roomStateRoom) $ \room -> do
                let leastRoot = head . filterAncestors . concatMap storedRoots . roomData $ room
                svcModify $ \ps -> ps { psSubscribedTo = filter (/= leastRoot) (psSubscribedTo ps) }

        when (not (null chatRoomMessage)) $ do
            updateLocalHead_ $ updateSharedState_ $ \roomSet -> do
                let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet
                    upd set (msgData :: Stored (Signed ChatMessageData))
                        | Just msg <- validateSingleMessage msgData = do
                            let roomInfo = cmsgRoomData msg
                                currentRoots = filterAncestors $ concatMap storedRoots roomInfo
                                isCurrentRoom = any ((`intersectsSorted` currentRoots) . storedRoots) .
                                    maybe [] roomData . roomStateRoom

                            let prevData = concatMap roomStateData $ filter isCurrentRoom rooms
                                prev = mergeSorted prevData
                                prevMessages = roomStateMessageData prev
                                messages = filterAncestors $ msgData : prevMessages

                            -- update local state only if subscribed and we got some new messages
                            if roomStateSubscribe prev && messages /= prevMessages
                              then do
                                sdata <- mstore ChatroomStateData
                                    { rsdPrev = prevData
                                    , rsdRoom = []
                                    , rsdSubscribe = Nothing
                                    , rsdMessages = messages
                                    }
                                storeSetAddComponent sdata set
                              else return set
                        | otherwise = return set
                foldM upd roomSet chatRoomMessage

    serviceNewPeer = do
        replyPacket emptyPacket { chatRoomQuery = True }

    serviceStorageWatchers _ = (:[]) $
        SomeStorageWatcher (lookupSharedValue . lsShared . fromStored) syncChatroomsToPeer

syncChatroomsToPeer :: Set ChatroomState -> ServiceHandler ChatroomService ()
syncChatroomsToPeer set = do
    ps@PeerState {..} <- svcGet
    when psSendRoomUpdates $ do
        let curList = chatroomSetToList set
            diff = makeChatroomDiff psLastList curList

        roomUpdates <- fmap (concat . catMaybes) $
            forM diff $ return . \case
                AddedChatroom room -> roomData <$> roomStateRoom room
                RemovedChatroom {} -> Nothing
                UpdatedChatroom oldroom room
                    | roomStateData oldroom /= roomStateData room -> roomData <$> roomStateRoom room
                    | otherwise -> Nothing

        (subscribe, unsubscribe) <- fmap (partitionEithers . concat . catMaybes) $
            forM diff $ return . \case
                AddedChatroom room
                    | roomStateSubscribe room
                    -> map Left . roomData <$> roomStateRoom room
                RemovedChatroom oldroom
                    | roomStateSubscribe oldroom
                    -> map Right . roomData <$> roomStateRoom oldroom
                UpdatedChatroom oldroom room
                    | roomStateSubscribe oldroom /= roomStateSubscribe room
                    -> map (if roomStateSubscribe room then Left else Right) . roomData <$> roomStateRoom room
                _ -> Nothing

        messages <- fmap concat $ do
            let leastRootFor = head . filterAncestors . concatMap storedRoots . roomData
            forM diff $ return . \case
                AddedChatroom rstate
                    | Just room <- roomStateRoom rstate
                    , leastRootFor room `elem` psSubscribedTo
                    -> roomStateMessageData rstate
                UpdatedChatroom oldstate rstate
                    | Just room <- roomStateRoom rstate
                    , leastRootFor room `elem` psSubscribedTo
                    , roomStateMessageData oldstate /= roomStateMessageData rstate
                    -> roomStateMessageData rstate
                _ -> []

        let packet = emptyPacket
                { chatRoomInfo = roomUpdates
                , chatRoomSubscribe = subscribe
                , chatRoomUnsubscribe = unsubscribe
                , chatRoomMessage = messages
                }

        when (packet /= emptyPacket) $ do
            replyPacket packet
        svcSet $ ps { psLastList = curList }