diff --git a/servant-purescript.cabal b/servant-purescript.cabal --- a/servant-purescript.cabal +++ b/servant-purescript.cabal @@ -1,5 +1,5 @@ name: servant-purescript -version: 0.3.0.0 +version: 0.3.1.0 synopsis: Generate PureScript accessor functions for you servant API description: Please see README.md homepage: https://github.com/eskimor/servant-purescript#readme @@ -20,6 +20,7 @@ exposed-modules: Servant.PureScript.Internal , Servant.PureScript.CodeGen , Servant.PureScript.Subscriber + , Servant.PureScript.MakeRequests , Servant.PureScript , Servant.API.BrowserHeader diff --git a/src/Servant/PureScript.hs b/src/Servant/PureScript.hs --- a/src/Servant/PureScript.hs +++ b/src/Servant/PureScript.hs @@ -44,10 +44,11 @@ import Servant.PureScript.CodeGen import Servant.PureScript.Internal import qualified Servant.PureScript.Subscriber as SubGen +import qualified Servant.PureScript.MakeRequests as MakeRequests import System.Directory import System.FilePath import System.IO (IOMode (..), withFile) -import Text.PrettyPrint.Mainland (hPutDocLn) +import Text.PrettyPrint.Mainland (hPutDocLn, Doc) -- | Standard entry point - just create a purescript module with default settings -- for accessing the servant API. @@ -64,22 +65,22 @@ , HasBridge bridgeSelector ) => Settings -> FilePath -> Proxy bridgeSelector -> Proxy api -> IO () writeAPIModuleWithSettings opts root pBr pAPI = do - let apiList = apiToList pAPI pBr - let contents = genModule opts apiList - unlessM (doesDirectoryExist mDir) $ createDirectoryIfMissing True mDir - withFile mPath WriteMode $ flip hPutDocLn contents + writeModule (opts ^. apiModuleName) genModule when (opts ^. generateSubscriberAPI) $ do - let msContents = SubGen.genModule opts apiList - unlessM (doesDirectoryExist msDir) $ createDirectoryIfMissing True msDir - withFile msPath WriteMode $ flip hPutDocLn msContents + writeModule (opts ^. apiModuleName <> ".Subscriber") SubGen.genModule + writeModule (opts ^. apiModuleName <> ".MakeRequests") MakeRequests.genModule where - moduleToFile mName = (joinPath . map T.unpack . T.splitOn "." $ mName) <> ".purs" - mFile = moduleToFile $ _apiModuleName opts - msFile = moduleToFile $ _apiModuleName opts <> ".Subscriber" - mPath = root mFile - msPath = root msFile - mDir = takeDirectory mPath - msDir = takeDirectory msPath + apiList = apiToList pAPI pBr + + writeModule :: Text -> (Settings -> [Req PSType] -> Doc) -> IO () + writeModule mName genModule' = let + fileName = (joinPath . map T.unpack . T.splitOn "." $ mName) <> ".purs" + mPath = root fileName + mDir = takeDirectory mPath + contents = genModule' opts apiList + in do + unlessM (doesDirectoryExist mDir) $ createDirectoryIfMissing True mDir + withFile mPath WriteMode $ flip hPutDocLn contents -- | Use this function for implementing 'parseUrlPiece' in your FromHttpApiData instances diff --git a/src/Servant/PureScript/MakeRequests.hs b/src/Servant/PureScript/MakeRequests.hs new file mode 100644 --- /dev/null +++ b/src/Servant/PureScript/MakeRequests.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +-- TODO: This module duplicates quite a lot of code from CodeGen.hs. +module Servant.PureScript.MakeRequests where + +import Control.Lens hiding (List) +import Data.Map (Map) +import Data.Maybe (mapMaybe, maybeToList) +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Language.PureScript.Bridge +import Language.PureScript.Bridge (buildBridge, defaultBridge) +import Language.PureScript.Bridge.PSTypes (psString, psUnit) +import Network.HTTP.Types.URI (urlEncode) +import Servant.Foreign +import Servant.PureScript.CodeGen hiding (genBuildHeader, + genBuildHeaders, + genBuildPath, + genBuildQuery, + genBuildQueryArg, + genBuildSegment, genFnBody, + genFunction, genModule, + genSignature) +import Servant.PureScript.Internal +import Servant.Subscriber.Request (HttpRequest) +import Text.PrettyPrint.Mainland + +subscriberImportLines :: Map Text ImportLine +subscriberImportLines = importsFromList + [ + ImportLine "Servant.Subscriber.Subscriptions" (Set.fromList [ "Subscriptions" + , "makeSubscriptions" + ]) + , ImportLine "Servant.Subscriber.Util" (Set.fromList [ "toUserType" + , "subGenNormalQuery" + , "subGenListQuery" + , "subGenFlagQuery" + , "TypedToUser" + ]) + , ImportLine "Servant.Subscriber" (Set.fromList ["ToUserType"]) + , ImportLine "Servant.Subscriber.Request" (Set.fromList ["HttpRequest(..)"]) + , ImportLine "Servant.Subscriber.Types" (Set.fromList ["Path(..)"]) + , ImportLine "Data.Tuple" (Set.fromList ["Tuple(..)"]) + ] + +genModule :: Settings -> [Req PSType] -> Doc +genModule opts reqs = let + allParams = concatMap reqToParams reqs + rParams = getReaderParams opts allParams + apiImports = reqsToImportLines reqs + webAPIImports = importsFromList [ + ImportLine (opts ^. apiModuleName) (Set.fromList ["SPParams_(..)"]) + ] + imports = _standardImports opts + `mergeImportLines` apiImports + `mergeImportLines` subscriberImportLines + `mergeImportLines` webAPIImports + moduleName = _apiModuleName opts <> ".MakeRequests" + in + genModuleHeader moduleName imports + (docIntercalate line . map (genFunction rParams)) reqs + +genFunction :: [PSParam] -> Req PSType -> Doc +genFunction allRParams req = let + rParamsSet = Set.fromList allRParams + fnName = req ^. reqFuncName ^. camelCaseL + allParamsList = baseURLParam : reqToParams req + allParams = Set.fromList allParamsList + fnParams = filter (not . flip Set.member rParamsSet) allParamsList -- Use list not set, as we don't want to change order of parameters + rParams = Set.toList $ rParamsSet `Set.intersection` allParams + + pTypes = map _pType fnParams + pNames = map _pName fnParams + signature = genSignature fnName pTypes (Just psHttpRequest) + body = genFnHead fnName pNames <+> genFnBody rParams req + in signature body + + +genSignature :: Text -> [PSType] -> Maybe PSType -> Doc +genSignature = genSignatureBuilder $ "forall m." <+/> "MonadReader (SPSettings_ SPParams_) m" <+/> "=>" + +genFnBody :: [PSParam] -> Req PSType -> Doc +genFnBody rParams req = "do" + indent 2 ( + "spOpts_' <- ask" + "let spOpts_ = case spOpts_' of SPSettings_ o -> o" + "let spParams_ = case spOpts_.params of SPParams_ ps_ -> ps_" + genGetReaderParams rParams + hang 6 ("let httpMethod =" <+> dquotes (req ^. reqMethod ^. to T.decodeUtf8 ^. to strictText)) + hang 6 ("let reqPath =" <+> genBuildPath (req ^. reqUrl . path)) + "let reqHeaders =" indent 6 (req ^. reqHeaders ^. to genBuildHeaders) + "let reqQuery =" indent 6 (req ^. reqUrl ^. queryStr . to genBuildQuery) + "let spReq = " <> hang 2 ("HttpRequest" + "{ httpMethod:" <+> "httpMethod" + ", httpPath:" <+> "reqPath" + ", httpHeaders:" <+> "reqHeaders" + ", httpQuery:" <+> "reqQuery" + ", httpBody:" <+> case req ^. reqBody of + Nothing -> "\"\"" + Just _ -> "printJson <<< encodeJson $ reqBody" + "}") + "pure spReq" + ) <> "\n" + +---------- +genBuildPath :: Path PSType -> Doc +genBuildPath p = "Path [" + <> (docIntercalate (softline <> ", ") . map (genBuildSegment . unSegment)) p + <> "]" + +genBuildSegment :: SegmentType PSType -> Doc +genBuildSegment (Static (PathSegment seg)) = dquotes $ strictText seg +genBuildSegment (Cap arg) = "gDefaultToURLPiece" <+> arg ^. argName ^. to unPathSegment ^. to psVar + +---------- +genBuildQuery :: [QueryArg PSType] -> Doc +genBuildQuery [] = "[]" +genBuildQuery args = docIntercalate (softline <> "<> ") . map genBuildQueryArg $ args + +genBuildQueryArg :: QueryArg PSType -> Doc +genBuildQueryArg arg = case arg ^. queryArgType of + Normal -> genQueryEncoding "subGenNormalQuery" + Flag -> genQueryEncoding "subGenFlagQuery" + List -> genQueryEncoding "subGenListQuery" + where + argText = arg ^. queryArgName ^. argName ^. to unPathSegment + argDoc = strictText argText + genQueryEncoding fn = fn <+> dquotes argDoc <+> psVar argText + +----------- + +genBuildHeaders :: [HeaderArg PSType] -> Doc +genBuildHeaders = list . map genBuildHeader + +genBuildHeader :: HeaderArg PSType -> Doc +genBuildHeader (HeaderArg arg) = let + argText = arg ^. argName ^. to unPathSegment + argDoc = strictText argText + in + align $ "Tuple" <+> dquotes argDoc <+> "(gDefaultToURLPiece" <+> psVar argText <> ")" +genBuildHeader (ReplaceHeaderArg _ _) = error "ReplaceHeaderArg - not yet implemented!" + + + +psHttpRequest :: PSType +psHttpRequest = let + haskType' = mkTypeInfo (Proxy :: Proxy HttpRequest) + bridge = buildBridge defaultBridge + in + bridge haskType' diff --git a/src/Servant/PureScript/Subscriber.hs b/src/Servant/PureScript/Subscriber.hs --- a/src/Servant/PureScript/Subscriber.hs +++ b/src/Servant/PureScript/Subscriber.hs @@ -6,7 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} --- TODO: This module duplicates quite a lot of code from CodeGen.hs. +-- TODO: This module duplicates quite a lot of code from MakeRequests.hs. module Servant.PureScript.Subscriber where import Control.Lens hiding (List) @@ -20,35 +20,18 @@ import Language.PureScript.Bridge.PSTypes (psString, psUnit) import Network.HTTP.Types.URI (urlEncode) import Servant.Foreign -import Servant.PureScript.CodeGen hiding (genBuildHeader, - genBuildHeaders, - genBuildPath, - genBuildQuery, - genBuildQueryArg, - genBuildSegment, genFnBody, +import Servant.PureScript.CodeGen (docIntercalate, genFnHead, + genModuleHeader, + getReaderParams, psVar, + reqToParams, + reqsToImportLines, + genSignatureBuilder) +import Servant.PureScript.Internal +import Servant.PureScript.MakeRequests hiding (genFnBody, genFunction, genModule, genSignature) -import Servant.PureScript.Internal import Text.PrettyPrint.Mainland -subscriberImportLines :: Map Text ImportLine -subscriberImportLines = importsFromList - [ - ImportLine "Servant.Subscriber.Subscriptions" (Set.fromList [ "Subscriptions" - , "makeSubscriptions" - ]) - , ImportLine "Servant.Subscriber.Util" (Set.fromList [ "toUserType" - , "subGenNormalQuery" - , "subGenListQuery" - , "subGenFlagQuery" - , "TypedToUser" - ]) - , ImportLine "Servant.Subscriber" (Set.fromList ["ToUserType"]) - , ImportLine "Servant.Subscriber.Request" (Set.fromList ["HttpRequest(..)"]) - , ImportLine "Servant.Subscriber.Types" (Set.fromList ["Path(..)"]) - , ImportLine "Data.Tuple" (Set.fromList ["Tuple(..)"]) - ] - genModule :: Settings -> [Req PSType] -> Doc genModule opts allReqs = let isSubscribable :: Req PSType -> Bool @@ -67,6 +50,8 @@ moduleName = _apiModuleName opts <> ".Subscriber" in genModuleHeader moduleName imports + "import" <+> opts ^. apiModuleName . to strictText <> ".MakeRequests as MakeRequests" + "" (docIntercalate line . map (genFunction rParams)) reqs genFunction :: [PSParam] -> Req PSType -> Doc @@ -77,79 +62,28 @@ Nothing -> psUnit Just t -> t allParamsList = makeTypedToUserParam responseType : baseURLParam : reqToParams req - allParams = Set.fromList allParamsList fnParams = filter (not . flip Set.member rParamsSet) allParamsList -- Use list not set, as we don't want to change order of parameters - rParams = Set.toList $ rParamsSet `Set.intersection` allParams pTypes = map _pType fnParams pNames = map _pName fnParams signature = genSignature fnName pTypes (Just psSubscriptions) - body = genFnHead fnName pNames <+> genFnBody rParams req + -- | Well - if you really want to put the ToUserType parameter into the Reader monad - this will crash: + body = genFnHead fnName pNames <+> genFnBody fnName (tail pNames) in signature body genSignature :: Text -> [PSType] -> Maybe PSType -> Doc genSignature = genSignatureBuilder $ "forall m a." <+/> "MonadReader (SPSettings_ SPParams_) m" <+/> "=>" -genFnBody :: [PSParam] -> Req PSType -> Doc -genFnBody rParams req = "do" - indent 2 ( - "spOpts_' <- ask" - "let spOpts_ = case spOpts_' of SPSettings_ o -> o" - "let spParams_ = case spOpts_.params of SPParams_ ps_ -> ps_" - genGetReaderParams rParams - hang 6 ("let httpMethod =" <+> dquotes (req ^. reqMethod ^. to T.decodeUtf8 ^. to strictText)) - hang 6 ("let reqPath =" <+> genBuildPath (req ^. reqUrl . path)) - "let reqHeaders =" indent 6 (req ^. reqHeaders ^. to genBuildHeaders) - "let reqQuery =" indent 6 (req ^. reqUrl ^. queryStr . to genBuildQuery) - "let spReq = " <> hang 2 ("HttpRequest" - "{ httpMethod:" <+> "httpMethod" - ", httpPath:" <+> "reqPath" - ", httpHeaders:" <+> "reqHeaders" - ", httpQuery:" <+> "reqQuery" - ", httpBody:" <+> case req ^. reqBody of - Nothing -> "\"\"" - Just _ -> "printJson <<< encodeJson $ reqBody" - "}") - "pure $ makeSubscriptions spReq (toUserType " <> strictText subscriberToUserId <> ")" - ) - ----------- -genBuildPath :: Path PSType -> Doc -genBuildPath p = "Path [" - <> (docIntercalate (softline <> ", ") . map (genBuildSegment . unSegment)) p - <> "]" - -genBuildSegment :: SegmentType PSType -> Doc -genBuildSegment (Static (PathSegment seg)) = dquotes $ strictText seg -genBuildSegment (Cap arg) = "gDefaultToURLPiece" <+> arg ^. argName ^. to unPathSegment ^. to psVar - ----------- -genBuildQuery :: [QueryArg PSType] -> Doc -genBuildQuery [] = "[]" -genBuildQuery args = docIntercalate (softline <> "<> ") . map genBuildQueryArg $ args +genFnBody :: Text -> [Text] -> Doc +genFnBody fName params = "do" + indent 2 ( + "spReq <- MakeRequests." <> genFnCall fName params + "pure $ makeSubscriptions spReq (toUserType " <> strictText subscriberToUserId <> ")" + ) <> "\n" -genBuildQueryArg :: QueryArg PSType -> Doc -genBuildQueryArg arg = case arg ^. queryArgType of - Normal -> genQueryEncoding "subGenNormalQuery" - Flag -> genQueryEncoding "subGenFlagQuery" - List -> genQueryEncoding "subGenListQuery" +genFnCall :: Text -> [Text] -> Doc +genFnCall fnName params = fName <+> align (docIntercalate softline docParams) where - argText = arg ^. queryArgName ^. argName ^. to unPathSegment - argDoc = strictText argText - genQueryEncoding fn = fn <+> dquotes argDoc <+> psVar argText - ------------ - -genBuildHeaders :: [HeaderArg PSType] -> Doc -genBuildHeaders = list . map genBuildHeader - -genBuildHeader :: HeaderArg PSType -> Doc -genBuildHeader (HeaderArg arg) = let - argText = arg ^. argName ^. to unPathSegment - argDoc = strictText argText - in - align $ "Tuple" <+> dquotes argDoc <+> "(gDefaultToURLPiece" <+> psVar argText <> ")" -genBuildHeader (ReplaceHeaderArg _ _) = error "ReplaceHeaderArg - not yet implemented!" - - + docParams = map psVar params + fName = strictText fnName