diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Identity.hs | 9 | ||||
| -rw-r--r-- | src/Main.hs | 104 | ||||
| -rw-r--r-- | src/Message.hs | 77 | ||||
| -rw-r--r-- | src/Network.hs | 66 |
4 files changed, 232 insertions, 24 deletions
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" |