summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--erebos.cabal1
-rw-r--r--main/Main.hs34
-rw-r--r--main/Test.hs14
-rw-r--r--src/Erebos/Attach.hs6
-rw-r--r--src/Erebos/Chatroom.hs26
-rw-r--r--src/Erebos/Contact.hs6
-rw-r--r--src/Erebos/Conversation.hs6
-rw-r--r--src/Erebos/DirectMessage.hs3
-rw-r--r--src/Erebos/Error.hs39
-rw-r--r--src/Erebos/ICE.chs3
-rw-r--r--src/Erebos/Identity.hs6
-rw-r--r--src/Erebos/Network.hs21
-rw-r--r--src/Erebos/Network/Channel.hs36
-rw-r--r--src/Erebos/Network/Protocol.hs24
-rw-r--r--src/Erebos/Object/Internal.hs48
-rw-r--r--src/Erebos/Pairing.hs38
-rw-r--r--src/Erebos/PubKey.hs9
-rw-r--r--src/Erebos/Service.hs8
-rw-r--r--src/Erebos/State.hs12
-rw-r--r--src/Erebos/Storable.hs3
-rw-r--r--src/Erebos/Storage/Key.hs4
21 files changed, 195 insertions, 152 deletions
diff --git a/erebos.cabal b/erebos.cabal
index cfa826f..e704a3f 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -99,6 +99,7 @@ library
Erebos.Conversation
Erebos.DirectMessage
Erebos.Discovery
+ Erebos.Error
Erebos.Identity
Erebos.Network
Erebos.Network.Channel
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
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
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-01 17:26:17 +0000