servant-client-namedargs-0.1.0.0: test/ClientServerEquivalency.hs

{-# LANGUAGE TypeOperators       #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE ExplicitForAll      #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedLabels    #-}
{-# LANGUAGE FlexibleContexts    #-}

import Test.Hspec
import Test.QuickCheck.Monadic
import Test.QuickCheck (property)
import Servant.Server
import Servant.API
import Servant.API.NamedArgs
import Servant.Client.NamedArgs
import Servant.Server.NamedArgs
import Servant.Client
import Data.Proxy
import Data.Functor.Identity
import Named
import Named.Internal
import Data.Function ((&))
import Network.HTTP.Client (Manager(..), newManager, defaultManagerSettings)
import Control.Concurrent.Async
import qualified Network.Wai.Handler.Warp as W

type All = [ NameCaptures
           , NameCaptureAlls
           , NameFlags
           , NameParams
           , NameMultiParams
           , NameHeaders
           ]

type CaptureEndpoint = "capture" :> Capture "x" Int :> Get '[JSON] Int
type CaptureAllEndpoint = "captureAll" :> CaptureAll "xs" Int :> Get '[JSON] [Int]
type FlagEndpoint = "flag" :> QueryFlag "f" :> Get '[JSON] Bool
type ReqParamEndpoint = "requiredParam" :>  QueryParam' [Required, Strict] "r" Int :> Get '[JSON] Int
type OpParamEndpoint = "optionalParam" :>  QueryParam' [Optional, Strict] "o" Int :> Get '[JSON] Int
type ParamsEndpoint = "params" :>  QueryParams "ps" Int :> Get '[JSON] [Int]
type ReqHeaderEndpoint = "requiredHeader" :> Header' [Required, Strict] "rh" Int :> Get '[JSON] Int
type OpHeaderEndpoint = "optionalHeader" :> Header' [Optional, Strict] "oh" Int :> Get '[JSON] Int
                    
type TestApi =    CaptureEndpoint
             :<|> CaptureAllEndpoint
             :<|> FlagEndpoint
             :<|> ReqParamEndpoint
             :<|> OpParamEndpoint
             :<|> ParamsEndpoint
             :<|> ReqHeaderEndpoint
             :<|> OpHeaderEndpoint

unnamedServer :: Server TestApi
unnamedServer =    pure
              :<|> pure
              :<|> pure
              :<|> pure
              :<|> pure . def 19
              :<|> pure
              :<|> pure
              :<|> pure . def 19

namedServer :: Server (Transform All TestApi)
namedServer =    pureI
            :<|> pureI
            :<|> pureI
            :<|> pureI
            :<|> pureM
            :<|> pureI
            :<|> pureI
            :<|> pureM
  where
    pureI (Arg v) = pure v
    pureM (ArgF mv) = maybe (pure 19) pure mv

unnamedApp = serve (Proxy @TestApi) unnamedServer
namedApp = serve (Proxy @(Transform All TestApi)) namedServer

uCapture
  :<|> uCaptureAll
  :<|> uFlag
  :<|> uRParam
  :<|> uOParam
  :<|> uParams
  :<|> uRHeader
  :<|> uOHeader = client (Proxy @TestApi)

nCapture
  :<|> nCaptureAll
  :<|> nFlag
  :<|> nRParam
  :<|> nOParam
  :<|> nParams
  :<|> nRHeader
  :<|> nOHeader = client (Proxy @(Transform All TestApi))

clientServerEq
  :: (Eq r)
  => Manager
  -> BaseUrl
  -> BaseUrl
  -> f a
  -> (f a -> ClientM r)
  -> (f a -> ClientM r)
  -> IO Bool
clientServerEq man ub nb val uf nf
    =       (runUs uf') `meq` (runUs nf')
    `mand`  (runNs uf') `meq` (runUs nf')
    `mand`  (runNs uf') `meq` (runNs nf')
    `mand`  (runUs uf') `meq` (runNs nf')
  where
    unnamedServer = mkClientEnv man ub
    namedServer   = mkClientEnv man nb
    runUs c = runClientM c unnamedServer
    runNs c = runClientM c namedServer
    uf' = uf val
    nf' = nf val
    l `meq` r = (==) <$> l <*> r
    l `mand` r = (&&) <$> l <*> r
    infix 4 `meq`
    infixr 3 `mand`

withF :: forall l p f a fn fn'. (p ~ NamedF f a l, WithParam p fn fn')
      => f a -> fn -> fn'
withF p fn = with (Param $ ArgF @_ @_ @l p) fn

def :: a -> Maybe a -> a
def a Nothing  = a
def _ (Just b) = b

-- we make sure that all permutations of the named or unnamed server being
-- queried by the named or unnamed clients return the same
main :: IO ()
main = do
    let uh = 11008
        nh = 11009
    man <- newManager defaultManagerSettings
    us <- async $ W.run uh unnamedApp
    ns <- async $ W.run nh namedApp
    let
      ub = BaseUrl Http "localhost" uh ""
      nb = BaseUrl Http "localhost" nh ""
      doComp :: (Eq r)
             => f a
             -> (f a -> ClientM r)
             -> (f a -> ClientM r)
             -> IO Bool
      doComp = clientServerEq man ub nb
      ioprop = monadicIO . run 
    hspec $ do
      describe "Named and unnamed equivalency (client/server)" $ do
        it "Capture and NamedCapture are equivalent" $ do
          property $ \x -> ioprop $ doComp x (uCapture . runIdentity) (nCapture . ArgF)
        it "CaptureAll and NamedCaptureAll are equivalent" $ do
          property $ \x -> ioprop $ doComp x (uCaptureAll . def []) (nCaptureAll . ArgF)
        it "QueryFlag and NamedFlag are equivalent" $ do
          property $ \x -> ioprop $ doComp x (uFlag . def False) (nFlag . ArgF)
        it "Required QueryParam and NamedParam are equivalent" $ do
          property $ \x -> ioprop $ doComp x (uRParam . runIdentity) (nRParam . ArgF)
        it "Optional QueryParam and NamedParam are equivalent" $ do
          property $ \x -> ioprop $ doComp x (uOParam) (nOParam . ArgF)
        it "Required QueryHeader and NamedHeader are equivalent" $ do
          property $ \x -> ioprop $ doComp x (uRHeader . runIdentity) (nRHeader . ArgF)
        it "Optional QueryHeader and NamedHeader are equivalent" $ do
          property $ \x -> ioprop $ doComp x (uOHeader) (nOHeader . ArgF)
    cancel us
    cancel ns