Direct messages in shared state

7 files changed, 173 insertions, 130 deletions

diff --git a/erebos.cabal b/erebos.cabal
index 766d708..e7a8cee 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -22,7 +22,6 @@ executable erebos
                        Identity,
                        Channel,
                        Message,
-                       Message.Service
                        Network,
                        PubKey,
                        Service
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