134 lines
4.2 KiB
Haskell
134 lines
4.2 KiB
Haskell
{-# language RecordWildCards #-}
|
|
module Fedi.Routes.Inbox where
|
|
|
|
import Prelude hiding (error)
|
|
import Fedi.Requests
|
|
import Fedi.Types
|
|
import Fedi.UserDetails
|
|
import Fedi.Routes.Helpers
|
|
import Fedi.Helpers
|
|
import Web.Twain qualified as Twain
|
|
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, displayException, SomeException)
|
|
import Text.ParserCombinators.ReadP qualified as P
|
|
import Data.Text.Encoding qualified as T
|
|
import Data.ByteString.Base64 qualified as Base64
|
|
import Data.ByteString.Lazy qualified as BSL
|
|
import Fedi.Crypto
|
|
|
|
-- * Inbox
|
|
|
|
matchInbox :: UserDetails -> Twain.PathPattern
|
|
matchInbox details =
|
|
fromString ("/" <> details.username <> "/inbox")
|
|
|
|
handleInbox :: (AnyActivity -> Twain.ResponderM Twain.Response) -> Twain.ResponderM b
|
|
handleInbox handle = do
|
|
let
|
|
handler = do
|
|
activity <- checkSignatureAndParseBody
|
|
response <- handle activity
|
|
Twain.send response
|
|
handler `catch` \(e :: SomeException) -> do
|
|
liftIO $ putStrLn (displayException e)
|
|
Twain.send $
|
|
Twain.status Twain.status500 $
|
|
Twain.text "Internal Server Error 500"
|
|
|
|
-- | 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 ("headers", Twain.requestHeaders request)
|
|
body <- liftIO (Wai.strictRequestBody request)
|
|
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
|
|
|
|
-- check
|
|
liftIO $
|
|
checkSignature personPkid personPublicKey sigheader digest (BSL.toStrict body)
|
|
|
|
-- parse the body and return it
|
|
parseJson body
|
|
|
|
checkSignature
|
|
:: MonadThrow m
|
|
=> Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> m ()
|
|
checkSignature personPkid personPublicKey sigheader digest body = do
|
|
-- check
|
|
unless (personPkid == sigheader.keyId) $
|
|
throw "public key mismatch with signature."
|
|
|
|
pub <- verifyPub personPublicKey sigheader.signature body
|
|
unless pub $
|
|
throw "signature verification failed."
|
|
|
|
dig <- verifyDigest personPublicKey digest body
|
|
unless dig $
|
|
throw "digest verification failed."
|
|
-- todo: check date
|
|
|
|
data SignatureHeader
|
|
= SignatureHeader
|
|
{ -- | Where to get the public key for this actor
|
|
keyId :: Url
|
|
, -- | Which headers have been sent
|
|
headers :: [T.Text]
|
|
, -- | Contains the signature
|
|
signature :: ByteString
|
|
, components :: [(Component, String)]
|
|
}
|
|
deriving Show
|
|
|
|
data Component
|
|
= KeyId
|
|
| Headers
|
|
| Signature
|
|
| Other String
|
|
deriving (Eq, Show)
|
|
|
|
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
|
|
xs -> throw $ "error parsing signature: " <> show xs
|
|
where
|
|
lookup' a b =
|
|
maybe (fail "error parsing signature") pure $ lookup a b
|
|
parser = do
|
|
components <- component `P.sepBy` P.char ','
|
|
keyId <- lookup' KeyId components
|
|
headers <- T.split (==' ') . T.pack <$> lookup' Headers components
|
|
signature <-
|
|
( Base64.decodeBase64Lenient
|
|
. fromString
|
|
) <$> lookup' Signature components
|
|
pure SignatureHeader{..}
|
|
component = P.choice
|
|
[ do
|
|
_ <- P.string "keyId="
|
|
url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
|
|
pure (KeyId, url)
|
|
, do
|
|
_ <- P.string "headers="
|
|
url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
|
|
pure (Headers, url)
|
|
, do
|
|
_ <- P.string "signature="
|
|
url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
|
|
pure (Signature, url)
|
|
, do
|
|
key <- P.munch1 (/= '=')
|
|
_ <- P.char '='
|
|
value <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
|
|
pure (Other key, value)
|
|
]
|