diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -18,11 +18,10 @@ It works! -Documentation is yet to come, but there is a usage example in examples/central-counter -which also employs a very early version of servant-subscriber -used for counter live updates. -The PureScript side of servant-subscriber is very low-level and will -change significantly in the future. +Documentation is yet to come, but there is a usage example in +examples/central-counter which also uses servant-subscriber used for counter +live updates. Generated code is only partly tested, especially Query parameters +are completely untested. For type translations purescript-bridge is used. 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.2.0.1 +version: 0.3.0.0 synopsis: Generate PureScript accessor functions for you servant API description: Please see README.md homepage: https://github.com/eskimor/servant-purescript#readme @@ -19,6 +19,7 @@ hs-source-dirs: src exposed-modules: Servant.PureScript.Internal , Servant.PureScript.CodeGen + , Servant.PureScript.Subscriber , Servant.PureScript , Servant.API.BrowserHeader @@ -32,7 +33,7 @@ , http-types , lens , mainland-pretty - , purescript-bridge >= 0.6 && < 0.7 + , purescript-bridge >= 0.6 , servant , servant-foreign , servant-server @@ -50,7 +51,7 @@ , containers , mainland-pretty , lens - , purescript-bridge >= 0.6 && < 0.7 + , purescript-bridge >= 0.6 , servant , servant-foreign , servant-purescript diff --git a/src/Servant/PureScript.hs b/src/Servant/PureScript.hs --- a/src/Servant/PureScript.hs +++ b/src/Servant/PureScript.hs @@ -27,25 +27,30 @@ ) where +import Control.Lens +import Control.Monad (when) import Data.Aeson import Data.Bifunctor -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as BS +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BS import Data.Monoid import Data.Proxy -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Language.PureScript.Bridge -import Network.HTTP.Types (urlDecode, urlEncode) +import Network.HTTP.Types (urlDecode, urlEncode) import Servant.Foreign import Servant.PureScript.CodeGen import Servant.PureScript.Internal +import qualified Servant.PureScript.Subscriber as SubGen import System.Directory import System.FilePath -import System.IO (IOMode (..), withFile) -import Text.PrettyPrint.Mainland (hPutDocLn) +import System.IO (IOMode (..), withFile) +import Text.PrettyPrint.Mainland (hPutDocLn) +-- | Standard entry point - just create a purescript module with default settings +-- for accessing the servant API. writeAPIModule :: forall bridgeSelector api. ( HasForeign (PureScript bridgeSelector) PSType api , GenerateList PSType (Foreign PSType api) @@ -63,10 +68,18 @@ let contents = genModule opts apiList unlessM (doesDirectoryExist mDir) $ createDirectoryIfMissing True mDir withFile mPath WriteMode $ flip hPutDocLn contents + when (opts ^. generateSubscriberAPI) $ do + let msContents = SubGen.genModule opts apiList + unlessM (doesDirectoryExist msDir) $ createDirectoryIfMissing True msDir + withFile msPath WriteMode $ flip hPutDocLn msContents where - mFile = (joinPath . map T.unpack . T.splitOn "." $ _apiModuleName opts) <> ".purs" + 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 -- | Use this function for implementing 'parseUrlPiece' in your FromHttpApiData instances diff --git a/src/Servant/PureScript/CodeGen.hs b/src/Servant/PureScript/CodeGen.hs --- a/src/Servant/PureScript/CodeGen.hs +++ b/src/Servant/PureScript/CodeGen.hs @@ -27,14 +27,19 @@ rParams = getReaderParams opts allParams apiImports = reqsToImportLines reqs imports = mergeImportLines (_standardImports opts) apiImports + in + genModuleHeader (_apiModuleName opts) imports + genParamSettings rParams <> line + (docIntercalate line . map (genFunction rParams)) reqs + +genModuleHeader :: Text -> ImportLines -> Doc +genModuleHeader moduleName imports = let importLines = map (strictText . importLineToText) . Map.elems $ imports in "-- File auto generated by servant-purescript! --" - "module" <+> strictText (_apiModuleName opts) <+> "where" <> line + "module" <+> strictText moduleName <+> "where" <> line "import Prelude" <> line docIntercalate line importLines <> line - genParamSettings rParams <> line - (docIntercalate line . map (genFunction rParams)) reqs getReaderParams :: Settings -> [PSParam] -> [PSParam] getReaderParams opts allParams = let @@ -83,10 +88,12 @@ genSignature :: Text -> [PSType] -> Maybe PSType -> Doc -genSignature fnName params mRet = fName <+> align (constraint <+/> parameterString) +genSignature = genSignatureBuilder $ "forall eff m." <+/> "(MonadReader (SPSettings_ SPParams_) m, MonadError AjaxError m, MonadAff ( ajax :: AJAX | eff) m)" <+/> "=>" + +genSignatureBuilder :: Doc -> Text -> [PSType] -> Maybe PSType -> Doc +genSignatureBuilder constraint fnName params mRet = fName <+> "::" <+> align (constraint <+/> parameterString) where fName = strictText fnName - constraint = ":: forall eff m." <+/> "(MonadReader (SPSettings_ SPParams_) m, MonadError AjaxError m, MonadAff ( ajax :: AJAX | eff) m)" <+/> "=>" retName = maybe "Unit" (strictText . typeInfoToText False) mRet retString = "m" <+> retName typeNames = map (strictText . typeInfoToText True) params diff --git a/src/Servant/PureScript/Internal.hs b/src/Servant/PureScript/Internal.hs --- a/src/Servant/PureScript/Internal.hs +++ b/src/Servant/PureScript/Internal.hs @@ -83,6 +83,9 @@ -- will be put in the Reader monad, all others will still be passed as function parameter. , _readerParams :: Set ParamName , _standardImports :: ImportLines + -- | If you want codegen for servant-subscriber, set this to True. See the central-counter example + -- for a simple usage case. +, _generateSubscriberAPI :: Bool } makeLenses ''Settings @@ -105,6 +108,7 @@ , ImportLine "Data.Maybe" (Set.fromList [ "Maybe(..)"]) , ImportLine "Data.Argonaut.Printer" (Set.fromList [ "printJson" ]) ] + , _generateSubscriberAPI = False } -- | Add a parameter name to be us put in the Reader monad instead of being passed to the @@ -118,6 +122,12 @@ baseURLParam :: PSParam baseURLParam = Param baseURLId psString +subscriberToUserId :: ParamName +subscriberToUserId = "spToUser_" + +makeTypedToUserParam :: PSType -> PSParam +makeTypedToUserParam response = Param subscriberToUserId (psTypedToUser response) + apiToList :: forall bridgeSelector api. ( HasForeign (PureScript bridgeSelector) PSType api , GenerateList PSType (Foreign PSType api) @@ -141,3 +151,27 @@ isValid c = isAlphaNum c || c == '_' in T.filter isValid + +psTypedToUser :: PSType -> PSType +psTypedToUser response = TypeInfo { + _typePackage = "purescript-subscriber" + , _typeModule = "Servant.Subscriber.Util" + , _typeName = "TypedToUser" + , _typeParameters = [response, psTypeParameterA] + } + +psSubscriptions :: PSType +psSubscriptions = TypeInfo { + _typePackage = "purescript-subscriber" + , _typeModule = "Servant.Subscriber.Subscriptions" + , _typeName = "Subscriptions" + , _typeParameters = [psTypeParameterA] + } + +psTypeParameterA :: PSType +psTypeParameterA = TypeInfo { + _typePackage = "" + , _typeModule = "" + , _typeName = "a" + , _typeParameters = [] + } diff --git a/src/Servant/PureScript/Subscriber.hs b/src/Servant/PureScript/Subscriber.hs new file mode 100644 --- /dev/null +++ b/src/Servant/PureScript/Subscriber.hs @@ -0,0 +1,155 @@ +{-# 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.Subscriber where + +import Control.Lens hiding (List) +import Data.Map (Map) +import Data.Maybe (mapMaybe, maybeToList) +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.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 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 + isSubscribable req = T.empty `elem` req ^.reqFuncName . to unFunctionName + reqs = filter isSubscribable allReqs + allParams = concatMap reqToParams allReqs + 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 <> ".Subscriber" + 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 + responseType = case req ^. reqReturnType of + 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 + 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 + +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!" + +