{-# 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)
      ]