summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Identity.hs9
-rw-r--r--src/Main.hs104
-rw-r--r--src/Message.hs77
-rw-r--r--src/Network.hs66
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"