me/fedi
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

monad throw instead of error

Browse Source
This commit is contained in:
me 2024-11-05 18:31:38 +02:00
parent 0db710272a
commit 2a3b0f9434
4 changed files with 69 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
app/Routes.hs
View File

@ -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

40
src/Fedi/Crypto.hs
View File

@ -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

9
src/Fedi/Helpers.hs
View File

@ -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

69
src/Fedi/Routes/Inbox.hs
View File

@ -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="