Direct message service basics

5 files changed, 234 insertions, 24 deletions

diff --git a/erebos.cabal b/erebos.cabal
index 259f9b6..8a5e15f 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -20,6 +20,7 @@ executable erebos
   main-is:             Main.hs
   other-modules:       Identity,
                        Channel,
+                       Message,
                        Network,
                        PubKey,
                        Storage,
@@ -30,6 +31,7 @@ executable erebos
                        FlexibleInstances,
                        FunctionalDependencies,
                        LambdaCase,
+                       MultiWayIf,
                        ScopedTypeVariables,
                        TupleSections
 
diff --git a/src/Identity.hs b/src/Identity.hs
index c1561b6..ff63353 100644
--- a/src/Identity.hs
+++ b/src/Identity.hs
@@ -1,6 +1,7 @@
 module Identity (
     Identity, IdentityData(..),
     emptyIdentity,
+    finalOwner,
 ) where
 
 import Data.Text (Text)
@@ -42,3 +43,11 @@ instance Storable IdentityData where
         <*> loadMbRef "owner"
         <*> loadRef "key-id"
         <*> loadRef "key-msg"
+
+unfoldOwners :: Stored Identity -> [Stored Identity]
+unfoldOwners cur = cur : case idOwner $ fromStored $ signedData $ fromStored cur of
+                              Nothing   -> []
+                              Just prev -> unfoldOwners prev
+
+finalOwner :: Stored Identity -> Stored Identity
+finalOwner = last . unfoldOwners
diff --git a/src/Main.hs b/src/Main.hs
index 2a4dc4e..35f5a23 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,9 +1,12 @@
 module Main (main) where
 
-import Control.Concurrent.Chan
+import Control.Concurrent
 import Control.Exception
 import Control.Monad
 
+import Data.List
+import Data.Maybe
+import qualified Data.Text as T
 import qualified Data.Text.IO as T
 
 import System.Environment
@@ -11,16 +14,30 @@ import System.IO
 import System.IO.Error
 
 import Identity
+import Message
 import Network
 import PubKey
 import Storage
 
 
-main :: IO ()
-main = do
-    [bhost] <- getArgs
-    st <- openStorage "test"
-    idhead <- catchJust (guard . isDoesNotExistError) (loadHead st "identity") $ \_ -> do
+data Erebos = Erebos
+    { erbIdentity :: Stored Identity
+    , erbMessages :: StoredList DirectMessageThread
+    }
+
+instance Storable Erebos where
+    store' erb = storeRec $ do
+        storeRef "id" $ erbIdentity erb
+        storeZRef "dmsgs" $ erbMessages erb
+
+    load' = loadRec $ Erebos
+        <$> loadRef "id"
+        <*> loadZRef "dmsgs"
+
+
+loadErebosHead :: Storage -> IO Head
+loadErebosHead st = do
+    catchJust (guard . isDoesNotExistError) (loadHead st "erebos") $ \_ -> do
         putStr "Name: "
         hFlush stdout
         name <- T.getLine
@@ -31,14 +48,77 @@ main = do
         (_devSecretMsg, devPublicMsg) <- generateKeys st
 
         owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentity public publicMsg) { idName = Just name }
-        base <- signAdd devSecret =<< sign secret =<<
+        identity <- wrappedStore st =<< signAdd devSecret =<< sign secret =<<
             wrappedStore st (emptyIdentity devPublic devPublicMsg) { idOwner = Just owner }
 
-        Right h <- replaceHead base (Left (st, "identity"))
+        msgs <- emptySList st
+        let erebos = Erebos
+                { erbIdentity = identity
+                , erbMessages = msgs
+                }
+
+        Right h <- replaceHead erebos (Left (st, "erebos"))
         return h
-    let sidentity = wrappedLoad (headRef idhead) :: Stored Identity
-    print $ fromStored sidentity
 
