Generic type for MonadError constraints

Changelog: API: MonadError constraints use generic error type

2 files changed, 30 insertions, 30 deletions

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