{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} module DomainDriven.Server.TH where import Control.Monad import Control.Monad.State import Data.Foldable import Data.Function (on) import Data.Generics.Product import Data.List qualified as L import Data.Map qualified as M import Data.Maybe import Data.Set qualified as S import Data.Traversable import DomainDriven.Server.Class import DomainDriven.Server.Config import DomainDriven.Server.Helpers import DomainDriven.Server.Types import Language.Haskell.TH import Lens.Micro import Servant import UnliftIO (MonadUnliftIO (..)) import Prelude -- import Debug.Trace -- import GHC.Generics (Generic) -- import Data.Bifunctor -- | Generate a server with granular configuration -- -- Expects a Map of ApiOptions generated by `DomainDriven.Config.getApiOptionsMap` -- Due to GHC stage restrictions this cannot be generated in the same module. -- -- Using this require you to enable template haskell -- {\-# LANGUAGE TemplateHaskell #-\} -- $(mkServer config ''MyAction) mkServer :: ServerConfig -> Name -> Q [Dec] mkServer cfg (GadtName -> gadtName) = do spec <- mkServerSpec cfg gadtName opts <- getApiOptions cfg gadtName let si :: ServerInfo si = ServerInfo { baseGadt = spec ^. typed , currentGadt = spec ^. typed , parentConstructors = [] , prefixSegments = [] , options = opts } runServerGenM ServerGenState{info = si, usedParamNames = mempty} (mkServerFromSpec spec) getApiOptions :: ServerConfig -> GadtName -> Q ApiOptions getApiOptions cfg (GadtName n) = case M.lookup (show n) (allApiOptions cfg) of Just o -> pure o Nothing -> fail $ "Cannot find ApiOptions for " <> show n <> ". " <> "\nProbable reasons:" <> "\n - It does not implement `HasApiOptions`." <> "\n - The instance is not visible from where `mkServerConfig` is run." <> "\n - The `ServerConfig` instance was manually defined and not complete." getActionDec :: GadtName -> Q (Dec, VarBindings) getActionDec (GadtName n) = do cmdType <- reify n let errMsg = fail $ "Expected " <> show n <> "to be a GADT" case cmdType of TyConI dec@(DataD _ctx _name params _ _ _) -> case mkVarBindings params of Right b -> pure (dec, b) Left err -> fail $ "getActionDec: " <> err TyConI{} -> errMsg ClassI{} -> errMsg ClassOpI{} -> errMsg FamilyI{} -> errMsg PrimTyConI{} -> errMsg DataConI{} -> errMsg PatSynI{} -> errMsg VarI{} -> errMsg TyVarI{} -> errMsg getSubActionDec :: VarBindings -> SubActionMatch -> Q (Dec, VarBindings) getSubActionDec tyVars subAction = do -- We have to do a `reify` on the subaction to get the constructors. When we do this -- we get new [TyVarBndr ()]. These needs to be unified with what we have from the -- parent. cmdType <- reify $ subAction ^. field @"subActionName" case cmdType of TyConI (DataD ctx name params mKind constructors deriv) -> do let parentParams :: [TyVarBndr ()] parentParams = getUsedTyVars (toTyVarBndr tyVars) (subAction ^. field @"subActionType") unless (on (==) length parentParams params) ( fail $ "getSubActionDec: Different number of parameters. Parent: " <> show parentParams <> ", child: " <> show params ) let tyVarMap :: M.Map Name Name tyVarMap = M.fromList $ on zip (^.. folded . typed @Name) params parentParams case mkVarBindings parentParams of Right b -> do let rename :: Type -> Type rename ty = either (const ty) id $ replaceVarT tyVarMap ty constructorDec :: Dec constructorDec = DataD (fmap rename ctx) name parentParams mKind (fmap (updateConstructorTypes rename) constructors) deriv pure (constructorDec, b) Left err -> fail $ "getSubActionDec: " <> err <> " --------- " <> show parentParams TyConI{} -> errorOut ClassI{} -> errorOut ClassOpI{} -> errorOut FamilyI{} -> errorOut PrimTyConI{} -> errorOut DataConI{} -> errorOut PatSynI{} -> errorOut VarI{} -> errorOut TyVarI{} -> errorOut where errorOut = fail $ "Expected " <> show (subAction ^. field @"subActionName") <> "to be a GADT" replaceVarT :: M.Map Name Name -> Type -> Either String Type replaceVarT m = \case AppT ty1 ty2 -> AppT <$> replaceVarT m ty1 <*> replaceVarT m ty2 VarT oldName -> case M.lookup oldName m of Just n -> Right (VarT n) Nothing -> Left $ "replaceVarT: No match for variable \"" <> show oldName <> "\"" ty -> Right ty -- Don't think I need to match on other constructors. *lazy* guardMethodVar :: TyVarBndr flag -> Q () guardMethodVar = \case KindedTV _ _ k -> check k PlainTV _ _ -> check StarT where check :: Type -> Q () check _ = pure () getMutabilityOf :: Type -> Q Mutability getMutabilityOf = \case AppT (AppT (AppT _ (PromotedT verbName)) _) _ -> checkVerb verbName ConT n -> reify n >>= \case TyConI (TySynD _ _ (AppT (AppT (AppT _ (PromotedT verbName)) _) _)) -> checkVerb verbName info -> fail $ "Expected method to be a Verb of a type synonym for a Verb. Got:\n" <> show info ty -> fail $ "Expected a Verb without return type applied, got: " <> show ty where checkVerb :: Name -> Q Mutability checkVerb n = case show n of "Network.HTTP.Types.Method.GET" -> pure Immutable _ -> pure Mutable guardReturnVar :: Show flag => TyVarBndr flag -> Q () guardReturnVar = \case KindedTV _ _ StarT -> pure () PlainTV _ _ -> pure () ty -> fail $ "Return type must be a concrete type. Got: " <> show ty getConstructors :: Dec -> Q [Con] getConstructors = \case DataD _ _ (last3 -> Just (_x, method, ret)) _ cs _ -> do guardMethodVar method guardReturnVar ret pure cs d@DataD{} -> fail $ "Unexpected Action data type: " <> show d d -> fail $ "Expected a GADT with two parameters but got: " <> show d where last3 :: [a] -> Maybe (a, a, a) last3 = \case [a, b, c] -> Just (a, b, c) [_, _] -> Nothing [_] -> Nothing [] -> Nothing l -> last3 $ tail l toTyVarBndr :: VarBindings -> [TyVarBndr ()] toTyVarBndr VarBindings{paramPart, method, return, extra} = extra <> [KindedTV paramPart () (ConT ''ParamPart), PlainTV method (), PlainTV return ()] mkVarBindings :: Show flag => [TyVarBndr flag] -> Either String VarBindings mkVarBindings varBinds = case varBinds of [KindedTV x _ kind, method, ret] | kind == ConT ''ParamPart -> Right VarBindings { paramPart = x , method = method ^. to noFlag . typed @Name , return = ret ^. to noFlag . typed @Name , extra = [] } | otherwise -> Left $ "mkVarBindings: Expected parameter of kind ParamPart, got: " <> show varBinds [_, _] -> Left errMsg [_] -> Left errMsg [] -> Left errMsg p : l -> over (field @"extra") (noFlag p :) <$> mkVarBindings l where noFlag :: TyVarBndr flag -> TyVarBndr () noFlag = \case KindedTV x _ kind -> KindedTV x () kind PlainTV x _ -> PlainTV x () errMsg = "mkVarBindings: Expected parameters `(x :: ParamPart) method return`, got: " <> show varBinds matchNormalConstructor :: Con -> Either String ConstructorMatch matchNormalConstructor con = do (x, gadtCon) <- unconsForall con (conName, params, constructorType) <- unconsGadt gadtCon finalType <- matchFinalConstructorType constructorType pure ConstructorMatch { xParam = x , constructorName = conName , parameters = params , finalType = finalType } where getParamPartVar :: Show a => [TyVarBndr a] -> Either String Name getParamPartVar = \case KindedTV x _spec kind : _ | kind == ConT ''ParamPart -> Right x a : l -> case getParamPartVar l of r@Right{} -> r Left e -> Left $ e <> show a [] -> Left "Expected a constrctor parameterized by `(x :: ParamPart)`, got: " unconsForall :: Con -> Either String (Name, Con) unconsForall = \case ForallC bindings _ctx con' -> do x <- getParamPartVar bindings Right (x, con') con' -> Left $ "Expected a constrctor parameterized by `(x :: ParamPart)`, got: " <> show con' unconsGadt :: Con -> Either String (Name, [Pmatch], Type) unconsGadt = \case GadtC [conName] bangArgs ty -> do params <- traverse (matchP . snd) bangArgs pure (conName, params, ty) con' -> Left $ "Expected Gadt constrctor, got: " <> show con' matchSubActionConstructor :: Con -> Either String SubActionMatch matchSubActionConstructor con = do gadtCon <- unconsForall con -- Left $ show gadtCon (conName, normalParams, (subActionName, subActionType), _constructorType) <- unconsGadt gadtCon pure SubActionMatch { constructorName = conName , parameters = normalParams , subActionName = subActionName , subActionType = subActionType } where unconsForall :: Con -> Either String Con unconsForall = \case ForallC _params _ctx con' -> pure con' con' -> Left $ "Expected a higher order constrctor parameterized by `(x :: ParamPart)`, got: " <> show con' unconsGadt :: Con -> Either String (Name, [Pmatch], (Name, Type), Type) unconsGadt = \case con'@(GadtC [actionName] bangArgs ty) -> do (normalArgs, subActionType) <- do let (normalArgs, subActions) = L.splitAt (length bangArgs - 1) (snd <$> bangArgs) case subActions of [] -> Left "No arguments" a : _ -> Right (normalArgs, a) normalParams <- traverse matchP normalArgs let getActionName :: Type -> Either String Name getActionName = \case ConT subAction -> Right subAction (AppT a _) -> getActionName a ty' -> Left $ "getActionName: Expected `ConT [action name]` got: " <> show ty' <> " from constructor: " <> show con' subActionName <- getActionName subActionType pure (actionName, normalParams, (subActionName, subActionType), ty) con' -> Left $ "Expected Gadt constrctor, got: " <> show con' matchFinalConstructorType :: Type -> Either String FinalConstructorTypeMatch matchFinalConstructorType = \case AppT (AppT _typeName a) retTy -> do reqTy <- matchRequestType a Right FinalConstructorTypeMatch{requestType = reqTy, returnType = retTy} ty -> Left $ "Expected constructor like `GetCount x Query Int`, got: " <> show ty matchRequestType :: Type -> Either String RequestTypeMatch matchRequestType = \case AppT (AppT (AppT (ConT _reqTy) accessType) ct) verb -> Right RequestTypeMatch{accessType = accessType, contentTypes = ct, verb = verb} ty -> Left $ "Expected `RequestType`, got: " <> show ty -- | Tries to match a Type to a more easily readable Pmatch. -- Successful match means the type is representing the type family `P` matchP :: Type -> Either String Pmatch matchP = \case AppT (AppT (AppT (ConT p) (VarT x)) (LitT (StrTyLit pName))) ty -> do unless (on (==) show p ''P) (Left $ "Expected " <> show ''P <> ", got: " <> show p) Right Pmatch{paramPart = x, paramName = pName, paramType = ty} ty -> Left $ "Expected type family `P`, got: " <> show ty mkApiPiece :: ServerConfig -> VarBindings -> Con -> Q ApiPiece mkApiPiece cfg varBindings con = do case (matchNormalConstructor con, matchSubActionConstructor con) of (Right c, _) -> do actionType <- getMutabilityOf $ c ^. field @"finalType" . field @"requestType" . field @"verb" pure $ Endpoint (ConstructorName $ c ^. field @"constructorName") ( ConstructorArgs $ c ^.. field @"parameters" . folded . to (\p -> (p ^. field @"paramName", p ^. field @"paramType")) ) varBindings HandlerSettings { contentTypes = c ^. field @"finalType" . field @"requestType" . field @"contentTypes" , verb = c ^. field @"finalType" . field @"requestType" . field @"verb" } actionType (EpReturnType $ c ^. field @"finalType" . field @"returnType") (_, Right c) -> do subServerSpec <- mkSubServerSpec cfg varBindings c pure $ SubApi (c ^. field @"constructorName" . to ConstructorName) ( ConstructorArgs $ c ^.. field @"parameters" . folded . to (\p -> (p ^. field @"paramName", p ^. field @"paramType")) ) subServerSpec (Left err1, Left err2) -> fail $ "mkApiPiece - " <> "\n---------------------mkApiPiece: Expected ------------------------" <> show err1 <> "\n---------------------or-------------------------------------------" <> "\n" <> show err2 <> "\n------------------------------------------------------------------" -- | Create a ApiSpec from a GADT -- The GADT must have one parameter representing the return type mkServerSpec :: ServerConfig -> GadtName -> Q ApiSpec mkServerSpec cfg n = do (dec, varBindings) <- getActionDec n --- AHA, THis is the fucker fucking with me! eps <- traverse (mkApiPiece cfg varBindings) =<< getConstructors dec opts <- getApiOptions cfg n pure ApiSpec { gadtName = n , gadtType = GadtType $ L.foldl' AppT (ConT $ n ^. typed @Name) ( varBindings ^.. field @"extra" . folded . typed @Name . to VarT ) , allVarBindings = varBindings , endpoints = eps , options = opts } gadtToAction :: GadtType -> Either String Type gadtToAction (GadtType ty) = case ty of AppT (AppT (AppT ty' (VarT _x)) (VarT _method)) (VarT _return) -> Right ty' _ -> Left $ "Expected `GADT` with final kind `Action`, got: " <> show ty mkSubServerSpec :: ServerConfig -> VarBindings -> SubActionMatch -> Q ApiSpec mkSubServerSpec cfg varBindings subAction = do (dec, bindings) <- getSubActionDec varBindings subAction -- We must not use the bindings or we'd end up with different names eps <- traverse (mkApiPiece cfg bindings) =<< getConstructors dec opts <- getApiOptions cfg name actionTy <- either fail pure $ subAction ^. field @"subActionType" . to GadtType . to gadtToAction pure ApiSpec { gadtName = name , gadtType = GadtType actionTy , allVarBindings = varBindings , endpoints = eps , options = opts } where name :: GadtName name = subAction ^. field @"subActionName" . to GadtName -- | Name and type variables used by API askApiNameAndParams :: ApiSpec -> ServerGenM (Name, [TyVarBndr ()]) askApiNameAndParams spec = do apiTypeName <- askApiTypeName pure (apiTypeName, apiSpecTyVars spec) apiPieceTyVars :: ApiPiece -> [TyVarBndr ()] apiPieceTyVars = \case Endpoint _ args bindings _ _ ret -> L.nub $ foldMap (getUsedTyVars $ bindings ^. field @"extra") (ret ^. typed @Type : args ^.. typed @[(String, Type)] . folded . typed @Type) SubApi _ _ spec -> apiSpecTyVars spec apiSpecTyVars :: ApiSpec -> [TyVarBndr ()] apiSpecTyVars spec = filter (`elem` usedTyVars) (spec ^. field @"allVarBindings" . field @"extra") where usedTyVars = L.nub $ foldMap apiPieceTyVars $ spec ^. field @"endpoints" mkApiTypeDecs :: ApiSpec -> ServerGenM [Dec] mkApiTypeDecs spec = do (apiTypeName, tyVars) <- askApiNameAndParams spec epTypes <- traverse mkEndpointApiType (spec ^. typed @[ApiPiece]) topLevelDec <- case reverse epTypes of -- :<|> is right associative [] -> fail "Server contains no endpoints" (ty, _tyVars) : ts -> do let fish :: Type -> Type -> Q Type fish b a = [t|$(pure a) :<|> $(pure b)|] apiType <- liftQ (foldM fish ty (fmap fst ts)) pure $ TySynD apiTypeName tyVars apiType handlerDecs <- mconcat <$> traverse mkHandlerTypeDec (spec ^. typed @[ApiPiece]) pure $ topLevelDec : handlerDecs applyTyVars :: Type -> [TyVarBndr ()] -> Type applyTyVars ty tyVars = foldl AppT ty (tyVars ^.. folded . typed @Name . to VarT) -- | Create endpoint types to be referenced in the API -- * For Endpoint this is just a reference to the handler type -- * For SubApi we apply the path parameters before referencing the SubApi mkEndpointApiType :: ApiPiece -> ServerGenM (Type, [TyVarBndr ()]) mkEndpointApiType p = enterApiPiece p $ case p of Endpoint _n args bindings _ _ ret -> do epName <- askEndpointTypeName let usedTyVars :: [TyVarBndr ()] usedTyVars = L.nub $ foldMap (getUsedTyVars $ bindings ^. field @"extra") (ret ^. typed @Type : args ^.. typed @[(String, Type)] . folded . typed @Type) pure ( applyTyVars (ConT epName) usedTyVars , filter (`elem` usedTyVars) (bindings ^. field @"extra") -- Make sure we get type vars in the right order ) SubApi cName cArgs spec -> do urlSegment <- mkUrlSegment cName (n, tyVars) <- askApiNameAndParams spec finalType <- liftQ $ prependServerEndpointName urlSegment (applyTyVars (ConT n) tyVars) params <- mkQueryParams cArgs bird <- liftQ [t|(:>)|] let ep = foldr (\a b -> bird `AppT` a `AppT` b) finalType params pure (ep, tyVars) -- | Defines the servant types for the endpoints -- For SubApi it will trigger the full creating of the sub server with types and all -- -- Result will be something like: -- ``` -- type Customer_CreateEndpoint -- = "Create" -- :> ReqBody '[JSON] (NamedField1 "Customer_Create" Name Email) -- :> Post '[JSON] CustomerKey mkHandlerTypeDec :: ApiPiece -> ServerGenM [Dec] mkHandlerTypeDec p = enterApiPiece p $ do case p of Endpoint name args varBindings hs Immutable retType -> do -- Get endpoint will use query parameters ty <- do queryParams <- mkQueryParams args let reqReturn = mkVerb hs $ mkReturnType retType bird <- liftQ [t|(:>)|] let stuff = foldr1 joinUrlParts $ queryParams <> [reqReturn] joinUrlParts :: Type -> Type -> Type joinUrlParts a b = bird `AppT` a `AppT` b urlSegment <- mkUrlSegment name liftQ $ prependServerEndpointName urlSegment stuff epTypeName <- askEndpointTypeName pure [TySynD epTypeName (getUsedTyVars (toTyVarBndr varBindings) ty) ty] Endpoint name args varBindings hs Mutable retType -> do -- Non-get endpoints use a request body ty <- do reqBody <- mkReqBody hs name args let reqReturn = mkReturnType retType middle <- case reqBody of Nothing -> pure $ mkVerb hs reqReturn Just b -> liftQ [t|$(pure b) :> $(pure $ mkVerb hs reqReturn)|] urlSegment <- mkUrlSegment name liftQ $ prependServerEndpointName urlSegment middle epTypeName <- askEndpointTypeName pure [TySynD epTypeName (getUsedTyVars (toTyVarBndr varBindings) ty) ty] SubApi _name args spec' -> enterApi spec' $ do _ <- mkQueryParams args -- Make sure we take into account what parameters have already been used. -- Skip this and we could end up generating APIs with multiple -- QueryParams with the same name, which servant will accept and use one -- one the values for both parameters. mkServerFromSpec spec' guardUniqueParamName :: String -> ServerGenM () guardUniqueParamName paramName = do existingNames <- gets (^. field @"usedParamNames") when (paramName `elem` existingNames) $ do info <- gets (^. field @"info") let problematicConstructor = info ^. field @"currentGadt" . typed @Name . to show problematicParentConstructors = L.intercalate "->" $ info ^.. field @"parentConstructors" . folded . typed @Name . to show fail $ "Duplicate query parameters with name " <> show paramName <> " in Action " <> show problematicConstructor <> " with constructor hierarcy " <> show problematicParentConstructors modify $ over (field @"usedParamNames") (S.insert paramName) mkQueryParams :: ConstructorArgs -> ServerGenM [QueryParamType] mkQueryParams (ConstructorArgs args) = do may <- liftQ [t|Maybe|] -- Maybe parameters are optional, others required for args $ \case (name, AppT may' ty) | may' == may -> do guardUniqueParamName name liftQ [t| QueryParam' '[Optional, Servant.Strict] $(pure . LitT . StrTyLit $ name) $(pure ty) |] (name, ty) -> do guardUniqueParamName name liftQ [t| QueryParam' '[Required, Servant.Strict] $(pure . LitT . StrTyLit $ name) $(pure ty) |] type QueryParamType = Type updateConstructorTypes :: (Type -> Type) -> Con -> Con updateConstructorTypes f = \case NormalC n bts -> NormalC n (fmap (fmap f) bts) RecC n vbt -> RecC n (fmap (fmap f) vbt) InfixC bt1 n bt2 -> InfixC bt1 n bt2 ForallC b cxt' c -> ForallC b cxt' (updateConstructorTypes f c) GadtC n bts ty -> GadtC n (fmap (fmap f) bts) (f ty) RecGadtC n vbt ty -> RecGadtC n (fmap (fmap f) vbt) (f ty) mkVerb :: HandlerSettings -> Type -> Type mkVerb (HandlerSettings _ verb) ret = verb `AppT` ret -- | Declare then handlers for the API mkServerDec :: ApiSpec -> ServerGenM [Dec] mkServerDec spec = do (apiTypeName, apiParams) <- askApiNameAndParams spec serverName <- askServerName let runnerName :: Name runnerName = mkName "runner" actionRunner' :: Type actionRunner' = ConT ''ActionRunner `AppT` VarT runnerMonadName `AppT` ( spec ^. field @"gadtType" . typed ) server :: Type server = ConT ''ServerT `AppT` applyTyVars (ConT apiTypeName) apiParams `AppT` VarT runnerMonadName serverType :: Type serverType = withForall (spec ^. field' @"allVarBindings" . field @"extra") (ArrowT `AppT` actionRunner' `AppT` server) let serverSigDec :: Dec serverSigDec = SigD serverName serverType mkHandlerExp :: ApiPiece -> ServerGenM Exp mkHandlerExp p = enterApiPiece p $ do n <- askHandlerName pure $ VarE n `AppE` VarE runnerName handlers <- traverse mkHandlerExp (spec ^. typed @[ApiPiece]) body <- case reverse handlers of -- :<|> is right associative [] -> fail "Server contains no endpoints" e : es -> liftQ $ foldM (\b a -> [|$(pure a) :<|> $(pure b)|]) e es let serverFunDec :: Dec serverFunDec = FunD serverName [Clause [VarP runnerName] (NormalB body) []] serverHandlerDecs <- mconcat <$> traverse (mkApiPieceHandler (gadtType spec)) (spec ^. typed @[ApiPiece]) pure $ serverSigDec : serverFunDec : serverHandlerDecs -- | Get the subset of type varaibes used ty a type, in the roder they're applied -- Used to avoid rendundant type variables in the forall statement of sub-servers getUsedTyVars :: forall flag. [TyVarBndr flag] -> Type -> [TyVarBndr flag] getUsedTyVars bindings ty = getUsedTyVarNames ty ^.. folded . to (`M.lookup` m) . _Just where m :: M.Map Name (TyVarBndr flag) m = M.fromList $ zip (fmap getName bindings) bindings getName :: TyVarBndr flag -> Name getName = \case PlainTV n _ -> n KindedTV n _ _ -> n -- | Get the type variables (VarT) used in a type, returned in the order they're -- referenced getUsedTyVarNames :: Type -> [Name] getUsedTyVarNames ty' = L.nub $ case ty' of (AppT a b) -> on (<>) getUsedTyVarNames a b (ConT _) -> [] (VarT n) -> [n] ForallT _ _ ty -> getUsedTyVarNames ty ForallVisT _ ty -> getUsedTyVarNames ty AppKindT ty _ -> getUsedTyVarNames ty SigT ty _ -> getUsedTyVarNames ty PromotedT _ -> [] InfixT ty1 _ ty2 -> getUsedTyVarNames ty1 <> getUsedTyVarNames ty2 UInfixT ty1 _ ty2 -> getUsedTyVarNames ty1 <> getUsedTyVarNames ty2 ParensT ty -> getUsedTyVarNames ty TupleT _ -> [] UnboxedTupleT _ -> [] UnboxedSumT _ -> [] ArrowT -> [] MulArrowT -> [] EqualityT -> [] ListT -> [] PromotedTupleT _ -> [] PromotedNilT -> [] PromotedConsT -> [] StarT -> [] ConstraintT -> [] LitT _ -> [] WildCardT -> [] ImplicitParamT _ ty -> getUsedTyVarNames ty withForall :: [TyVarBndr ()] -> Type -> Type withForall extra ty = ForallT bindings varConstraints ty where bindings :: [TyVarBndr Specificity] bindings = KindedTV runnerMonadName SpecifiedSpec (ArrowT `AppT` StarT `AppT` StarT) : ( getUsedTyVars extra ty & traversed %~ \case PlainTV n _ -> PlainTV n SpecifiedSpec KindedTV n _ k -> KindedTV n SpecifiedSpec k ) varConstraints :: [Type] varConstraints = [ConT ''MonadUnliftIO `AppT` VarT runnerMonadName] actionRunner :: Type -> Type actionRunner runnerGADT = ConT ''ActionRunner `AppT` VarT runnerMonadName `AppT` runnerGADT runnerMonadName :: Name runnerMonadName = mkName "m" mkNamedFieldsType :: ConstructorName -> ConstructorArgs -> ServerGenM (Maybe Type) mkNamedFieldsType cName = \case ConstructorArgs [] -> pure Nothing ConstructorArgs args -> do bodyTag <- askBodyTag cName let nfType :: Type nfType = AppT (ConT nfName) (LitT bodyTag) nfName :: Name nfName = mkName $ "NF" <> show (length args) addNFxParam :: Type -> (String, Type) -> Type addNFxParam nfx (name, ty) = AppT (AppT nfx (LitT $ StrTyLit name)) ty pure . Just $ foldl addNFxParam nfType args mkQueryHandlerSignature :: GadtType -> ConstructorArgs -> EpReturnType -> Type mkQueryHandlerSignature gadt@(GadtType actionType) (ConstructorArgs args) (EpReturnType retType) = withForall (either (const []) id $ gadtTypeParams gadt) $ mkFunction $ actionRunner actionType : fmap snd args <> [ret] where ret :: Type ret = AppT (VarT runnerMonadName) retType -- | Makes command handler, e.g. -- counterCmd_AddToCounterHandler :: -- ActionRunner m CounterCmd -> NamedFields1 "CounterCmd_AddToCounter" Int -> m Int mkCmdHandlerSignature :: GadtType -> ConstructorName -> ConstructorArgs -> EpReturnType -> ServerGenM Type mkCmdHandlerSignature gadt cName cArgs (EpReturnType retType) = do nfArgs <- mkNamedFieldsType cName cArgs pure $ withForall (either (const []) id $ gadtTypeParams gadt) $ mkFunction $ [actionRunner (gadt ^. typed)] <> maybe [] pure nfArgs <> [ret] where ret :: Type ret = AppT (VarT runnerMonadName) $ case retType of TupleT 0 -> ConT ''NoContent ty -> ty mkFunction :: [Type] -> Type mkFunction = foldr1 (\a b -> ArrowT `AppT` a `AppT` b) sortAndExcludeBindings :: [TyVarBndr Specificity] -> Type -> Either String [TyVarBndr Specificity] sortAndExcludeBindings bindings ty = do varOrder <- varNameOrder ty let m :: M.Map Name Int m = M.fromList $ zip varOrder [1 ..] Right $ fmap fst . catMaybes $ bindings ^.. folded . to (\a -> (a,) <$> M.lookup (a ^. typed) m) varNameOrder :: Type -> Either String [Name] varNameOrder = \case ConT _ -> Right [] VarT n -> Right [n] (AppT a b) -> (<>) <$> varNameOrder a <*> varNameOrder b crap -> Left $ "sortAndExcludeBindings: " <> show crap gadtTypeParams :: GadtType -> Either String [TyVarBndr ()] gadtTypeParams = fmap (fmap (`PlainTV` ())) . varNameOrder . (^. typed) -- | Define the servant handler for an enpoint or referens the subapi with path -- parameters applied mkApiPieceHandler :: GadtType -> ApiPiece -> ServerGenM [Dec] mkApiPieceHandler gadt apiPiece = enterApiPiece apiPiece $ do case apiPiece of Endpoint _cName cArgs _ _hs Immutable ty -> do let nrArgs :: Int nrArgs = length $ cArgs ^. typed @[(String, Type)] varNames <- liftQ $ replicateM nrArgs (newName "arg") handlerName <- askHandlerName runnerName <- liftQ $ newName "runner" let funSig :: Dec funSig = SigD handlerName $ mkQueryHandlerSignature gadt cArgs ty funBodyBase = AppE (VarE runnerName) $ foldl AppE (ConE $ apiPiece ^. typed @ConstructorName . typed) (fmap VarE varNames) funBody = case ty ^. typed of TupleT 0 -> [|fmap (const NoContent) $(pure funBodyBase)|] _ -> pure $ funBodyBase funClause <- liftQ $ clause (fmap (pure . VarP) (runnerName : varNames)) (normalB [|$(funBody)|]) [] pure [funSig, FunD handlerName [funClause]] Endpoint cName cArgs _ hs Mutable ty | hasJsonContentType hs -> do let nrArgs :: Int nrArgs = length $ cArgs ^. typed @[(String, Type)] varNames <- liftQ $ replicateM nrArgs (newName "arg") handlerName <- askHandlerName runnerName <- liftQ $ newName "runner" let varPat :: Pat varPat = ConP nfName [] (fmap VarP varNames) nfName :: Name nfName = mkName $ "NF" <> show nrArgs funSig <- SigD handlerName <$> mkCmdHandlerSignature gadt cName cArgs ty let funBodyBase = AppE (VarE runnerName) $ foldl AppE (ConE $ apiPiece ^. typed @ConstructorName . typed) (fmap VarE varNames) funBody = case ty ^. typed of TupleT 0 -> [|fmap (const NoContent) $(pure funBodyBase)|] _ -> pure $ funBodyBase funClause <- liftQ $ clause (pure (VarP runnerName) : [pure varPat | nrArgs > 0]) (normalB [|$(funBody)|]) [] pure [funSig, FunD handlerName [funClause]] Endpoint _cName cArgs _ _hs Mutable ty -> do let nrArgs :: Int nrArgs = length $ cArgs ^. typed @[(String, Type)] unless (nrArgs < 2) $ fail "Only one argument is supported for non-JSON request bodies" varName <- liftQ $ newName "arg" handlerName <- askHandlerName runnerName <- liftQ $ newName "runner" let varPat :: Pat varPat = VarP varName let funSig :: Dec funSig = SigD handlerName $ mkQueryHandlerSignature gadt cArgs ty funBodyBase = AppE (VarE runnerName) $ AppE (ConE $ apiPiece ^. typed @ConstructorName . typed) (VarE varName) funBody = case ty ^. typed of TupleT 0 -> [|fmap (const NoContent) $(pure funBodyBase)|] _ -> pure $ funBodyBase funClause <- liftQ $ clause (pure (VarP runnerName) : [pure varPat | nrArgs > 0]) (normalB [|$(funBody)|]) [] pure [funSig, FunD handlerName [funClause]] SubApi cName cArgs spec -> do -- Apply the arguments to the constructor before referencing the subserver varNames <- liftQ $ replicateM (length (cArgs ^. typed @[(String, Type)])) (newName "arg") handlerName <- askHandlerName (targetApiTypeName, targetApiParams) <- enterApi spec (askApiNameAndParams spec) targetServer <- enterApi spec askServerName runnerName <- liftQ $ newName "runner" funSig <- liftQ $ do let params = withForall (spec ^. field @"allVarBindings" . field @"extra") $ mkFunction $ [actionRunner (gadt ^. typed)] <> cArgs ^.. typed @[(String, Type)] . folded . _2 <> [ ConT ''ServerT `AppT` applyTyVars (ConT targetApiTypeName) targetApiParams `AppT` VarT runnerMonadName ] pure (SigD handlerName params) funClause <- liftQ $ do let cmd = foldl AppE (ConE $ cName ^. typed) (fmap VarE varNames) in clause (varP <$> runnerName : varNames) ( fmap NormalB [e| $(varE targetServer) ($(varE runnerName) . $(pure cmd)) |] ) [] let funDef = FunD handlerName [funClause] pure [funSig, funDef] ---- | This is the only layer of the ReaderT stack where we do not use `local` to update the ---- url segments. mkServerFromSpec :: ApiSpec -> ServerGenM [Dec] mkServerFromSpec spec = enterApi spec $ do apiTypeDecs <- mkApiTypeDecs spec serverDecs <- mkServerDec spec pure $ apiTypeDecs <> serverDecs -- | Handles the special case of `()` being transformed into `NoContent` mkReturnType :: EpReturnType -> Type mkReturnType (EpReturnType ty) = case ty of TupleT 0 -> ConT ''NoContent _ -> ty prependServerEndpointName :: UrlSegment -> Type -> Q Type prependServerEndpointName prefix rest = [t|$(pure $ LitT . StrTyLit $ prefix ^. typed) :> $(pure $ rest)|] mkReqBody :: HandlerSettings -> ConstructorName -> ConstructorArgs -> ServerGenM (Maybe Type) mkReqBody hs name args = if hasJsonContentType hs then do body <- mkNamedFieldsType name args case body of Nothing -> pure Nothing Just b -> Just <$> liftQ [t|ReqBody '[JSON] $(pure b)|] else do let body = case args of ConstructorArgs [] -> Nothing ConstructorArgs [(_, t)] -> Just t ConstructorArgs _ -> fail "Multiple arguments are only supported for JSON content" case body of Nothing -> pure Nothing Just b -> Just <$> liftQ [t|ReqBody $(pure $ hs ^. field @"contentTypes") $(pure b)|]