{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}

module Servant.Auth.ServerSpec (spec) where

#if !MIN_VERSION_servant_server(0,16,0)
#define ServerError ServantErr
#endif

import Control.Lens
import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
import Crypto.JOSE
  ( Alg (HS256, None)
  , Error
  , JWK
  , JWSHeader
  , KeyMaterialGenParam (OctGenParam)
  , ToCompact
  , encodeCompact
  , genJWK
  , newJWSHeader
  , runJOSE
  )
import Crypto.JWT
  ( Audience (..)
  , ClaimsSet
  , NumericDate (NumericDate)
  , SignedJWT
  , claimAud
  , claimNbf
  , emptyClaimsSet
  , signClaims
  , unregisteredClaims
  )
import Data.Aeson (FromJSON, ToJSON, Value, encode, toJSON)
import Data.Aeson.Lens (_JSON)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.CaseInsensitive (mk)
import Data.Foldable (find)
import Data.Text (Text, pack)
import Data.Time
import GHC.Generics (Generic)
import Network.HTTP.Client
  ( cookie_expiry_time
  , cookie_http_only
  , cookie_name
  , cookie_value
  , destroyCookieJar
  )
import Network.HTTP.Types (Status, status200, status401)
import Network.Wai (responseLBS)
import Network.Wai.Handler.Warp (testWithApplication)
import Network.Wreq
  ( Options
  , auth
  , basicAuth
  , checkResponse
  , cookieExpiryTime
  , cookies
  , defaults
  , get
  , getWith
  , header
  , oauth2Bearer
  , postWith
  , responseBody
  , responseCookieJar
  , responseHeader
  , responseStatus
  )
import Network.Wreq.Types (Postable (..))
import Servant hiding (BasicAuth, IsSecure (..), header)
import Servant.API.Generic ((:-))

import Servant.Auth.Server
import Servant.Auth.Server.Internal.Cookie (expireTime)
import Servant.Auth.Server.SetCookieOrphan ()
#if MIN_VERSION_servant_server(0,15,0)
import qualified Servant.Types.SourceT as S
#endif
import qualified Network.HTTP.Client as HCli
import System.IO.Unsafe (unsafePerformIO)
import Test.Hspec
import Test.QuickCheck

spec :: Spec
spec = do
  authSpec
  cookieAuthSpec
  jwtAuthSpec
  throwAllSpec
  basicAuthSpec

------------------------------------------------------------------------------

