{- This file is part of http-client-signature.
 -
 - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# LANGUAGE OverloadedStrings #-}

import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe
import Data.Time.Clock
import Network.HTTP.Client
import Network.HTTP.Types.Header
import Network.HTTP.Types.Status
import Network.URI
import System.Exit

import Network.HTTP.Client.Signature

import qualified Crypto.Error as E
import qualified Crypto.PubKey.Ed25519 as E
import qualified Data.ByteArray as BA (convert)
import qualified Data.ByteString.Lazy.Char8 as BLC (pack)
import qualified Data.CaseInsensitive as CI (mk)
import qualified Network.HTTP.Signature as S
import qualified Network.Wai as W
import qualified Network.Wai.Handler.Warp as W

hTest :: HeaderName
hTest = "CustomTestHeader"

portNumber :: Int
portNumber = 8761

keyId :: S.KeyId
keyId = S.KeyId "https://dev.angeley.es/test-akey999999999"

server :: E.PublicKey -> IO ()
server publicKey = W.run portNumber $ \ req respond -> do
    result <- runExceptT $ do
        let m = CI.mk $ W.requestMethod req
            p = W.rawPathInfo req
        unless (m == "POST" && p == "/testsig") $
            throwE $ notFound "Unexpected method/path"
        let request = S.Request
                { S.requestMethod  = m
                , S.requestPath    = p
                , S.requestHeaders = W.requestHeaders req
                }
        now <- liftIO getCurrentTime
        let requires = [hDate, hHost, hTest, S.hRequestTarget]
            seconds = 30
        verification <-
            case S.prepareToVerify requires [] seconds now request of
                Left e -> throwE $ sigFailed $ displayException e
                Right v -> return v
        unless (isNothing $ S.verAlgorithm verification) $
            throwE $ sigFailed "Expected algorithm not to be specified"
        unless (S.verKeyId verification == keyId) $
            throwE $ sigFailed "Unrecognized keyId"
        sig <-
            let S.Signature b = S.verSignature verification
            in  case E.signature b of
                    E.CryptoFailed e ->
                        throwE $ sigFailed $
                            "Ed25519 signature decoding failed: " ++
                            displayException e
                    E.CryptoPassed s -> return s
        let valid = E.verify publicKey (S.verInput verification) sig
        unless valid $ throwE $
            sigFailed "Ed25519 signature verification says invalid"
    case result of
        Left resp -> respond resp
        Right () -> respond sigValid
    where
    notFound = W.responseLBS notFound404 [] . BLC.pack
    sigFailed = W.responseLBS unauthorized401 [] . BLC.pack
    sigValid = W.responseLBS ok200 [] ""

client :: E.SecretKey -> E.PublicKey -> IO ()
client secretKey publicKey = do
    let headersToSign = S.hRequestTarget :| [hDate, hHost, hTest]
        sign = S.Signature . BA.convert . E.sign secretKey publicKey
        uri =
            fromJust $
            parseURI $ "http://localhost:" ++ show portNumber ++ "/testsig"
    requestInitial <- requestFromURI uri
    let requestReady =
            setRequestCheckStatus $
            consHeader hContentType "application/json; charset=utf-8" $
            consHeader hTest        "Hello world!" $
            requestInitial
                { method      = "POST"
                , requestBody = RequestBodyBS "[1, 2, 3]"
                }
    requestSigned <- do
        now <- getCurrentTime
        let ereq =
                signRequest headersToSign Nothing keyId sign now requestReady
        case ereq of
            Left e ->
                die $
                    "Request signing failed: " ++
                    displayException (e :: S.HttpSigGenError)
            Right r -> return r
    manager <- newManager defaultManagerSettings
    eresp <- try $ httpNoBody requestSigned manager
    case eresp of
        Left e -> die $ displayException (e :: HttpException)
        Right _resp -> return ()
    where
    consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }

main :: IO ()
main = do
    secretKey <- E.generateSecretKey
    let publicKey = E.toPublic secretKey
    _ <- forkIO $ server publicKey
    client secretKey publicKey