diff --git a/app/Routes.hs b/app/Routes.hs index 6c4208d..dae51b5 100644 --- a/app/Routes.hs +++ b/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 - if Fedi.checkContentTypeAccept request - then do - Fedi.handleInbox (handleInbox db detailsFile) - else Twain.next + Fedi.handleInbox (handleInbox db detailsFile) , -- Match Create object Twain.get (Fedi.matchCreateNote $ unsafePerformIO $ fetchUserDetails detailsFile) do diff --git a/src/Fedi/Crypto.hs b/src/Fedi/Crypto.hs index e2c3105..a875677 100644 --- a/src/Fedi/Crypto.hs +++ b/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 pubkeypem sig message = - let - pubkey = case Crypto.readPubKeyFileFromMemory pubkeypem of - [Crypto.PubKeyRSA pubkey'] -> pubkey' - _ -> error "failed to read pubkey pem" - in - Crypto.verify (Crypto.defaultPSSParams Crypto.SHA256) pubkey message sig +verifyPub :: MonadThrow m => ByteString -> ByteString -> ByteString -> m Bool +verifyPub pubkeypem sig message = do + pubkey <- + case Crypto.readPubKeyFileFromMemory pubkeypem of + [Crypto.PubKeyRSA pubkey'] -> pure pubkey' + _ -> throw "failed to read pubkey pem" + pure $ Crypto.verify (Crypto.defaultPSSParams Crypto.SHA256) pubkey message sig -verifyDigest :: ByteString -> ByteString -> ByteString -> Bool -verifyDigest pubkeypem sig digest' = +verifyDigest :: MonadThrow m => ByteString -> ByteString -> ByteString -> m Bool +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 - Crypto.verifyDigest (Crypto.defaultPSSParams Crypto.SHA256) pubkey digest sig + pure $ 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 - [Crypto.Unprotected (Crypto.PrivKeyRSA privkey)] -> privkey - _ -> error $ "error reading local private key from '" <> details.privatePem <> "'." + privateKey <- case privkeypem of + [Crypto.Unprotected (Crypto.PrivKeyRSA privkey)] -> pure privkey + _ -> throw $ "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 diff --git a/src/Fedi/Helpers.hs b/src/Fedi/Helpers.hs index 1d42913..354973a 100644 --- a/src/Fedi/Helpers.hs +++ b/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 diff --git a/src/Fedi/Routes/Inbox.hs b/src/Fedi/Routes/Inbox.hs index 095ecf6..fe32574 100644 --- a/src/Fedi/Routes/Inbox.hs +++ b/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 - response <- handle activity - Twain.send response + let + handler = do + 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" - digest <- - maybe (error "missing header Digest") T.encodeUtf8 <$> Twain.header "Digest" + sigheader <- parseSignature =<< Twain.header "Signature" + digest <- 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) $ - error "signature verification failed." + pub <- verifyPub personPublicKey sigheader.signature body + unless pub $ + throw "signature verification failed." - unless (verifyDigest personPublicKey digest body) $ - error "digest verification failed." + dig <- verifyDigest personPublicKey digest body + 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 minput = - let - input = maybe (error "no signature.") T.unpack minput - in case P.readP_to_S parser input of - [(sig, "")] -> sig - _ -> error "error parsing signature." +parseSignature :: MonadThrow m => Maybe T.Text -> m SignatureHeader +parseSignature minput = do + input <- maybe (throw "no signature.") (pure . T.unpack) minput + case P.readP_to_S parser input of + [(sig, "")] -> pure sig + _ -> throw "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 - , headers = T.split (==' ') . T.pack $ lookup' Headers components - , signature = - ( T.encodeUtf8 - . Base64.decodeBase64Lenient - . T.pack - . lookup' Signature - ) components - } + keyId <- lookup' KeyId components + headers <- T.split (==' ') . T.pack <$> lookup' Headers components + signature <- + ( T.encodeUtf8 + . Base64.decodeBase64Lenient + . T.pack + ) <$> lookup' Signature components + pure SignatureHeader{..} component = P.choice [ do _ <- P.string "keyId="