jose-0.13: test/Perf.hs

{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}

{-

Test program for ensuring that verification of a large JWT
happens in reasonable time.  This program is based on a test
program published by Silvan Mosberger at:

  https://github.com/tweag/haskell-fido2/tree/a25308a07551ccd86af47774a74dbdf989454d51

Related: https://github.com/frasertweedale/hs-jose/pull/103

-}

import Control.Lens ((^?), _Just)
import Control.Monad.Except (ExceptT, runExceptT)
import Crypto.JOSE.JWK.Store (VerificationKeyStore (getVerificationKeys))
import Crypto.JWT (CompactJWS, HasX5c (x5c), JWSHeader, JWTError, RequiredProtection, decodeCompact, fromX509Certificate, param, verifyJWS')
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.List.NonEmpty (NonEmpty ((:|)))
import System.Timeout (timeout)
import System.Exit (die)

data Store = Store

instance VerificationKeyStore (ExceptT JWTError IO) (JWSHeader RequiredProtection) B.ByteString Store where
  getVerificationKeys header _ _ = do
    let Just (x :| _) = header ^? x5c . _Just . param
    res <- fromX509Certificate x
    return [res]

main :: IO ()
main = do
  s <- L.readFile path
  r <- timeout 500000 (go s)
  case r of
    Nothing -> die "Verifying the big JWT timed out!"
    Just _ -> pure ()
  where
    path = "test/data/fido.jwt"
    go :: L.ByteString -> IO ()
    go s = do
      r <- runExceptT $ do
        jws <- decodeCompact s
        verifyJWS' Store (jws :: CompactJWS JWSHeader)
      case r of
        Left err ->
          die $ "Verification failure: " ++ show (err :: JWTError)
        Right payload ->
          putStrLn $ "Payload verified (size = " ++ show (B.length payload) ++ ")"