summaryrefslogtreecommitdiff
path: root/src/Erebos
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2024-03-23 13:27:46 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2024-03-23 16:49:28 +0100
commita168d79d757c28cd328b9c9cd0fb5033c57a4ee7 (patch)
tree44bc0745ea68637b222f7e981248d59a50e61ad1 /src/Erebos
parent68db551ede73903c5f23dca6ea0fcff41c6a0ac5 (diff)
Chatroom shared type
Diffstat (limited to 'src/Erebos')
-rw-r--r--src/Erebos/Chatroom.hs120
1 files changed, 120 insertions, 0 deletions
diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs
new file mode 100644
index 0000000..90848dd
--- /dev/null
+++ b/src/Erebos/Chatroom.hs
@@ -0,0 +1,120 @@
+module Erebos.Chatroom (
+ Chatroom(..),
+ ChatroomData(..),
+ validateChatroom,
+
+ ChatroomState(..),
+ createChatroom,
+) where
+
+import Control.Monad
+import Control.Monad.Except
+
+import Data.Monoid
+import Data.Text (Text)
+
+import Erebos.PubKey
+import Erebos.Set
+import Erebos.State
+import Erebos.Storage
+import Erebos.Storage.Merge
+
+
+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 ChatroomStateData = ChatroomStateData
+ { rsdPrev :: [Stored ChatroomStateData]
+ , rsdRoom :: [Stored (Signed ChatroomData)]
+ }
+
+data ChatroomState = ChatroomState
+ { roomStateData :: [Stored ChatroomStateData]
+ , roomStateRoom :: Maybe Chatroom
+ }
+
+instance Storable ChatroomStateData where
+ store' ChatroomStateData {..} = storeRec $ do
+ forM_ rsdPrev $ storeRef "PREV"
+ forM_ rsdRoom $ storeRef "room"
+
+ load' = loadRec $ do
+ rsdPrev <- loadRefs "PREV"
+ rsdRoom <- loadRefs "room"
+ return ChatroomStateData {..}
+
+instance Mergeable ChatroomState where
+ type Component ChatroomState = ChatroomStateData
+
+ mergeSorted cdata = ChatroomState
+ { roomStateData = cdata
+ , roomStateRoom = either (const Nothing) Just $ runExcept $
+ validateChatroom $ concat $ findProperty ((\case [] -> Nothing; xs -> Just xs) . rsdRoom) cdata
+ }
+
+ 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 Chatroom
+createChatroom rdName rdDescription = do
+ st <- getStorage
+ (secret, rdKey) <- liftIO $ generateKeys st
+ let rdPrev = []
+ rdata <- wrappedStore st =<< sign secret =<< wrappedStore st ChatroomData {..}
+ room <- liftEither $ runExcept $ validateChatroom [ rdata ]
+
+ updateLocalHead_ $ updateSharedState_ $ \rooms -> do
+ sdata <- wrappedStore st ChatroomStateData
+ { rsdPrev = []
+ , rsdRoom = [ rdata ]
+ }
+ storeSetAdd st (mergeSorted @ChatroomState [ sdata ]) rooms
+ return room