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.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 <-
    makeSignatureString request sigheader.headers

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

  -- parse the body and return it
  parseJson body

makeSignatureString
  :: forall m. (MonadThrow m) => Wai.Request -> [T.Text] -> m ByteString
makeSignatureString 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
  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)
        ]