fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

feat(apis): support servant-generic

Browse Source
This commit is contained in:
Gregor Kleen 2020-04-08 17:04:57 +02:00
parent 90679e0095
commit e8bbaa0463
4 changed files with 82 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/Foundation/Servant.hs
View File

@ -134,10 +134,10 @@ type UniWorXContext = UniWorX ': '[]
type ServantHandler = ServantHandlerFor UniWorX
type ServantDB = ServantDBFor UniWorX
class (HasServer api UniWorXContext, Servant.HasRoute api) => ServantApiDispatchUniWorX api where
servantServer' :: ServantApi api -> ServerT api ServantHandler
class (HasServer (ServantApiUnproxy proxy) UniWorXContext, Servant.HasRoute (ServantApiUnproxy proxy)) => ServantApiDispatchUniWorX proxy where
servantServer' :: ServantApi proxy -> ServerT (ServantApiUnproxy proxy) ServantHandler
instance ServantApiDispatchUniWorX api => ServantApiDispatch UniWorXContext ServantHandler UniWorX api where
instance ServantApiDispatchUniWorX proxy => ServantApiDispatch UniWorXContext ServantHandler UniWorX proxy where
servantContext _ app _ = return $ app :. EmptyContext
servantHoist _ sctxSite sctxRequest _ = ($ ServantHandlerContextFor{..}) . unServantHandlerFor
servantMiddleware _ _ _ = modifyResponse (mapResponseHeaders setDefaultHeaders) . fixTrailingSlash

12
src/ServantApi/ExternalApis.hs
View File

@ -10,11 +10,13 @@ import ServantApi.ExternalApis.Type
instance ServantApiDispatchUniWorX ExternalApis where
servantServer' _ = externalApisList
:<|> externalApiCreate
:<|> externalApiInfo
:<|> externalApiPong
:<|> externalApiDelete
servantServer' _ = genericServerT ExternalApis
{ externalApisListR = externalApisList
, externalApisCreateR = externalApiCreate
, externalApisInfoR = externalApiInfo
, externalApisPongR = externalApiPong
, externalApisDeleteR = externalApiDelete
}
externalApisList :: ServantHandler ExternalApisList
externalApisList = runDB $ fmap ExternalApisList . lift . toResponse =<< selectList [] [Desc ExternalApiLastAlive]

14
src/ServantApi/ExternalApis/Type.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module ServantApi.ExternalApis.Type where
@ -24,13 +25,16 @@ type ExternalApisInfoR = CaptureCryptoUUID "external-api" ExternalApiId
type ExternalApisDeleteR = CaptureCryptoUUID "external-api" ExternalApiId
:> DeleteNoContent
type ExternalApis = ExternalApisListR
:<|> ExternalApisCreateR
:<|> ExternalApisInfoR
:<|> ExternalApisPongR
:<|> ExternalApisDeleteR
data ExternalApis mode = ExternalApis
{ externalApisListR :: mode :- ExternalApisListR
, externalApisCreateR :: mode :- ExternalApisCreateR
, externalApisInfoR :: mode :- ExternalApisInfoR
, externalApisPongR :: mode :- ExternalApisPongR
, externalApisDeleteR :: mode :- ExternalApisDeleteR
} deriving (Generic)
type ServantApiExternalApis = ServantApi ExternalApis
type instance ServantApiUnproxy ExternalApis = ToServantApi ExternalApis
instance ToCapture (Capture "external-api" UUID) where

119
src/Yesod/Servant.hs
View File

