MonadHead instance for main UI commands

1 files changed, 23 insertions, 14 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 1aaa4f7..6e118e6 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -178,13 +178,12 @@ interactiveLoop st opts = runInputT defaultSettings $ do
                                        then (cmdSetPeer $ read scmd, args)
                                        else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
                     _        -> (cmdSend, input)
-            h <- liftIO (reloadHead erebosHead) >>= \case
+            h <- liftIO (reloadHead $ csHead cstate) >>= \case
                 Just h  -> return h
                 Nothing -> do lift $ lift $ extPrint "current head deleted"
                               mzero
-            res <- liftIO $ runExceptT $ flip execStateT cstate $ runReaderT cmd CommandInput
-                { ciHead = h
-                , ciServer = server
+            res <- liftIO $ runExceptT $ flip execStateT cstate { csHead = h } $ runReaderT cmd CommandInput
+                { ciServer = server
                 , ciLine = line
                 , ciPrint = extPrintLn
                 , ciPeers = liftIO $ readMVar peers
@@ -197,22 +196,23 @@ interactiveLoop st opts = runInputT defaultSettings $ do
     let loop (Just cstate) = runMaybeT (process cstate) >>= loop
         loop Nothing = return ()
     loop $ Just $ CommandState
-        { csPeer = Nothing
+        { csHead = erebosHead
+        , csPeer = Nothing
         , csIceSessions = []
         , csIcePeer = Nothing
         }
 
 
 data CommandInput = CommandInput
-    { ciHead :: Head LocalState
-    , ciServer :: Server
+    { ciServer :: Server
     , ciLine :: String
     , ciPrint :: String -> IO ()
     , ciPeers :: CommandM [(Peer, String)]
     }
 
 data CommandState = CommandState
-    { csPeer :: Maybe Peer
+    { csHead :: Head LocalState
+    , csPeer :: Maybe Peer
     , csIceSessions :: [IceSession]
     , csIcePeer :: Maybe Peer
     }
@@ -226,6 +226,16 @@ instance MonadFail CommandM where
 instance MonadRandom CommandM where
     getRandomBytes = liftIO . getRandomBytes
 
+instance MonadStorage CommandM where
+    getStorage = gets $ refStorage . headRef . csHead
+
+instance MonadHead LocalState CommandM where
+    updateLocalHead f = do
+        h <- gets csHead
+        (Just h', x) <- maybe (fail "failed to reload head") (flip updateHead f) =<< reloadHead h
+        modify $ \s -> s { csHead = h' }
+        return x
+
 type Command = CommandM ()
 
 commands :: [(String, Command)]
@@ -285,16 +295,15 @@ cmdSetPeer n | n < 1     = liftIO $ putStrLn "Invalid peer index"
 
 cmdSend :: Command
 cmdSend = void $ do
-    ehead <- asks ciHead
     Just peer <- gets csPeer
     text <- asks ciLine
-    smsg <- flip runReaderT ehead $ sendDirectMessage peer $ T.pack text
+    smsg <- sendDirectMessage peer $ T.pack text
     tzone <- liftIO $ getCurrentTimeZone
     liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg
 
 cmdHistory :: Command
 cmdHistory = void $ do
-    ehead <- asks ciHead
+    ehead <- gets csHead
     Just peer <- gets csPeer
     PeerIdentityFull pid <- peerIdentity peer
     let powner = finalOwner pid
@@ -309,7 +318,7 @@ cmdHistory = void $ do
 
 cmdUpdateIdentity :: Command
 cmdUpdateIdentity = void $ do
-    runReaderT updateSharedIdentity =<< asks ciHead
+    runReaderT updateSharedIdentity =<< gets csHead
 
 cmdAttach :: Command
 cmdAttach = join $ attachToOwner
@@ -326,7 +335,7 @@ cmdAttachReject = join $ attachReject
 cmdContacts :: Command
 cmdContacts = do
     args <- words <$> asks ciLine
-    ehead <- asks ciHead
+    ehead <- gets csHead
     let contacts = fromSetBy (comparing contactName) $ lookupSharedValue $ lsShared $ headObject ehead
         verbose = "-v" `elem` args
     forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do
@@ -364,7 +373,7 @@ cmdDiscoveryInit = void $ do
 cmdDiscovery :: Command
 cmdDiscovery = void $ do
     Just peer <- gets csIcePeer
-    st <- asks (storedStorage . headStoredObject . ciHead)
+    st <- gets (storedStorage . headStoredObject . csHead)
     sref <- asks ciLine
     eprint <- asks ciPrint
     liftIO $ readRef st (BC.pack sref) >>= \case