ClientSpec.hs

{-# LANGUAGE CPP #-}

module Servant.Auth.ClientSpec (spec) where

import Crypto.JOSE (JWK, KeyMaterialGenParam (OctGenParam), genJWK)
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.ByteString.Lazy as BSL
import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError)
import GHC.Generics (Generic)
import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)
import Network.HTTP.Types (status401)
import Network.Wai.Handler.Warp (testWithApplication)
import Servant
import Servant.Client
  ( BaseUrl (..)
  , ClientError (FailureResponse)
  , Scheme (Http)
  , client
  )
#if MIN_VERSION_servant_client(0,16,0)
import Servant.Client (ResponseF (..))
#elif MIN_VERSION_servant_client(0,13,0)
import Servant.Client (GenResponse (..))
#elif MIN_VERSION_servant_client(0,12,0)
import Servant.Client (Response (..))
#endif

import System.IO.Unsafe (unsafePerformIO)
import Test.Hspec
import Test.QuickCheck

#if MIN_VERSION_servant_client(0,13,0)
import Servant.Client (mkClientEnv, runClientM)
#elif MIN_VERSION_servant_client(0,9,0)
import Servant.Client (ClientEnv (..), runClientM)
#else
import Control.Monad.Trans.Except (runExceptT)
#endif

#if !MIN_VERSION_servant_server(0,16,0)
#define ClientError ServantError
#endif

import Servant.Auth.Server
import Servant.Auth.Server.SetCookieOrphan ()

import Servant.Auth.Client

spec :: Spec
spec = describe "The JWT combinator" $ do
  hasClientSpec

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

-- * HasClient {{{

hasClientSpec :: Spec
hasClientSpec = describe "HasClient" $ aroundAll (testWithApplication $ pure app) $ do
  let mkTok :: User -> Maybe UTCTime -> IO Token
      mkTok user mexp = do
        Right tok <- makeJWT user jwtCfg mexp
        pure $ Token $ BSL.toStrict tok

  it "succeeds when the token does not have expiry" $ \port -> property $ \user -> do
    tok <- mkTok user Nothing
    v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")
    v `shouldBe` Right (length $ name user)

  it "succeeds when the token is not expired" $ \port -> property $ \user -> do
    tok <- mkTok user (Just future)
    v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")
    v `shouldBe` Right (length $ name user)

{- FOURMOLU_DISABLE -}
  it "fails when token is expired" $ \port -> property $ \user -> do
    tok <- mkTok user (Just past)
#if MIN_VERSION_servant_client(0,16,0)
    Left (FailureResponse _ (Response stat _ _ _))
#elif MIN_VERSION_servant_client(0,12,0)
    Left (FailureResponse (Response stat _ _ _))
#elif MIN_VERSION_servant_client(0,11,0)
    Left (FailureResponse _ stat _ _)
#else
    Left (FailureResponse stat _ _)
#endif
      <- getIntClient tok mgr (BaseUrl Http "localhost" port "")
    stat `shouldBe` status401
{- FOURMOLU_ENABLE -}

getIntClient :: Token -> Manager -> BaseUrl -> IO (Either ClientError Int)
#if MIN_VERSION_servant(0,13,0)
getIntClient tok m burl = runClientM (client api tok) (mkClientEnv m burl)
#elif MIN_VERSION_servant(0,9,0)
getIntClient tok m burl = runClientM (client api tok) (ClientEnv m burl)
#else
getIntClient tok m burl = runExceptT $ client api tok m burl
#endif

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

-- * API and Server {{{

type API = Auth '[JWT] User :> Get '[JSON] Int

api :: Proxy API
api = Proxy

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

mgr :: Manager
mgr = unsafePerformIO $ newManager defaultManagerSettings
{-# NOINLINE mgr #-}

app :: Application
app = serveWithContext api ctx server
  where
    ctx = cookieCfg :. jwtCfg :. EmptyContext

jwtCfg :: JWTSettings
jwtCfg = defaultJWTSettings theKey

cookieCfg :: CookieSettings
cookieCfg = defaultCookieSettings

server :: Server API
server = getInt
  where
    getInt :: AuthResult User -> Handler Int
    getInt (Authenticated u) = pure . length $ name u
    getInt _ = throwAll err401

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

-- * 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"

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

-- * 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

-- }}}