fedi/src/Fedi/Signature/Check.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

module Fedi.Signature.Check (
  module Fedi.Signature.Types,
  module Fedi.Signature.Check,
) where

import Control.Monad.IO.Class
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.CaseInsensitive qualified as CI
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Fedi.Crypto
import Fedi.Helpers
import Fedi.Requests
import Fedi.Routes.Helpers
import Fedi.Signature.Types
import Fedi.Types
import Fedi.UserDetails
import Network.HTTP.Types.Header qualified as HTTP
import Network.HTTP.Types.URI qualified as HTTP
import Network.Wai qualified as Wai
import Text.ParserCombinators.ReadP qualified as P
import Web.Twain qualified as Twain
import Prelude hiding (error)

-- * Check

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

  signatureString <-
    signatureStringFromRequest request sigheader.headers

  -- check
  liftIO $
    checkSignature personPkid personPublicKey sigheader signatureString digest (BSL.toStrict body)

  -- parse the body and return it
  parseJson body

signatureStringFromRequest
  :: forall m
   . (MonadThrow m)
  => Wai.Request -> [T.Text] -> m ByteString
signatureStringFromRequest request (map (T.encodeUtf8 . T.toLower) -> headers) = do
  let
    requestHeaders = Wai.requestHeaders request
    method = T.encodeUtf8 $ T.toLower $ T.decodeUtf8 $ Wai.requestMethod request
    path =
      "/"
        <> T.encodeUtf8 (T.intercalate "/" $ Wai.pathInfo request)
        <> HTTP.renderQuery True (Wai.queryString request)
    requestTarget = method <> " " <> path
  signatureStringFromSpecifics requestHeaders requestTarget headers

signatureStringFromSpecifics
  :: forall m
   . (MonadThrow m)
  => HTTP.RequestHeaders -> ByteString -> [ByteString] -> m ByteString
signatureStringFromSpecifics requestHeaders requestTarget headers = do
  let
    mylookup :: ByteString -> m ByteString
    mylookup header
      | header == "(request-target)" =
          pure $ header <> ": " <> requestTarget
      | header == "host" = do
          let
            result = lookup (CI.mk header) requestHeaders
          case result of
            Nothing -> throw $ "Missing header '" <> show header <> "'."
            Just value ->
              pure $
                header
                  <> ": "
                  <> if ":443" `BS.isSuffixOf` value
                    then BS.dropEnd (BS.length ":443") value
                    else value
      | otherwise = do
          let
            result = lookup (CI.mk header) requestHeaders
          case result of
            Nothing -> throw $ "Missing header '" <> show header <> "'."
            Just value -> pure $ header <> ": " <> value
  BS.intercalate "\n" <$> traverse mylookup headers

checkSignature
  :: (MonadIO m)
  => (MonadThrow m)
  => Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> ByteString -> m ()
checkSignature personPkid personPublicKey sigheader signatureString digest body = do
  -- check
  unless (personPkid == sigheader.keyId) $
    throw "public key mismatch with signature."

  pub <- verifyPub personPublicKey sigheader.signature signatureString
  unless pub $
    throw "signature verification failed."

  let
    mydigest = "SHA-256=" <> encodeBase64 (makeDigest body)
  unless (mydigest == digest) $
    throw "digest verification failed."

-- todo: check date

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 <-
        (fromString)
          <$> lookup' Signature components
      P.eof
      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
            _ <- P.string "algorithm="
            alg <- P.between (P.char '\"') (P.char '\"') (P.string "rsa-sha256")
            pure (Algorithm, alg)
            -- , do
            --   key <- P.munch1 (/= '=')
            --   _ <- P.char '='
            --   value <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
            --   pure (Other key, value)
        ]