@ -1,7 +1,8 @@
{-# LANGUAGE UndecidableInstances #-}
module Yesod.Servant
( HasRoute(..)
( ServantApiUnproxy, ServantApiDirect
, HasRoute(..)
, ServantApi(..), getServantApi
, ServantApiDispatch(..)
, servantApiLink
@ -111,7 +112,7 @@ escapedSymbol :: forall sym. KnownSymbol sym => Proxy sym -> Text
escapedSymbol _ = pack . escapeURIString isUnreserved . symbolVal $ Proxy @sym
class HasLink api => HasRoute api where
parseServantRoute :: ([Text], [(Text, Text)]) -> Maybe (Route (ServantApi api))
parseServantRoute :: forall proxy. ServantApiUnproxy proxy ~ api => ([Text], [(Text, Text)]) -> Maybe (Route (ServantApi proxy))
instance HasRoute EmptyAPI where
parseServantRoute _ = Nothing
@ -129,115 +130,121 @@ instance (Typeable m, Typeable k, Typeable status, Typeable fr, Typeable ct, Typ
parseServantRoute _ = Nothing
instance HasRoute sub => HasRoute (HttpVersion :> sub) where
parseServantRoute args = parseServantRoute @sub args <&> \case
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(HttpVersion :> endpoint)) f ps qs
instance HasRoute sub => HasRoute (Vault :> sub) where
parseServantRoute args = parseServantRoute @sub args <&> \case
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Vault :> endpoint)) f ps qs
instance (HasRoute sub, KnownSymbol realm, Typeable a) => HasRoute (BasicAuth realm a :> sub) where
parseServantRoute args = parseServantRoute @sub args <&> \case
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(BasicAuth realm a :> endpoint)) f ps qs
instance (HasRoute sub, KnownSymbol s) => HasRoute (Description s :> sub) where
parseServantRoute args = parseServantRoute @sub args <&> \case
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Description s :> endpoint)) f ps qs
instance (HasRoute sub, KnownSymbol s) => HasRoute (Summary s :> sub) where
parseServantRoute args = parseServantRoute @sub args <&> \case
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Summary s :> endpoint)) f ps qs
instance (HasRoute sub, Typeable tag, Typeable k) => HasRoute (AuthProtect (tag :: k) :> sub) where
parseServantRoute args = parseServantRoute @sub args <&> \case
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(AuthProtect tag :> endpoint)) f ps qs
instance HasRoute sub => HasRoute (IsSecure :> sub) where
parseServantRoute args = parseServantRoute @sub args <&> \case
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(IsSecure :> endpoint)) f ps qs
instance HasRoute sub => HasRoute (RemoteHost :> sub) where
parseServantRoute args = parseServantRoute @sub args <&> \case
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(RemoteHost :> endpoint)) f ps qs
instance (HasRoute sub, Typeable mods, Typeable restr) => HasRoute (CaptureBearerRestriction' mods restr :> sub) where
parseServantRoute args = parseServantRoute @sub args <&> \case
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(CaptureBearerRestriction' mods restr :> endpoint)) f ps qs
instance (HasRoute sub, Typeable mods) => HasRoute (CaptureBearerToken' mods :> sub) where
parseServantRoute args = parseServantRoute @sub args <&> \case
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(CaptureBearerToken' mods :> endpoint)) f ps qs
instance (KnownSymbol sym, HasRoute sub, HasLink sub) => HasRoute (sym :> sub) where
parseServantRoute (p : ps, qs)
| p == escapedSymbol (Proxy @sym)
= parseServantRoute @sub (ps, qs) <&> \case
= parseServantRoute @sub @(ServantApiDirect sub) (ps, qs) <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(sym :> endpoint)) f (escapedSymbol (Proxy @sym) : ps') qs'
parseServantRoute _ = Nothing
instance (HasRoute a, HasRoute b) => HasRoute (a :<|> b) where
parseServantRoute args = asum
[ parseServantRoute @a args <&> \case
[ parseServantRoute @a @(ServantApiDirect a) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @endpoint) f ps qs
, parseServantRoute @b args <&> \case
, parseServantRoute @b @(ServantApiDirect b) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @endpoint) f ps qs
]
instance (HasRoute sub, Typeable mods, Typeable ct, Typeable a) => HasRoute (ReqBody' mods ct a :> sub) where
parseServantRoute args = parseServantRoute @sub args <&> \case
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(ReqBody' mods ct a :> endpoint)) f ps qs
instance (HasRoute sub, Typeable mods, Typeable framing, Typeable ct, Typeable a) => HasRoute (StreamBody' mods framing ct a :> sub) where
parseServantRoute args = parseServantRoute @sub args <&> \case
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(StreamBody' mods framing ct a :> endpoint)) f ps qs
instance (HasRoute sub, KnownSymbol sym, Typeable mods, Typeable a) => HasRoute (Header' mods sym (a :: *) :> sub) where
parseServantRoute args = parseServantRoute @sub args <&> \case
parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Header' mods sym a :> endpoint)) f ps qs
instance (HasRoute sub, Typeable mods, KnownSymbol sym, Typeable v, ToHttpApiDataInjective v, FromHttpApiData v) => HasRoute (Capture' mods sym (v :: *) :> sub) where
parseServantRoute ((p : ps), qs)
| Right v <- parseUrlPiece @v p
= parseServantRoute @sub (ps, qs) <&> \case
= parseServantRoute @sub @(ServantApiDirect sub) (ps, qs) <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(Capture' mods sym v :> endpoint)) (f . ($ v)) (toUrlPieceInjective v : ps') qs'
parseServantRoute _ = Nothing
instance (HasRoute sub, Typeable mods, KnownSymbol sym, Typeable plaintext, ToHttpApiDataInjective ciphertext, FromHttpApiData ciphertext, Typeable ciphertext) => HasRoute (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
parseServantRoute ((p : ps), qs)
| Right v <- parseUrlPiece @(CryptoID ciphertext plaintext) p
= parseServantRoute @sub (ps, qs) <&> \case
= parseServantRoute @sub @(ServantApiDirect sub) (ps, qs) <&> \case
ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(CaptureCryptoID' mods ciphertext sym plaintext :> endpoint)) (f . ($ v)) (toUrlPieceInjective v : ps') qs'
parseServantRoute _ = Nothing
data ServantApi (api :: *) = ServantApi
data ServantApi (proxy :: k) = ServantApi
getServantApi :: forall master api. master -> ServantApi api
getServantApi :: forall master proxy. master -> ServantApi proxy
getServantApi _ = ServantApi
instance HasRoute api => RenderRoute (ServantApi api) where
data Route (ServantApi api) = forall endpoint.
( IsElem endpoint api ~ (() :: Constraint)
, HasRoute endpoint
, Typeable endpoint
)
=> ServantApiRoute
(Proxy endpoint)
(forall a. MkLink endpoint a -> a)
[Text] (HashMap Text [Text])
renderRoute (ServantApiRoute (_ :: Proxy endpoint) f _ _) = f $ safeLink' renderServantRoute (Proxy @api) (Proxy @endpoint)
instance HasRoute api => Eq (Route (ServantApi api)) where
type family ServantApiUnproxy (proxy :: k) :: *
data ServantApiDirect (api :: *)
type instance ServantApiUnproxy (ServantApiDirect api) = api
instance HasRoute (ServantApiUnproxy proxy) => RenderRoute (ServantApi proxy) where
data Route (ServantApi proxy)
= forall endpoint.
( IsElem endpoint (ServantApiUnproxy proxy) ~ (() :: Constraint)
, HasRoute endpoint
, Typeable endpoint
)
=> ServantApiRoute
(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)
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 api => Hashable (Route (ServantApi api)) 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 api => Read (Route (ServantApi api)) where
instance HasRoute (ServantApiUnproxy proxy) => Read (Route (ServantApi proxy)) where
readPrec = readP_to_Prec $ \d -> do
when (d > 10) . void $ R.char '('
R.skipSpaces
@ -259,7 +266,7 @@ instance HasRoute api => Read (Route (ServantApi api)) where
R.skipSpaces
when (d > 10) . void $ R.char ')'
maybe (fail "Could not parse servant route") return $ parseServantRoute (ps, ifoldMap (fmap . (,)) qs)
instance HasRoute api => Show (Route (ServantApi api)) 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)
@ -268,26 +275,26 @@ instance HasRoute api => Show (Route (ServantApi api)) where
. showString " "
. showsPrec 11 qs
instance HasRoute api => ParseRoute (ServantApi api) where
instance HasRoute (ServantApiUnproxy proxy) => ParseRoute (ServantApi proxy) where
parseRoute = parseServantRoute
newtype ServantErrorResponse
= ServantErrorResponse { getServantErrorResponse :: W.Response }
class (HasServer api context, HasRoute api) => ServantApiDispatch context m master api | master api -> context m where
servantContext :: ServantApi api -> master -> Request -> Yesod.HandlerFor master (Context context)
servantHoist :: ServantApi api -> master -> Request -> Context context -> (forall a. m a -> Handler a)
servantMiddleware :: ServantApi api -> master -> Context context -> Middleware
servantYesodMiddleware :: ServantApi api -> master -> Yesod.HandlerFor master Middleware
servantServer :: ServantApi api -> master -> ServerT api m
class (HasServer (ServantApiUnproxy proxy) context, HasRoute (ServantApiUnproxy proxy)) => 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
instance ServantApiDispatch context m master api => YesodSubDispatch (ServantApi api) master where
instance ServantApiDispatch context m master proxy => YesodSubDispatch (ServantApi proxy) master where
yesodSubDispatch YesodSubRunnerEnv{..} req
= ysreParentRunner handlerT ysreParentEnv (ysreToParentRoute <$> route) req
where
master :: master
master = yreSite ysreParentEnv
proxy :: ServantApi api
proxy :: ServantApi proxy
proxy = ysreGetSub master
route = parseRoute ( W.pathInfo req
@ -299,7 +306,7 @@ instance ServantApiDispatch context m master api => YesodSubDispatch (ServantApi
yesodMiddleware <- servantYesodMiddleware proxy master
ctx <- servantContext proxy master req
let server' = hoistServerWithContext (Proxy @api) (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
@ -341,16 +348,16 @@ instance ServantApiDispatch context m master api => YesodSubDispatch (ServantApi
| otherwise = Nothing
fmap toTypedContent . withUnliftIO $ \UnliftIO{..} ->
(yesodMiddleware . servantMiddleware proxy master ctx $ serveWithContext (Proxy @api) ctx server') req $ unliftIO . sendResponse
(yesodMiddleware . servantMiddleware proxy master ctx $ serveWithContext (Proxy @(ServantApiUnproxy proxy)) ctx server') req $ unliftIO . sendResponse
servantApiLink :: forall p1 p2 api endpoint.
( IsElem endpoint api ~ (() :: Constraint), HasRoute api, HasLink endpoint, Typeable endpoint )
=> p1 api
servantApiLink :: forall p1 p2 proxy endpoint.
( IsElem endpoint (ServantApiUnproxy proxy) ~ (() :: Constraint), HasRoute (ServantApiUnproxy proxy), HasLink endpoint, Typeable endpoint )
=> p1 proxy
-> p2 endpoint
-> MkLink endpoint (Route (ServantApi api))
servantApiLink _ _ = safeLink' (fromMaybe (error "Could not parse result of safeLink'") . guardEndpoint . parseServantRoute @api . renderServantRoute) (Proxy @api) (Proxy @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)
where
guardEndpoint :: Maybe (Route (ServantApi api)) -> Maybe (Route (ServantApi api))
guardEndpoint :: Maybe (Route (ServantApi proxy)) -> Maybe (Route (ServantApi proxy))
guardEndpoint x@(Just (ServantApiRoute (_ :: Proxy endpoint') _ _ _))
| Just Refl <- eqT @endpoint @endpoint' = x
guardEndpoint _ = Nothing
@ -515,7 +522,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, 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