-- * Auth {{{

authSpec :: Spec
authSpec =
  describe "The Auth combinator" $
    aroundAll (testWithApplication . pure $ app jwtAndCookieApi) $ do
      it "returns a 401 if all authentications are Indefinite" $ \port -> do
        get (url port) `shouldHTTPErrorWith` status401

      it "succeeds if one authentication suceeds" $ \port -> property $
        \(user :: User) -> do
          jwt <- makeJWT user jwtCfg Nothing
          opts <- addJwtToHeader jwt
          resp <- getWith opts (url port)
          resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

      it "fails (403) if one authentication fails" $
        const $
          pendingWith "Authentications don't yet fail, only are Indefinite"

      it "doesn't clobber pre-existing response headers" $ \port -> property $
        \(user :: User) -> do
          jwt <- makeJWT user jwtCfg Nothing
          opts <- addJwtToHeader jwt
          resp <- getWith opts (url port ++ "/header")
          resp ^. responseHeader "Blah" `shouldBe` "1797"
          resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")

      context "Raw" $ do
        it "gets the response body" $ \port -> property $ \(user :: User) -> do
          jwt <- makeJWT user jwtCfg Nothing
          opts <- addJwtToHeader jwt
          resp <- getWith opts (url port ++ "/raw")
          resp ^. responseBody `shouldBe` "how are you?"

        it "doesn't clobber pre-existing reponse headers" $ \port -> property $
          \(user :: User) -> do
            jwt <- makeJWT user jwtCfg Nothing
            opts <- addJwtToHeader jwt
            resp <- getWith opts (url port ++ "/raw")
            resp ^. responseHeader "hi" `shouldBe` "there"
            resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")

      context "Setting cookies" $ do
        it "sets cookies that it itself accepts" $ \port -> property $ \user -> do
          jwt <-
            createJWT
              theKey
              (newJWSHeader ((), HS256))
              (claims $ toJSON user)
          opts' <- addJwtToCookie cookieCfg jwt
          let opts =
                addCookie
                  (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
                  (xsrfField xsrfCookieName cookieCfg <> "=blah")
          resp <- getWith opts (url port)
          let (cookieJar : _) = resp ^.. responseCookieJar
              Just xxsrf =
                find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg) $
                  destroyCookieJar cookieJar
              opts2 =
                defaults
                  & cookies ?~ cookieJar
                  & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf]
          resp2 <- getWith opts2 (url port)
          resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user)

        it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do
          jwt <-
            createJWT
              theKey
              (newJWSHeader ((), HS256))
              (claims $ toJSON user)
          opts' <- addJwtToCookie cookieCfg jwt
          let opts =
                addCookie
                  (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
                  (xsrfField xsrfCookieName cookieCfg <> "=blah")
          resp <- getWith opts (url port)
          let (cookieJar : _) = resp ^.. responseCookieJar
              Just xxsrf =
                find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg) $
                  destroyCookieJar cookieJar
          xxsrf ^. cookieExpiryTime `shouldBe` future

        it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do
          jwt <-
            createJWT
              theKey
              (newJWSHeader ((), HS256))
              (claims $ toJSON user)
          opts' <- addJwtToCookie cookieCfg jwt
          let opts =
                addCookie
                  (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
                  (xsrfField xsrfCookieName cookieCfg <> "=blah")
          resp <- getWith opts (url port)
          let (cookieJar : _) = resp ^.. responseCookieJar
              Just token =
                find (\x -> cookie_name x == sessionCookieName cookieCfg) $
                  destroyCookieJar cookieJar
          cookie_http_only token `shouldBe` True

-- }}}
------------------------------------------------------------------------------

