Haskeline interface for sending messages

1 files changed, 139 insertions, 36 deletions

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
+    ]