Haskeline interface for sending messages

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