servant-namedargs-0.1.0.0: test/LinkEquivalency.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
import Servant.API
import Servant.API.NamedArgs
import Data.Proxy
import Data.Functor.Identity
import Named
import Named.Internal
import Data.Function ((&))

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

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

cmpLinks
  :: forall endpoint a n. ( IsElem endpoint TestApi
                          , IsElem (Transform All endpoint) (Transform All TestApi)
                          , HasLink endpoint
                          , HasLink (Transform All endpoint)
                          )
  => a
  -> (a -> (MkLink endpoint Link) -> Link)
  -> (a -> (MkLink (Transform All endpoint) Link) -> Link)
  -> Bool
cmpLinks val uf nf = toUrlPiece (uf val unnamed) == toUrlPiece (nf val named)
  where
    unnamed = safeLink (Proxy @TestApi) (Proxy @endpoint)
    named   = safeLink (Proxy @(Transform All TestApi)) (Proxy @(Transform All endpoint))

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

main :: IO ()
main = hspec $ do
    describe "Named and unnamed equivalency" $ do
      it "Capture and NamedCapture are equivalent" $ do
        property $ \x -> cmpLinks @CaptureEndpoint x ((&) . runIdentity) ((withF @"x"))
      it "CaptureAll and NamedCaptureAll are equivalent" $ do
        property $ \x -> cmpLinks @CaptureAllEndpoint x ((&) . def []) (withF @"xs")
      it "QueryFlag and NamedFlag are equivalent" $ do
        property $ \x -> cmpLinks @FlagEndpoint x ((&) . def False) (withF @"f")
      it "Required QueryParam and NamedParam are equivalent" $ do
        property $ \x -> cmpLinks @ReqParamEndpoint x ((&) . runIdentity) (withF @"r")
      it "Optional QueryParam and NamedParam are equivalent" $ do
        property $ \x -> cmpLinks @OpParamEndpoint x ((&)) (withF @"o")
      it "Required QueryHeader and NamedHeader are equivalent" $ do
        cmpLinks @ReqHeaderEndpoint Nothing (flip const) (flip const)
      it "Optional QueryHeader and NamedHeader are equivalent" $ do
        cmpLinks @OpHeaderEndpoint Nothing (flip const) (flip const)