-    chan <- peerDiscovery bhost sidentity
-    void $ forever $ print =<< readChan chan
+updateErebosHead_ :: Storage -> (Stored Erebos -> IO (Stored Erebos)) -> IO ()
+updateErebosHead_ st f = updateErebosHead st (fmap (,()) . f)
+
+updateErebosHead :: Storage -> (Stored Erebos -> IO (Stored Erebos, a)) -> IO a
+updateErebosHead st f = do
+    erebosHead <- loadHead st "erebos"
+    (erebos, x) <- f $ wrappedLoad (headRef erebosHead)
+    Right _ <- replaceHead erebos (Right erebosHead)
+    return x
+
+main :: IO ()
+main = do
+    [bhost] <- getArgs
+    st <- openStorage "test"
+    erebosHead <- loadErebosHead st
+    let serebos = wrappedLoad (headRef erebosHead) :: Stored Erebos
+        self = erbIdentity $ fromStored serebos
+    print $ fromStored self
+
+    (chanPeer, chanSvc) <- startServer bhost $ erbIdentity $ fromStored serebos
+
+    void $ forkIO $ void $ forever $ do
+        peer@Peer { peerAddress = DatagramAddress addr } <- readChan chanPeer
+        print addr
+        putStrLn $ maybe "<noid>" show $ peerIdentity peer
+        if | Just powner <- finalOwner <$> peerIdentity peer
+           , _:_ <- peerChannels peer
+           -> do
+               msg <- updateErebosHead st $ \erb -> do
+                   (slist, msg) <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
+                       Just thread -> do
+                           (msg, thread') <- createDirectMessage self (fromStored thread) (T.pack "Hello")
+                           (,msg) <$> slistReplaceS thread thread' (erbMessages $ fromStored erb)
+                       Nothing -> do
+                           (msg, thread') <- createDirectMessage self (emptyDirectThread powner) (T.pack "Hello")
+                           (,msg) <$> slistAddS thread' (erbMessages $ fromStored erb)
+                   erb' <- wrappedStore st (fromStored erb) { erbMessages = slist }
+                   return (erb', msg)
+               sendToPeer self peer (T.pack "dmsg") msg
+
+           | otherwise -> return ()
+
+    void $ forever $ readChan chanSvc >>= \case
+        (peer, svc, ref)
+            | svc == T.pack "dmsg" -> do
+                let msg = wrappedLoad ref
+                putStr "Direct message from: "
+                T.putStrLn $ fromMaybe (T.pack "<unnamed>") $ idName $ fromStored $ signedData $ fromStored $ msgFrom $ fromStored msg
+                if | Just powner <- finalOwner <$> peerIdentity peer
+                   , powner == msgFrom (fromStored msg)
+                   -> updateErebosHead_ st $ \erb -> do
+                          slist <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
+                                        Just thread -> do thread' <- wrappedStore st (fromStored thread) { msgHead = msg : msgHead (fromStored thread) }
+                                                          slistReplaceS thread thread' $ erbMessages $ fromStored erb
+                                        Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [msg] } $ erbMessages $ fromStored erb
+                          wrappedStore st (fromStored erb) { erbMessages = slist }
+
+                   | otherwise -> putStrLn $ "Owner mismatch"
+
+            | otherwise -> T.putStrLn $ T.pack "Unknown service: " `T.append` svc
+
     return ()
diff --git a/src/Message.hs b/src/Message.hs
new file mode 100644
index 0000000..8eaf7f1
--- /dev/null
+++ b/src/Message.hs
@@ -0,0 +1,77 @@
+module Message (
+    DirectMessage(..), DirectMessageThread(..),
+    emptyDirectThread, createDirectMessage,
+    threadToList,
+) where
+
+import Data.List
+import Data.Ord
+import Data.Text (Text)
+import Data.Time.LocalTime
+
+import Identity
+import Storage
+
+data DirectMessage = DirectMessage
+    { msgFrom :: Stored Identity
+    , msgPrev :: [Stored DirectMessage]
+    , msgTime :: ZonedTime
+    , msgText :: Text
+    }
+
+data DirectMessageThread = DirectMessageThread
+    { msgPeer :: Stored Identity
+    , msgHead :: [Stored DirectMessage]
+    , msgSeen :: [Stored DirectMessage]
+    }
+
+instance Storable DirectMessage where
+    store' msg = storeRec $ do
+        storeRef "from" $ msgFrom msg
+        mapM_ (storeRef "prev") $ msgPrev msg
+        storeDate "time" $ msgTime msg
+        storeText "text" $ msgText msg
+
+    load' = loadRec $ DirectMessage
+        <$> loadRef "from"
+        <*> loadRefs "prev"
+        <*> loadDate "time"
+        <*> loadText "text"
+
+instance Storable DirectMessageThread where
+    store' msg = storeRec $ do
+        storeRef "peer" $ msgPeer msg
+        mapM_ (storeRef "head") $ msgHead msg
+        mapM_ (storeRef "seen") $ msgSeen msg
+
+    load' = loadRec $ DirectMessageThread
+        <$> loadRef "peer"
+        <*> loadRefs "head"
+        <*> loadRefs "seen"
+
+
+emptyDirectThread :: Stored Identity -> DirectMessageThread
+emptyDirectThread peer = DirectMessageThread peer [] []
+
+createDirectMessage :: Stored Identity -> DirectMessageThread -> Text -> IO (Stored DirectMessage, Stored DirectMessageThread)
+createDirectMessage self thread msg = do
+    let st = storedStorage self
+    time <- getZonedTime
+    smsg <- wrappedStore st DirectMessage
+        { msgFrom = finalOwner self
+        , msgPrev = msgHead thread
+        , msgTime = time
+        , msgText = msg
+        }
+    sthread <- wrappedStore st thread
+        { msgHead = [smsg]
+        , msgSeen = [smsg]
+        }
+    return (smsg, sthread)
+
+threadToList :: DirectMessageThread -> [DirectMessage]
+threadToList thread = helper $ msgHead thread
+    where helper msgs | msg : msgs' <- sortBy (comparing cmpView) msgs =
+              fromStored msg : helper (dropWhile (== msg) msgs')
+                      | otherwise = []
+          cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, storedRef msg)
diff --git a/src/Network.hs b/src/Network.hs
index 1056265..827f542 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -1,7 +1,8 @@
 module Network (
     Peer(..),
-    PeerAddress,
-    peerDiscovery,
+    PeerAddress(..),
+    startServer,
+    sendToPeer,
 ) where
 
 import Control.Concurrent
@@ -31,6 +32,7 @@ data Peer = Peer
     { peerAddress :: PeerAddress
     , peerIdentity :: Maybe (Stored Identity)
     , peerChannels :: [Channel]
+    , peerSocket :: Socket
     }
     deriving (Show)
 
@@ -44,6 +46,8 @@ data TransportHeader = AnnouncePacket Ref
                      | TrChannelRequest Ref
                      | TrChannelAccept Ref
 
+data ServiceHeader = ServiceHeader T.Text Ref
+
 transportToObject :: TransportHeader -> Object
 transportToObject = \case
     AnnouncePacket ref -> Rec
@@ -93,10 +97,24 @@ transportFromObject (Rec items)
 
 transportFromObject _ = Nothing
 
+serviceToObject :: ServiceHeader -> Object
+serviceToObject (ServiceHeader svc ref) = Rec
+        [ (BC.pack "SVC", RecText svc)
+        , (BC.pack "ref", RecRef ref)
+        ]
+
+serviceFromObject :: Object -> Maybe ServiceHeader
+serviceFromObject (Rec items)
+    | Just (RecText svc) <- lookup (BC.pack "SVC") items
+    , Just (RecRef ref) <- lookup (BC.pack "ref") items
+    = Just $ ServiceHeader svc ref
+serviceFromObject _ = Nothing
 
-peerDiscovery :: String -> Stored Identity -> IO (Chan Peer)
-peerDiscovery bhost sidentity = do
+
+startServer :: String -> Stored Identity -> IO (Chan Peer, Chan (Peer, T.Text, Ref))
+startServer bhost sidentity = do
     chanPeer <- newChan
+    chanSvc <- newChan
     peers <- newMVar M.empty
 
     let open addr = do
@@ -112,11 +130,20 @@ peerDiscovery bhost sidentity = do
             void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ storedRef sidentity) (addrAddress baddr)
             forever $ do
                 (msg, paddr) <- recvFrom sock 4096
-                let packet' = packet sock paddr
-                case runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg of
-                     Left err -> putStrLn $ show paddr ++ ": " ++ err
-                     Right (obj:objs) | Just tpack <- transportFromObject obj -> packet' tpack objs
-                     _ -> putStrLn $ show paddr ++ ": invalid transport packet"
+                mbpeer <- M.lookup paddr <$> readMVar peers
+                if | Just peer <- mbpeer
+                   , ch:_ <- peerChannels peer
+                   , Just plain <- channelDecrypt ch msg
+                   , Right (obj:objs) <- runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict plain
+                   , Just (ServiceHeader svc ref) <- serviceFromObject obj
+                   -> do forM_ objs $ store $ storedStorage sidentity
+                         writeChan chanSvc (peer, svc, ref)
+
+                   | Right (obj:objs) <- runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg
+                   , Just tpack <- transportFromObject obj
+                   -> packet sock paddr tpack objs
+
+                   | otherwise -> putStrLn $ show paddr ++ ": invalid packet"
 
         packet sock paddr (AnnouncePacket ref) _ = do
             putStrLn $ "Got announce: " ++ show ref ++ " from " ++ show paddr
@@ -134,7 +161,7 @@ peerDiscovery bhost sidentity = do
             from' <- store (storedStorage sidentity) obj
             if from == from'
                then do forM_ objs $ store $ storedStorage sidentity
-                       let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad from) []
+                       let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad from) [] sock
                        modifyMVar_ peers $ return . M.insert paddr peer
                        writeChan chanPeer peer
                        void $ sendTo sock (BL.toStrict $ BL.concat
@@ -153,7 +180,7 @@ peerDiscovery bhost sidentity = do
             if ref == ref'
                then do forM_ objs $ store $ storedStorage sidentity
                        let pidentity = wrappedLoad ref
-                           peer = Peer (DatagramAddress paddr) (Just pidentity) []
+                           peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock
                        modifyMVar_ peers $ return . M.insert paddr peer
                        writeChan chanPeer peer
                        req <- createChannelRequest sidentity pidentity
@@ -231,4 +258,19 @@ peerDiscovery bhost sidentity = do
         addr:_ <- getAddrInfo (Just hints) Nothing (Just discoveryPort)
         bracket (open addr) close loop
 
-    return chanPeer
+    return (chanPeer, chanSvc)
+
+
+sendToPeer :: Storable a => Stored Identity -> Peer -> T.Text -> a -> IO ()
+sendToPeer self peer@Peer { peerChannels = ch:_ } svc obj = do
+    let st = storedStorage self
+    ref <- store st obj
+    let plain = BL.toStrict $ BL.concat
+            [ serializeObject $ serviceToObject $ ServiceHeader svc ref
+            , lazyLoadBytes ref
+            ]
+    ctext <- channelEncrypt ch plain
+    let DatagramAddress paddr = peerAddress peer
+    void $ sendTo (peerSocket peer) ctext paddr
+
+sendToPeer _ _ _ _ = putStrLn $ "No channel to peer"