From 83d291f476a9793012a7aabb27c3cf59c7bdea05 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Tue, 11 Mar 2025 20:22:33 +0100
Subject: Generic type for MonadError constraints
Changelog: API: MonadError constraints use generic error type
---
main/Main.hs | 34 +++++++++++++++++-----------------
main/Test.hs | 14 +++++++-------
2 files changed, 24 insertions(+), 24 deletions(-)
(limited to 'main')
diff --git a/main/Main.hs b/main/Main.hs
index d91330c..9ea09e5 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -235,7 +235,7 @@ main = do
Nothing -> error "ref does not exist"
Just ref -> print $ storedGeneration (wrappedLoad ref :: Stored Object)
- ["update-identity"] -> either fail return <=< runExceptT $ do
+ ["update-identity"] -> either (fail . showErebosError) return <=< runExceptT $ do
runReaderT updateSharedIdentity =<< loadLocalStateHead st
("update-identity" : srefs) -> do
@@ -244,7 +244,7 @@ main = do
Just refs
| Just idt <- validateIdentityF $ map wrappedLoad refs -> do
BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<<
- (either fail return <=< runExceptT $ runReaderT (interactiveIdentityUpdate idt) st)
+ (either (fail . showErebosError) return <=< runExceptT $ runReaderT (interactiveIdentityUpdate idt) st)
| otherwise -> error "invalid identity"
["test"] -> runTestTool st
@@ -408,7 +408,7 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
| csQuit cstate' -> mzero
| otherwise -> return cstate'
Left err -> do
- lift $ extPrintLn $ "Error: " ++ err
+ lift $ extPrintLn $ "Error: " ++ showErebosError err
return cstate
let loop (Just cstate) = runMaybeT (process cstate) >>= loop
@@ -454,15 +454,15 @@ data CommandContext = NoContext
| SelectedChatroom ChatroomState
| SelectedConversation Conversation
-newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a)
- deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError String)
+newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT ErebosError IO)) a)
+ deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError ErebosError)
instance MonadFail CommandM where
- fail = throwError
+ fail = throwOtherError
instance MonadIO CommandM where
liftIO act = CommandM (liftIO (try act)) >>= \case
- Left (e :: SomeException) -> throwError (show e)
+ Left (e :: SomeException) -> throwOtherError (show e)
Right x -> return x
instance MonadRandom CommandM where
@@ -483,27 +483,27 @@ type Command = CommandM ()
getSelectedPeer :: CommandM Peer
getSelectedPeer = gets csContext >>= \case
SelectedPeer peer -> return peer
- _ -> throwError "no peer selected"
+ _ -> throwOtherError "no peer selected"
getSelectedChatroom :: CommandM ChatroomState
getSelectedChatroom = gets csContext >>= \case
SelectedChatroom rstate -> return rstate
- _ -> throwError "no chatroom selected"
+ _ -> throwOtherError "no chatroom selected"
getSelectedConversation :: CommandM Conversation
getSelectedConversation = gets csContext >>= \case
SelectedPeer peer -> peerIdentity peer >>= \case
PeerIdentityFull pid -> directMessageConversation $ finalOwner pid
- _ -> throwError "incomplete peer identity"
+ _ -> throwOtherError "incomplete peer identity"
SelectedContact contact -> case contactIdentity contact of
Just cid -> directMessageConversation cid
- Nothing -> throwError "contact without erebos identity"
+ Nothing -> throwOtherError "contact without erebos identity"
SelectedChatroom rstate ->
chatroomConversation rstate >>= \case
Just conv -> return conv
- Nothing -> throwError "invalid chatroom"
+ Nothing -> throwOtherError "invalid chatroom"
SelectedConversation conv -> reloadConversation conv
- _ -> throwError "no contact, peer or conversation selected"
+ _ -> throwOtherError "no contact, peer or conversation selected"
commands :: [(String, Command)]
commands =
@@ -568,7 +568,7 @@ cmdPeerAdd = void $ do
(hostname, port) <- (words <$> asks ciLine) >>= \case
hostname:p:_ -> return (hostname, p)
[hostname] -> return (hostname, show discoveryPort)
- [] -> throwError "missing peer address"
+ [] -> throwOtherError "missing peer address"
addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port)
liftIO $ serverPeer server (addrAddress addr)
@@ -633,7 +633,7 @@ cmdSelectContext = do
when (not (roomStateSubscribe rstate)) $ do
chatroomSetSubscribe (head $ roomStateData rstate) True
_ -> return ()
- | otherwise -> throwError "invalid index"
+ | otherwise -> throwOtherError "invalid index"
cmdSend :: Command
cmdSend = void $ do
@@ -709,7 +709,7 @@ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do
forM_ (take (num - subscribedNum) notSubscribed) $ \rstate -> do
(runExceptT $ flip runReaderT h $ chatroomSetSubscribe (head $ roomStateData rstate) True) >>= \case
Right () -> return ()
- Left err -> eprint err
+ Left err -> eprint (showErebosError err)
Just diff -> do
modifyMVar_ chatroomSetVar $ return . const set
@@ -932,7 +932,7 @@ cmdIceCreate = do
, Just ( T.pack stunServer, read stunPort )
, Just ( T.pack turnServer, read turnPort )
)
- _ -> throwError "invalid parameters"
+ _ -> throwOtherError "invalid parameters"
eprint <- asks ciPrint
Just cfg <- liftIO $ iceCreateConfig stun turn
diff --git a/main/Test.hs b/main/Test.hs
index 570dd5d..08ad880 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -103,7 +103,7 @@ runTestTool st = do
Nothing -> return ()
runExceptT (evalStateT testLoop initTestState) >>= \case
- Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack x
+ Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack (showErebosError x)
Right () -> return ()
getLineMb :: MonadIO m => m (Maybe Text)
@@ -175,7 +175,7 @@ pairingAttributes _ out peers prefix = PairingAttributes
, pairingHookFailed = \case
PairingUserRejected -> failed "user"
PairingUnexpectedMessage pstate packet -> failed $ "unexpected " ++ strState pstate ++ " " ++ strPacket packet
- PairingFailedOther str -> failed $ "other " ++ str
+ PairingFailedOther err -> failed $ "other " ++ showErebosError err
, pairingHookVerifyFailed = failed "verify"
, pairingHookRejected = failed "rejected"
}
@@ -226,11 +226,11 @@ dmReceivedWatcher out smsg = do
]
-newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT String IO)) a)
- deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError String)
+newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT ErebosError IO)) a)
+ deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError ErebosError)
instance MonadFail CommandM where
- fail = throwError
+ fail = throwOtherError
instance MonadRandom CommandM where
getRandomBytes = liftIO . getRandomBytes
@@ -502,7 +502,7 @@ cmdStartServer = do
void $ store (headStorage h) obj
outLine out $ unwords ["test-message-received", otype, len, sref]
}
- sname -> throwError $ "unknown service `" <> T.unpack sname <> "'"
+ sname -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'"
rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services
@@ -662,7 +662,7 @@ cmdUpdateSharedIdentity :: Command
cmdUpdateSharedIdentity = do
[name] <- asks tiParams
updateLocalHead_ $ updateSharedState_ $ \case
- Nothing -> throwError "no existing shared identity"
+ Nothing -> throwOtherError "no existing shared identity"
Just identity -> do
let public = idKeyIdentity identity
secret <- loadKey public
--
cgit v1.2.3