From 83d291f476a9793012a7aabb27c3cf59c7bdea05 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Tue, 11 Mar 2025 20:22:33 +0100 Subject: Generic type for MonadError constraints Changelog: API: MonadError constraints use generic error type --- src/Erebos/Attach.hs | 6 +++--- src/Erebos/Chatroom.hs | 26 +++++++++++------------ src/Erebos/Contact.hs | 6 +++--- src/Erebos/Conversation.hs | 6 +++--- src/Erebos/DirectMessage.hs | 3 +-- src/Erebos/Error.hs | 39 ++++++++++++++++++++++++++++++++++ src/Erebos/ICE.chs | 3 +-- src/Erebos/Identity.hs | 6 +++--- src/Erebos/Network.hs | 21 +++++++++--------- src/Erebos/Network/Channel.hs | 36 +++++++++++++++---------------- src/Erebos/Network/Protocol.hs | 24 ++++++++++----------- src/Erebos/Object/Internal.hs | 48 ++++++++++++++++++++++-------------------- src/Erebos/Pairing.hs | 38 ++++++++++++++++----------------- src/Erebos/PubKey.hs | 9 ++++---- src/Erebos/Service.hs | 8 +++---- src/Erebos/State.hs | 12 +++++------ src/Erebos/Storable.hs | 3 +++ src/Erebos/Storage/Key.hs | 4 ++-- 18 files changed, 170 insertions(+), 128 deletions(-) create mode 100644 src/Erebos/Error.hs (limited to 'src/Erebos') diff --git a/src/Erebos/Attach.hs b/src/Erebos/Attach.hs index aac7297..df61406 100644 --- a/src/Erebos/Attach.hs +++ b/src/Erebos/Attach.hs @@ -113,11 +113,11 @@ instance PairingResult AttachIdentity where svcPrint $ "Attachement failed" } -attachToOwner :: (MonadIO m, MonadError String m) => Peer -> m () +attachToOwner :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () attachToOwner = pairingRequest @AttachIdentity Proxy -attachAccept :: (MonadIO m, MonadError String m) => Peer -> m () +attachAccept :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () attachAccept = pairingAccept @AttachIdentity Proxy -attachReject :: (MonadIO m, MonadError String m) => Peer -> m () +attachReject :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () attachReject = pairingReject @AttachIdentity Proxy diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs index fec3fbf..2d4f272 100644 --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -181,17 +181,17 @@ threadToListSince since thread = helper (S.fromList since) thread cmpView msg = (zonedTimeToUTC $ mdTime $ fromSigned msg, msg) sendChatroomMessage - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => ChatroomState -> Text -> m () sendChatroomMessage rstate msg = sendChatroomMessageByStateData (head $ roomStateData rstate) msg sendChatroomMessageByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> Text -> m () sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing Nothing (Just msg) False sendRawChatroomMessageByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> Maybe UnifiedIdentity -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m () sendRawChatroomMessageByStateData lookupData mbIdentity mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate @@ -283,7 +283,7 @@ instance Mergeable ChatroomState where instance SharedType (Set ChatroomState) where sharedTypeID _ = mkSharedTypeID "7bc71cbf-bc43-42b1-b413-d3a2c9a2aae0" -createChatroom :: (MonadStorage m, MonadHead LocalState m, MonadIO m, MonadError String m) => Maybe Text -> Maybe Text -> m ChatroomState +createChatroom :: (MonadStorage m, MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e) => Maybe Text -> Maybe Text -> m ChatroomState createChatroom rdName rdDescription = do (secret, rdKey) <- liftIO . generateKeys =<< getStorage let rdPrev = [] @@ -317,7 +317,7 @@ findAndUpdateChatroomState f = do [] -> return (roomSet, Nothing) deleteChatroomByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> m () deleteChatroomByStateData lookupData = void $ findAndUpdateChatroomState $ \cstate -> do guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate @@ -328,7 +328,7 @@ deleteChatroomByStateData lookupData = void $ findAndUpdateChatroomState $ \csta } updateChatroomByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> Maybe Text -> Maybe Text @@ -369,7 +369,7 @@ findChatroomByStateData :: MonadHead LocalState m => Stored ChatroomStateData -> findChatroomByStateData cdata = findChatroom $ any (cdata `precedesOrEquals`) . roomStateData chatroomSetSubscribe - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> Bool -> m () chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $ \cstate -> do guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate @@ -390,32 +390,32 @@ chatroomMembers ChatroomState {..} = toList $ ancestors $ roomStateMessageData joinChatroom - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => ChatroomState -> m () joinChatroom rstate = joinChatroomByStateData (head $ roomStateData rstate) joinChatroomByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> m () joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing False joinChatroomAs - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => UnifiedIdentity -> ChatroomState -> m () joinChatroomAs identity rstate = joinChatroomAsByStateData identity (head $ roomStateData rstate) joinChatroomAsByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => UnifiedIdentity -> Stored ChatroomStateData -> m () joinChatroomAsByStateData identity lookupData = sendRawChatroomMessageByStateData lookupData (Just identity) Nothing Nothing False leaveChatroom - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => ChatroomState -> m () leaveChatroom rstate = leaveChatroomByStateData (head $ roomStateData rstate) leaveChatroomByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> m () leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing True diff --git a/src/Erebos/Contact.hs b/src/Erebos/Contact.hs index 0e92e41..25239b9 100644 --- a/src/Erebos/Contact.hs +++ b/src/Erebos/Contact.hs @@ -155,13 +155,13 @@ instance PairingResult ContactAccepted where svcPrint $ "Contact failed" } -contactRequest :: (MonadIO m, MonadError String m) => Peer -> m () +contactRequest :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () contactRequest = pairingRequest @ContactAccepted Proxy -contactAccept :: (MonadIO m, MonadError String m) => Peer -> m () +contactAccept :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () contactAccept = pairingAccept @ContactAccepted Proxy -contactReject :: (MonadIO m, MonadError String m) => Peer -> m () +contactReject :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () contactReject = pairingReject @ContactAccepted Proxy finalizeContact :: MonadHead LocalState m => UnifiedIdentity -> m () diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs index 7c9d329..dee6faa 100644 --- a/src/Erebos/Conversation.hs +++ b/src/Erebos/Conversation.hs @@ -101,10 +101,10 @@ conversationHistory (DirectMessageConversation thread) = map (\msg -> DirectMess conversationHistory (ChatroomConversation rstate) = map (\msg -> ChatroomMessage msg False) $ roomStateMessages rstate -sendMessage :: (MonadHead LocalState m, MonadError String m) => Conversation -> Text -> m (Maybe Message) +sendMessage :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> Text -> m (Maybe Message) sendMessage (DirectMessageConversation thread) text = fmap Just $ DirectMessageMessage <$> (fromStored <$> sendDirectMessage (msgPeer thread) text) <*> pure False sendMessage (ChatroomConversation rstate) text = sendChatroomMessage rstate text >> return Nothing -deleteConversation :: (MonadHead LocalState m, MonadError String m) => Conversation -> m () -deleteConversation (DirectMessageConversation _) = throwError "deleting direct message conversation is not supported" +deleteConversation :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> m () +deleteConversation (DirectMessageConversation _) = throwOtherError "deleting direct message conversation is not supported" deleteConversation (ChatroomConversation rstate) = deleteChatroomByStateData (head $ roomStateData rstate) diff --git a/src/Erebos/DirectMessage.hs b/src/Erebos/DirectMessage.hs index 39d453c..28d8085 100644 --- a/src/Erebos/DirectMessage.hs +++ b/src/Erebos/DirectMessage.hs @@ -17,7 +17,6 @@ module Erebos.DirectMessage ( ) where import Control.Monad -import Control.Monad.Except import Control.Monad.Reader import Data.List @@ -157,7 +156,7 @@ findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do return $ sel x -sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m, MonadError String m) +sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m) => Identity f -> Text -> m (Stored DirectMessage) sendDirectMessage pid text = updateLocalHead $ \ls -> do let self = localIdentity $ fromStored ls diff --git a/src/Erebos/Error.hs b/src/Erebos/Error.hs new file mode 100644 index 0000000..3bb8736 --- /dev/null +++ b/src/Erebos/Error.hs @@ -0,0 +1,39 @@ +module Erebos.Error ( + ErebosError(..), + showErebosError, + + FromErebosError(..), + throwOtherError, +) where + +import Control.Monad.Except + + +data ErebosError + = ManyErrors [ ErebosError ] + | OtherError String + +showErebosError :: ErebosError -> String +showErebosError (ManyErrors errs) = unlines $ map showErebosError errs +showErebosError (OtherError str) = str + +instance Semigroup ErebosError where + ManyErrors [] <> b = b + a <> ManyErrors [] = a + ManyErrors a <> ManyErrors b = ManyErrors (a ++ b) + ManyErrors a <> b = ManyErrors (a ++ [ b ]) + a <> ManyErrors b = ManyErrors (a : b) + a@OtherError {} <> b@OtherError {} = ManyErrors [ a, b ] + +instance Monoid ErebosError where + mempty = ManyErrors [] + + +class FromErebosError e where + fromErebosError :: ErebosError -> e + +instance FromErebosError ErebosError where + fromErebosError = id + +throwOtherError :: (MonadError e m, FromErebosError e) => String -> m a +throwOtherError = throwError . fromErebosError . OtherError diff --git a/src/Erebos/ICE.chs b/src/Erebos/ICE.chs index e0b1b34..06edecf 100644 --- a/src/Erebos/ICE.chs +++ b/src/Erebos/ICE.chs @@ -21,7 +21,6 @@ module Erebos.ICE ( import Control.Arrow import Control.Concurrent.MVar import Control.Monad -import Control.Monad.Except import Control.Monad.Identity import Data.ByteString (ByteString, packCStringLen, useAsCString) @@ -118,7 +117,7 @@ instance StorableText IceCandidate where , icandPort = port , icandType = ctype } - _ -> throwError "failed to parse candidate" + _ -> throwOtherError "failed to parse candidate" {#enum pj_ice_sess_role as IceSessionRole {underscoreToCase} deriving (Show, Eq) #} diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs index e75999d..a3f17b5 100644 --- a/src/Erebos/Identity.hs +++ b/src/Erebos/Identity.hs @@ -280,13 +280,13 @@ validateExtendedIdentityFE mdata = do Just mk -> return mk loadIdentity :: String -> LoadRec ComposedIdentity -loadIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentityF =<< loadRefs name +loadIdentity name = maybe (throwOtherError "identity validation failed") return . validateExtendedIdentityF =<< loadRefs name loadMbIdentity :: String -> LoadRec (Maybe ComposedIdentity) loadMbIdentity name = return . validateExtendedIdentityF =<< loadRefs name loadUnifiedIdentity :: String -> LoadRec UnifiedIdentity -loadUnifiedIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentity =<< loadRef name +loadUnifiedIdentity name = maybe (throwOtherError "identity validation failed") return . validateExtendedIdentity =<< loadRef name loadMbUnifiedIdentity :: String -> LoadRec (Maybe UnifiedIdentity) loadMbUnifiedIdentity name = return . (validateExtendedIdentity =<<) =<< loadMbRef name @@ -322,7 +322,7 @@ lookupProperty sel topHeads = findResult propHeads findResult [] = Nothing findResult xs = sel $ fromSigned $ minimum xs -mergeIdentity :: (MonadStorage m, MonadError String m, MonadIO m) => Identity f -> m UnifiedIdentity +mergeIdentity :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m) => Identity f -> m UnifiedIdentity mergeIdentity idt | Just idt' <- toUnifiedIdentity idt = return idt' mergeIdentity idt@Identity {..} = do (owner, ownerData) <- case idOwner_ of diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs index e398b56..54658de 100644 --- a/src/Erebos/Network.hs +++ b/src/Erebos/Network.hs @@ -58,6 +58,7 @@ import GHC.Conc.Sync (unsafeIOToSTM) import Network.Socket hiding (ControlMessage) import qualified Network.Socket.ByteString as S +import Erebos.Error #ifdef ENABLE_ICE_SUPPORT import Erebos.ICE #endif @@ -93,7 +94,7 @@ data Server = Server , serverRawPath :: SymFlow (PeerAddress, BC.ByteString) , serverControlFlow :: Flow (ControlMessage PeerAddress) (ControlRequest PeerAddress) , serverDataResponse :: TQueue (Peer, Maybe PartialRef) - , serverIOActions :: TQueue (ExceptT String IO ()) + , serverIOActions :: TQueue (ExceptT ErebosError IO ()) , serverServices :: [SomeService] , serverServiceStates :: TMVar (M.Map ServiceID SomeServiceGlobalState) , serverPeers :: MVar (Map PeerAddress Peer) @@ -189,8 +190,8 @@ instance Ord PeerAddress where #endif -data PeerIdentity = PeerIdentityUnknown (TVar [UnifiedIdentity -> ExceptT String IO ()]) - | PeerIdentityRef WaitingRef (TVar [UnifiedIdentity -> ExceptT String IO ()]) +data PeerIdentity = PeerIdentityUnknown (TVar [UnifiedIdentity -> ExceptT ErebosError IO ()]) + | PeerIdentityRef WaitingRef (TVar [UnifiedIdentity -> ExceptT ErebosError IO ()]) | PeerIdentityFull UnifiedIdentity peerIdentity :: MonadIO m => Peer -> m PeerIdentity @@ -255,7 +256,7 @@ startServer serverOptions serverOrigHead logd' serverServices = do forkServerThread server $ dataResponseWorker server forkServerThread server $ forever $ do - either (atomically . logd) return =<< runExceptT =<< + either (atomically . logd . showErebosError) return =<< runExceptT =<< atomically (readTQueue serverIOActions) let open addr = do @@ -407,7 +408,7 @@ dataResponseWorker server = forever $ do Right ref -> do atomically (writeTVar tvar $ Right ref) forkServerThread server $ runExceptT (wrefAction wr ref) >>= \case - Left err -> atomically $ writeTQueue (serverErrorLog server) err + Left err -> atomically $ writeTQueue (serverErrorLog server) (showErebosError err) Right () -> return () return (Nothing, []) @@ -586,7 +587,7 @@ handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs = liftSTM $ writeTQueue (serverIOActions server) $ void $ liftIO $ forkIO $ do (runExcept <$> readObjectsFromStream (peerInStorage peer) streamReader) >>= \case Left err -> atomically $ writeTQueue (serverErrorLog server) $ - "failed to receive object from stream: " <> err + "failed to receive object from stream: " <> showErebosError err Right objs -> do forM_ objs $ \obj -> do pref <- storeObject (peerInStorage peer) obj @@ -668,7 +669,7 @@ handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs = _ -> return () -withPeerIdentity :: MonadIO m => Peer -> (UnifiedIdentity -> ExceptT String IO ()) -> m () +withPeerIdentity :: MonadIO m => Peer -> (UnifiedIdentity -> ExceptT ErebosError IO ()) -> m () withPeerIdentity peer act = liftIO $ atomically $ readTVar (peerIdentityVar peer) >>= \case PeerIdentityUnknown tvar -> modifyTVar' tvar (act:) PeerIdentityRef _ tvar -> modifyTVar' tvar (act:) @@ -724,7 +725,7 @@ handleChannelAccept identity accref = do sendToPeerS peer [] $ TransportPacket (TransportHeader [Acknowledged $ refDigest accref]) [] finalizedChannel peer ch identity - Left dgst -> throwError $ "missing accept data " ++ BC.unpack (showRefDigest dgst) + Left dgst -> throwOtherError $ "missing accept data " ++ BC.unpack (showRefDigest dgst) finalizedChannel :: Peer -> Channel -> UnifiedIdentity -> STM () @@ -882,7 +883,7 @@ sendToPeerS = sendToPeerS' EncryptedOnly sendToPeerPlain :: Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM () sendToPeerPlain = sendToPeerS' PlaintextAllowed -sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => Peer -> (ServiceState s -> ExceptT String IO (Maybe s, ServiceState s)) -> m () +sendToPeerWith :: forall s m e. (Service s, MonadIO m, MonadError e m, FromErebosError e) => Peer -> (ServiceState s -> ExceptT ErebosError IO (Maybe s, ServiceState s)) -> m () sendToPeerWith peer fobj = do let sproxy = Proxy @s sid = serviceID sproxy @@ -897,7 +898,7 @@ sendToPeerWith peer fobj = do case res of Right (Just obj) -> sendToPeer peer obj Right Nothing -> return () - Left err -> throwError err + Left err -> throwError $ fromErebosError err lookupService :: forall s. Service s => Proxy s -> [SomeService] -> Maybe (SomeService, ServiceAttributes s) diff --git a/src/Erebos/Network/Channel.hs b/src/Erebos/Network/Channel.hs index 17e1a37..d9679bd 100644 --- a/src/Erebos/Network/Channel.hs +++ b/src/Erebos/Network/Channel.hs @@ -78,23 +78,23 @@ instance Storable ChannelAcceptData where keySize :: Int keySize = 32 -createChannelRequest :: (MonadStorage m, MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> m (Stored ChannelRequest) +createChannelRequest :: (MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => UnifiedIdentity -> UnifiedIdentity -> m (Stored ChannelRequest) createChannelRequest self peer = do (_, xpublic) <- liftIO . generateKeys =<< getStorage skey <- loadKey $ idKeyMessage self mstore =<< sign skey =<< mstore ChannelRequest { crPeers = sort [idData self, idData peer], crKey = xpublic } -acceptChannelRequest :: (MonadStorage m, MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelRequest -> m (Stored ChannelAccept, Channel) +acceptChannelRequest :: (MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelRequest -> m (Stored ChannelAccept, Channel) acceptChannelRequest self peer req = do case sequence $ map validateIdentity $ crPeers $ fromStored $ signedData $ fromStored req of - Nothing -> throwError $ "invalid peers in channel request" + Nothing -> throwOtherError $ "invalid peers in channel request" Just peers -> do when (not $ any (self `sameIdentity`) peers) $ - throwError $ "self identity missing in channel request peers" + throwOtherError $ "self identity missing in channel request peers" when (not $ any (peer `sameIdentity`) peers) $ - throwError $ "peer identity missing in channel request peers" + throwOtherError $ "peer identity missing in channel request peers" when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $ - throwError $ "channel requent not signed by peer" + throwOtherError $ "channel requent not signed by peer" (xsecret, xpublic) <- liftIO . generateKeys =<< getStorage skey <- loadKey $ idKeyMessage self @@ -110,20 +110,20 @@ acceptChannelRequest self peer req = do return (acc, Channel {..}) -acceptedChannel :: (MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelAccept -> m Channel +acceptedChannel :: (MonadIO m, MonadError e m, FromErebosError e) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelAccept -> m Channel acceptedChannel self peer acc = do let req = caRequest $ fromStored $ signedData $ fromStored acc case sequence $ map validateIdentity $ crPeers $ fromStored $ signedData $ fromStored req of - Nothing -> throwError $ "invalid peers in channel accept" + Nothing -> throwOtherError $ "invalid peers in channel accept" Just peers -> do when (not $ any (self `sameIdentity`) peers) $ - throwError $ "self identity missing in channel accept peers" + throwOtherError $ "self identity missing in channel accept peers" when (not $ any (peer `sameIdentity`) peers) $ - throwError $ "peer identity missing in channel accept peers" + throwOtherError $ "peer identity missing in channel accept peers" when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored acc)) $ - throwError $ "channel accept not signed by peer" + throwOtherError $ "channel accept not signed by peer" when (idKeyMessage self `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $ - throwError $ "original channel request not signed by us" + throwOtherError $ "original channel request not signed by us" xsecret <- loadKey $ crKey $ fromStored $ signedData $ fromStored req let chPeers = crPeers $ fromStored $ signedData $ fromStored req @@ -137,23 +137,23 @@ acceptedChannel self peer acc = do return Channel {..} -channelEncrypt :: (ByteArray ba, MonadIO m, MonadError String m) => Channel -> ba -> m (ba, Word64) +channelEncrypt :: (ByteArray ba, MonadIO m, MonadError e m, FromErebosError e) => Channel -> ba -> m (ba, Word64) channelEncrypt Channel {..} plain = do count <- liftIO $ modifyMVar chCounterNextOut $ \c -> return (c + 1, c) let cbytes = convert $ BL.toStrict $ encode count nonce = nonce8 chNonceFixedOur cbytes state <- case initialize chKey =<< nonce of CryptoPassed state -> return state - CryptoFailed err -> throwError $ "failed to init chacha-poly1305 cipher: " <> show err + CryptoFailed err -> throwOtherError $ "failed to init chacha-poly1305 cipher: " <> show err let (ctext, state') = encrypt plain state tag = finalize state' return (BA.concat [ convert $ BA.drop 7 cbytes, ctext, convert tag ], count) -channelDecrypt :: (ByteArray ba, MonadIO m, MonadError String m) => Channel -> ba -> m (ba, Word64) +channelDecrypt :: (ByteArray ba, MonadIO m, MonadError e m, FromErebosError e) => Channel -> ba -> m (ba, Word64) channelDecrypt Channel {..} body = do when (BA.length body < 17) $ do - throwError $ "invalid encrypted data length" + throwOtherError $ "invalid encrypted data length" expectedCount <- liftIO $ readMVar chCounterNextIn let countByte = body `BA.index` 0 @@ -165,11 +165,11 @@ channelDecrypt Channel {..} body = do tag = BA.dropView body' blen state <- case initialize chKey =<< nonce of CryptoPassed state -> return state - CryptoFailed err -> throwError $ "failed to init chacha-poly1305 cipher: " <> show err + CryptoFailed err -> throwOtherError $ "failed to init chacha-poly1305 cipher: " <> show err let (plain, state') = decrypt (convert ctext) state when (not $ tag `BA.constEq` finalize state') $ do - throwError $ "tag validation falied" + throwOtherError $ "tag validation falied" liftIO $ modifyMVar_ chCounterNextIn $ return . max (guessedCount + 1) return (plain, guessedCount) diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs index c657759..c340503 100644 --- a/src/Erebos/Network/Protocol.hs +++ b/src/Erebos/Network/Protocol.hs @@ -323,7 +323,7 @@ connAddWriteStream conn@Connection {..} = do Right (ctext, counter) -> do let isAcked = True return $ Just (0x80 `B.cons` ctext, if isAcked then [ AcknowledgedSingle $ fromIntegral counter ] else []) - Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ err + Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ showErebosError err return Nothing Nothing | secure -> return Nothing | otherwise -> return $ Just (plain, plainAckedBy) @@ -402,16 +402,16 @@ readStreamToList stream = readFlowIO stream >>= \case StreamData sq bytes -> fmap ((sq, bytes) :) <$> readStreamToList stream StreamClosed sqEnd -> return (sqEnd, []) -readObjectsFromStream :: PartialStorage -> RawStreamReader -> IO (Except String [PartialObject]) +readObjectsFromStream :: PartialStorage -> RawStreamReader -> IO (Except ErebosError [PartialObject]) readObjectsFromStream st stream = do (seqEnd, list) <- readStreamToList stream let validate s ((s', bytes) : rest) | s == s' = (bytes : ) <$> validate (s + 1) rest | s > s' = validate s rest - | otherwise = throwError "missing object chunk" + | otherwise = throwOtherError "missing object chunk" validate s [] | s == seqEnd = return [] - | otherwise = throwError "content length mismatch" + | otherwise = throwOtherError "content length mismatch" return $ do content <- BL.fromChunks <$> validate 0 list deserializeObjects st content @@ -434,7 +434,7 @@ data WaitingRef = WaitingRef , wrefStatus :: TVar (Either [RefDigest] Ref) } -type WaitingRefCallback = ExceptT String IO () +type WaitingRefCallback = ExceptT ErebosError IO () wrDigest :: WaitingRef -> RefDigest wrDigest = refDigest . wrefPartial @@ -571,7 +571,7 @@ processIncoming gs@GlobalState {..} = do let parse = case B.uncons msg of Just (b, enc) | b .&. 0xE0 == 0x80 -> do - ch <- maybe (throwError "unexpected encrypted packet") return mbch + ch <- maybe (throwOtherError "unexpected encrypted packet") return mbch (dec, counter) <- channelDecrypt ch enc case B.uncons dec of @@ -586,18 +586,18 @@ processIncoming gs@GlobalState {..} = do return $ Right (snum, seq8, content, counter) Just (_, _) -> do - throwError "unexpected stream header" + throwOtherError "unexpected stream header" Nothing -> do - throwError "empty decrypted content" + throwOtherError "empty decrypted content" | b .&. 0xE0 == 0x60 -> do objs <- deserialize msg return $ Left (False, objs, Nothing) - | otherwise -> throwError "invalid packet" + | otherwise -> throwOtherError "invalid packet" - Nothing -> throwError "empty packet" + Nothing -> throwOtherError "empty packet" now <- getTime Monotonic runExceptT parse >>= \case @@ -648,7 +648,7 @@ processIncoming gs@GlobalState {..} = do atomically $ gLog $ show addr <> ": stream packet without connection" Left err -> do - atomically $ gLog $ show addr <> ": failed to parse packet: " <> err + atomically $ gLog $ show addr <> ": failed to parse packet: " <> showErebosError err processPacket :: GlobalState addr -> Either addr (Connection addr) -> Bool -> TransportPacket a -> IO (Maybe (Connection addr, Maybe (TransportPacket a))) processPacket gs@GlobalState {..} econn secure packet@(TransportPacket (TransportHeader header) _) = if @@ -882,7 +882,7 @@ processOutgoing gs@GlobalState {..} = do Right (ctext, counter) -> do let isAcked = any isHeaderItemAcknowledged hitems return $ Just (0x80 `B.cons` ctext, if isAcked then [ AcknowledgedSingle $ fromIntegral counter ] else []) - Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ err + Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ showErebosError err return Nothing mbs <- case (secure, mbch) of diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs index 5d88ad0..4bca49c 100644 --- a/src/Erebos/Object/Internal.hs +++ b/src/Erebos/Object/Internal.hs @@ -79,6 +79,7 @@ import qualified Data.UUID as U import System.IO.Unsafe +import Erebos.Error import Erebos.Storage.Internal @@ -215,7 +216,7 @@ ioLoadObject ref@(Ref st rhash) = do let chash = hashToRefDigest file when (chash /= rhash) $ error $ "Hash mismatch on object " ++ BC.unpack (showRef ref) {- TODO throw -} return $ case runExcept $ unsafeDeserializeObject st file of - Left err -> error $ err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -} + Left err -> error $ showErebosError err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -} Right (x, rest) | BL.null rest -> x | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -} @@ -223,7 +224,7 @@ lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.By lazyLoadBytes ref | isZeroRef ref = returnLoadResult (return BL.empty :: c BL.ByteString) lazyLoadBytes ref = returnLoadResult $ unsafePerformIO $ ioLoadBytes ref -unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except String (Object' c, BL.ByteString) +unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except ErebosError (Object' c, BL.ByteString) unsafeDeserializeObject _ bytes | BL.null bytes = return (ZeroObject, bytes) unsafeDeserializeObject st bytes = case BLC.break (=='\n') bytes of @@ -232,10 +233,10 @@ unsafeDeserializeObject st bytes = guard $ B.length content == len (,next) <$> case otype of _ | otype == BC.pack "blob" -> return $ Blob content - | otype == BC.pack "rec" -> maybe (throwError $ "Malformed record item ") + | otype == BC.pack "rec" -> maybe (throwOtherError $ "malformed record item ") (return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content | otherwise -> return $ UnknownObject otype content - _ -> throwError $ "Malformed object" + _ -> throwOtherError $ "malformed object" where splitObjPrefix line = do [otype, tlen] <- return $ BLC.words line (len, rest) <- BLC.readInt tlen @@ -270,10 +271,10 @@ unsafeDeserializeObject st bytes = _ -> Nothing return (name, val) -deserializeObject :: PartialStorage -> BL.ByteString -> Except String (PartialObject, BL.ByteString) +deserializeObject :: PartialStorage -> BL.ByteString -> Except ErebosError (PartialObject, BL.ByteString) deserializeObject = unsafeDeserializeObject -deserializeObjects :: PartialStorage -> BL.ByteString -> Except String [PartialObject] +deserializeObjects :: PartialStorage -> BL.ByteString -> Except ErebosError [PartialObject] deserializeObjects _ bytes | BL.null bytes = return [] deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes (obj:) <$> deserializeObjects st rest @@ -344,11 +345,12 @@ newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString type StoreRec c = StoreRecM c () -newtype Load a = Load (ReaderT (Ref, Object) (Except String) a) - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String) +newtype Load a = Load (ReaderT (Ref, Object) (Except ErebosError) a) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError ErebosError) evalLoad :: Load a -> Ref -> a -evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ")++)) id $ runExcept $ runReaderT f (ref, lazyLoadObject ref) +evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ") ++) . showErebosError) id $ + runExcept $ runReaderT f (ref, lazyLoadObject ref) loadCurrentRef :: Load Ref loadCurrentRef = Load $ asks fst @@ -356,8 +358,8 @@ loadCurrentRef = Load $ asks fst loadCurrentObject :: Load Object loadCurrentObject = Load $ asks snd -newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except String) a) - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String) +newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except ErebosError) a) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError ErebosError) loadRecCurrentRef :: LoadRec Ref loadRecCurrentRef = LoadRec $ asks fst @@ -413,7 +415,7 @@ storeZero = StoreZero class StorableText a where toText :: a -> Text - fromText :: MonadError String m => Text -> m a + fromText :: MonadError ErebosError m => Text -> m a instance StorableText Text where toText = id; fromText = return @@ -526,23 +528,23 @@ storeRecItems items = StoreRecM $ do loadBlob :: (ByteString -> a) -> Load a loadBlob f = loadCurrentObject >>= \case Blob x -> return $ f x - _ -> throwError "Expecting blob" + _ -> throwOtherError "Expecting blob" loadRec :: LoadRec a -> Load a loadRec (LoadRec lrec) = loadCurrentObject >>= \case Rec rs -> do ref <- loadCurrentRef either throwError return $ runExcept $ runReaderT lrec (ref, rs) - _ -> throwError "Expecting record" + _ -> throwOtherError "Expecting record" loadZero :: a -> Load a loadZero x = loadCurrentObject >>= \case ZeroObject -> return x - _ -> throwError "Expecting zero" + _ -> throwOtherError "Expecting zero" loadEmpty :: String -> LoadRec () -loadEmpty name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name +loadEmpty name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name loadMbEmpty :: String -> LoadRec (Maybe ()) loadMbEmpty name = listToMaybe . mapMaybe p <$> loadRecItems @@ -553,7 +555,7 @@ loadMbEmpty name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadInt :: Num a => String -> LoadRec a -loadInt name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbInt name +loadInt name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbInt name loadMbInt :: Num a => String -> LoadRec (Maybe a) loadMbInt name = listToMaybe . mapMaybe p <$> loadRecItems @@ -564,7 +566,7 @@ loadMbInt name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadNum :: (Real a, Fractional a) => String -> LoadRec a -loadNum name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbNum name +loadNum name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbNum name loadMbNum :: (Real a, Fractional a) => String -> LoadRec (Maybe a) loadMbNum name = listToMaybe . mapMaybe p <$> loadRecItems @@ -575,7 +577,7 @@ loadMbNum name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadText :: StorableText a => String -> LoadRec a -loadText name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbText name +loadText name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbText name loadMbText :: StorableText a => String -> LoadRec (Maybe a) loadMbText name = listToMaybe <$> loadTexts name @@ -589,7 +591,7 @@ loadTexts name = sequence . mapMaybe p =<< loadRecItems p _ = Nothing loadBinary :: BA.ByteArray a => String -> LoadRec a -loadBinary name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbBinary name +loadBinary name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbBinary name loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a) loadMbBinary name = listToMaybe <$> loadBinaries name @@ -603,7 +605,7 @@ loadBinaries name = mapMaybe p <$> loadRecItems p _ = Nothing loadDate :: StorableDate a => String -> LoadRec a -loadDate name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbDate name +loadDate name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbDate name loadMbDate :: StorableDate a => String -> LoadRec (Maybe a) loadMbDate name = listToMaybe . mapMaybe p <$> loadRecItems @@ -614,7 +616,7 @@ loadMbDate name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadUUID :: StorableUUID a => String -> LoadRec a -loadUUID name = maybe (throwError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name +loadUUID name = maybe (throwOtherError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a) loadMbUUID name = listToMaybe . mapMaybe p <$> loadRecItems @@ -625,7 +627,7 @@ loadMbUUID name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadRawRef :: String -> LoadRec Ref -loadRawRef name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name +loadRawRef name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name loadMbRawRef :: String -> LoadRec (Maybe Ref) loadMbRawRef name = listToMaybe <$> loadRawRefs name diff --git a/src/Erebos/Pairing.hs b/src/Erebos/Pairing.hs index da6a9b4..703afcd 100644 --- a/src/Erebos/Pairing.hs +++ b/src/Erebos/Pairing.hs @@ -49,7 +49,7 @@ data PairingState a = NoPairing data PairingFailureReason a = PairingUserRejected | PairingUnexpectedMessage (PairingState a) (PairingService a) - | PairingFailedOther String + | PairingFailedOther ErebosError data PairingAttributes a = PairingAttributes { pairingHookRequest :: ServiceHandler (PairingService a) () @@ -116,16 +116,16 @@ instance PairingResult a => Service (PairingService a) where serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case (NoPairing, PairingRequest pdata sdata confirm) -> do - self <- maybe (throwError "failed to validate received identity") return $ validateIdentity sdata - self' <- maybe (throwError "failed to validate own identity") return . + self <- maybe (throwOtherError "failed to validate received identity") return $ validateIdentity sdata + self' <- maybe (throwOtherError "failed to validate own identity") return . validateExtendedIdentity . lsIdentity . fromStored =<< svcGetLocal when (not $ self `sameIdentity` self') $ do - throwError "pairing request to different identity" + throwOtherError "pairing request to different identity" - peer <- maybe (throwError "failed to validate received peer identity") return $ validateIdentity pdata + peer <- maybe (throwOtherError "failed to validate received peer identity") return $ validateIdentity pdata peer' <- asks $ svcPeerIdentity when (not $ peer `sameIdentity` peer') $ do - throwError "pairing request from different identity" + throwOtherError "pairing request from different identity" join $ asks $ pairingHookRequest . svcAttributes nonce <- liftIO $ getRandomBytes 32 @@ -167,7 +167,7 @@ instance PairingResult a => Service (PairingService a) where svcSet $ PairingDone Nothing -> do join $ asks $ pairingHookVerifyFailed . svcAttributes - throwError "" + throwOtherError "" x@(OurRequestReady, _) -> reject $ uncurry PairingUnexpectedMessage x (PeerRequest peer self nonce dgst, PairingRequestNonce pnonce) -> do @@ -204,22 +204,22 @@ confirmationNumber dgst = _ -> "" where len = 6 -pairingRequest :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m () +pairingRequest :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m () pairingRequest _ peer = do self <- liftIO $ serverIdentity $ peerServer peer nonce <- liftIO $ getRandomBytes 32 pid <- peerIdentity peer >>= \case PeerIdentityFull pid -> return pid - _ -> throwError "incomplete peer identity" + _ -> throwOtherError "incomplete peer identity" sendToPeerWith @(PairingService a) peer $ \case NoPairing -> return (Just $ PairingRequest (idData self) (idData pid) (nonceDigest self pid nonce BA.empty), OurRequest self pid nonce) - _ -> throwError "already in progress" + _ -> throwOtherError "already in progress" -pairingAccept :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m () +pairingAccept :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m () pairingAccept _ peer = runPeerService @(PairingService a) peer $ do svcGet >>= \case - NoPairing -> throwError $ "none in progress" - OurRequest {} -> throwError $ "waiting for peer" + NoPairing -> throwOtherError $ "none in progress" + OurRequest {} -> throwOtherError $ "waiting for peer" OurRequestConfirm Nothing -> do join $ asks $ pairingHookConfirmedResponse . svcAttributes svcSet OurRequestReady @@ -227,17 +227,17 @@ pairingAccept _ peer = runPeerService @(PairingService a) peer $ do join $ asks $ pairingHookAcceptedResponse . svcAttributes pairingFinalizeRequest verified svcSet PairingDone - OurRequestReady -> throwError $ "already accepted, waiting for peer" - PeerRequest {} -> throwError $ "waiting for peer" + OurRequestReady -> throwOtherError $ "already accepted, waiting for peer" + PeerRequest {} -> throwOtherError $ "waiting for peer" PeerRequestConfirm -> do join $ asks $ pairingHookAcceptedRequest . svcAttributes replyPacket . PairingAccept =<< pairingFinalizeResponse svcSet PairingDone - PairingDone -> throwError $ "already done" + PairingDone -> throwOtherError $ "already done" -pairingReject :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m () +pairingReject :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m () pairingReject _ peer = runPeerService @(PairingService a) peer $ do svcGet >>= \case - NoPairing -> throwError $ "none in progress" - PairingDone -> throwError $ "already done" + NoPairing -> throwOtherError $ "none in progress" + PairingDone -> throwOtherError $ "already done" _ -> reject PairingUserRejected diff --git a/src/Erebos/PubKey.hs b/src/Erebos/PubKey.hs index bea208b..a2ee519 100644 --- a/src/Erebos/PubKey.hs +++ b/src/Erebos/PubKey.hs @@ -11,7 +11,6 @@ module Erebos.PubKey ( ) where import Control.Monad -import Control.Monad.Except import Crypto.Error import qualified Crypto.PubKey.Ed25519 as ED @@ -70,7 +69,7 @@ instance Storable PublicKey where load' = loadRec $ do ktype <- loadText "type" guard $ ktype == "ed25519" - maybe (throwError "Public key decoding failed") (return . PublicKey) . + maybe (throwOtherError "public key decoding failed") (return . PublicKey) . maybeCryptoError . (ED.publicKey :: ByteString -> CryptoFailable ED.PublicKey) =<< loadBinary "pubkey" @@ -82,7 +81,7 @@ instance Storable Signature where load' = loadRec $ Signature <$> loadRef "key" <*> loadSignature "sig" - where loadSignature = maybe (throwError "Signature decoding failed") return . + where loadSignature = maybe (throwOtherError "signature decoding failed") return . maybeCryptoError . (ED.signature :: ByteString -> CryptoFailable ED.Signature) <=< loadBinary instance Storable a => Storable (Signed a) where @@ -96,7 +95,7 @@ instance Storable a => Storable (Signed a) where forM_ sigs $ \sig -> do let PublicKey pubkey = fromStored $ sigKey $ fromStored sig when (not $ ED.verify pubkey (storedRef sdata) $ sigSignature $ fromStored sig) $ - throwError "signature verification failed" + throwOtherError "signature verification failed" return $ Signed sdata sigs sign :: MonadStorage m => SecretKey -> Stored a -> m (Signed a) @@ -148,7 +147,7 @@ instance Storable PublicKexKey where load' = loadRec $ do ktype <- loadText "type" guard $ ktype == "x25519" - maybe (throwError "public key decoding failed") (return . PublicKexKey) . + maybe (throwOtherError "public key decoding failed") (return . PublicKexKey) . maybeCryptoError . (CX.publicKey :: ScrubbedBytes -> CryptoFailable CX.PublicKey) =<< loadBinary "pubkey" diff --git a/src/Erebos/Service.hs b/src/Erebos/Service.hs index 5c81a3d..e95e700 100644 --- a/src/Erebos/Service.hs +++ b/src/Erebos/Service.hs @@ -127,8 +127,8 @@ data ServiceHandlerState s = ServiceHandlerState , svcLocal :: Stored LocalState } -newtype ServiceHandler s a = ServiceHandler (ReaderT (ServiceInput s) (WriterT [ServiceReply s] (StateT (ServiceHandlerState s) (ExceptT String IO))) a) - deriving (Functor, Applicative, Monad, MonadReader (ServiceInput s), MonadWriter [ServiceReply s], MonadState (ServiceHandlerState s), MonadError String, MonadIO) +newtype ServiceHandler s a = ServiceHandler (ReaderT (ServiceInput s) (WriterT [ServiceReply s] (StateT (ServiceHandlerState s) (ExceptT ErebosError IO))) a) + deriving (Functor, Applicative, Monad, MonadReader (ServiceInput s), MonadWriter [ServiceReply s], MonadState (ServiceHandlerState s), MonadError ErebosError, MonadIO) instance MonadStorage (ServiceHandler s) where getStorage = asks $ peerStorage . svcPeer @@ -145,7 +145,7 @@ runServiceHandler h input svc global shandler = do ServiceHandler handler = shandler (runExceptT $ flip runStateT sstate $ execWriterT $ flip runReaderT input $ handler) >>= \case Left err -> do - svcPrintOp input $ "service failed: " ++ err + svcPrintOp input $ "service failed: " ++ showErebosError err return ([], (svc, global)) Right (rsp, sstate') | svcLocal sstate' == svcLocal sstate -> return (rsp, (svcValue sstate', svcGlobal sstate')) @@ -178,7 +178,7 @@ svcSetLocal :: Stored LocalState -> ServiceHandler s () svcSetLocal x = modify $ \st -> st { svcLocal = x } svcSelf :: ServiceHandler s UnifiedIdentity -svcSelf = maybe (throwError "failed to validate own identity") return . +svcSelf = maybe (throwOtherError "failed to validate own identity") return . validateExtendedIdentity . lsIdentity . fromStored =<< svcGetLocal svcPrint :: String -> ServiceHandler s () diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs index 79f17b7..f0af8a0 100644 --- a/src/Erebos/State.hs +++ b/src/Erebos/State.hs @@ -172,20 +172,20 @@ makeSharedStateUpdate st val prev = liftIO $ wrappedStore st SharedState } -mergeSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m UnifiedIdentity +mergeSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => m UnifiedIdentity mergeSharedIdentity = updateLocalHead $ updateSharedState $ \case Just cidentity -> do identity <- mergeIdentity cidentity return (Just $ toComposedIdentity identity, identity) - Nothing -> throwError "no existing shared identity" + Nothing -> throwOtherError "no existing shared identity" -updateSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m () +updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => m () updateSharedIdentity = updateLocalHead_ $ updateSharedState_ $ \case Just identity -> do Just . toComposedIdentity <$> interactiveIdentityUpdate identity - Nothing -> throwError "no existing shared identity" + Nothing -> throwOtherError "no existing shared identity" -interactiveIdentityUpdate :: (Foldable f, MonadStorage m, MonadIO m, MonadError String m) => Identity f -> m UnifiedIdentity +interactiveIdentityUpdate :: (Foldable f, MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => Identity f -> m UnifiedIdentity interactiveIdentityUpdate identity = do let public = idKeyIdentity identity @@ -203,7 +203,7 @@ interactiveIdentityUpdate identity = do if | T.null name -> mergeIdentity identity | otherwise -> do secret <- loadKey public - maybe (throwError "created invalid identity") return . validateIdentity =<< + maybe (throwOtherError "created invalid identity") return . validateIdentity =<< mstore =<< sign secret =<< mstore (emptyIdentityData public) { iddPrev = toList $ idDataF identity , iddName = Just name diff --git a/src/Erebos/Storable.hs b/src/Erebos/Storable.hs index ee389ce..b0795f9 100644 --- a/src/Erebos/Storable.hs +++ b/src/Erebos/Storable.hs @@ -36,6 +36,9 @@ module Erebos.Storable ( unsafeMapStored, Storage, MonadStorage(..), + + module Erebos.Error, ) where +import Erebos.Error import Erebos.Object.Internal diff --git a/src/Erebos/Storage/Key.hs b/src/Erebos/Storage/Key.hs index fab2103..b615f16 100644 --- a/src/Erebos/Storage/Key.hs +++ b/src/Erebos/Storage/Key.hs @@ -27,8 +27,8 @@ storeKey key = do case storedStorage spub of Storage {..} -> backendStoreKey stBackend (refDigest $ storedRef spub) (keyGetData key) -loadKey :: (KeyPair sec pub, MonadIO m, MonadError String m) => Stored pub -> m sec -loadKey pub = maybe (throwError $ "secret key not found for " <> show (storedRef pub)) return =<< loadKeyMb pub +loadKey :: (KeyPair sec pub, MonadIO m, MonadError e m, FromErebosError e) => Stored pub -> m sec +loadKey pub = maybe (throwOtherError $ "secret key not found for " <> show (storedRef pub)) return =<< loadKeyMb pub loadKeyMb :: forall sec pub m. (KeyPair sec pub, MonadIO m) => Stored pub -> m (Maybe sec) loadKeyMb spub = liftIO $ run $ storedStorage spub -- cgit v1.2.3