-- * Cookie Auth {{{

cookieAuthSpec :: Spec
cookieAuthSpec =
  describe "The Auth combinator" $ do
    describe "With XSRF check" $
      aroundAll (testWithApplication . pure $ app cookieOnlyApi) $ do
        it "fails if XSRF header and cookie don't match" $ \port -> property $
          \(user :: User) -> do
            jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
            opts' <- addJwtToCookie cookieCfg jwt
            let opts =
                  addCookie
                    (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
                    (xsrfField xsrfCookieName cookieCfg <> "=blerg")
            getWith opts (url port) `shouldHTTPErrorWith` status401

        it "fails with no XSRF header or cookie" $ \port -> property $
          \(user :: User) -> do
            jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
            opts' <- addJwtToCookie cookieCfg jwt
            let opts = opts' & checkResponse ?~ mempty
            resp <- getWith opts (url port)
            resp ^. responseStatus `shouldBe` status401
            (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]

            -- Validating that the XSRF cookie isn't added for UVerb routes either.
            -- These routes can return a 401 response directly without using throwError / throwAll,
            -- which revealed a bug:
            --
            -- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449
            resp <- getWith opts (url port ++ "/uverb")
            resp ^. responseStatus `shouldBe` status401
            (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]

        it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property $
          \(user :: User) -> do
            jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
            opts' <- addJwtToCookie cookieCfg jwt
            let opts =
                  addCookie
                    (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
                    (xsrfField xsrfCookieName cookieCfg <> "=blah")
            resp <- getWith opts (url port)
            resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

        it "sets and clears the right cookies" $ \port -> property $
          \(user :: User) -> do
            let optsFromResp resp =
                  let jar = resp ^. responseCookieJar
                      Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar)
                   in defaults
                        & cookies ?~ jar -- real cookie jars aren't updated by being replaced
                        & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue]

            resp <- postWith defaults (url port ++ "/login") user
            (resp ^. responseCookieJar)
              `shouldMatchCookieNames` [ sessionCookieName cookieCfg
                                       , xsrfField xsrfCookieName cookieCfg
                                       ]
            let loggedInOpts = optsFromResp resp

            resp <- getWith loggedInOpts (url port)
            resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

            -- logout
            resp <- getWith loggedInOpts (url port ++ "/logout")

            -- assert cookies were expired
            now <- getCurrentTime
            let assertCookie c = now >= cookie_expiry_time c
            all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True

            let loggedOutOpts = optsFromResp resp
            getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401

    describe "With no XSRF check for GET requests" $
      let
        noXsrfGet xsrfCfg = xsrfCfg{xsrfExcludeGet = True}
        cookieCfgNoXsrfGet = cookieCfg{cookieXsrfSetting = noXsrfGet <$> cookieXsrfSetting cookieCfg}
       in
        aroundAll (testWithApplication . pure $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do
          it "succeeds with no XSRF header or cookie for GET" $ \port -> property $
            \(user :: User) -> do
              jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
              opts <- addJwtToCookie cookieCfgNoXsrfGet jwt
              resp <- getWith opts (url port)
              resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

          it "fails with no XSRF header or cookie for POST" $ \port -> property $
            \(user :: User) number -> do
              jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
              opts <- addJwtToCookie cookieCfgNoXsrfGet jwt
              postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401

    describe "With no XSRF check at all" $
      let
        cookieCfgNoXsrf = cookieCfg{cookieXsrfSetting = Nothing}
       in
        aroundAll (testWithApplication . pure $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do
          it "succeeds with no XSRF header or cookie for GET" $ \port -> property $
            \(user :: User) -> do
              jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
              opts <- addJwtToCookie cookieCfgNoXsrf jwt
              resp <- getWith opts (url port)
              resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

          it "succeeds with no XSRF header or cookie for POST" $ \port -> property $
            \(user :: User) number -> do
              jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
              opts <- addJwtToCookie cookieCfgNoXsrf jwt
              resp <- postWith opts (url port) $ toJSON (number :: Int)
              resp ^? responseBody . _JSON `shouldBe` Just number

          it "sets and clears the right cookies" $ \port -> property $
            \(user :: User) -> do
              let optsFromResp resp =
                    defaults
                      & cookies ?~ (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced
              resp <- postWith defaults (url port ++ "/login") user
              (resp ^. responseCookieJar)
                `shouldMatchCookieNames` [ sessionCookieName cookieCfg
                                         , "NO-XSRF-TOKEN"
                                         ]
              let loggedInOpts = optsFromResp resp

              resp <- getWith loggedInOpts (url port)
              resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

              resp <- getWith loggedInOpts (url port ++ "/logout")
              (resp ^. responseCookieJar)
                `shouldMatchCookieNameValues` [ (sessionCookieName cookieCfg, "value")
                                              , ("NO-XSRF-TOKEN", "")
                                              ]

              -- assert cookies were expired
              now <- getCurrentTime
              let assertCookie c = now >= cookie_expiry_time c
              all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True

              let loggedOutOpts = optsFromResp resp

              getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401

-- }}}
------------------------------------------------------------------------------

-- * JWT Auth {{{

jwtAuthSpec :: Spec
jwtAuthSpec =
  describe "The JWT combinator" $
    aroundAll (testWithApplication . pure $ app jwtOnlyApi) $ do
      it "fails if 'aud' does not match predicate" $ \port -> property $
        \(user :: User) -> do
          jwt <-
            createJWT
              theKey
              (newJWSHeader ((), HS256))
              (claims (toJSON user) & claimAud ?~ Audience ["boo"])
          opts <- addJwtToHeader (jwt <&> encodeCompact)
          getWith opts (url port) `shouldHTTPErrorWith` status401

      it "succeeds if 'aud' does match predicate" $ \port -> property $
        \(user :: User) -> do
          jwt <-
            createJWT
              theKey
              (newJWSHeader ((), HS256))
              (claims (toJSON user) & claimAud ?~ Audience ["anythingElse"])
          opts <- addJwtToHeader (jwt <&> encodeCompact)
          resp <- getWith opts (url port)
          resp ^. responseStatus `shouldBe` status200

      it "fails if 'nbf' is set to a future date" $ \port -> property $
        \(user :: User) -> do
          jwt <-
            createJWT
              theKey
              (newJWSHeader ((), HS256))
              (claims (toJSON user) & claimNbf ?~ NumericDate future)
          opts <- addJwtToHeader (jwt <&> encodeCompact)
          getWith opts (url port) `shouldHTTPErrorWith` status401

      it "fails if 'exp' is set to a past date" $ \port -> property $
        \(user :: User) -> do
          jwt <- makeJWT user jwtCfg (Just past)
          opts <- addJwtToHeader jwt
          getWith opts (url port) `shouldHTTPErrorWith` status401

      it "succeeds if 'exp' is set to a future date" $ \port -> property $
        \(user :: User) -> do
          jwt <- makeJWT user jwtCfg (Just future)
          opts <- addJwtToHeader jwt
          resp <- getWith opts (url port)
          resp ^. responseStatus `shouldBe` status200

      it "fails if JWT is not signed" $ \port -> property $ \(user :: User) -> do
        jwt <-
          createJWT
            theKey
            (newJWSHeader ((), None))
            (claims $ toJSON user)
        opts <- addJwtToHeader (jwt <&> encodeCompact)
        getWith opts (url port) `shouldHTTPErrorWith` status401

      it "fails if JWT does not use expected algorithm" $
        const $
          pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19"

      it "fails if data is not valid JSON" $ \port -> do
        jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{")
        opts <- addJwtToHeader (jwt <&> encodeCompact)
        getWith opts (url port) `shouldHTTPErrorWith` status401

      it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do
        jwt <-
          createJWT
            theKey
            (newJWSHeader ((), HS256))
            (claims $ toJSON user)
        resp <- case jwt <&> encodeCompact of
          Left (e :: Error) -> fail $ show e
          Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port)
        resp ^. responseStatus `shouldBe` status200

-- }}}
------------------------------------------------------------------------------

-- * Basic Auth {{{

basicAuthSpec :: Spec
basicAuthSpec = describe "The BasicAuth combinator" $
  aroundAll (testWithApplication . pure $ app basicAuthApi) $ do
    it "succeeds with the correct password and username" $ \port -> do
      resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port)
      resp ^. responseStatus `shouldBe` status200

    it "fails with non-existent user" $ \port -> do
      getWith (defaults & auth ?~ basicAuth "thief" "Open sesame") (url port)
        `shouldHTTPErrorWith` status401

    it "fails with incorrect password" $ \port -> do
      getWith (defaults & auth ?~ basicAuth "ali" "phatic") (url port)
        `shouldHTTPErrorWith` status401

    it "fails with no auth header" $ \port -> do
      get (url port) `shouldHTTPErrorWith` status401

-- }}}
------------------------------------------------------------------------------

-- * ThrowAll {{{

throwAllSpec :: Spec
throwAllSpec = describe "throwAll" $ do
  it "works for plain values" $ do
    let t :: Either ServerError Int :<|> Either ServerError Bool :<|> Either ServerError String
        t = throwAll err401
    t `shouldBe` throwError err401 :<|> throwError err401 :<|> throwError err401

  it "works for function types" $ property $ \i -> do
    let t :: Int -> (Either ServerError Bool :<|> Either ServerError String)
        t = throwAll err401
        expected _ = throwError err401 :<|> throwError err401
    t i `shouldBe` expected i

-- }}}
------------------------------------------------------------------------------

-- * API and Server {{{

{- FOURMOLU_DISABLE -}
type API auths
    = Auth auths User :>
        ( Get '[JSON] Int
       :<|> ReqBody '[JSON] Int :> Post '[JSON] Int
       :<|> "named" :> NamedRoutes DummyRoutes
       :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
#if MIN_VERSION_servant_server(0,15,0)
       :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
#endif
       :<|> "raw" :> Raw
        )
      :<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text]
      :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
                                                                     , Header "Set-Cookie" SetCookie ] NoContent)
      :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
                                             , Header "Set-Cookie" SetCookie ] NoContent)
{- FOURMOLU_ENABLE -}

