monad throw instead of error

app/Routes.hs

@@ -47,13 +47,10 @@ routes db detailsFile =
       notes <- map noteToCreate <$> liftIO db.getNotes
 
       Fedi.handleCreateNote details notes
+
   , -- Match inbox
     Twain.post (Fedi.matchInbox $ unsafePerformIO $ fetchUserDetails detailsFile) do
-      request <- Twain.request
+      Fedi.handleInbox (handleInbox db detailsFile)
-      if Fedi.checkContentTypeAccept request
-        then do
-          Fedi.handleInbox (handleInbox db detailsFile)
-        else Twain.next
 
   , -- Match Create object
     Twain.get (Fedi.matchCreateNote $ unsafePerformIO $ fetchUserDetails detailsFile) do

src/Fedi/Crypto.hs

@@ -12,36 +12,34 @@ import Fedi.UserDetails
 import Data.ByteString.Base64 qualified as Base64
 import Data.Base64.Types qualified as Base64
 
-verifyPub :: ByteString -> ByteString -> ByteString -> Bool
+verifyPub :: MonadThrow m => ByteString -> ByteString -> ByteString -> m Bool
-verifyPub pubkeypem sig message =
+verifyPub pubkeypem sig message = do
-  let
+  pubkey <-
-    pubkey = case Crypto.readPubKeyFileFromMemory pubkeypem of
+    case Crypto.readPubKeyFileFromMemory pubkeypem of
-      [Crypto.PubKeyRSA pubkey'] -> pubkey'
+      [Crypto.PubKeyRSA pubkey'] -> pure pubkey'
-      _ -> error "failed to read pubkey pem"
+      _ -> throw "failed to read pubkey pem"
-  in
+  pure $ Crypto.verify (Crypto.defaultPSSParams Crypto.SHA256) pubkey message sig
-    Crypto.verify (Crypto.defaultPSSParams Crypto.SHA256) pubkey message sig
 
-verifyDigest :: ByteString -> ByteString -> ByteString -> Bool
+verifyDigest :: MonadThrow m => ByteString -> ByteString -> ByteString -> m Bool
-verifyDigest pubkeypem sig digest' =
+verifyDigest pubkeypem sig digest' = do
+  pubkey <-
+    case Crypto.readPubKeyFileFromMemory pubkeypem of
+      [Crypto.PubKeyRSA pubkey'] -> pure pubkey'
+      _ -> throw "failed to read pubkey pem"
   let
-    pubkey = case Crypto.readPubKeyFileFromMemory pubkeypem of
-      [Crypto.PubKeyRSA pubkey'] -> pubkey'
-      _ -> error "failed to read pubkey pem"
     digest = Crypto.hash digest'
-  in
+  pure $ Crypto.verifyDigest (Crypto.defaultPSSParams Crypto.SHA256) pubkey digest sig
-    Crypto.verifyDigest (Crypto.defaultPSSParams Crypto.SHA256) pubkey digest sig
 
 sign :: UserDetails -> ByteString -> IO Signed
 sign details message = do
   -- get private key
   privkeypem <- Crypto.readKeyFile details.privatePem
-  let
+  privateKey <- case privkeypem of
-    privateKey = case privkeypem of
+    [Crypto.Unprotected (Crypto.PrivKeyRSA privkey)] -> pure privkey
-      [Crypto.Unprotected (Crypto.PrivKeyRSA privkey)] -> privkey
+    _ -> throw $ "error reading local private key from '" <> details.privatePem <> "'."
-      _ -> error $ "error reading local private key from '" <> details.privatePem <> "'."
 
   -- sign message
-  signedMessage <- either (error . show) id <$>
+  signedMessage <- either (throw . show) pure =<<
     Crypto.sign Nothing (Crypto.defaultPSSParams Crypto.SHA256) privateKey message
 
   -- sign digest
@@ -49,7 +47,7 @@ sign details message = do
     digest :: Crypto.Digest Crypto.SHA256
     digest = Crypto.hash message
 
-  signedDigest <- either (error . show) id <$>
+  signedDigest <- either (throw . show) pure =<<
     Crypto.signDigest Nothing (Crypto.defaultPSSParams Crypto.SHA256) privateKey digest
 
   -- return

src/Fedi/Helpers.hs

@@ -1,5 +1,6 @@
 module Fedi.Helpers
   ( module Export
+  , module Fedi.Helpers
   )
 where
 
@@ -15,3 +16,11 @@ import GHC.Generics as Export (Generic)
 import Control.Monad as Export
 import Data.Functor as Export
 import Data.Function as Export
+import Control.Monad.Catch as Export (throwM, Exception, MonadThrow)
+
+data Error
+  = Error String
+  deriving (Show, Exception)
+
+throw :: MonadThrow m => String -> m a
+throw = throwM . Error

src/Fedi/Routes/Inbox.hs

@@ -1,5 +1,7 @@
+{-# language RecordWildCards #-}
 module Fedi.Routes.Inbox where
 
+import Prelude hiding (error)
 import Fedi.Requests
 import Fedi.Types
 import Fedi.UserDetails
@@ -10,6 +12,7 @@ import Web.Twain.Types qualified as Twain
 import Data.Text qualified as T
 import Network.Wai qualified as Wai
 import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Catch (catch)
 import Text.ParserCombinators.ReadP qualified as P
 import Data.Text.Encoding qualified as T
 import Data.Text.Encoding.Base64 qualified as Base64
@@ -24,19 +27,25 @@ matchInbox details =
 
 handleInbox :: (AnyActivity -> Twain.ResponderM Twain.Response) -> Twain.ResponderM b
 handleInbox handle = do
-  activity <- checkSignatureAndParseBody
+  let
-  response <- handle activity
+    handler = do
-  Twain.send response
+      activity <- checkSignatureAndParseBody
+      response <- handle activity
+      Twain.send response
+  handler `catch` \(Error e) -> do
+    liftIO $ print e
+    Twain.send $ Twain.status Twain.status500 $ Twain.text (T.pack e)
 
 -- | Check the signature of the sender and parse the body of the request.
 checkSignatureAndParseBody :: Twain.ResponderM AnyActivity
 checkSignatureAndParseBody = do
   -- get info
   request <- Twain.request
+  liftIO $ print $ Twain.requestHeaders request
   body <- liftIO (Wai.strictRequestBody request)
-  sigheader <- parseSignature <$> Twain.header "Signature"
+  sigheader <- parseSignature =<< Twain.header "Signature"
-  digest <-
+  digest <- Twain.header "Digest" >>=
-    maybe (error "missing header Digest") T.encodeUtf8 <$> Twain.header "Digest"
+    maybe (throw "missing header Digest") (pure . T.encodeUtf8)
   (person :: Person) <- liftIO $ sendGet sigheader.keyId
   let personPkid = person.otype.publicKey.pkid
   let personPublicKey = pemToBS person.otype.publicKey.publicKeyPem
@@ -49,17 +58,20 @@ checkSignatureAndParseBody = do
   parseJson body
 
 checkSignature
-  :: Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> IO ()
+  :: MonadThrow m
+  => Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> m ()
 checkSignature personPkid personPublicKey sigheader digest body = do
   -- check
   unless (personPkid == sigheader.keyId) $
-    error "public key mismatch with signature."
+    throw "public key mismatch with signature."
 
-  unless (verifyPub personPublicKey sigheader.signature body) $
+  pub <- verifyPub personPublicKey sigheader.signature body
-    error "signature verification failed."
+  unless pub $
+    throw "signature verification failed."
 
-  unless (verifyDigest personPublicKey digest body) $
+  dig <- verifyDigest personPublicKey digest body
-    error "digest verification failed."
+  unless dig $
+    throw "digest verification failed."
   -- todo: check date
 
 data SignatureHeader
@@ -78,28 +90,25 @@ data Component
   | Signature
   deriving Eq
 
-parseSignature :: Maybe T.Text -> SignatureHeader
+parseSignature :: MonadThrow m => Maybe T.Text -> m SignatureHeader
-parseSignature minput =
+parseSignature minput = do
-  let
+  input <- maybe (throw "no signature.") (pure . T.unpack) minput
-    input = maybe (error "no signature.") T.unpack minput
+  case P.readP_to_S parser input of
-  in case P.readP_to_S parser input of
+    [(sig, "")] -> pure sig
-    [(sig, "")] -> sig
+    _ -> throw "error parsing signature."
-    _ -> error "error parsing signature."
   where
     lookup' a b =
-      fromMaybe (error "error parsing signature") $ lookup a b
+      maybe (fail "error parsing signature") pure $ lookup a b
     parser = do
       components <- component `P.sepBy` P.char ','
-      pure SignatureHeader
+      keyId <- lookup' KeyId components
-        { keyId = lookup' KeyId components
+      headers <- T.split (==' ') . T.pack <$> lookup' Headers components
-        , headers = T.split (==' ') . T.pack $ lookup' Headers components
+      signature <-
-        , signature =
+        ( T.encodeUtf8
-          ( T.encodeUtf8
+        . Base64.decodeBase64Lenient
-          . Base64.decodeBase64Lenient
+        . T.pack
-          . T.pack
+        ) <$> lookup' Signature components
-          . lookup' Signature
+      pure SignatureHeader{..}
-          ) components
-        }
     component = P.choice
       [ do
         _ <- P.string "keyId="