feat(apis): version negotiation
This commit is contained in:
Gregor Kleen
parent
39c0c44c2a
commit
76e0bcf693
@ -174,6 +174,7 @@ dependencies:
|
||||
- network-uri
|
||||
- psqueues
|
||||
- nonce
|
||||
- semver
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
- IncoherentInstances
|
||||
|
||||
31
src/Data/SemVer/Instances.hs
Normal file
31
src/Data/SemVer/Instances.hs
Normal file
@ -0,0 +1,31 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.SemVer.Instances
|
||||
() where
|
||||
|
||||
import ClassyPrelude
|
||||
import qualified Data.SemVer as SemVer
|
||||
import qualified Data.SemVer.Constraint as SemVer (Constraint(..))
|
||||
import qualified Data.SemVer.Constraint as SemVer.Constraint
|
||||
|
||||
import Web.HttpApiData
|
||||
|
||||
|
||||
instance ToHttpApiData SemVer.Version where
|
||||
toUrlPiece = SemVer.toText
|
||||
|
||||
instance ToHttpApiData SemVer.Constraint where
|
||||
toUrlPiece SemVer.CAny = "*"
|
||||
toUrlPiece (SemVer.CLt v) = "<" <> toUrlPiece v
|
||||
toUrlPiece (SemVer.CLtEq v) = "<=" <> toUrlPiece v
|
||||
toUrlPiece (SemVer.CGt v) = ">" <> toUrlPiece v
|
||||
toUrlPiece (SemVer.CGtEq v) = ">=" <> toUrlPiece v
|
||||
toUrlPiece (SemVer.CEq v) = toUrlPiece v
|
||||
toUrlPiece (SemVer.CAnd a b) = toUrlPiece a <> " " <> toUrlPiece b
|
||||
toUrlPiece (SemVer.COr a b) = toUrlPiece a <> " || " <> toUrlPiece b
|
||||
|
||||
instance FromHttpApiData SemVer.Version where
|
||||
parseUrlPiece = first pack . SemVer.fromText
|
||||
|
||||
instance FromHttpApiData SemVer.Constraint where
|
||||
parseUrlPiece = first pack . SemVer.Constraint.fromText
|
||||
@ -133,8 +133,8 @@ type UniWorXContext = UniWorX ': '[]
|
||||
type ServantHandler = ServantHandlerFor UniWorX
|
||||
type ServantDB = ServantDBFor UniWorX
|
||||
|
||||
class (HasServer (ServantApiUnproxy proxy) UniWorXContext, Servant.HasRoute (ServantApiUnproxy proxy)) => ServantApiDispatchUniWorX proxy where
|
||||
servantServer' :: ServantApi proxy -> ServerT (ServantApiUnproxy proxy) ServantHandler
|
||||
class (HasServer (ServantApiUnproxy' proxy) UniWorXContext, Servant.HasRoute (ServantApiUnproxy' proxy)) => ServantApiDispatchUniWorX proxy where
|
||||
servantServer' :: ServantApi proxy -> ServerT (ServantApiUnproxy' proxy) ServantHandler
|
||||
|
||||
instance ServantApiDispatchUniWorX proxy => ServantApiDispatch UniWorXContext ServantHandler UniWorX proxy where
|
||||
servantContext _ app _ = return $ app :. EmptyContext
|
||||
|
||||
@ -4,6 +4,7 @@ module Foundation.Servant.Types
|
||||
( CaptureBearerRestriction, CaptureBearerRestriction'
|
||||
, CaptureBearerToken, CaptureBearerToken'
|
||||
, CaptureCryptoID', CaptureCryptoID, CaptureCryptoUUID, CaptureCryptoFileName
|
||||
, ApiVersion, apiVersionToSemVer, matchesApiVersion
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
@ -13,20 +14,34 @@ import Servant.API
|
||||
import Servant.API.Description
|
||||
import Servant.Swagger
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
import Servant.Server.Internal.Router
|
||||
import Servant.Server.Internal.RouteResult
|
||||
import Servant.Server.Internal.Delayed
|
||||
import Servant.Server.Internal.ErrorFormatter
|
||||
-- import Servant.Server.Internal.DelayedIO
|
||||
|
||||
import Control.Lens
|
||||
import Network.Wai (mapResponseHeaders, requestHeaders)
|
||||
|
||||
import Control.Lens hiding (Context)
|
||||
|
||||
import Data.UUID (UUID)
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Data.CryptoID.Class.ImplicitNamespace
|
||||
import Data.CryptoID.Instances ()
|
||||
|
||||
import GHC.TypeLits (Symbol, KnownSymbol)
|
||||
import GHC.TypeLits
|
||||
|
||||
import Data.Swagger (ToParamSchema)
|
||||
|
||||
import Data.Kind (Type)
|
||||
|
||||
import qualified Data.SemVer as SemVer
|
||||
import qualified Data.SemVer.Constraint as SemVer (Constraint)
|
||||
import qualified Data.SemVer.Constraint as SemVer.Constraint
|
||||
|
||||
import Data.SemVer.Instances ()
|
||||
|
||||
|
||||
type CaptureBearerRestriction = CaptureBearerRestriction' '[Required]
|
||||
data CaptureBearerRestriction' (mods :: [Type]) (restr :: Type)
|
||||
@ -39,6 +54,26 @@ type CaptureCryptoID = CaptureCryptoID' '[]
|
||||
type CaptureCryptoUUID = CaptureCryptoID UUID
|
||||
type CaptureCryptoFileName = CaptureCryptoID (CI FilePath)
|
||||
|
||||
data ApiVersion (major :: Nat) (minor :: Nat) (patch :: Nat)
|
||||
|
||||
apiVersionToSemVer :: forall major minor patch p.
|
||||
( KnownNat major, KnownNat minor, KnownNat patch )
|
||||
=> p (ApiVersion major minor patch)
|
||||
-> SemVer.Version
|
||||
apiVersionToSemVer _ = SemVer.version
|
||||
(fromIntegral . natVal $ Proxy @major)
|
||||
(fromIntegral . natVal $ Proxy @minor)
|
||||
(fromIntegral . natVal $ Proxy @patch)
|
||||
[]
|
||||
[]
|
||||
|
||||
matchesApiVersion :: forall major minor patch p.
|
||||
( KnownNat major, KnownNat minor, KnownNat patch )
|
||||
=> p (ApiVersion major minor patch)
|
||||
-> SemVer.Constraint
|
||||
-> Bool
|
||||
matchesApiVersion _ = SemVer.Constraint.satisfies . apiVersionToSemVer $ Proxy @(ApiVersion major minor patch)
|
||||
|
||||
|
||||
instance HasLink sub => HasLink (CaptureBearerRestriction' mods restr :> sub) where
|
||||
type MkLink (CaptureBearerRestriction' mods restr :> sub) r = MkLink sub r
|
||||
@ -52,6 +87,10 @@ instance (HasLink sub, ToHttpApiData ciphertext) => HasLink (CaptureCryptoID' mo
|
||||
type MkLink (CaptureCryptoID' mods ciphertext sym plaintext :> sub) r = MkLink (Capture' mods sym (CryptoID ciphertext plaintext) :> sub) r
|
||||
toLink toA _ = toLink toA $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub)
|
||||
|
||||
instance HasLink sub => HasLink (ApiVersion major minor patch :> sub) where
|
||||
type MkLink (ApiVersion major minor patch :> sub) r = MkLink sub r
|
||||
toLink toA _ = toLink toA $ Proxy @sub
|
||||
|
||||
instance HasSwagger sub => HasSwagger (CaptureBearerRestriction' mods restr :> sub) where
|
||||
toSwagger _ = toSwagger $ Proxy @sub
|
||||
|
||||
@ -61,6 +100,9 @@ instance HasSwagger sub => HasSwagger (CaptureBearerToken' mods :> sub) where
|
||||
instance (HasSwagger sub, ToParamSchema ciphertext, KnownSymbol sym, KnownSymbol (FoldDescription mods)) => HasSwagger (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
|
||||
toSwagger _ = toSwagger $ Proxy @(Capture' mods sym (CryptoID ciphertext plaintext) :> sub)
|
||||
|
||||
instance HasSwagger sub => HasSwagger (ApiVersion major minor patch :> sub) where
|
||||
toSwagger _ = toSwagger $ Proxy @sub
|
||||
|
||||
instance HasDocs sub => HasDocs (CaptureBearerRestriction' mods restr :> sub) where
|
||||
docsFor _ (endpoint, action) = docsFor (Proxy @sub) (endpoint, action')
|
||||
where action' = action & notes <>~ [DocNote "Bearer restrictions" ["The behaviour of this route dependes on the restrictions stored for it in the bearer token used for authorization"]]
|
||||
@ -72,4 +114,152 @@ instance HasDocs sub => HasDocs (CaptureBearerToken' mods :> sub) where
|
||||
instance (ToCapture (Capture sym ciphertext), KnownSymbol sym, HasDocs sub) => HasDocs (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
|
||||
docsFor _ = docsFor $ Proxy @(Capture' mods sym ciphertext :> sub)
|
||||
|
||||
type instance IsElem' (CaptureCryptoID' mods ciphertext sym plaintext :> sub) api = IsElem (Capture' mods sym (CryptoID ciphertext plaintext) :> sub) api
|
||||
|
||||
type family ApiVersionSub major minor patch sup sub where
|
||||
ApiVersionSub major minor patch (ApiVersion major' minor' patch') sub = ApiVersion major' minor' patch' :> sub
|
||||
ApiVersionSub major minor patch sup sub = sup :> (ApiVersion major minor patch :> sub)
|
||||
|
||||
instance HasServer (ApiVersionSub major minor patch sup sub) context => HasServer (ApiVersion major minor patch :> ((sup :: Type) :> sub)) context where
|
||||
type ServerT (ApiVersion major minor patch :> (sup :> sub)) m = ServerT (ApiVersionSub major minor patch sup sub) m
|
||||
hoistServerWithContext _ = hoistServerWithContext $ Proxy @(ApiVersionSub major minor patch sup sub)
|
||||
route _ = route $ Proxy @(ApiVersionSub major minor patch sup sub)
|
||||
|
||||
instance HasServer (sup :> (ApiVersion major minor patch :> sub)) context => HasServer (ApiVersion major minor patch :> ((sup :: Symbol) :> sub)) context where
|
||||
type ServerT (ApiVersion major minor patch :> (sup :> sub)) m = ServerT (sup :> (ApiVersion major minor patch :> sub)) m
|
||||
hoistServerWithContext _ = hoistServerWithContext $ Proxy @(sup :> (ApiVersion major minor patch :> sub))
|
||||
route _ = route $ Proxy @(sup :> (ApiVersion major minor patch :> sub))
|
||||
|
||||
instance ( HasServer (ApiVersion major minor patch :> a) context
|
||||
, HasServer (ApiVersion major minor patch :> b) context
|
||||
, SBoolI (IsLT (CmpVersion (FinalApiVersion (ApiVersion major minor patch :> a)) (FinalApiVersion (ApiVersion major minor patch :> b))))
|
||||
) => HasServer (ApiVersion major minor patch :> (a :<|> b)) context where
|
||||
type ServerT (ApiVersion major minor patch :> (a :<|> b)) m = ServerT (ApiVersion major minor patch :> a) m :<|> ServerT (ApiVersion major minor patch :> b) m
|
||||
hoistServerWithContext _ = hoistServerWithContext $ Proxy @((ApiVersion major minor patch :> a) :<|> (ApiVersion major minor patch :> b))
|
||||
route Proxy context server = choice'
|
||||
(route (Proxy @(ApiVersion major minor patch :> a)) context $ (\(a :<|> _) -> a) <$> server)
|
||||
(route (Proxy @(ApiVersion major minor patch :> b)) context $ (\(_ :<|> b) -> b) <$> server)
|
||||
where
|
||||
choice' :: forall env' a'. Router' env' a' -> Router' env' a' -> Router' env' a'
|
||||
choice' = case (sbool :: SBool (IsLT (CmpVersion (FinalApiVersion (ApiVersion major minor patch :> a)) (FinalApiVersion (ApiVersion major minor patch :> b))))) of
|
||||
STrue -> flip choice
|
||||
SFalse -> choice
|
||||
|
||||
|
||||
routeWithApiVersion :: forall api context env major minor patch.
|
||||
( HasServer api context
|
||||
, KnownNat major, KnownNat minor, KnownNat patch
|
||||
, HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters
|
||||
)
|
||||
=> Proxy (ApiVersion major minor patch)
|
||||
-> Proxy api -> Context context -> Delayed env (Server api) -> Router env
|
||||
routeWithApiVersion _ _ context subserver = RawRouter $ \env req ((. addVersion) -> cont) -> case maybe (pure SemVer.Constraint.CAny) parseHeader . lookup versionRequestHeaderName $ requestHeaders req of
|
||||
Left parseErr -> cont $ FailFatal err400 { errBody = encodeUtf8 . fromStrict $ "Could not parse version constraint: " <> parseErr }
|
||||
Right vHdr -> if
|
||||
| version `SemVer.Constraint.satisfies` vHdr -> runRouterEnv notFound (route (Proxy @api) context subserver) env req cont
|
||||
| otherwise -> cont $ Fail err400 { errBody = encodeUtf8 "Requested version could not be satisfied" }
|
||||
where addVersion (Fail sError) = Fail sError { errHeaders = addVersionHeader $ errHeaders sError}
|
||||
addVersion (FailFatal sError) = FailFatal sError { errHeaders = addVersionHeader $ errHeaders sError }
|
||||
addVersion (Route resp) = Route $ mapResponseHeaders addVersionHeader resp
|
||||
|
||||
addVersionHeader hdrs
|
||||
| has (folded . _1 . only versionHeaderName) hdrs = hdrs
|
||||
| otherwise = hdrs <> pure (versionHeaderName, versionHeader)
|
||||
|
||||
version = apiVersionToSemVer $ Proxy @(ApiVersion major minor patch)
|
||||
|
||||
versionHeaderName = "API-Version"
|
||||
versionRequestHeaderName = "Accept-API-Version"
|
||||
versionHeader = encodeUtf8 $ SemVer.toText version
|
||||
|
||||
notFound = notFoundErrorFormatter . getContextEntry $ mkContextWithErrorFormatter context
|
||||
|
||||
instance ( HasServer (Verb method statusCode contentTypes a) context
|
||||
, KnownNat major, KnownNat minor, KnownNat patch
|
||||
, HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters
|
||||
) => HasServer (ApiVersion major minor patch :> Verb method statusCode contentTypes a) context where
|
||||
type ServerT (ApiVersion major minor patch :> Verb method statusCode contentTypes a) m = ServerT (Verb method statusCode contentTypes a) m
|
||||
|
||||
hoistServerWithContext _ = hoistServerWithContext $ Proxy @(Verb method statusCode contentTypes a)
|
||||
|
||||
route _ = routeWithApiVersion (Proxy @(ApiVersion major minor patch)) (Proxy @(Verb method statusCode contentTypes a))
|
||||
|
||||
instance ( HasServer (NoContentVerb method) context
|
||||
, KnownNat major, KnownNat minor, KnownNat patch
|
||||
, HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters
|
||||
) => HasServer (ApiVersion major minor patch :> NoContentVerb method) context where
|
||||
type ServerT (ApiVersion major minor patch :> NoContentVerb method) m = ServerT (NoContentVerb method) m
|
||||
|
||||
hoistServerWithContext _ = hoistServerWithContext $ Proxy @(NoContentVerb method)
|
||||
|
||||
route _ = routeWithApiVersion (Proxy @(ApiVersion major minor patch)) (Proxy @(NoContentVerb method))
|
||||
|
||||
|
||||
instance ( HasDocs (ApiVersionSub major minor patch sup sub)
|
||||
) => HasDocs (ApiVersion major minor patch :> ((sup :: Type) :> sub)) where
|
||||
docsFor _ = docsFor $ Proxy @(ApiVersionSub major minor patch sup sub)
|
||||
|
||||
instance ( HasDocs (sup :> (ApiVersion major minor patch :> sub))
|
||||
) => HasDocs (ApiVersion major minor patch :> ((sup :: Symbol) :> sub)) where
|
||||
docsFor _ = docsFor $ Proxy @(sup :> (ApiVersion major minor patch :> sub))
|
||||
|
||||
instance ( HasDocs (ApiVersion major minor patch :> a)
|
||||
, HasDocs (ApiVersion major minor patch :> b)
|
||||
) => HasDocs (ApiVersion major minor patch :> (a :<|> b)) where
|
||||
docsFor _ = docsFor $ Proxy @(ApiVersion major minor patch :> a :<|> ApiVersion major minor patch :> b)
|
||||
|
||||
|
||||
apiVersionDocNote :: forall major minor patch.
|
||||
( KnownNat major, KnownNat minor, KnownNat patch )
|
||||
=> Proxy (ApiVersion major minor patch)
|
||||
-> DocNote
|
||||
apiVersionDocNote p = DocNote "Versioning" ["This route is provided in version " <> SemVer.toString (apiVersionToSemVer p)]
|
||||
|
||||
instance ( HasDocs (Verb method statusCode contentTypes a)
|
||||
, KnownNat major, KnownNat minor, KnownNat patch
|
||||
) => HasDocs (ApiVersion major minor patch :> Verb method statusCode contentTypes a) where
|
||||
docsFor _ (endpoint, action) = docsFor (Proxy @(Verb method statusCode contentTypes a)) (endpoint, action')
|
||||
where action' = action & notes <>~ [apiVersionDocNote $ Proxy @(ApiVersion major minor patch)]
|
||||
|
||||
instance ( HasDocs (NoContentVerb method)
|
||||
, KnownNat major, KnownNat minor, KnownNat patch
|
||||
) => HasDocs (ApiVersion major minor patch :> NoContentVerb method) where
|
||||
docsFor _ (endpoint, action) = docsFor (Proxy @(NoContentVerb method)) (endpoint, action')
|
||||
where action' = action & notes <>~ [apiVersionDocNote $ Proxy @(ApiVersion major minor patch)]
|
||||
|
||||
|
||||
type family FinalApiVersion api where
|
||||
FinalApiVersion (ApiVersion major minor patch :> sub) = AlternativeMaybe (FinalApiVersion sub) ('Just (ApiVersion major minor patch))
|
||||
FinalApiVersion (sup :> sub) = FinalApiVersion sub
|
||||
FinalApiVersion (a :<|> b) = MaxMaybe (CmpVersion (FinalApiVersion a) (FinalApiVersion b)) (FinalApiVersion a) (FinalApiVersion b)
|
||||
FinalApiVersion (Verb method statusCode contentTypes a) = 'Nothing
|
||||
FinalApiVersion (NoContentVerb method) = 'Nothing
|
||||
|
||||
type family MaxMaybe ord a b where
|
||||
MaxMaybe _ a 'Nothing = a
|
||||
MaxMaybe _ 'Nothing b = b
|
||||
MaxMaybe 'LT _ b = b
|
||||
MaxMaybe _ a _ = a
|
||||
|
||||
type family MappendOrdering a b where
|
||||
MappendOrdering 'EQ b = b
|
||||
MappendOrdering a _ = a
|
||||
|
||||
type family AlternativeMaybe a b where
|
||||
AlternativeMaybe ('Just a) _ = 'Just a
|
||||
AlternativeMaybe _ ('Just b) = 'Just b
|
||||
AlternativeMaybe _ _ = 'Nothing
|
||||
|
||||
type family CmpVersion x y where
|
||||
CmpVersion 'Nothing 'Nothing = 'EQ
|
||||
CmpVersion 'Nothing _ = 'GT
|
||||
CmpVersion _ 'Nothing = 'LT
|
||||
CmpVersion ('Just (ApiVersion major minor patch)) ('Just (ApiVersion major' minor' patch')) = MappendOrdering (CmpNat major major') (MappendOrdering (CmpNat minor minor') (CmpNat patch patch'))
|
||||
|
||||
type family IsLT x where
|
||||
IsLT 'LT = 'True
|
||||
IsLT _ = 'False
|
||||
|
||||
|
||||
type instance IsElem' sa (CaptureCryptoID' mods ciphertext sym plaintext :> sb) = IsElem sa (Capture' mods sym (CryptoID ciphertext plaintext) :> sb)
|
||||
|
||||
type instance IsElem' sa (ApiVersion major minor patch :> sb) = IsElem sa sb
|
||||
|
||||
@ -200,6 +200,7 @@ import Text.Shakespeare.Text.Instances as Import ()
|
||||
import Ldap.Client.Instances as Import ()
|
||||
import Data.MultiSet.Instances as Import ()
|
||||
import Control.Arrow.Instances as Import ()
|
||||
import Data.SemVer.Instances as Import ()
|
||||
|
||||
import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
|
||||
import Crypto.Random as Import (ChaChaDRG, Seed)
|
||||
|
||||
@ -37,7 +37,7 @@ data ExternalApis mode = ExternalApis
|
||||
} deriving (Generic)
|
||||
|
||||
type ServantApiExternalApis = ServantApi ExternalApis
|
||||
type instance ServantApiUnproxy ExternalApis = ToServantApi ExternalApis
|
||||
type instance ServantApiUnproxy ExternalApis = ApiVersion 1 0 0 :> ToServantApi ExternalApis
|
||||
|
||||
|
||||
instance ToCapture (Capture "external-api" UUID) where
|
||||
|
||||
@ -1,7 +1,8 @@
|
||||
{-# OPTIONS_GHC -fno-warn-unused-foralls #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Yesod.Servant
|
||||
( ServantApiUnproxy, ServantApiDirect
|
||||
( ServantApiUnproxy, ServantApiUnproxy', ServantApiDirect
|
||||
, HasRoute(..)
|
||||
, ServantApi(..), getServantApi
|
||||
, ServantApiDispatch(..)
|
||||
@ -83,7 +84,7 @@ import Data.Typeable (eqT, typeRep)
|
||||
|
||||
import Network.URI
|
||||
import Network.URI.Lens
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal, KnownNat)
|
||||
|
||||
import Text.Read (Read(readPrec), readP_to_Prec, readPrec_to_P)
|
||||
import Text.Show (showParen, showString)
|
||||
@ -114,7 +115,7 @@ escapedSymbol :: forall sym. KnownSymbol sym => Proxy sym -> Text
|
||||
escapedSymbol _ = pack . escapeURIString isUnreserved . symbolVal $ Proxy @sym
|
||||
|
||||
class HasLink api => HasRoute api where
|
||||
parseServantRoute :: forall proxy. ServantApiUnproxy proxy ~ api => ([Text], [(Text, Text)]) -> Maybe (Route (ServantApi proxy))
|
||||
parseServantRoute :: forall proxy. ServantApiUnproxy' proxy ~ api => ([Text], [(Text, Text)]) -> Maybe (Route (ServantApi proxy))
|
||||
|
||||
instance HasRoute EmptyAPI where
|
||||
parseServantRoute _ = Nothing
|
||||
@ -212,6 +213,9 @@ instance (HasRoute sub, Typeable mods, KnownSymbol sym, Typeable plaintext, ToHt
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(CaptureCryptoID' mods ciphertext sym plaintext :> endpoint)) (f . ($ v)) (toUrlPieceInjective v : ps') qs'
|
||||
parseServantRoute _ = Nothing
|
||||
|
||||
instance (HasRoute sub, KnownNat major, KnownNat minor, KnownNat patch) => HasRoute (ApiVersion major minor patch :> sub) where
|
||||
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
|
||||
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(ApiVersion major minor patch :> endpoint)) f ps qs
|
||||
|
||||
|
||||
data ServantApi (proxy :: k) = ServantApi
|
||||
@ -223,13 +227,18 @@ getServantApi _ = ServantApi
|
||||
|
||||
type family ServantApiUnproxy (proxy :: k) :: Type
|
||||
|
||||
type ServantApiUnproxy' :: forall k. forall (proxy :: k) -> Type
|
||||
type family ServantApiUnproxy' proxy where
|
||||
ServantApiUnproxy' @Type (ServantApiDirect api) = api
|
||||
ServantApiUnproxy' @k' proxy = ServantApiUnproxy proxy
|
||||
|
||||
data ServantApiDirect (api :: Type)
|
||||
type instance ServantApiUnproxy (ServantApiDirect api) = api
|
||||
|
||||
instance HasRoute (ServantApiUnproxy proxy) => RenderRoute (ServantApi proxy) where
|
||||
instance HasRoute (ServantApiUnproxy' proxy) => RenderRoute (ServantApi proxy) where
|
||||
data Route (ServantApi proxy)
|
||||
= forall endpoint.
|
||||
( IsElem endpoint (ServantApiUnproxy proxy) ~ (() :: Constraint)
|
||||
( IsElem endpoint (ServantApiUnproxy' proxy) ~ (() :: Constraint)
|
||||
, HasRoute endpoint
|
||||
, Typeable endpoint
|
||||
)
|
||||
@ -237,24 +246,24 @@ instance HasRoute (ServantApiUnproxy proxy) => RenderRoute (ServantApi proxy) wh
|
||||
(Proxy endpoint)
|
||||
(forall a. MkLink endpoint a -> a)
|
||||
[Text] (HashMap Text [Text])
|
||||
renderRoute (ServantApiRoute (_ :: Proxy endpoint) f _ _) = f $ safeLink' renderServantRoute (Proxy @(ServantApiUnproxy proxy)) (Proxy @endpoint)
|
||||
renderRoute (ServantApiRoute (_ :: Proxy endpoint) f _ _) = f $ safeLink' renderServantRoute (Proxy @(ServantApiUnproxy' proxy)) (Proxy @endpoint)
|
||||
|
||||
instance HasRoute (ServantApiUnproxy proxy) => Eq (Route (ServantApi proxy)) where
|
||||
instance HasRoute (ServantApiUnproxy' proxy) => Eq (Route (ServantApi proxy)) where
|
||||
(ServantApiRoute (_ :: Proxy endpoint) _ ps qs) == (ServantApiRoute (_ :: Proxy endpoint') _ ps' qs')
|
||||
= case eqT @endpoint @endpoint' of
|
||||
Just Refl -> ps == ps' && qs == qs'
|
||||
Nothing -> False
|
||||
|
||||
instance HasRoute (ServantApiUnproxy proxy) => Ord (Route (ServantApi proxy)) where
|
||||
instance HasRoute (ServantApiUnproxy' proxy) => Ord (Route (ServantApi proxy)) where
|
||||
compare (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) (ServantApiRoute (_ :: Proxy endpoint') _ ps' qs')
|
||||
= case eqT @endpoint @endpoint' of
|
||||
Just Refl -> compare ps ps' <> compare qs qs'
|
||||
Nothing -> typeRep (Proxy @endpoint) `compare` typeRep (Proxy @endpoint')
|
||||
|
||||
instance HasRoute (ServantApiUnproxy proxy) => Hashable (Route (ServantApi proxy)) where
|
||||
instance HasRoute (ServantApiUnproxy' proxy) => Hashable (Route (ServantApi proxy)) where
|
||||
hashWithSalt salt (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) = salt `hashWithSalt` typeRep (Proxy @endpoint) `hashWithSalt` ps `hashWithSalt` qs
|
||||
|
||||
instance HasRoute (ServantApiUnproxy proxy) => Read (Route (ServantApi proxy)) where
|
||||
instance HasRoute (ServantApiUnproxy' proxy) => Read (Route (ServantApi proxy)) where
|
||||
readPrec = readP_to_Prec $ \d -> do
|
||||
when (d > 10) . void $ R.char '('
|
||||
R.skipSpaces
|
||||
@ -276,7 +285,7 @@ instance HasRoute (ServantApiUnproxy proxy) => Read (Route (ServantApi proxy)) w
|
||||
R.skipSpaces
|
||||
when (d > 10) . void $ R.char ')'
|
||||
maybe (fail "Could not parse servant route") return $ parseServantRoute (ps, ifoldMap (fmap . (,)) qs)
|
||||
instance HasRoute (ServantApiUnproxy proxy) => Show (Route (ServantApi proxy)) where
|
||||
instance HasRoute (ServantApiUnproxy' proxy) => Show (Route (ServantApi proxy)) where
|
||||
showsPrec d (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) = showParen (d > 10)
|
||||
$ showString "ServantApiRoute "
|
||||
. showsPrec 11 (typeRep $ Proxy @endpoint)
|
||||
@ -285,18 +294,18 @@ instance HasRoute (ServantApiUnproxy proxy) => Show (Route (ServantApi proxy)) w
|
||||
. showString " "
|
||||
. showsPrec 11 qs
|
||||
|
||||
instance HasRoute (ServantApiUnproxy proxy) => ParseRoute (ServantApi proxy) where
|
||||
instance HasRoute (ServantApiUnproxy' proxy) => ParseRoute (ServantApi proxy) where
|
||||
parseRoute = parseServantRoute
|
||||
|
||||
newtype ServantErrorResponse
|
||||
= ServantErrorResponse { getServantErrorResponse :: W.Response }
|
||||
|
||||
class (HasServer (ServantApiUnproxy proxy) context, HasRoute (ServantApiUnproxy proxy), HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters) => ServantApiDispatch context m master proxy | master proxy -> context m where
|
||||
class (HasServer (ServantApiUnproxy' proxy) context, HasRoute (ServantApiUnproxy' proxy), HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters) => ServantApiDispatch context m master proxy | master proxy -> context m where
|
||||
servantContext :: ServantApi proxy -> master -> Request -> Yesod.HandlerFor master (Context context)
|
||||
servantHoist :: ServantApi proxy -> master -> Request -> Context context -> (forall a. m a -> Handler a)
|
||||
servantMiddleware :: ServantApi proxy -> master -> Context context -> Middleware
|
||||
servantYesodMiddleware :: ServantApi proxy -> master -> Yesod.HandlerFor master Middleware
|
||||
servantServer :: ServantApi proxy -> master -> ServerT (ServantApiUnproxy proxy) m
|
||||
servantServer :: ServantApi proxy -> master -> ServerT (ServantApiUnproxy' proxy) m
|
||||
|
||||
instance ServantApiDispatch context m master proxy => YesodSubDispatch (ServantApi proxy) master where
|
||||
yesodSubDispatch YesodSubRunnerEnv{..} req
|
||||
@ -316,7 +325,7 @@ instance ServantApiDispatch context m master proxy => YesodSubDispatch (ServantA
|
||||
yesodMiddleware <- servantYesodMiddleware proxy master
|
||||
ctx <- servantContext proxy master req
|
||||
|
||||
let server' = hoistServerWithContext (Proxy @(ServantApiUnproxy proxy)) (Proxy @context) (servantHoist proxy master req ctx) (servantServer proxy master)
|
||||
let server' = hoistServerWithContext (Proxy @(ServantApiUnproxy' proxy)) (Proxy @context) (servantHoist proxy master req ctx) (servantServer proxy master)
|
||||
toTypedContent = error "Servant handler did not shortcircuit"
|
||||
sendResponse res = case yesodError of
|
||||
Just err -> do
|
||||
@ -358,14 +367,14 @@ instance ServantApiDispatch context m master proxy => YesodSubDispatch (ServantA
|
||||
| otherwise = Nothing
|
||||
|
||||
fmap toTypedContent . withUnliftIO $ \UnliftIO{..} ->
|
||||
(yesodMiddleware . servantMiddleware proxy master ctx $ serveWithContext (Proxy @(ServantApiUnproxy proxy)) ctx server') req $ unliftIO . sendResponse
|
||||
(yesodMiddleware . servantMiddleware proxy master ctx $ serveWithContext (Proxy @(ServantApiUnproxy' proxy)) ctx server') req $ unliftIO . sendResponse
|
||||
|
||||
servantApiLink :: forall p1 p2 proxy endpoint.
|
||||
( IsElem endpoint (ServantApiUnproxy proxy) ~ (() :: Constraint), HasRoute (ServantApiUnproxy proxy), HasLink endpoint, Typeable endpoint )
|
||||
( IsElem endpoint (ServantApiUnproxy' proxy) ~ (() :: Constraint), HasRoute (ServantApiUnproxy' proxy), HasLink endpoint, Typeable endpoint )
|
||||
=> p1 proxy
|
||||
-> p2 endpoint
|
||||
-> MkLink endpoint (Route (ServantApi proxy))
|
||||
servantApiLink _ _ = safeLink' (fromMaybe (error "Could not parse result of safeLink'") . guardEndpoint . parseServantRoute @(ServantApiUnproxy proxy) . renderServantRoute) (Proxy @(ServantApiUnproxy proxy)) (Proxy @endpoint)
|
||||
servantApiLink _ _ = safeLink' (fromMaybe (error "Could not parse result of safeLink'") . guardEndpoint . parseServantRoute @(ServantApiUnproxy' proxy) . renderServantRoute) (Proxy @(ServantApiUnproxy' proxy)) (Proxy @endpoint)
|
||||
where
|
||||
guardEndpoint :: Maybe (Route (ServantApi proxy)) -> Maybe (Route (ServantApi proxy))
|
||||
guardEndpoint x@(Just (ServantApiRoute (_ :: Proxy endpoint') _ _ _))
|
||||
@ -532,7 +541,7 @@ mkYesodApi (nameBase -> masterN) ress = do
|
||||
Just tn <- lift $ lookupTypeName subsiteType
|
||||
TyConI (TySynD _ [] (ConT conN `AppT` apiT)) <- lift $ reify tn
|
||||
guard $ conN == ''ServantApi
|
||||
return $ pure (ps <> resourcePieces, ConT ''ServantApiUnproxy `AppT` apiT, map pack resourceAttrs)
|
||||
return $ pure (ps <> resourcePieces, ConT ''ServantApiUnproxy' `AppT` apiT, map pack resourceAttrs)
|
||||
toPiecesApi ps (ResourceParent _ _ ps' cs)
|
||||
= lift . fmap concat $ mapMaybeM (toPiecesApi (ps <> ps')) cs
|
||||
apiRess <- concat <$> mapMaybeM (toPiecesApi []) ress
|
||||
|
||||
@ -80,6 +80,7 @@ extra-deps:
|
||||
- hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
|
||||
- network-arbitrary-0.6.0.0@sha256:a7034d63295dfc41cf559ee705fc95cac9a9a01b4715300f590eaa237b5ffd48,2506
|
||||
- servant-quickcheck-0.0.10.0@sha256:1d5849d703c2487752f8fc7391cca7c998ee24f54ca0bb72d238bf99b64ac667,3755
|
||||
- servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
|
||||
|
||||
resolver: nightly-2021-01-11
|
||||
compiler: ghc-8.10.3
|
||||
|
||||
@ -359,6 +359,13 @@ packages:
|
||||
sha256: 37dab60111c71d011fc4964e9a8b4b05ac544bc0ba8155e895518680066c2adb
|
||||
original:
|
||||
hackage: servant-quickcheck-0.0.10.0@sha256:1d5849d703c2487752f8fc7391cca7c998ee24f54ca0bb72d238bf99b64ac667,3755
|
||||
- completed:
|
||||
hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
|
||||
pantry-tree:
|
||||
size: 325
|
||||
sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3
|
||||
original:
|
||||
hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 562265
|
||||
|
||||
@ -29,5 +29,8 @@ instance HasGenRequest sub => HasGenRequest (CaptureBearerToken' mods :> sub) wh
|
||||
instance HasGenRequest sub => HasGenRequest (CaptureBearerRestriction' mods restr :> sub) where
|
||||
genRequest _ = genRequest $ Proxy @sub
|
||||
|
||||
instance HasGenRequest sub => HasGenRequest (ApiVersion major minor patch :> sub) where
|
||||
genRequest _ = genRequest $ Proxy @sub
|
||||
|
||||
spec :: Spec
|
||||
spec = return ()
|
||||
|
||||
@ -12,7 +12,7 @@ import Servant.QuickCheck.Internal.HasGenRequest (HasGenRequest(..))
|
||||
import qualified Network.HTTP.Client as HTTP
|
||||
import qualified Network.HTTP.Types.URI as URI
|
||||
|
||||
import Yesod.Servant (HasRoute(..), ServantApi, ServantApiUnproxy)
|
||||
import Yesod.Servant (HasRoute(..), ServantApi, ServantApiUnproxy')
|
||||
|
||||
import Foundation.ServantSpec ()
|
||||
import ServantApi.ExternalApis.TypeSpec ()
|
||||
@ -36,9 +36,9 @@ instance Arbitrary (Route EmbeddedStatic) where
|
||||
params <- replicateM paramNum $ (,) <$> printableText' <*> printableText
|
||||
return $ embeddedResourceR path params
|
||||
|
||||
instance (HasRoute (ServantApiUnproxy api), HasGenRequest (ServantApiUnproxy api)) => Arbitrary (Route (ServantApi api)) where
|
||||
instance (HasRoute (ServantApiUnproxy' api), HasGenRequest (ServantApiUnproxy' api)) => Arbitrary (Route (ServantApi api)) where
|
||||
arbitrary = do
|
||||
genReq <- view _2 . genRequest $ Proxy @(ServantApiUnproxy api)
|
||||
genReq <- view _2 . genRequest $ Proxy @(ServantApiUnproxy' api)
|
||||
let req = genReq $ BaseUrl Http "" 0 ""
|
||||
p = filter (not . null) . URI.decodePathSegments $ HTTP.path req
|
||||
qs = over (traverse . _2) (fromMaybe mempty) . URI.parseQueryText $ HTTP.queryString req
|
||||
|
||||
@ -7,6 +7,8 @@ module Model.TypesSpec
|
||||
import TestImport
|
||||
import Settings
|
||||
|
||||
import Utils (guardOn)
|
||||
|
||||
import Data.Aeson (Value)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
@ -46,6 +48,10 @@ import qualified Data.Text.Lazy as LT
|
||||
|
||||
import Text.Blaze.Html.Renderer.Text (renderHtml)
|
||||
|
||||
import qualified Data.SemVer as SemVer
|
||||
import qualified Data.SemVer.Constraint as SemVer (Constraint)
|
||||
import qualified Data.SemVer.Constraint as SemVer.Constraint
|
||||
|
||||
|
||||
|
||||
instance Arbitrary Season where
|
||||
@ -330,6 +336,36 @@ instance Arbitrary ExternalApiConfig where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary SemVer.Version where
|
||||
arbitrary = SemVer.version
|
||||
<$> fmap getNonNegative arbitrary
|
||||
<*> fmap getNonNegative arbitrary
|
||||
<*> fmap getNonNegative arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
|
||||
instance Arbitrary SemVer.Identifier where
|
||||
arbitrary = -- oneof
|
||||
-- [ SemVer.numeric . getNonNegative <$> arbitrary -- Numeric does not roundtrip
|
||||
{- , -} fmap (\s -> fromMaybe (error $ "Generated invalid SemVer.Identifier: " <> s) . SemVer.textual $ pack s) . listOf1 . elements $ ['A'..'Z'] <> ['a'..'z'] {- <> ['0'..'9'] -} <> ['-']
|
||||
-- ]
|
||||
|
||||
deriving instance Generic SemVer.Constraint
|
||||
|
||||
instance Arbitrary SemVer.Constraint where
|
||||
-- Syntax has no brackets; so be very careful about nesting
|
||||
arbitrary = sized $ \n -> oneof $ catMaybes
|
||||
[ pure unitary
|
||||
, guardOn (n > 1) conj
|
||||
, guardOn (n > 1) disj
|
||||
]
|
||||
where unitary = oneof
|
||||
[ pure SemVer.Constraint.CAny
|
||||
, elements [SemVer.Constraint.CLt, SemVer.Constraint.CLtEq, SemVer.Constraint.CGt, SemVer.Constraint.CGtEq, SemVer.Constraint.CEq] <*> arbitrary
|
||||
]
|
||||
conj = SemVer.Constraint.CAnd <$> unitary <*> sized (\n -> oneof $ catMaybes [pure unitary, guardOn (n > 1) $ scale (`div` 2) conj])
|
||||
disj = SemVer.Constraint.COr <$> unitary <*> scale (`div` 2) arbitrary
|
||||
|
||||
|
||||
|
||||
spec :: Spec
|
||||
@ -435,6 +471,10 @@ spec = do
|
||||
[ eqLaws, ordLaws, finiteLaws, showReadLaws, pathPieceLaws, boundedEnumLaws ]
|
||||
lawsCheckHspec (Proxy @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey))
|
||||
[ eqLaws, ordLaws, showLaws, showReadLaws, pathPieceLaws, jsonLaws, persistFieldLaws, binaryLaws ]
|
||||
lawsCheckHspec (Proxy @SemVer.Version)
|
||||
[ eqLaws, ordLaws, showLaws, hashableLaws, httpApiDataLaws ]
|
||||
lawsCheckHspec (Proxy @SemVer.Constraint)
|
||||
[ eqLaws, showLaws, httpApiDataLaws ]
|
||||
|
||||
describe "TermIdentifier" $ do
|
||||
it "has compatible encoding/decoding to/from Text" . property $
|
||||
|
||||
Reference in New Issue
Block a user