{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors      #-}
{-# LANGUAGE StrictData            #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}

-- | Implementation of the HTTP Signatures specification for providing cryptographic
-- authentication of network requests.
module Puppy.Protocol.HTTP.Signature (
  KeySource (..),
  makeSignature,
  makeDigestHeader,
  fmtDateHeader,
  fmtSignature,
  Server (..),
  Signer (..),
  Signature (..),
  Algorithm (..),
  Request (..),
) where

import Crypto.Hash.Algorithms (SHA256(..))
import Data.Bifunctor (Bifunctor(..))
import Data.ByteString.Base64 (encodeBase64)
import Data.Foldable (Foldable(..))
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.List (intersperse)
import Data.String (IsString (..))
import Data.Time.Format
import Data.Time (UTCTime)
import Puppy.Config (ServerConfig (..))
import Puppy.Crypto
import Puppy.Protocol.ActivityStreams (Id (..))
import Puppy.Types (Channel (..))
import qualified Crypto.PubKey.RSA        as RSA
import qualified Crypto.PubKey.RSA.PKCS15 as PKCS15
import qualified Data.ByteString          as BS
import qualified Data.Text                as T
import qualified Data.Text.Encoding       as T

-- | A simplified representation of a network request containing *just* the information
-- we need to generate a signature header.
data Request
  = POST {
    body :: BS.ByteString,
    host :: BS.ByteString,
    path :: BS.ByteString,
    date :: UTCTime
  }
  | GET {
    host :: BS.ByteString,
    path :: BS.ByteString,
    date :: UTCTime
  }

-- | The result of signing a `Request`. Use `fmtSignature` to turn it into a header value.
data Signature
  = Signature {
    -- | Where can we find the public key?
    keyId :: Id,
    -- | The signing algorithm used to construct the signature
    algorithm :: Algorithm,
    -- | The names of the components of the signing string
    components :: [BS.ByteString],
    -- | Base64-encoded cryptographic signature
    signature :: T.Text
  }

data Algorithm
  = RSA_SHA256
  | HS2019

instance Show Algorithm where
  show RSA_SHA256 = "rsa-sha256"
  show HS2019     = "hs2019"

makeSignature :: Signer -> Request -> Either String Signature
makeSignature (Signer { privateKey, keyId }) req =
  let -- Components that are used either way
      common = [ ("(request-target)", fmtTarget req),
                 ("date", fmtDateHeader req.date),
                 ("host", req.host) ]
      -- The final set of components.
      components
        -- In the case of a POST request, many implementations require a digest of
        -- the request body to be included in the signature string.
        | POST { body } <- req = common <> [("digest", makeDigestHeader body)]
        -- In any other case, signing extra stuff is not required.
        | otherwise = common
  in generateSignature components privateKey keyId
     -- `first` converts the RSA error to a string to satisfy the API
     & first show
  where
    fmtTarget (POST { path }) = "post " <> path
    fmtTarget (GET { path })  = "get " <> path

generateSignature
  :: [(BS.ByteString, BS.ByteString)]
  -> RSA.PrivateKey
  -> Id
  -> Either RSA.Error Signature
generateSignature components key keyId =
  let -- This is the string we're gonna end up signing. Every component needs to be
      -- lowercased and separated by newlines.
      signatureString :: BS.ByteString
      signatureString = [ fold [k, ": ", v] | (k,v) <- components ]
          & intersperse "\n"
          & fold
      sign = PKCS15.sign
        Nothing       -- The blinder, empty here because it's not needed (afaik)
        (Just SHA256) -- Hashing algorithm, SHA-256 should be pretty widely supported
        key
        signatureString
      structure signature = Signature { signature, algorithm = RSA_SHA256, components = map fst components, keyId }
  in sign <&> encodeBase64
          <&> structure

makeDigestHeader :: BS.ByteString -> BS.ByteString
makeDigestHeader = ("sha-256=" <>) . base64 . sha256

-- | Format a date header from a time.
fmtDateHeader :: UTCTime -> BS.ByteString
fmtDateHeader now -- RFC-822 formatting, forcing GMT time zone
  = formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" now
  & T.pack
  & T.encodeUtf8

-- | Format an HTTP signature so it can be stuck in a header
fmtSignature :: Signature -> BS.ByteString
fmtSignature sig =
  -- Note: we use `show` here because it adds the quotes around each `show`n
  -- component, which is what we want here.
  fromString $ fold $ intersperse ", " [
    "keyId="     <> show sig.keyId.url,
    "algorithm=" <> show (show sig.algorithm),
    "headers="   <> show (fold $ intersperse " " sig.components),
    "signature=" <> show sig.signature
  ]

class KeySource s where
  toSigner :: s -> Signer

data Signer
  = Signer {
    keyId :: Id,
    privateKey :: RSA.PrivateKey
  }

newtype Server = Server ServerConfig

instance KeySource Server where
  toSigner (Server c) = Signer {
    keyId = Id ("https://" <> c.name <> "/ap/a/server#key"),
    privateKey = c.serverKey
  }

instance KeySource Channel where
  toSigner c = Signer {
    keyId = Id (c.linkedActorId <> "#key"),
    privateKey = c.privateKeyPem
  }

instance KeySource Signer where
  toSigner = id