summaryrefslogtreecommitdiff
path: root/src/Main.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-07-02 22:54:53 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2023-07-02 22:54:53 +0200
commit4bed9f9d88f4ce57b540e756e3d26ed708078604 (patch)
tree2cfbced02c510ca7084cef1b6095c732c8e43462 /src/Main.hs
parent2278e5f103ed9c4f0e2c28bed82aae3639e7b46f (diff)
MonadHead instance for main UI commands
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs37
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