newtype DummyRoutes mode = DummyRoutes
  { dummyInt :: mode :- "dummy" :> Get '[JSON] Int
  }
  deriving (Generic)

jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])
jwtOnlyApi = Proxy

cookieOnlyApi :: Proxy (API '[Cookie])
cookieOnlyApi = Proxy

basicAuthApi :: Proxy (API '[BasicAuth])
basicAuthApi = Proxy

jwtAndCookieApi :: Proxy (API '[Servant.Auth.Server.JWT, Cookie])
jwtAndCookieApi = Proxy

theKey :: JWK
theKey = unsafePerformIO . genJWK $ OctGenParam 256
{-# NOINLINE theKey #-}

cookieCfg :: CookieSettings
cookieCfg =
  def
    { cookieExpires = Just future
    , cookieIsSecure = NotSecure
    , sessionCookieName = "RuncibleSpoon"
    , cookieXsrfSetting =
        pure $
          def
            { xsrfCookieName = "TheyDinedOnMince"
            , xsrfHeaderName = "AndSlicesOfQuince"
            }
    }

xsrfField :: (XsrfCookieSettings -> a) -> CookieSettings -> a
xsrfField f = maybe (error "expected XsrfCookieSettings for test") f . cookieXsrfSetting

jwtCfg :: JWTSettings
jwtCfg =
  (defaultJWTSettings theKey)
    { audienceMatches = \x ->
        if x == "boo" then DoesNotMatch else Matches
    }

instance FromBasicAuthData User where
  fromBasicAuthData (BasicAuthData usr pwd) _ =
    pure $
      if usr == "ali" && pwd == "Open sesame"
        then Authenticated $ User "ali" "ali@the-thieves-den.com"
        else Indefinite

-- Could be anything, really, but since this is already in the cfg we don't
-- have to add it
type instance BasicAuthCfg = JWK

appWithCookie
  :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User
  => Proxy (API auths)
  -> CookieSettings
  -> Application
appWithCookie api ccfg = serveWithContext api ctx $ server ccfg
  where
    ctx = ccfg :. jwtCfg :. theKey :. EmptyContext

-- | Takes a proxy parameter indicating which authentication systems to enable.
app
  :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User
  => Proxy (API auths)
  -> Application
app api = appWithCookie api cookieCfg

{- FOURMOLU_DISABLE -}

server :: CookieSettings -> Server (API auths)
server ccfg =
  ( \case
      Authenticated usr ->
        getInt usr
          :<|> postInt usr
          :<|> DummyRoutes{dummyInt = getInt usr}
          :<|> getHeaderInt
#if MIN_VERSION_servant_server(0,15,0)
          :<|> pure (S.source ["bytestring"])
#endif
          :<|> raw
      Indefinite -> throwAll err401
      _ -> throwAll err403
  )
    :<|> ( \case
            Authenticated usr -> respond (WithStatus @200 (42 :: Int))
            Indefinite        -> respond (WithStatus @401 $ pack "Authentication required")
            _                 -> respond (WithStatus @403 $ pack "Forbidden")
         )
    :<|> getLogin
    :<|> getLogout
  where
    getInt :: User -> Handler Int
    getInt usr = pure . length $ name usr

    postInt :: User -> Int -> Handler Int
    postInt _ = pure

    getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int)
    getHeaderInt = pure $ addHeader 1797 17

    getLogin
      :: User
      -> Handler
          ( Headers
              '[ Header "Set-Cookie" SetCookie
               , Header "Set-Cookie" SetCookie
               ]
              NoContent
          )
    getLogin user = do
      maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user
      case maybeApplyCookies of
        Just applyCookies -> pure $ applyCookies NoContent
        Nothing           -> error "cookies failed to apply"

    getLogout
      :: Handler
          ( Headers
              '[ Header "Set-Cookie" SetCookie
               , Header "Set-Cookie" SetCookie
               ]
              NoContent
          )
    getLogout = pure $ clearSession ccfg NoContent

    raw :: Server Raw
    raw = tagged $ \_req respond ->
            respond $ responseLBS status200 [("hi", "there")] "how are you?"

#if MIN_VERSION_servant_server(0,11,0)
    tagged :: Application -> Tagged Handler Application
    tagged = Tagged
#else
    tagged :: Application -> Application
    tagged = id
#endif
{- FOURMOLU_ENABLE -}

-- }}}
------------------------------------------------------------------------------

