From ce3e4f71932550d6664f85d0d1f772e20dcd7218 Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Mon, 21 Sep 2015 13:31:00 +0300 Subject: [PATCH] Extract common code-generation stuff to servant-foreign --- servant-foreign/CHANGELOG.md | 4 + servant-foreign/LICENSE | 30 ++ servant-foreign/README.md | 5 + servant-foreign/Setup.hs | 2 + servant-foreign/servant-foreign.cabal | 29 ++ servant-foreign/src/Servant/Foreign.hs | 409 +++++++++++++++++ servant-js/servant-js.cabal | 44 +- servant-js/src/Servant/JS.hs | 16 +- servant-js/src/Servant/JS/Angular.hs | 1 + servant-js/src/Servant/JS/Axios.hs | 1 + servant-js/src/Servant/JS/Internal.hs | 415 ++---------------- servant-js/src/Servant/JS/JQuery.hs | 1 + servant-js/src/Servant/JS/Vanilla.hs | 1 + servant-js/test/Servant/JSSpec.hs | 4 +- .../test/Servant/JSSpec/CustomHeaders.hs | 26 +- sources.txt | 1 + stack.yaml | 1 + 17 files changed, 562 insertions(+), 428 deletions(-) create mode 100644 servant-foreign/CHANGELOG.md create mode 100644 servant-foreign/LICENSE create mode 100644 servant-foreign/README.md create mode 100644 servant-foreign/Setup.hs create mode 100644 servant-foreign/servant-foreign.cabal create mode 100644 servant-foreign/src/Servant/Foreign.hs diff --git a/servant-foreign/CHANGELOG.md b/servant-foreign/CHANGELOG.md new file mode 100644 index 00000000..f348e741 --- /dev/null +++ b/servant-foreign/CHANGELOG.md @@ -0,0 +1,4 @@ +0.1 +----- + +* Extract javascript-oblivious types and helpers to *servant-foreign* diff --git a/servant-foreign/LICENSE b/servant-foreign/LICENSE new file mode 100644 index 00000000..bfee8018 --- /dev/null +++ b/servant-foreign/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Zalora South East Asia Pte Ltd + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Zalora South East Asia Pte Ltd nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/servant-foreign/README.md b/servant-foreign/README.md new file mode 100644 index 00000000..e13ffe79 --- /dev/null +++ b/servant-foreign/README.md @@ -0,0 +1,5 @@ +# servant-foreign + +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) + +Types and helpers for generating clients for *servant* servers in arbitrary programming languages. diff --git a/servant-foreign/Setup.hs b/servant-foreign/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-foreign/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal new file mode 100644 index 00000000..3a4ac0de --- /dev/null +++ b/servant-foreign/servant-foreign.cabal @@ -0,0 +1,29 @@ +name: servant-foreign +version: 0.1.0.0 +synopsis: Abstract all necessary info for client code-generation in arbitrary programming language. +description: Consolidates such projects as servant-js and lackey. +license: BSD3 +license-file: LICENSE +author: Denis Redozubov +maintainer: denis.redozubov@gmail.com +copyright: 2015 Denis Redozubov, Alp Mestanogullari +category: Web +build-type: Simple +cabal-version: >=1.10 +extra-source-files: + CHANGELOG.md + README.md +source-repository head + type: git + location: http://github.com/haskell-servant/servant.git + +library + exposed-modules: Servant.Foreign + build-depends: base >=4.8 && <5 + , charset + , lens >= 4 + , servant >= 0.5 + , text + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall \ No newline at end of file diff --git a/servant-foreign/src/Servant/Foreign.hs b/servant-foreign/src/Servant/Foreign.hs new file mode 100644 index 00000000..78e85a7b --- /dev/null +++ b/servant-foreign/src/Servant/Foreign.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Generalizes all the data needed to make code generation work with +-- arbitrary programming languages. +module Servant.Foreign + ( HasForeign(..) + , Segment(..) + , SegmentType(..) + , MatrixArg + , FunctionName + , QueryArg(..) + , HeaderArg(..) + , ArgType(..) + , Req + , CommonGeneratorOptions(..) + , defCommonGeneratorOptions + , toValidFunctionName + , captureArg + , defReq + , concatCase + , snakeCase + , camelCase + -- lenses + , argType + , argName + , isCapture + , funcName + , path + , reqUrl + , reqBody + , reqHeaders + , reqMethod + , segment + , queryStr + -- re-exports + , module Servant.API + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Lens hiding (List) +import Data.Char (toLower, toUpper) +import qualified Data.CharSet as Set +import qualified Data.CharSet.Unicode.Category as Set +import Data.List +import Data.Monoid +import Data.Proxy +import qualified Data.Text as T +import GHC.Exts (Constraint) +import GHC.TypeLits +import Servant.API + +-- | This structure is used by specific implementations to let you +-- customize the output +data CommonGeneratorOptions = CommonGeneratorOptions + { + functionNameBuilder :: FunctionName -> String -- ^ function generating function names + , requestBody :: String -- ^ name used when a user want to send the request body (to let you redefine it) + , successCallback :: String -- ^ name of the callback parameter when the request was successful + , errorCallback :: String -- ^ name of the callback parameter when the request reported an error + , moduleName :: String -- ^ namespace on which we define the foreign function (empty mean local var) + , urlPrefix :: String -- ^ a prefix we should add to the Url in the codegen + } + +-- | Default options. +-- +-- @ +-- > defCommonGeneratorOptions = CommonGeneratorOptions +-- > { functionNameBuilder = camelCase +-- > , requestBody = "body" +-- > , successCallback = "onSuccess" +-- > , errorCallback = "onError" +-- > , moduleName = "" +-- > , urlPrefix = "" +-- > } +-- @ +defCommonGeneratorOptions :: CommonGeneratorOptions +defCommonGeneratorOptions = CommonGeneratorOptions + { + functionNameBuilder = camelCase + , requestBody = "body" + , successCallback = "onSuccess" + , errorCallback = "onError" + , moduleName = "" + , urlPrefix = "" + } + +-- | Function name builder that simply concat each part together +concatCase :: FunctionName -> String +concatCase = concat + +-- | Function name builder using the snake_case convention. +-- each part is separated by a single underscore character. +snakeCase :: FunctionName -> String +snakeCase = intercalate "_" + +-- | Function name builder using the CamelCase convention. +-- each part begins with an upper case character. +camelCase :: FunctionName -> String +camelCase [] = "" +camelCase (p:ps) = concat $ p : camelCase' ps + where camelCase' [] = [] + camelCase' (r:rs) = capitalize r : camelCase' rs + capitalize [] = [] + capitalize (x:xs) = toUpper x : xs + +type Arg = String + +data Segment = Segment { _segment :: SegmentType, _matrix :: [MatrixArg] } + deriving (Eq, Show) + +data SegmentType = Static String -- ^ a static path segment. like "/foo" + | Cap Arg -- ^ a capture. like "/:userid" + deriving (Eq, Show) + +type Path = [Segment] + +data ArgType = + Normal + | Flag + | List + deriving (Eq, Show) + +data QueryArg = QueryArg + { _argName :: Arg + , _argType :: ArgType + } deriving (Eq, Show) + +data HeaderArg = HeaderArg + { headerArgName :: String + } + | ReplaceHeaderArg + { headerArgName :: String + , headerPattern :: String + } deriving (Eq) + + +-- | +instance Show HeaderArg where + show (HeaderArg n) = toValidFunctionName ("header" <> n) + show (ReplaceHeaderArg n p) + | pn `isPrefixOf` p = pv <> " + \"" <> rp <> "\"" + | pn `isSuffixOf` p = "\"" <> rp <> "\" + " <> pv + | pn `isInfixOf` p = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p) + <> "\"" + | otherwise = p + where + pv = toValidFunctionName ("header" <> n) + pn = "{" <> n <> "}" + rp = replace pn "" p + -- Use replace method from Data.Text + replace old new = T.unpack . + T.replace (T.pack old) (T.pack new) . + T.pack + +-- | Attempts to reduce the function name provided to that allowed by @'Foreign'@. +-- +-- Here we are making an assumption that js identifiers are common enough. +-- https://mathiasbynens.be/notes/javascript-identifiers +-- Couldn't work out how to handle zero-width characters. +-- TODO: compare it with other generated languages(such as ruby via lackey) +-- and generalize. +-- +-- @TODO: specify better default function name, or throw error? +toValidFunctionName :: String -> String +toValidFunctionName (x:xs) = [setFirstChar x] <> filter remainder xs + where + setFirstChar c = if firstChar c + then c + else '_' + firstChar c = prefixOK c || any (Set.member c) firstLetterOK + remainder c = prefixOK c || any (Set.member c) remainderOK + -- Valid prefixes + prefixOK c = c `elem` ['$','_'] + -- Unicode character sets + firstLetterOK = [ Set.lowercaseLetter + , Set.uppercaseLetter + , Set.titlecaseLetter + , Set.modifierLetter + , Set.otherLetter + , Set.letterNumber ] + remainderOK = firstLetterOK <> [ Set.nonSpacingMark + , Set.spacingCombiningMark + , Set.decimalNumber + , Set.connectorPunctuation ] +toValidFunctionName [] = "_" + +type MatrixArg = QueryArg + +data Url = Url + { _path :: Path + , _queryStr :: [QueryArg] + } deriving (Eq, Show) + +defUrl :: Url +defUrl = Url [] [] + +type FunctionName = [String] +type Method = String + +data Req = Req + { _reqUrl :: Url + , _reqMethod :: Method + , _reqHeaders :: [HeaderArg] + , _reqBody :: Bool + , _funcName :: FunctionName + } deriving (Eq, Show) + +makeLenses ''QueryArg +makeLenses ''Segment +makeLenses ''Url +makeLenses ''Req + +isCapture :: Segment -> Bool +isCapture (Segment (Cap _) _) = True +isCapture _ = False + +captureArg :: Segment -> Arg +captureArg (Segment (Cap s) _) = s +captureArg _ = error "captureArg called on non capture" + +defReq :: Req +defReq = Req defUrl "GET" [] False [] + +type family Elem (a :: *) (ls::[*]) :: Constraint where + Elem a '[] = 'False ~ 'True + Elem a (a ': list) = () + Elem a (b ': list) = Elem a list + +class HasForeign (layout :: *) where + type Foreign layout :: * + foreignFor :: Proxy layout -> Req -> Foreign layout + +instance (HasForeign a, HasForeign b) + => HasForeign (a :<|> b) where + type Foreign (a :<|> b) = Foreign a :<|> Foreign b + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy a) req + :<|> foreignFor (Proxy :: Proxy b) req + +instance (KnownSymbol sym, HasForeign sublayout) + => HasForeign (Capture sym a :> sublayout) where + type Foreign (Capture sym a :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) $ + req & reqUrl.path <>~ [Segment (Cap str) []] + & funcName %~ (++ ["by", str]) + + where str = symbolVal (Proxy :: Proxy sym) + +instance Elem JSON list => HasForeign (Delete list a) where + type Foreign (Delete list a) = Req + + foreignFor Proxy req = + req & funcName %~ ("delete" :) + & reqMethod .~ "DELETE" + +instance Elem JSON list => HasForeign (Get list a) where + type Foreign (Get list a) = Req + + foreignFor Proxy req = + req & funcName %~ ("get" :) + & reqMethod .~ "GET" + +instance (KnownSymbol sym, HasForeign sublayout) + => HasForeign (Header sym a :> sublayout) where + type Foreign (Header sym a :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor subP (req & reqHeaders <>~ [HeaderArg hname]) + + where hname = symbolVal (Proxy :: Proxy sym) + subP = Proxy :: Proxy sublayout + +instance Elem JSON list => HasForeign (Post list a) where + type Foreign (Post list a) = Req + + foreignFor Proxy req = + req & funcName %~ ("post" :) + & reqMethod .~ "POST" + +instance Elem JSON list => HasForeign (Put list a) where + type Foreign (Put list a) = Req + + foreignFor Proxy req = + req & funcName %~ ("put" :) + & reqMethod .~ "PUT" + +instance (KnownSymbol sym, HasForeign sublayout) + => HasForeign (QueryParam sym a :> sublayout) where + type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) $ + req & reqUrl.queryStr <>~ [QueryArg str Normal] + + where str = symbolVal (Proxy :: Proxy sym) + +instance (KnownSymbol sym, HasForeign sublayout) + => HasForeign (QueryParams sym a :> sublayout) where + type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) $ + req & reqUrl.queryStr <>~ [QueryArg str List] + + where str = symbolVal (Proxy :: Proxy sym) + +instance (KnownSymbol sym, HasForeign sublayout) + => HasForeign (QueryFlag sym :> sublayout) where + type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) $ + req & reqUrl.queryStr <>~ [QueryArg str Flag] + + where str = symbolVal (Proxy :: Proxy sym) + +instance (KnownSymbol sym, HasForeign sublayout) + => HasForeign (MatrixParam sym a :> sublayout) where + type Foreign (MatrixParam sym a :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) $ + req & reqUrl.path._last.matrix <>~ [QueryArg strArg Normal] + + where str = symbolVal (Proxy :: Proxy sym) + strArg = str ++ "Value" + +instance (KnownSymbol sym, HasForeign sublayout) + => HasForeign (MatrixParams sym a :> sublayout) where + type Foreign (MatrixParams sym a :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) $ + req & reqUrl.path._last.matrix <>~ [QueryArg str List] + + where str = symbolVal (Proxy :: Proxy sym) + +instance (KnownSymbol sym, HasForeign sublayout) + => HasForeign (MatrixFlag sym :> sublayout) where + type Foreign (MatrixFlag sym :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) $ + req & reqUrl.path._last.matrix <>~ [QueryArg str Flag] + + where str = symbolVal (Proxy :: Proxy sym) + +instance HasForeign Raw where + type Foreign Raw = Method -> Req + + foreignFor Proxy req method = + req & funcName %~ ((toLower <$> method) :) + & reqMethod .~ method + +instance (Elem JSON list, HasForeign sublayout) => HasForeign (ReqBody list a :> sublayout) where + type Foreign (ReqBody list a :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) $ + req & reqBody .~ True + +instance (KnownSymbol path, HasForeign sublayout) + => HasForeign (path :> sublayout) where + type Foreign (path :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) $ + req & reqUrl.path <>~ [Segment (Static str) []] + & funcName %~ (++ [str]) + + where str = map (\c -> if c == '.' then '_' else c) $ symbolVal (Proxy :: Proxy path) + +instance HasForeign sublayout => HasForeign (RemoteHost :> sublayout) where + type Foreign (RemoteHost :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) req + +instance HasForeign sublayout => HasForeign (IsSecure :> sublayout) where + type Foreign (IsSecure :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) req + +instance HasForeign sublayout => HasForeign (Vault :> sublayout) where + type Foreign (Vault :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) req + +instance HasForeign sublayout => HasForeign (HttpVersion :> sublayout) where + type Foreign (HttpVersion :> sublayout) = Foreign sublayout + + foreignFor Proxy req = + foreignFor (Proxy :: Proxy sublayout) req diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index 239afbb9..376dc94f 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -37,14 +37,12 @@ library exposed-modules: Servant.JS Servant.JS.Angular Servant.JS.Axios + Servant.JS.Internal Servant.JS.JQuery Servant.JS.Vanilla - Servant.JS.Internal build-depends: base >=4.5 && <5 - , charset , lens >= 4 - , servant == 0.5.* - , text + , servant-foreign hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -59,16 +57,16 @@ executable counter else buildable: False - build-depends: - aeson - , base - , filepath - , servant == 0.5.* - , servant-server == 0.5.* - , servant-js == 0.5.* - , stm - , transformers - , warp + build-depends: aeson + , base + , filepath + , lens >= 4 + , servant + , servant-server + , servant-js + , stm + , transformers + , warp default-language: Haskell2010 test-suite spec @@ -76,12 +74,12 @@ test-suite spec hs-source-dirs: test ghc-options: -Wall main-is: Spec.hs - build-depends: - base == 4.* - , lens - , servant-js - , servant - , hspec >= 2.1.8 - , hspec-expectations - , language-ecmascript >= 0.16 - default-language: Haskell2010 + build-depends: base == 4.* + , hspec >= 2.1.8 + , hspec-expectations + , language-ecmascript >= 0.16 + , lens + , lens >= 4 + , servant + , servant-js + default-language: Haskell2010 diff --git a/servant-js/src/Servant/JS.hs b/servant-js/src/Servant/JS.hs index 0e989824..d15d811e 100644 --- a/servant-js/src/Servant/JS.hs +++ b/servant-js/src/Servant/JS.hs @@ -76,7 +76,7 @@ module Servant.JS , JavaScriptGenerator , -- * Options common to all generators - CommonGeneratorOptions(..) + CommonGeneratorOptions , defCommonGeneratorOptions , -- * Function renamers @@ -109,13 +109,10 @@ module Servant.JS , -- * Misc. listFromAPI , javascript - , HasJS(..) , GenerateList(..) - , AjaxReq ) where import Data.Proxy -import Servant.API import Servant.JS.Angular import Servant.JS.Axios import Servant.JS.Internal @@ -125,13 +122,13 @@ import Servant.JS.Vanilla -- | Generate the data necessary to generate javascript code -- for all the endpoints of an API, as ':<|>'-separated values -- of type 'AjaxReq'. -javascript :: HasJS layout => Proxy layout -> JS layout -javascript p = javascriptFor p defReq +javascript :: HasForeign layout => Proxy layout -> Foreign layout +javascript p = foreignFor p defReq -- | Directly generate all the javascript functions for your API -- from a 'Proxy' for your API type. You can then write it to -- a file or integrate it in a page, for example. -jsForAPI :: (HasJS api, GenerateList (JS api)) +jsForAPI :: (HasForeign api, GenerateList (Foreign api)) => Proxy api -- ^ proxy for your API type -> JavaScriptGenerator -- ^ js code generator to use (angular, vanilla js, jquery, others) -> String -- ^ a string that you can embed in your pages or write to a file @@ -140,7 +137,7 @@ jsForAPI p gen = gen (listFromAPI p) -- | Directly generate all the javascript functions for your API -- from a 'Proxy' for your API type using the given generator -- and write the resulting code to a file at the given path. -writeJSForAPI :: (HasJS api, GenerateList (JS api)) +writeJSForAPI :: (HasForeign api, GenerateList (Foreign api)) => Proxy api -- ^ proxy for your API type -> JavaScriptGenerator -- ^ js code generator to use (angular, vanilla js, jquery, others) -> FilePath -- ^ path to the file you want to write the resulting javascript code into @@ -161,5 +158,6 @@ instance (GenerateList start, GenerateList rest) => GenerateList (start :<|> res -- | Generate the necessary data for JS codegen as a list, each 'AjaxReq' -- describing one endpoint from your API type. -listFromAPI :: (HasJS api, GenerateList (JS api)) => Proxy api -> [AjaxReq] +listFromAPI :: (HasForeign api, GenerateList (Foreign api)) => Proxy api -> [AjaxReq] listFromAPI p = generateList (javascript p) + diff --git a/servant-js/src/Servant/JS/Angular.hs b/servant-js/src/Servant/JS/Angular.hs index 7b93dfdf..3ea38d1c 100644 --- a/servant-js/src/Servant/JS/Angular.hs +++ b/servant-js/src/Servant/JS/Angular.hs @@ -3,6 +3,7 @@ module Servant.JS.Angular where import Control.Lens import Data.List import Data.Monoid +import Servant.Foreign import Servant.JS.Internal -- | Options specific to the angular code generator diff --git a/servant-js/src/Servant/JS/Axios.hs b/servant-js/src/Servant/JS/Axios.hs index 3d65480b..56c521f2 100644 --- a/servant-js/src/Servant/JS/Axios.hs +++ b/servant-js/src/Servant/JS/Axios.hs @@ -4,6 +4,7 @@ import Control.Lens import Data.Char (toLower) import Data.List import Data.Monoid +import Servant.Foreign import Servant.JS.Internal -- | Axios 'configuration' type diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs index 123da537..5363a58b 100644 --- a/servant-js/src/Servant/JS/Internal.hs +++ b/servant-js/src/Servant/JS/Internal.hs @@ -1,206 +1,43 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Servant.JS.Internal where +module Servant.JS.Internal + ( JavaScriptGenerator + , AjaxReq + , jsSegments + , segmentToStr + , segmentTypeToStr + , jsParams + , jsGParams + , jsMParams + , paramToStr + -- re-exports + , (:<|>)(..) + , (:>) + , defReq + , defCommonGeneratorOptions + , reqHeaders + , CommonGeneratorOptions(..) + , HasForeign(..) + , HeaderArg(..) + , concatCase + , snakeCase + , camelCase + , ReqBody + , JSON + , FormUrlEncoded + , Post + , Get + , Raw + , Header + ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif import Control.Lens hiding (List) -import Data.Char (toLower, toUpper) -import qualified Data.CharSet as Set -import qualified Data.CharSet.Unicode.Category as Set -import Data.List -import Data.Monoid -import Data.Proxy -import qualified Data.Text as T -import GHC.Exts (Constraint) -import GHC.TypeLits -import Servant.API +import Servant.Foreign --- | this structure is used by JavaScriptGenerator implementations to let you --- customize the output -data CommonGeneratorOptions = CommonGeneratorOptions - { - functionNameBuilder :: FunctionName -> String -- ^ function generating function names - , requestBody :: String -- ^ name used when a user want to send the request body (to let you redefine it) - , successCallback :: String -- ^ name of the callback parameter when the request was successful - , errorCallback :: String -- ^ name of the callback parameter when the request reported an error - , moduleName :: String -- ^ namespace on which we define the js function (empty mean local var) - , urlPrefix :: String -- ^ a prefix we should add to the Url in the JS codegen - } - --- | Default options. --- --- @ --- > defCommonGeneratorOptions = CommonGeneratorOptions --- > { functionNameBuilder = camelCase --- > , requestBody = "body" --- > , successCallback = "onSuccess" --- > , errorCallback = "onError" --- > , moduleName = "" --- > , urlPrefix = "" --- > } --- @ -defCommonGeneratorOptions :: CommonGeneratorOptions -defCommonGeneratorOptions = CommonGeneratorOptions - { - functionNameBuilder = camelCase - , requestBody = "body" - , successCallback = "onSuccess" - , errorCallback = "onError" - , moduleName = "" - , urlPrefix = "" - } - --- | Function name builder that simply concat each part together -concatCase :: FunctionName -> String -concatCase = concat - --- | Function name builder using the snake_case convention. --- each part is separated by a single underscore character. -snakeCase :: FunctionName -> String -snakeCase = intercalate "_" - --- | Function name builder using the CamelCase convention. --- each part begins with an upper case character. -camelCase :: FunctionName -> String -camelCase [] = "" -camelCase (p:ps) = concat $ p : camelCase' ps - where camelCase' [] = [] - camelCase' (r:rs) = capitalize r : camelCase' rs - capitalize [] = [] - capitalize (x:xs) = toUpper x : xs - -type Arg = String +type AjaxReq = Req -- A 'JavascriptGenerator' just takes the data found in the API type -- for each endpoint and generates Javascript code in a String. Several -- generators are available in this package. -type JavaScriptGenerator = [AjaxReq] -> String - -data Segment = Segment { _segment :: SegmentType, _matrix :: [MatrixArg] } - deriving (Eq, Show) - -data SegmentType = Static String -- ^ a static path segment. like "/foo" - | Cap Arg -- ^ a capture. like "/:userid" - deriving (Eq, Show) - -type Path = [Segment] - -data ArgType = - Normal - | Flag - | List - deriving (Eq, Show) - -data QueryArg = QueryArg - { _argName :: Arg - , _argType :: ArgType - } deriving (Eq, Show) - -data HeaderArg = HeaderArg - { headerArgName :: String - } - | ReplaceHeaderArg - { headerArgName :: String - , headerPattern :: String - } deriving (Eq) - -instance Show HeaderArg where - show (HeaderArg n) = toValidFunctionName ("header" <> n) - show (ReplaceHeaderArg n p) - | pn `isPrefixOf` p = pv <> " + \"" <> rp <> "\"" - | pn `isSuffixOf` p = "\"" <> rp <> "\" + " <> pv - | pn `isInfixOf` p = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p) - <> "\"" - | otherwise = p - where - pv = toValidFunctionName ("header" <> n) - pn = "{" <> n <> "}" - rp = replace pn "" p - -- Use replace method from Data.Text - replace old new = T.unpack . - T.replace (T.pack old) (T.pack new) . - T.pack - --- | Attempts to reduce the function name provided to that allowed by JS. --- https://mathiasbynens.be/notes/javascript-identifiers --- Couldn't work out how to handle zero-width characters. --- @TODO: specify better default function name, or throw error? -toValidFunctionName :: String -> String -toValidFunctionName (x:xs) = [setFirstChar x] <> filter remainder xs - where - setFirstChar c = if firstChar c - then c - else '_' - firstChar c = prefixOK c || any (Set.member c) firstLetterOK - remainder c = prefixOK c || any (Set.member c) remainderOK - -- Valid prefixes - prefixOK c = c `elem` ['$','_'] - -- Unicode character sets - firstLetterOK = [ Set.lowercaseLetter - , Set.uppercaseLetter - , Set.titlecaseLetter - , Set.modifierLetter - , Set.otherLetter - , Set.letterNumber ] - remainderOK = firstLetterOK <> [ Set.nonSpacingMark - , Set.spacingCombiningMark - , Set.decimalNumber - , Set.connectorPunctuation ] -toValidFunctionName [] = "_" - -type MatrixArg = QueryArg - -data Url = Url - { _path :: Path - , _queryStr :: [QueryArg] - } deriving (Eq, Show) - -defUrl :: Url -defUrl = Url [] [] - -type FunctionName = [String] -type Method = String - -data AjaxReq = AjaxReq - { _reqUrl :: Url - , _reqMethod :: Method - , _reqHeaders :: [HeaderArg] - , _reqBody :: Bool - , _funcName :: FunctionName - } deriving (Eq, Show) - -makeLenses ''QueryArg -makeLenses ''Segment -makeLenses ''Url -makeLenses ''AjaxReq - -isCapture :: Segment -> Bool -isCapture (Segment (Cap _) _) = True -isCapture _ = False - -hasMatrixArgs :: Segment -> Bool -hasMatrixArgs (Segment _ (_:_)) = True -hasMatrixArgs _ = False - -hasArgs :: Segment -> Bool -hasArgs s = isCapture s || hasMatrixArgs s - -matrixArgs :: Segment -> [MatrixArg] -matrixArgs (Segment _ ms) = ms - -captureArg :: Segment -> Arg -captureArg (Segment (Cap s) _) = s -captureArg _ = error "captureArg called on non capture" +type JavaScriptGenerator = [Req] -> String jsSegments :: [Segment] -> String jsSegments [] = "" @@ -216,8 +53,8 @@ segmentTypeToStr (Static s) = s segmentTypeToStr (Cap s) = "' + encodeURIComponent(" ++ s ++ ") + '" jsGParams :: String -> [QueryArg] -> String -jsGParams _ [] = "" -jsGParams _ [x] = paramToStr x False +jsGParams _ [] = "" +jsGParams _ [x] = paramToStr x False jsGParams s (x:xs) = paramToStr x True ++ s ++ jsGParams s xs jsParams :: [QueryArg] -> String @@ -234,191 +71,9 @@ paramToStr qarg notTheEnd = ++ "=' + encodeURIComponent(" ++ name ++ if notTheEnd then ") + '" else ")" - Flag -> name ++ "=" - List -> name ++ "[]=' + encodeURIComponent(" ++ name ++ if notTheEnd then ") + '" else ")" - where name = qarg ^. argName - -defReq :: AjaxReq -defReq = AjaxReq defUrl "GET" [] False [] - -type family Elem (a :: *) (ls::[*]) :: Constraint where - Elem a '[] = 'False ~ 'True - Elem a (a ': list) = () - Elem a (b ': list) = Elem a list - -class HasJS (layout :: *) where - type JS layout :: * - javascriptFor :: Proxy layout -> AjaxReq -> JS layout - -instance (HasJS a, HasJS b) - => HasJS (a :<|> b) where - type JS (a :<|> b) = JS a :<|> JS b - - javascriptFor Proxy req = - javascriptFor (Proxy :: Proxy a) req - :<|> javascriptFor (Proxy :: Proxy b) req - -instance (KnownSymbol sym, HasJS sublayout) - => HasJS (Capture sym a :> sublayout) where - type JS (Capture sym a :> sublayout) = JS sublayout - - javascriptFor Proxy req = - javascriptFor (Proxy :: Proxy sublayout) $ - req & reqUrl.path <>~ [Segment (Cap str) []] - & funcName %~ (++ ["by", str]) - - where str = symbolVal (Proxy :: Proxy sym) - -instance Elem JSON list => HasJS (Delete list a) where - type JS (Delete list a) = AjaxReq - - javascriptFor Proxy req = - req & funcName %~ ("delete" :) - & reqMethod .~ "DELETE" - -instance Elem JSON list => HasJS (Get list a) where - type JS (Get list a) = AjaxReq - - javascriptFor Proxy req = - req & funcName %~ ("get" :) - & reqMethod .~ "GET" - -instance (KnownSymbol sym, HasJS sublayout) - => HasJS (Header sym a :> sublayout) where - type JS (Header sym a :> sublayout) = JS sublayout - - javascriptFor Proxy req = - javascriptFor subP (req & reqHeaders <>~ [HeaderArg hname]) - - where hname = symbolVal (Proxy :: Proxy sym) - subP = Proxy :: Proxy sublayout - -instance Elem JSON list => HasJS (Post list a) where - type JS (Post list a) = AjaxReq - - javascriptFor Proxy req = - req & funcName %~ ("post" :) - & reqMethod .~ "POST" - -instance Elem JSON list => HasJS (Put list a) where - type JS (Put list a) = AjaxReq - - javascriptFor Proxy req = - req & funcName %~ ("put" :) - & reqMethod .~ "PUT" - -instance (KnownSymbol sym, HasJS sublayout) - => HasJS (QueryParam sym a :> sublayout) where - type JS (QueryParam sym a :> sublayout) = JS sublayout - - javascriptFor Proxy req = - javascriptFor (Proxy :: Proxy sublayout) $ - req & reqUrl.queryStr <>~ [QueryArg str Normal] - - where str = symbolVal (Proxy :: Proxy sym) - -instance (KnownSymbol sym, HasJS sublayout) - => HasJS (QueryParams sym a :> sublayout) where - type JS (QueryParams sym a :> sublayout) = JS sublayout - - javascriptFor Proxy req = - javascriptFor (Proxy :: Proxy sublayout) $ - req & reqUrl.queryStr <>~ [QueryArg str List] - - where str = symbolVal (Proxy :: Proxy sym) - -instance (KnownSymbol sym, HasJS sublayout) - => HasJS (QueryFlag sym :> sublayout) where - type JS (QueryFlag sym :> sublayout) = JS sublayout - - javascriptFor Proxy req = - javascriptFor (Proxy :: Proxy sublayout) $ - req & reqUrl.queryStr <>~ [QueryArg str Flag] - - where str = symbolVal (Proxy :: Proxy sym) - -instance (KnownSymbol sym, HasJS sublayout) - => HasJS (MatrixParam sym a :> sublayout) where - type JS (MatrixParam sym a :> sublayout) = JS sublayout - - javascriptFor Proxy req = - javascriptFor (Proxy :: Proxy sublayout) $ - req & reqUrl.path._last.matrix <>~ [QueryArg strArg Normal] - - where str = symbolVal (Proxy :: Proxy sym) - strArg = str ++ "Value" - -instance (KnownSymbol sym, HasJS sublayout) - => HasJS (MatrixParams sym a :> sublayout) where - type JS (MatrixParams sym a :> sublayout) = JS sublayout - - javascriptFor Proxy req = - javascriptFor (Proxy :: Proxy sublayout) $ - req & reqUrl.path._last.matrix <>~ [QueryArg str List] - - where str = symbolVal (Proxy :: Proxy sym) - -instance (KnownSymbol sym, HasJS sublayout) - => HasJS (MatrixFlag sym :> sublayout) where - type JS (MatrixFlag sym :> sublayout) = JS sublayout - - javascriptFor Proxy req = - javascriptFor (Proxy :: Proxy sublayout) $ - req & reqUrl.path._last.matrix <>~ [QueryArg str Flag] - - where str = symbolVal (Proxy :: Proxy sym) - -instance HasJS Raw where - type JS Raw = Method -> AjaxReq - - javascriptFor Proxy req method = - req & funcName %~ ((toLower <$> method) :) - & reqMethod .~ method - -instance (Elem JSON list, HasJS sublayout) => HasJS (ReqBody list a :> sublayout) where - type JS (ReqBody list a :> sublayout) = JS sublayout - - javascriptFor Proxy req = - javascriptFor (Proxy :: Proxy sublayout) $ - req & reqBody .~ True - -instance (KnownSymbol path, HasJS sublayout) - => HasJS (path :> sublayout) where - type JS (path :> sublayout) = JS sublayout - - javascriptFor Proxy req = - javascriptFor (Proxy :: Proxy sublayout) $ - req & reqUrl.path <>~ [Segment (Static str) []] - & funcName %~ (++ [str]) - - where str = map (\c -> if c == '.' then '_' else c) $ symbolVal (Proxy :: Proxy path) - -instance HasJS sublayout => HasJS (RemoteHost :> sublayout) where - type JS (RemoteHost :> sublayout) = JS sublayout - - javascriptFor Proxy req = - javascriptFor (Proxy :: Proxy sublayout) req - -instance HasJS sublayout => HasJS (IsSecure :> sublayout) where - type JS (IsSecure :> sublayout) = JS sublayout - - javascriptFor Proxy req = - javascriptFor (Proxy :: Proxy sublayout) req - -instance HasJS sublayout => HasJS (Vault :> sublayout) where - type JS (Vault :> sublayout) = JS sublayout - - javascriptFor Proxy req = - javascriptFor (Proxy :: Proxy sublayout) req - -instance HasJS sublayout => HasJS (HttpVersion :> sublayout) where - type JS (HttpVersion :> sublayout) = JS sublayout - - javascriptFor Proxy req = - javascriptFor (Proxy :: Proxy sublayout) req diff --git a/servant-js/src/Servant/JS/JQuery.hs b/servant-js/src/Servant/JS/JQuery.hs index e85f1e7d..200310f1 100644 --- a/servant-js/src/Servant/JS/JQuery.hs +++ b/servant-js/src/Servant/JS/JQuery.hs @@ -3,6 +3,7 @@ module Servant.JS.JQuery where import Control.Lens import Data.List import Data.Monoid +import Servant.Foreign import Servant.JS.Internal -- | Generate javascript functions that use the /jQuery/ library diff --git a/servant-js/src/Servant/JS/Vanilla.hs b/servant-js/src/Servant/JS/Vanilla.hs index 13378dcc..f5107795 100644 --- a/servant-js/src/Servant/JS/Vanilla.hs +++ b/servant-js/src/Servant/JS/Vanilla.hs @@ -3,6 +3,7 @@ module Servant.JS.Vanilla where import Control.Lens import Data.List import Data.Monoid +import Servant.Foreign import Servant.JS.Internal -- | Generate vanilla javascript functions to make AJAX requests diff --git a/servant-js/test/Servant/JSSpec.hs b/servant-js/test/Servant/JSSpec.hs index 46ea2e1c..46662ea5 100644 --- a/servant-js/test/Servant/JSSpec.hs +++ b/servant-js/test/Servant/JSSpec.hs @@ -12,8 +12,8 @@ import Data.Proxy import Language.ECMAScript3.Parser (parseFromString) import Test.Hspec -import Servant.API import Servant.JS +import Servant.JS.Internal import qualified Servant.JS.Angular as NG import qualified Servant.JS.Axios as AX import qualified Servant.JS.JQuery as JQ @@ -75,7 +75,7 @@ spec = describe "Servant.JQuery" $ do generateJSSpec Angular (NG.generateAngularJS NG.defAngularOptions) generateJSSpec AngularCustom (NG.generateAngularJSWith NG.defAngularOptions customOptions) generateJSSpec Axios (AX.generateAxiosJS AX.defAxiosOptions) - generateJSSpec AxiosCustom (AX.generateAxiosJSWith (AX.defAxiosOptions { withCredentials = True }) customOptions) + generateJSSpec AxiosCustom (AX.generateAxiosJSWith (AX.defAxiosOptions { AX.withCredentials = True }) customOptions) angularSpec Angular axiosSpec diff --git a/servant-js/test/Servant/JSSpec/CustomHeaders.hs b/servant-js/test/Servant/JSSpec/CustomHeaders.hs index 64a27306..810760c7 100644 --- a/servant-js/test/Servant/JSSpec/CustomHeaders.hs +++ b/servant-js/test/Servant/JSSpec/CustomHeaders.hs @@ -12,8 +12,6 @@ import Control.Lens import Data.Monoid import Data.Proxy import GHC.TypeLits -import Servant.API -import Servant.JS import Servant.JS.Internal -- | This is a hypothetical combinator that fetches an Authorization header. @@ -21,11 +19,11 @@ import Servant.JS.Internal -- using -- Basic, Digest, whatever. data Authorization (sym :: Symbol) a -instance (KnownSymbol sym, HasJS sublayout) - => HasJS (Authorization sym a :> sublayout) where - type JS (Authorization sym a :> sublayout) = JS sublayout +instance (KnownSymbol sym, HasForeign sublayout) + => HasForeign (Authorization sym a :> sublayout) where + type Foreign (Authorization sym a :> sublayout) = Foreign sublayout - javascriptFor Proxy req = javascriptFor (Proxy :: Proxy sublayout) $ + foreignFor Proxy req = foreignFor (Proxy :: Proxy sublayout) $ req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $ tokenType (symbolVal (Proxy :: Proxy sym)) ] where @@ -34,11 +32,11 @@ instance (KnownSymbol sym, HasJS sublayout) -- | This is a combinator that fetches an X-MyLovelyHorse header. data MyLovelyHorse a -instance (HasJS sublayout) - => HasJS (MyLovelyHorse a :> sublayout) where - type JS (MyLovelyHorse a :> sublayout) = JS sublayout +instance (HasForeign sublayout) + => HasForeign (MyLovelyHorse a :> sublayout) where + type Foreign (MyLovelyHorse a :> sublayout) = Foreign sublayout - javascriptFor Proxy req = javascriptFor (Proxy :: Proxy sublayout) $ + foreignFor Proxy req = foreignFor (Proxy :: Proxy sublayout) $ req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ] where tpl = "I am good friends with {X-MyLovelyHorse}" @@ -46,11 +44,11 @@ instance (HasJS sublayout) -- | This is a combinator that fetches an X-WhatsForDinner header. data WhatsForDinner a -instance (HasJS sublayout) - => HasJS (WhatsForDinner a :> sublayout) where - type JS (WhatsForDinner a :> sublayout) = JS sublayout +instance (HasForeign sublayout) + => HasForeign (WhatsForDinner a :> sublayout) where + type Foreign (WhatsForDinner a :> sublayout) = Foreign sublayout - javascriptFor Proxy req = javascriptFor (Proxy :: Proxy sublayout) $ + foreignFor Proxy req = foreignFor (Proxy :: Proxy sublayout) $ req & reqHeaders <>~ [ ReplaceHeaderArg "X-WhatsForDinner" tpl ] where tpl = "I would like {X-WhatsForDinner} with a cherry on top." diff --git a/sources.txt b/sources.txt index bd229587..24719355 100644 --- a/sources.txt +++ b/sources.txt @@ -2,6 +2,7 @@ servant servant-cassava servant-client servant-docs +servant-foreign servant-js servant-server servant-examples diff --git a/stack.yaml b/stack.yaml index 8e1a6e18..5d11a3a7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -8,6 +8,7 @@ packages: - servant-client/ - servant-docs/ - servant-examples/ +- servant-foreign/ - servant-js/ - servant-lucid/ - servant-mock/