summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Identity.hs5
-rw-r--r--src/Main.hs22
-rw-r--r--src/Message.hs194
-rw-r--r--src/Message/Service.hs63
-rw-r--r--src/State.hs8
-rw-r--r--src/Storage/Merge.hs10
6 files changed, 173 insertions, 129 deletions
diff --git a/src/Identity.hs b/src/Identity.hs
index dcf0ca4..91bd04c 100644
--- a/src/Identity.hs
+++ b/src/Identity.hs
@@ -6,7 +6,7 @@ module Identity (
emptyIdentityData,
validateIdentity, validateIdentityF,
- loadIdentity,
+ loadIdentity, loadUnifiedIdentity,
mergeIdentity, toUnifiedIdentity, toComposedIdentity,
updateIdentity, updateOwners,
@@ -128,6 +128,9 @@ validateIdentityF mdata = do
loadIdentity :: String -> LoadRec ComposedIdentity
loadIdentity name = maybe (throwError "identity validation failed") return . validateIdentityF =<< loadRefs name
+loadUnifiedIdentity :: String -> LoadRec UnifiedIdentity
+loadUnifiedIdentity name = maybe (throwError "identity validation failed") return . validateIdentity =<< loadRef name
+
gatherPrevious :: Set (Stored (Signed IdentityData)) -> [Stored (Signed IdentityData)] -> Set (Stored (Signed IdentityData))
gatherPrevious res (n:ns) | n `S.member` res = gatherPrevious res ns
diff --git a/src/Main.hs b/src/Main.hs
index 696b896..6da9826 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -27,13 +27,11 @@ import System.Environment
import Attach
import Identity
import Message
-import Message.Service
import Network
import PubKey
import Service
import State
import Storage
-import Storage.List
import Sync
main :: IO ()
@@ -211,24 +209,9 @@ cmdSetPeer n | n < 1 = liftIO $ putStrLn "Invalid peer index"
cmdSend :: Command
cmdSend = void $ do
self <- asks ciSelf
- let st = storedStorage $ idData self
Just peer <- gets csPeer
- PeerIdentityFull pid <- return $ peerIdentity peer
- let powner = finalOwner pid :: ComposedIdentity
text <- asks ciLine
- smsg <- liftIO $ updateLocalState st $ \erb -> do
- threads <- storedFromSList $ lsMessages $ fromStored erb
- (slist, smsg) <- case find (sameIdentity powner . msgPeer . fromStored) threads of
- Just thread -> do
- (smsg, thread') <- createDirectMessage self (fromStored thread) (T.pack text)
- (,smsg) <$> slistReplaceS thread thread' (lsMessages $ fromStored erb)
- Nothing -> do
- (smsg, thread') <- createDirectMessage self (emptyDirectThread powner) (T.pack text)
- (,smsg) <$> slistAddS thread' (lsMessages $ fromStored erb)
- erb' <- wrappedStore st (fromStored erb) { lsMessages = slist }
- return (erb', smsg)
- sendToPeer self peer $ DirectMessagePacket smsg
-
+ smsg <- sendDirectMessage self peer $ T.pack text
tzone <- liftIO $ getCurrentTimeZone
liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg
@@ -242,7 +225,8 @@ cmdHistory = void $ do
Just erebosHead <- liftIO $ loadHead st "erebos"
let erebos = wrappedLoad (headRef erebosHead)
- Just thread <- return $ find (sameIdentity powner . msgPeer) $ fromSList $ lsMessages $ fromStored erebos
+ Just thread <- return $ find (sameIdentity powner . msgPeer) $
+ messageThreadView $ lookupSharedValue $ lsShared $ fromStored erebos
tzone <- liftIO $ getCurrentTimeZone
liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread
diff --git a/src/Message.hs b/src/Message.hs
index 21f398c..bfb4b66 100644
--- a/src/Message.hs
+++ b/src/Message.hs
@@ -1,16 +1,32 @@
module Message (
- DirectMessage(..), DirectMessageThread(..),
- emptyDirectThread, createDirectMessage,
+ DirectMessage(..),
+ DirectMessageService,
+ ServicePacket(DirectMessagePacket),
+
+ sendDirectMessage,
+
+ DirectMessageThread(..),
threadToList,
+ messageThreadView,
+
+ formatMessage,
) where
+import Control.Monad.Except
+import Control.Monad.Reader
+
import Data.List
import Data.Ord
import qualified Data.Set as S
import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Format
import Data.Time.LocalTime
import Identity
+import Network
+import Service
+import State
import Storage
import Storage.Merge
@@ -21,12 +37,6 @@ data DirectMessage = DirectMessage
, msgText :: Text
}
-data DirectMessageThread = DirectMessageThread
- { msgPeer :: ComposedIdentity
- , msgHead :: [Stored DirectMessage]
- , msgSeen :: [Stored DirectMessage]
- }
-
instance Storable DirectMessage where
store' msg = storeRec $ do
mapM_ (storeRef "from") $ idDataF $ msgFrom msg
@@ -40,43 +50,123 @@ instance Storable DirectMessage where
<*> loadDate "time"
<*> loadText "text"
-instance Storable DirectMessageThread where
- store' msg = storeRec $ do
- mapM_ (storeRef "peer") $ idDataF $ msgPeer msg
- mapM_ (storeRef "head") $ msgHead msg
- mapM_ (storeRef "seen") $ msgSeen msg
+data DirectMessageService
+
+instance Service DirectMessageService where
+ serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d"
+
+ data ServiceState DirectMessageService = DirectMessageService
+ emptyServiceState = DirectMessageService
+
+ newtype ServicePacket DirectMessageService = DirectMessagePacket (Stored DirectMessage)
+
+ serviceHandler packet = do
+ let DirectMessagePacket smsg = fromStored packet
+ msg = fromStored smsg
+ powner <- asks $ finalOwner . svcPeer
+ tzone <- liftIO $ getCurrentTimeZone
+ erb <- svcGetLocal
+ let st = storedStorage erb
+ prev = lookupSharedValue $ lsShared $ fromStored erb
+ sent = findMsgProperty powner msSent prev
+ received = findMsgProperty powner msReceived prev
+ if powner `sameIdentity` msgFrom msg ||
+ filterAncestors sent == filterAncestors (smsg : sent)
+ then do
+ erb' <- liftIO $ do
+ next <- wrappedStore st $ MessageState
+ { msPrev = prev
+ , msPeer = powner
+ , msSent = []
+ , msReceived = filterAncestors $ smsg : received
+ , msSeen = []
+ }
+ shared <- makeSharedStateUpdate st [next] (lsShared $ fromStored erb)
+ wrappedStore st (fromStored erb) { lsShared = [shared] }
+ svcSetLocal erb'
+ if powner `sameIdentity` msgFrom msg
+ then do
+ svcPrint $ formatMessage tzone msg
+ return $ Just $ DirectMessagePacket smsg
+ else return Nothing
+
+ else do svcPrint "Owner mismatch"
+ return Nothing
+
+instance Storable (ServicePacket DirectMessageService) where
+ store' (DirectMessagePacket smsg) = store' smsg
+ load' = DirectMessagePacket <$> load'
+
- load' = loadRec $ DirectMessageThread
- <$> loadIdentity "peer"
- <*> loadRefs "head"
+data MessageState = MessageState
+ { msPrev :: [Stored MessageState]
+ , msPeer :: ComposedIdentity
+ , msSent :: [Stored DirectMessage]
+ , msReceived :: [Stored DirectMessage]
+ , msSeen :: [Stored DirectMessage]
+ }
+
+instance Storable MessageState where
+ store' ms = storeRec $ do
+ mapM_ (storeRef "PREV") $ msPrev ms
+ mapM_ (storeRef "peer") $ idDataF $ msPeer ms
+ mapM_ (storeRef "sent") $ msSent ms
+ mapM_ (storeRef "received") $ msReceived ms
+ mapM_ (storeRef "seen") $ msSeen ms
+
+ load' = loadRec $ MessageState
+ <$> loadRefs "PREV"
+ <*> loadIdentity "peer"
+ <*> loadRefs "sent"
+ <*> loadRefs "received"
<*> loadRefs "seen"
-instance Mergeable DirectMessageThread where
- mergeSorted ts = DirectMessageThread
- { msgPeer = msgPeer $ fromStored $ head ts -- TODO: merge identity
- , msgHead = filterAncestors $ msgHead . fromStored =<< ts
- , msgSeen = filterAncestors $ msgSeen . fromStored =<< ts
- }
+instance SharedType MessageState where
+ sharedTypeID _ = mkSharedTypeID "ee793681-5976-466a-b0f0-4e1907d3fade"
+findMsgProperty :: Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a]
+findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do
+ guard $ msPeer x `sameIdentity` pid
+ guard $ not $ null $ sel x
+ return $ sel x
-emptyDirectThread :: ComposedIdentity -> DirectMessageThread
-emptyDirectThread peer = DirectMessageThread peer [] []
-createDirectMessage :: UnifiedIdentity -> DirectMessageThread -> Text -> IO (Stored DirectMessage, Stored DirectMessageThread)
-createDirectMessage self thread msg = do
+sendDirectMessage :: (MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> Text -> m (Stored DirectMessage)
+sendDirectMessage self peer text = do
+ pid <- case peerIdentity peer of PeerIdentityFull pid -> return pid
+ _ -> throwError "incomplete peer identity"
let st = storedStorage $ idData self
- time <- getZonedTime
- smsg <- wrappedStore st DirectMessage
- { msgFrom = toComposedIdentity $ finalOwner self
- , msgPrev = msgHead thread
- , msgTime = time
- , msgText = msg
- }
- sthread <- wrappedStore st thread
- { msgHead = [smsg]
- , msgSeen = [smsg]
- }
- return (smsg, sthread)
+ powner = finalOwner pid
+
+ smsg <- liftIO $ updateSharedState st $ \prev -> do
+ let sent = findMsgProperty powner msSent prev
+ received = findMsgProperty powner msReceived prev
+
+ time <- getZonedTime
+ smsg <- wrappedStore st DirectMessage
+ { msgFrom = toComposedIdentity $ finalOwner self
+ , msgPrev = filterAncestors $ sent ++ received
+ , msgTime = time
+ , msgText = text
+ }
+ next <- wrappedStore st $ MessageState
+ { msPrev = prev
+ , msPeer = powner
+ , msSent = [smsg]
+ , msReceived = []
+ , msSeen = []
+ }
+ return ([next], smsg)
+
+ sendToPeer self peer $ DirectMessagePacket smsg
+ return smsg
+
+
+data DirectMessageThread = DirectMessageThread
+ { msgPeer :: ComposedIdentity
+ , msgHead :: [Stored DirectMessage]
+ , msgSeen :: [Stored DirectMessage]
+ }
threadToList :: DirectMessageThread -> [DirectMessage]
threadToList thread = helper S.empty $ msgHead thread
@@ -85,3 +175,31 @@ threadToList thread = helper S.empty $ msgHead thread
fromStored msg : helper (S.insert msg seen) (msgs' ++ msgPrev (fromStored msg))
| otherwise = []
cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, msg)
+
+messageThreadView :: [Stored MessageState] -> [DirectMessageThread]
+messageThreadView = helper []
+ where helper used ms' = case filterAncestors ms' of
+ mss@(sms : rest)
+ | any (sameIdentity $ msPeer $ fromStored sms) used ->
+ helper used $ msPrev (fromStored sms) ++ rest
+ | otherwise ->
+ let peer = msPeer $ fromStored sms
+ sent = findMsgProperty peer msSent mss
+ received = findMsgProperty peer msReceived mss
+ seen = findMsgProperty peer msSeen mss
+
+ in DirectMessageThread
+ { msgPeer = peer
+ , msgHead = filterAncestors $ sent ++ received
+ , msgSeen = filterAncestors $ sent ++ seen
+ } : helper (peer : used) (msPrev (fromStored sms) ++ rest)
+ _ -> []
+
+
+formatMessage :: TimeZone -> DirectMessage -> String
+formatMessage tzone msg = concat
+ [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg
+ , maybe "<unnamed>" T.unpack $ idName $ msgFrom msg
+ , ": "
+ , T.unpack $ msgText msg
+ ]
diff --git a/src/Message/Service.hs b/src/Message/Service.hs
deleted file mode 100644
index 0a8f180..0000000
--- a/src/Message/Service.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-module Message.Service (
- DirectMessageService,
- ServicePacket(DirectMessagePacket),
- formatMessage,
-) where
-
-import Control.Monad.Reader
-
-import Data.List
-import qualified Data.Text as T
-import Data.Time.Format
-import Data.Time.LocalTime
-
-import Identity
-import Message
-import Service
-import State
-import Storage
-import Storage.List
-
-data DirectMessageService
-
-instance Service DirectMessageService where
- serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d"
-
- data ServiceState DirectMessageService = DirectMessageService
- emptyServiceState = DirectMessageService
-
- newtype ServicePacket DirectMessageService = DirectMessagePacket (Stored DirectMessage)
-
- serviceHandler packet = do
- let DirectMessagePacket smsg = fromStored packet
- msg = fromStored smsg
- powner <- asks $ finalOwner . svcPeer
- tzone <- liftIO $ getCurrentTimeZone
- svcPrint $ formatMessage tzone msg
- if | powner `sameIdentity` msgFrom msg
- -> do erb <- svcGetLocal
- let st = storedStorage erb
- erb' <- liftIO $ do
- threads <- storedFromSList $ lsMessages $ fromStored erb
- slist <- case find (sameIdentity powner . msgPeer . fromStored) threads of
- Just thread -> do thread' <- wrappedStore st (fromStored thread) { msgHead = smsg : msgHead (fromStored thread) }
- slistReplaceS thread thread' $ lsMessages $ fromStored erb
- Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [smsg] } $ lsMessages $ fromStored erb
- wrappedStore st (fromStored erb) { lsMessages = slist }
- svcSetLocal erb'
- return Nothing
-
- | otherwise -> do svcPrint "Owner mismatch"
- return Nothing
-
-instance Storable (ServicePacket DirectMessageService) where
- store' (DirectMessagePacket smsg) = store' smsg
- load' = DirectMessagePacket <$> load'
-
-formatMessage :: TimeZone -> DirectMessage -> String
-formatMessage tzone msg = concat
- [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg
- , maybe "<unnamed>" T.unpack $ idName $ msgFrom msg
- , ": "
- , T.unpack $ msgText msg
- ]
diff --git a/src/State.hs b/src/State.hs
index bb7c570..15ae7d2 100644
--- a/src/State.hs
+++ b/src/State.hs
@@ -29,16 +29,13 @@ import qualified Data.UUID as U
import System.IO
import Identity
-import Message
import PubKey
import Storage
-import Storage.List
import Storage.Merge
data LocalState = LocalState
{ lsIdentity :: Stored (Signed IdentityData)
, lsShared :: [Stored SharedState]
- , lsMessages :: StoredList DirectMessageThread -- TODO: move to shared
}
data SharedState = SharedState
@@ -60,12 +57,10 @@ instance Storable LocalState where
store' st = storeRec $ do
storeRef "id" $ lsIdentity st
mapM_ (storeRef "shared") $ lsShared st
- storeRef "dmsg" $ lsMessages st
load' = loadRec $ LocalState
<$> loadRef "id"
<*> loadRefs "shared"
- <*> loadRef "dmsg"
instance Storable SharedState where
store' st = storeRec $ do
@@ -114,8 +109,6 @@ loadLocalStateHead st = loadHeadDef st "erebos" $ do
, iddKeyMessage = Just devPublicMsg
}
- msgs <- emptySList st
-
shared <- wrappedStore st $ SharedState
{ ssPrev = []
, ssType = Just $ sharedTypeID @(Signed IdentityData) Proxy
@@ -124,7 +117,6 @@ loadLocalStateHead st = loadHeadDef st "erebos" $ do
return $ LocalState
{ lsIdentity = identity
, lsShared = [shared]
- , lsMessages = msgs
}
loadLocalIdentity :: Storage -> IO UnifiedIdentity
diff --git a/src/Storage/Merge.hs b/src/Storage/Merge.hs
index 17b02aa..f0eaf98 100644
--- a/src/Storage/Merge.hs
+++ b/src/Storage/Merge.hs
@@ -6,6 +6,8 @@ module Storage.Merge (
ancestors,
precedes,
filterAncestors,
+
+ findProperty,
) where
import qualified Data.ByteString.Char8 as BC
@@ -58,4 +60,12 @@ precedes :: Storable a => Stored a -> Stored a -> Bool
precedes x y = x `S.member` ancestors [y]
filterAncestors :: Storable a => [Stored a] -> [Stored a]
+filterAncestors [x] = [x]
filterAncestors xs = uniq $ sort $ filter (`S.notMember` ancestors xs) xs
+
+
+findProperty :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> [b]
+findProperty sel = map (fromJust . sel . fromStored) . filterAncestors . (findPropHeads =<<)
+ where findPropHeads :: Stored a -> [Stored a]
+ findPropHeads sobj | Just _ <- sel $ fromStored sobj = [sobj]
+ | otherwise = findPropHeads =<< previous sobj
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-07 21:03:41 +0000