-- * Utils {{{

past :: UTCTime
past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"

future :: UTCTime
future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"

addJwtToHeader :: Either Error BSL.ByteString -> IO Options
addJwtToHeader = \case
  Left e -> fail $ show e
  Right v ->
    pure $
      defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]

createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
createJWT k a b = runJOSE $ signClaims k a b

addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options
addJwtToCookie ccfg jwt = case jwt <&> encodeCompact of
  Left e -> fail $ show e
  Right v ->
    pure $
      defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v]

addCookie :: Options -> BS.ByteString -> Options
addCookie opts cookie' =
  opts
    & header "Cookie" %~ \case
      [h] -> [cookie' <> "; " <> h]
      [] -> [cookie']
      _ -> error "expecting single cookie header"

{- FOURMOLU_DISABLE -}
shouldHTTPErrorWith :: IO a -> Status -> Expectation
shouldHTTPErrorWith act stat = act `shouldThrow` \case
#if MIN_VERSION_http_client(0,5,0)
  HCli.HttpExceptionRequest _ (HCli.StatusCodeException resp _)
    -> HCli.responseStatus resp == stat
#else
  HCli.StatusCodeException x _ _ -> x == stat
#endif
  _ -> False
{- FOURMOLU_ENABLE -}

shouldMatchCookieNames :: HCli.CookieJar -> [BS.ByteString] -> Expectation
shouldMatchCookieNames cj patterns =
  fmap cookie_name (destroyCookieJar cj)
    `shouldMatchList` patterns

shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation
shouldNotHaveCookies cj patterns =
  forM_ patterns (\cookieName -> cookieNames `shouldNotContain` [cookieName])
  where
    cookieNames :: [BS.ByteString]
    cookieNames = cookie_name <$> destroyCookieJar cj

shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation
shouldMatchCookieNameValues cj patterns =
  fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)
    `shouldMatchList` patterns

url :: Int -> String
url port = "http://localhost:" <> show port

claims :: Value -> ClaimsSet
claims val = emptyClaimsSet & unregisteredClaims . at "dat" ?~ val

-- }}}
------------------------------------------------------------------------------

-- * Types {{{

data User = User
  { name :: String
  , _id :: String
  }
  deriving (Eq, Generic, Read, Show)

instance FromJWT User

instance ToJWT User

instance FromJSON User

instance ToJSON User

instance Arbitrary User where
  arbitrary = User <$> arbitrary <*> arbitrary

instance Postable User where
  postPayload user request =
    pure $
      request
        { HCli.requestBody = HCli.RequestBodyLBS $ encode user
        , HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request
        }

-- }}}
