module Servant.PureScript.MakeRequests where
import Control.Lens hiding (List)
import Data.Map (Map)
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 (ImportLine (..),
PSType,
buildBridge,
defaultBridge,
importsFromList,
mergeImportLines,
mkTypeInfo)
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 ^. jsCamelCaseL
allParamsList = baseURLParam : reqToParams req
allParams = Set.fromList allParamsList
fnParams = filter (not . flip Set.member rParamsSet) allParamsList
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." <+/> "MonadAsk (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 _ -> "stringify <<< 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'