summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--erebos.cabal2
-rw-r--r--src/Main.hs175
-rw-r--r--src/Network.hs52
3 files changed, 167 insertions, 62 deletions
diff --git a/erebos.cabal b/erebos.cabal
index 8a5e15f..0eedaa4 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -44,6 +44,7 @@ executable erebos
cryptonite >=0.25 && <0.26,
directory >= 1.3 && <1.4,
filepath >=1.4 && <1.5,
+ haskeline >=0.7 && <0.8,
memory >=0.14 && <0.15,
mime >= 0.4 && < 0.5,
mtl >=2.2 && <2.3,
@@ -51,6 +52,7 @@ executable erebos
tagged >= 0.8 && <0.9,
text >= 1.2 && <1.3,
time >= 1.8 && <1.9,
+ transformers >= 0.5 && <0.6,
unix >=2.7 && <2.8,
zlib >=0.6 && <0.7
hs-source-dirs: src
diff --git a/src/Main.hs b/src/Main.hs
index e6e9d9c..59e6d5c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -3,12 +3,19 @@ module Main (main) where
import Control.Concurrent
import Control.Exception
import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Trans.Maybe
+import Data.Char
import Data.List
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
+import Data.Time.Format
+import Data.Time.LocalTime
+import System.Console.Haskeline
import System.Environment
import System.IO
import System.IO.Error
@@ -71,54 +78,150 @@ updateErebosHead st f = do
return x
main :: IO ()
-main = do
- [bhost] <- getArgs
- st <- openStorage "test"
- erebosHead <- loadErebosHead st
+main = runInputT defaultSettings $ do
+ bhost <- liftIO getArgs >>= \case [bhost] -> return bhost
+ _ -> error "Expecting broadcast address"
+ st <- liftIO $ openStorage "test"
+ erebosHead <- liftIO $ loadErebosHead st
let serebos = wrappedLoad (headRef erebosHead) :: Stored Erebos
self = erbIdentity $ fromStored serebos
- T.putStrLn $ displayIdentity self
+ outputStrLn $ T.unpack $ displayIdentity self
- (chanPeer, chanSvc) <- startServer bhost $ erbIdentity $ fromStored serebos
+ haveTerminalUI >>= \case True -> return ()
+ False -> error "Requires terminal"
+ extPrint <- getExternalPrint
+ let extPrintLn str = extPrint $ str ++ "\n";
+ (chanPeer, chanSvc) <- liftIO $
+ startServer extPrintLn bhost $ erbIdentity $ fromStored serebos
- void $ forkIO $ void $ forever $ do
+ peers <- liftIO $ newMVar []
+
+ void $ liftIO $ forkIO $ void $ forever $ do
peer@Peer { peerAddress = DatagramAddress addr } <- readChan chanPeer
- print addr
- T.putStrLn $ maybe (T.pack "<noid>") displayIdentity $ 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
+ extPrint $ show addr ++ "\n"
+ extPrintLn $ maybe "<noid>" (T.unpack . displayIdentity) $ peerIdentity peer
+ let update [] = [peer]
+ update (p:ps) | peerIdentity p == peerIdentity peer = peer : ps
+ | otherwise = p : update ps
+ when (isJust $ peerIdentity peer) $
+ modifyMVar_ peers (return . update)
+
+ tzone <- liftIO $ getCurrentTimeZone
+ void $ liftIO $ forkIO $ 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
+ let smsg = wrappedLoad ref
+ msg = fromStored smsg
+ extPrintLn $ formatMessage tzone msg
if | Just powner <- finalOwner <$> peerIdentity peer
- , powner == msgFrom (fromStored msg)
+ , powner == msgFrom 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) }
+ Just thread -> do thread' <- wrappedStore st (fromStored thread) { msgHead = smsg : msgHead (fromStored thread) }
slistReplaceS thread thread' $ erbMessages $ fromStored erb
- Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [msg] } $ erbMessages $ fromStored erb
+ Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [smsg] } $ erbMessages $ fromStored erb
wrappedStore st (fromStored erb) { erbMessages = slist }
- | otherwise -> putStrLn $ "Owner mismatch"
+ | otherwise -> extPrint $ "Owner mismatch"
+ | otherwise -> extPrint $ "Unknown service: " ++ T.unpack svc
+
+ let process cstate = do
+ let pname = case csPeer cstate of
+ Nothing -> ""
+ Just peer -> maybe "<unnamed>" T.unpack $ idName . fromStored . signedData . fromStored . finalOwner <=< peerIdentity $ peer
+ Just input <- lift $ getInputLine $ pname ++ "> "
+ let (cmd, line) = case input of
+ '/':rest -> let (scmd, args) = dropWhile isSpace <$> span isAlphaNum rest
+ in if all isDigit scmd
+ then (cmdSetPeer $ read scmd, args)
+ else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
+ _ -> (cmdSend, input)
+ liftIO $ flip execStateT cstate $ runReaderT cmd CommandInput
+ { ciSelf = self
+ , ciLine = line
+ , ciPeers = liftIO $ readMVar peers
+ }
+
+ let loop (Just cstate) = runMaybeT (process cstate) >>= loop
+ loop Nothing = return ()
+ loop $ Just $ CommandState { csPeer = Nothing }
+
- | otherwise -> T.putStrLn $ T.pack "Unknown service: " `T.append` svc
+data CommandInput = CommandInput
+ { ciSelf :: Stored Identity
+ , ciLine :: String
+ , ciPeers :: CommandM [Peer]
+ }
+
+data CommandState = CommandState
+ { csPeer :: Maybe Peer
+ }
- return ()
+type CommandM a = ReaderT CommandInput (StateT CommandState IO) a
+type Command = CommandM ()
+
+commands :: [(String, Command)]
+commands =
+ [ ("history", cmdHistory)
+ , ("peers", cmdPeers)
+ , ("send", cmdSend)
+ ]
+
+cmdUnknown :: String -> Command
+cmdUnknown cmd = liftIO $ putStrLn $ "Unknown command: " ++ cmd
+
+cmdPeers :: Command
+cmdPeers = do
+ peers <- join $ asks ciPeers
+ forM_ (zip [1..] peers) $ \(i :: Int, p) -> do
+ liftIO $ putStrLn $ show i ++ ": " ++ maybe "<noid>" (T.unpack . displayIdentity) (peerIdentity p)
+
+cmdSetPeer :: Int -> Command
+cmdSetPeer n | n < 1 = liftIO $ putStrLn "Invalid peer index"
+ | otherwise = do peers <- join $ asks ciPeers
+ modify $ \s -> s { csPeer = listToMaybe $ drop (n - 1) peers }
+
+cmdSend :: Command
+cmdSend = void $ runMaybeT $ do
+ self <- asks ciSelf
+ let st = storedStorage self
+ Just peer <- gets csPeer
+ Just powner <- return $ finalOwner <$> peerIdentity peer
+ _:_ <- return $ peerChannels peer
+ text <- asks ciLine
+ smsg <- liftIO $ updateErebosHead st $ \erb -> do
+ (slist, smsg) <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
+ Just thread -> do
+ (smsg, thread') <- createDirectMessage self (fromStored thread) (T.pack text)
+ (,smsg) <$> slistReplaceS thread thread' (erbMessages $ fromStored erb)
+ Nothing -> do
+ (smsg, thread') <- createDirectMessage self (emptyDirectThread powner) (T.pack text)
+ (,smsg) <$> slistAddS thread' (erbMessages $ fromStored erb)
+ erb' <- wrappedStore st (fromStored erb) { erbMessages = slist }
+ return (erb', smsg)
+ liftIO $ sendToPeer self peer (T.pack "dmsg") smsg
+
+ tzone <- liftIO $ getCurrentTimeZone
+ liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg
+
+cmdHistory :: Command
+cmdHistory = void $ runMaybeT $ do
+ self <- asks ciSelf
+ let st = storedStorage self
+ Just peer <- gets csPeer
+ Just powner <- return $ finalOwner <$> peerIdentity peer
+
+ erebosHead <- liftIO $ loadHead st "erebos"
+ let erebos = wrappedLoad (headRef erebosHead)
+ Just thread <- return $ find ((==powner) . msgPeer) $ fromSList $ erbMessages $ fromStored erebos
+ tzone <- liftIO $ getCurrentTimeZone
+ liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread
+
+
+formatMessage :: TimeZone -> DirectMessage -> String
+formatMessage tzone msg = concat
+ [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg
+ , maybe "<unnamed>" T.unpack $ idName $ fromStored $ signedData $ fromStored $ msgFrom msg
+ , ": "
+ , T.unpack $ msgText msg
+ ]
diff --git a/src/Network.hs b/src/Network.hs
index 827f542..391e236 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -111,8 +111,8 @@ serviceFromObject (Rec items)
serviceFromObject _ = Nothing
-startServer :: String -> Stored Identity -> IO (Chan Peer, Chan (Peer, T.Text, Ref))
-startServer bhost sidentity = do
+startServer :: (String -> IO ()) -> String -> Stored Identity -> IO (Chan Peer, Chan (Peer, T.Text, Ref))
+startServer logd bhost sidentity = do
chanPeer <- newChan
chanSvc <- newChan
peers <- newMVar M.empty
@@ -143,21 +143,21 @@ startServer bhost sidentity = do
, Just tpack <- transportFromObject obj
-> packet sock paddr tpack objs
- | otherwise -> putStrLn $ show paddr ++ ": invalid packet"
+ | otherwise -> logd $ show paddr ++ ": invalid packet"
packet sock paddr (AnnouncePacket ref) _ = do
- putStrLn $ "Got announce: " ++ show ref ++ " from " ++ show paddr
+ logd $ "Got announce: " ++ show ref ++ " from " ++ show paddr
when (ref /= storedRef sidentity) $ void $ sendTo sock (BL.toStrict $ BL.concat
[ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity)
, BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
]) paddr
packet _ paddr (IdentityRequest ref from) [] = do
- putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr ++ " without content"
+ logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr ++ " without content"
packet sock paddr (IdentityRequest ref from) (obj:objs) = do
- putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr
- print (obj:objs)
+ logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr
+ logd $ show (obj:objs)
from' <- store (storedStorage sidentity) obj
if from == from'
then do forM_ objs $ store $ storedStorage sidentity
@@ -168,14 +168,14 @@ startServer bhost sidentity = do
[ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity)
, BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
]) paddr
- else putStrLn $ "Mismatched content"
+ else logd $ "Mismatched content"
packet _ paddr (IdentityResponse ref) [] = do
- putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr ++ " without content"
+ logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr ++ " without content"
packet sock paddr (IdentityResponse ref) (obj:objs) = do
- putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr
- print (obj:objs)
+ logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr
+ logd $ show (obj:objs)
ref' <- store (storedStorage sidentity) obj
if ref == ref'
then do forM_ objs $ store $ storedStorage sidentity
@@ -191,14 +191,14 @@ startServer bhost sidentity = do
, lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req
, BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req
]) paddr
- else putStrLn $ "Mismatched content"
+ else logd $ "Mismatched content"
packet _ paddr (TrChannelRequest _) [] = do
- putStrLn $ "Got channel request: from " ++ show paddr ++ " without content"
+ logd $ "Got channel request: from " ++ show paddr ++ " without content"
packet sock paddr (TrChannelRequest ref) (obj:objs) = do
- putStrLn $ "Got channel request: from " ++ show paddr
- print (obj:objs)
+ logd $ "Got channel request: from " ++ show paddr
+ logd $ show (obj:objs)
ref' <- store (storedStorage sidentity) obj
if ref == ref'
then do forM_ objs $ store $ storedStorage sidentity
@@ -206,10 +206,10 @@ startServer bhost sidentity = do
modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
Just peer | Just pid <- peerIdentity peer ->
runExceptT (acceptChannelRequest sidentity pid request) >>= \case
- Left errs -> do mapM_ putStrLn ("Invalid channel request" : errs)
+ Left errs -> do mapM_ logd ("Invalid channel request" : errs)
return pval
Right (acc, channel) -> do
- putStrLn $ "Got channel: " ++ show (storedRef channel)
+ logd $ "Got channel: " ++ show (storedRef channel)
let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
writeChan chanPeer peer'
void $ sendTo sock (BL.toStrict $ BL.concat
@@ -221,16 +221,16 @@ startServer bhost sidentity = do
]) paddr
return $ M.insert paddr peer' pval
- _ -> do putStrLn $ "Invalid channel request - no peer identity"
+ _ -> do logd $ "Invalid channel request - no peer identity"
return pval
- else putStrLn $ "Mismatched content"
+ else logd $ "Mismatched content"
packet _ paddr (TrChannelAccept _) [] = do
- putStrLn $ "Got channel accept: from " ++ show paddr ++ " without content"
+ logd $ "Got channel accept: from " ++ show paddr ++ " without content"
packet _ paddr (TrChannelAccept ref) (obj:objs) = do
- putStrLn $ "Got channel accept: from " ++ show paddr
- print (obj:objs)
+ logd $ "Got channel accept: from " ++ show paddr
+ logd $ show (obj:objs)
ref' <- store (storedStorage sidentity) obj
if ref == ref'
then do forM_ objs $ store $ storedStorage sidentity
@@ -238,17 +238,17 @@ startServer bhost sidentity = do
modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
Just peer | Just pid <- peerIdentity peer ->
runExceptT (acceptedChannel sidentity pid accepted) >>= \case
- Left errs -> do mapM_ putStrLn ("Invalid channel accept" : errs)
+ Left errs -> do mapM_ logd ("Invalid channel accept" : errs)
return pval
Right channel -> do
- putStrLn $ "Got channel: " ++ show (storedRef channel)
+ logd $ "Got channel: " ++ show (storedRef channel)
let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
writeChan chanPeer peer'
return $ M.insert paddr peer' pval
- _ -> do putStrLn $ "Invalid channel accept - no peer identity"
+ _ -> do logd $ "Invalid channel accept - no peer identity"
return pval
- else putStrLn $ "Mismatched content"
+ else logd $ "Mismatched content"
void $ forkIO $ withSocketsDo $ do
let hints = defaultHints