diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,23 @@ +0.5 +---- + +* Extract javascript-obvlious types and helpers to *servant-foreign* +* Use `text` package instead of `String` +* Provide new targets for code generation along with the old jQuery one: vanilla Javascript and Angular.js +* Greatly simplify usage of this library by reducing down the API to just 2 functions: `jsForAPI` and `writeJSForAPI` + the choice of a code generator +* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators +* Remove matrix params. + +0.4 +--- +* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body +* Extend `HeaderArg` to support more advanced HTTP header handling (https://github.com/haskell-servant/servant-jquery/pull/6) +* Support content-type aware combinators (but require that endpoints support JSON) +* Add support for Matrix params (https://github.com/haskell-servant/servant-jquery/pull/11) +* Add functions that directly generate the Javascript code from the API type without having to manually pattern match on the result. + +0.2.2 +----- + +* Fix an issue where toplevel Raw endpoints would generate a JS function with no name (https://github.com/haskell-servant/servant-jquery/issues/2) +* Replace dots by _ in paths (https://github.com/haskell-servant/servant-jquery/issues/1) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors + +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,99 @@ +# servant-js + +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) + +This library lets you derive automatically Javascript functions that let you query each endpoint of a *servant* webservice. + +It contains a powerful system allowing you to generate functions for several frameworks (Angular, AXios, JQuery) as well as +vanilla (framework-free) javascript code. + +## Example + +Read more about the following example [here](https://github.com/haskell-servant/servant/tree/master/servant-js/examples#examples). + +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Data.Aeson +import Data.Proxy +import GHC.Generics +import Network.Wai.Handler.Warp (run) +import Servant +import Servant.JS +import System.FilePath + +-- * A simple Counter data type +newtype Counter = Counter { value :: Int } + deriving (Generic, Show, Num) + +instance ToJSON Counter + +-- * Shared counter operations + +-- Creating a counter that starts from 0 +newCounter :: IO (TVar Counter) +newCounter = newTVarIO 0 + +-- Increasing the counter by 1 +counterPlusOne :: MonadIO m => TVar Counter -> m Counter +counterPlusOne counter = liftIO . atomically $ do + oldValue <- readTVar counter + let newValue = oldValue + 1 + writeTVar counter newValue + return newValue + +currentValue :: MonadIO m => TVar Counter -> m Counter +currentValue counter = liftIO $ readTVarIO counter + +-- * Our API type +type TestApi = "counter" :> Post '[JSON] Counter -- endpoint for increasing the counter + :<|> "counter" :> Get '[JSON] Counter -- endpoint to get the current value + +type TestApi' = TestApi -- The API we want a JS handler for + :<|> Raw -- used for serving static files + +-- this proxy only targets the proper endpoints of our API, +-- not the static file serving bit +testApi :: Proxy TestApi +testApi = Proxy + +-- this proxy targets everything +testApi' :: Proxy TestApi' +testApi' = Proxy + +-- * Server-side handler + +-- where our static files reside +www :: FilePath +www = "examples/www" + +-- defining handlers +server :: TVar Counter -> Server TestApi +server counter = counterPlusOne counter -- (+1) on the TVar + :<|> currentValue counter -- read the TVar + +server' :: TVar Counter -> Server TestApi' +server counter = server counter + :<|> serveDirectory www -- serve static files + +runServer :: TVar Counter -- ^ shared variable for the counter + -> Int -- ^ port the server should listen on + -> IO () +runServer var port = run port (serve testApi' $ server' var) + +main :: IO () +main = do + -- write the JS code to www/api.js at startup + writeJSForAPI testApi jquery (www "api.js") + + -- setup a shared counter + cnt <- newCounter + + -- listen to requests on port 8080 + runServer cnt 8080 +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/counter.hs b/examples/counter.hs new file mode 100644 --- /dev/null +++ b/examples/counter.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeOperators #-} + +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Data.Aeson +import Data.Proxy +import GHC.Generics +import Network.Wai.Handler.Warp (run) +import Servant +import Servant.JS +import qualified Servant.JS as SJS +import qualified Servant.JS.Angular as NG +import System.FilePath + +-- * A simple Counter data type +newtype Counter = Counter { value :: Int } + deriving (Generic, Show, Num) + +instance ToJSON Counter + +-- * Shared counter operations + +-- Creating a counter that starts from 0 +newCounter :: IO (TVar Counter) +newCounter = newTVarIO 0 + +-- Increasing the counter by 1 +counterPlusOne :: MonadIO m => TVar Counter -> m Counter +counterPlusOne counter = liftIO . atomically $ do + oldValue <- readTVar counter + let newValue = oldValue + 1 + writeTVar counter newValue + return newValue + +currentValue :: MonadIO m => TVar Counter -> m Counter +currentValue counter = liftIO $ readTVarIO counter + +-- * Our API type +type TestApi = "counter" :> Post '[JSON] Counter -- endpoint for increasing the counter + :<|> "counter" :> Get '[JSON] Counter -- endpoint to get the current value + +type TestApi' = TestApi + :<|> Raw -- used for serving static files + +-- this proxy only targets the proper endpoints of our API, +-- not the static file serving bit +testApi :: Proxy TestApi +testApi = Proxy + +-- this proxy targets everything +testApi' :: Proxy TestApi' +testApi' = Proxy + +-- * Server-side handler + +-- where our static files reside +www :: FilePath +www = "examples/www" + +-- defining handlers of our endpoints +server :: TVar Counter -> Server TestApi +server counter = counterPlusOne counter -- (+1) on the TVar + :<|> currentValue counter -- read the TVar + +-- the whole server, including static file serving +server' :: TVar Counter -> Server TestApi' +server' counter = server counter + :<|> serveDirectory www -- serve static files + +runServer :: TVar Counter -- ^ shared variable for the counter + -> Int -- ^ port the server should listen on + -> IO () +runServer var port = run port (serve testApi' $ server' var) + +writeServiceJS :: FilePath -> IO () +writeServiceJS fp = + writeJSForAPI testApi + (angularServiceWith (NG.defAngularOptions { NG.serviceName = "counterSvc" }) + (defCommonGeneratorOptions { SJS.moduleName = "counterApp" }) + ) + fp + +main :: IO () +main = do + -- write the JS code to www/api.js at startup + writeJSForAPI testApi jquery (www "jquery" "api.js") + + writeJSForAPI testApi vanillaJS (www "vanilla" "api.js") + + writeJSForAPI testApi (angular defAngularOptions) (www "angular" "api.js") + + writeJSForAPI testApi axios (www "axios" "api.js") + + writeServiceJS (www "angular" "api.service.js") + + -- setup a shared counter + cnt <- newCounter + + -- listen to requests on port 8080 + runServer cnt 8080 diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h new file mode 100644 --- /dev/null +++ b/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-js.cabal b/servant-js.cabal new file mode 100644 --- /dev/null +++ b/servant-js.cabal @@ -0,0 +1,95 @@ +name: servant-js +version: 0.5 +synopsis: Automatically derive javascript functions to query servant webservices. +description: + Automatically derive javascript functions to query servant webservices. + . + Supports deriving functions using vanilla javascript AJAX requests, Angulari, Axios or JQuery. + . + You can find an example + which serves the generated javascript to a webpage that allows you to trigger + webservice calls. + . + +license: BSD3 +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2016 Servant Contributors +category: Web +build-type: Simple +cabal-version: >=1.10 +homepage: http://haskell-servant.github.io/ +Bug-reports: http://github.com/haskell-servant/servant/issues +extra-source-files: + include/*.h + CHANGELOG.md + README.md +source-repository head + type: git + location: http://github.com/haskell-servant/servant.git + +flag example + description: Build the example too + manual: True + default: False + +library + exposed-modules: Servant.JS + Servant.JS.Angular + Servant.JS.Axios + Servant.JS.Internal + Servant.JS.JQuery + Servant.JS.Vanilla + build-depends: base >= 4.5 && <5 + , base-compat >= 0.9 + , charset >= 0.3 + , lens >= 4 + , servant-foreign == 0.5.* + , text >= 1.2 && < 1.3 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + include-dirs: include + +executable counter + main-is: counter.hs + ghc-options: -O2 -Wall + hs-source-dirs: examples + + if flag(example) + buildable: True + else + buildable: False + + build-depends: base >= 4.7 && < 5 + , aeson >= 0.7 && < 0.12 + , filepath >= 1 + , lens >= 4 + , servant == 0.5.* + , servant-server == 0.5.* + , servant-js + , stm + , transformers + , warp + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + hs-source-dirs: test + ghc-options: -Wall + main-is: Spec.hs + other-modules: + Servant.JSSpec + Servant.JSSpec.CustomHeaders + build-depends: base + , base-compat + , hspec >= 2.1.8 + , hspec-expectations + , language-ecmascript >= 0.16 + , lens + , servant + , servant-js + , text + default-language: Haskell2010 diff --git a/src/Servant/JS.hs b/src/Servant/JS.hs new file mode 100644 --- /dev/null +++ b/src/Servant/JS.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +----------------------------------------------------------------------------- +-- | +-- Module : Servant.JS +-- License : BSD3 +-- Maintainer : Alp Mestanogullari +-- Stability : experimental +-- Portability : non-portable +-- +-- Generating Javascript code to query your APIs using vanilla Javascript, +-- Angular.js or JQuery. +-- +-- Using this package is very simple. Say you have this API type around: +-- +-- > type API = "users" :> Get '[JSON] [Users] +-- > :<|> "messages" :> Get '[JSON] [Message] +-- +-- All you need to do to generate the Javascript code is to write a 'Proxy' +-- for this API type: +-- +-- > api :: Proxy API +-- > api = Proxy +-- +-- And pick one of the generators: +-- +-- - 'vanillaJS' and 'vanillaJSWith' generate functions that use +-- /XMLHttpRequest/ to query your endpoints. The former just calls +-- the latter with default code-generation options. +-- - 'jquery' and 'jqueryWith' follow the same pattern except that they +-- generate functions that use /jQuery/'s AJAX functions. +-- - 'angular' and 'angularWith' do the same but use /Angular.js/'s $http +-- service. In addition, we provide 'angularService' and 'angularServiceWith' +-- which produce functions under an Angular service that your controlers +-- can depend on to query the API. +-- +-- Let's keep it simple and produce vanilla Javascript code with the default options. +-- +-- @ +-- jsCode :: Text +-- jsCode = 'jsForAPI' api 'vanillaJS' +-- @ +-- +-- That's it! If you want to write that code to a file: +-- +-- @ +-- writeJSCode :: IO () +-- writeJSCode = 'writeJSForAPI' api 'vanillaJS' "./my_api.js" +-- @ +-- +-- If you want to customize the rendering options, take a look +-- at 'CommonGeneratorOptions' which are generic options common to all the +-- generators. the /xxxWith/ variants all take 'CommonGeneratorOptions' whereas +-- the /xxx/ versions use 'defCommonGeneratorOptions'. Once you have some custom +-- +-- > myOptions :: 'CommonGeneratorOptions' +-- +-- All you need to do to use it is to use 'vanillaJSWith' and pass it @myOptions@. +-- +-- @ +-- jsCodeWithMyOptions :: Text +-- jsCodeWithMyOptions = 'jsForAPI' api ('vanillaJSWith' myOptions) +-- @ +-- +-- Follow the same pattern for any other generator. +-- +-- /Note/: The Angular generators take an additional type of options, +-- namely 'AngularOptions', to let you tweak aspects of the code generation +-- that are specific to /Angular.js/. +module Servant.JS + ( -- * Generating javascript code from an API type + jsForAPI + , writeJSForAPI + , JavaScriptGenerator + + , -- * Options common to all generators + CommonGeneratorOptions(..) + , defCommonGeneratorOptions + + , -- * Function renamers + concatCase + , snakeCase + , camelCase + + , -- * Vanilla Javascript code generation + vanillaJS + , vanillaJSWith + + , -- * JQuery code generation + jquery + , jqueryWith + + , -- * Angular.js code generation + angular + , angularWith + , angularService + , angularServiceWith + , AngularOptions(..) + , defAngularOptions + + , -- * Axios code generation + axios + , axiosWith + , AxiosOptions(..) + , defAxiosOptions + + , -- * Misc. + listFromAPI + , javascript + , NoTypes + , GenerateList(..) + ) where + +import Prelude hiding (writeFile) +import Data.Proxy +import Data.Text +import Data.Text.IO (writeFile) +import Servant.JS.Angular +import Servant.JS.Axios +import Servant.JS.Internal +import Servant.JS.JQuery +import Servant.JS.Vanilla +import Servant.Foreign (GenerateList(..), listFromAPI, NoTypes) + +-- | Generate the data necessary to generate javascript code +-- for all the endpoints of an API, as ':<|>'-separated values +-- of type 'AjaxReq'. +javascript :: HasForeign NoTypes () layout => Proxy layout -> Foreign () layout +javascript p = foreignFor (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) 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 :: (HasForeign NoTypes () api, GenerateList () (Foreign () api)) + => Proxy api -- ^ proxy for your API type + -> JavaScriptGenerator -- ^ js code generator to use (angular, vanilla js, jquery, others) + -> Text -- ^ a text that you can embed in your pages or write to a file +jsForAPI p gen = gen (listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) 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 :: (HasForeign NoTypes () 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 + -> IO () +writeJSForAPI p gen fp = writeFile fp (jsForAPI p gen) + diff --git a/src/Servant/JS/Angular.hs b/src/Servant/JS/Angular.hs new file mode 100644 --- /dev/null +++ b/src/Servant/JS/Angular.hs @@ -0,0 +1,149 @@ +{-#LANGUAGE OverloadedStrings #-} +module Servant.JS.Angular where + +import Control.Lens +import Data.Maybe (isJust) +import Data.Monoid +import qualified Data.Text as T +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Servant.Foreign +import Servant.JS.Internal + +-- | Options specific to the angular code generator +data AngularOptions = AngularOptions + { serviceName :: Text -- ^ When generating code with wrapInService, + -- name of the service to generate + , prologue :: Text -> Text -> Text -- ^ beginning of the service definition + , epilogue :: Text -- ^ end of the service definition + } + +-- | Default options for the Angular codegen. Used by 'wrapInService'. +defAngularOptions :: AngularOptions +defAngularOptions = AngularOptions + { serviceName = "" + , prologue = \svc m -> m <> "service('" <> svc <> "', function($http) {\n" + <> " return ({" + , epilogue = "});\n});\n" + } + +-- | Instead of simply generating top level functions, generates a service instance +-- on which your controllers can depend to access your API. +-- This variant uses default 'AngularOptions'. +angularService :: AngularOptions -> JavaScriptGenerator +angularService ngOpts = angularServiceWith ngOpts defCommonGeneratorOptions + +-- | Instead of simply generating top level functions, generates a service instance +-- on which your controllers can depend to access your API +angularServiceWith :: AngularOptions -> CommonGeneratorOptions -> JavaScriptGenerator +angularServiceWith ngOpts opts reqs = + prologue ngOpts svc mName + <> T.intercalate "," (map generator reqs) <> + epilogue ngOpts + where + generator req = generateAngularJSWith ngOpts opts req + svc = serviceName ngOpts + mName = if moduleName opts == "" + then "app." + else moduleName opts <> "." + +-- | Generate regular javacript functions that use +-- the $http service, using default values for 'CommonGeneratorOptions'. +angular :: AngularOptions -> JavaScriptGenerator +angular ngopts = angularWith ngopts defCommonGeneratorOptions + +-- | Generate regular javascript functions that use the $http service. +angularWith :: AngularOptions -> CommonGeneratorOptions -> JavaScriptGenerator +angularWith ngopts opts = T.intercalate "\n\n" . map (generateAngularJSWith ngopts opts) + +-- | js codegen using $http service from Angular using default options +generateAngularJS :: AngularOptions -> AjaxReq -> Text +generateAngularJS ngOpts = generateAngularJSWith ngOpts defCommonGeneratorOptions + +-- | js codegen using $http service from Angular +generateAngularJSWith :: AngularOptions -> CommonGeneratorOptions -> AjaxReq -> Text +generateAngularJSWith ngOptions opts req = "\n" <> + fname <> fsep <> " function(" <> argsStr <> ")\n" + <> "{\n" + <> " return $http(\n" + <> " { url: " <> url <> "\n" + <> dataBody + <> reqheaders + <> " , method: '" <> decodeUtf8 method <> "'\n" + <> " });\n" + <> "}\n" + + where argsStr = T.intercalate ", " args + args = http + ++ captures + ++ map (view $ queryArgName . argPath) queryparams + ++ body + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . argPath) + ) hs + + -- If we want to generate Top Level Function, they must depend on + -- the $http service, if we generate a service, the functions will + -- inherit this dependency from the service + http = case T.length (serviceName ngOptions) of + 0 -> ["$http"] + _ -> [] + + captures = map (view argPath . captureArg) + . filter isCapture + $ req ^. reqUrl . path + + hs = req ^. reqHeaders + + queryparams = req ^.. reqUrl.queryStr.traverse + + body = if isJust (req ^. reqBody) + then [requestBody opts] + else [] + + dataBody = + if isJust (req ^. reqBody) + then " , data: JSON.stringify(body)\n" <> + " , contentType: 'application/json'\n" + else "" + + reqheaders = + if null hs + then "" + else " , headers: { " <> headersStr <> " }\n" + + where + headersStr = T.intercalate ", " $ map headerStr hs + headerStr header = "\"" <> + header ^. headerArg . argPath <> + "\": " <> toJSHeader header + + namespace = + if hasService + then "" + else if hasNoModule + then "var " + else (moduleName opts) <> "." + where + hasNoModule = moduleName opts == "" + + hasService = serviceName ngOptions /= "" + + fsep = if hasService then ":" else " =" + + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) + + method = req ^. reqMethod + url = if url' == "'" then "'/'" else url' + url' = "'" + <> urlPrefix opts + <> urlArgs + <> queryArgs + + urlArgs = jsSegments + $ req ^.. reqUrl.path.traverse + + queryArgs = if null queryparams + then "" + else " + '?" <> jsParams queryparams diff --git a/src/Servant/JS/Axios.hs b/src/Servant/JS/Axios.hs new file mode 100644 --- /dev/null +++ b/src/Servant/JS/Axios.hs @@ -0,0 +1,137 @@ +{-#LANGUAGE OverloadedStrings #-} +module Servant.JS.Axios where + +import Control.Lens +import Data.Maybe (isJust) +import Data.Monoid +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import qualified Data.Text as T +import Servant.Foreign +import Servant.JS.Internal + +-- | Axios 'configuration' type +-- Let you customize the generation using Axios capabilities +data AxiosOptions = AxiosOptions + { -- | indicates whether or not cross-site Access-Control requests + -- should be made using credentials + withCredentials :: !Bool + -- | the name of the cookie to use as a value for xsrf token + , xsrfCookieName :: !(Maybe Text) + -- | the name of the header to use as a value for xsrf token + , xsrfHeaderName :: !(Maybe Text) + } + +-- | Default instance of the AxiosOptions +-- Defines the settings as they are in the Axios documentation +-- by default +defAxiosOptions :: AxiosOptions +defAxiosOptions = AxiosOptions + { withCredentials = False + , xsrfCookieName = Nothing + , xsrfHeaderName = Nothing + } + +-- | Generate regular javacript functions that use +-- the axios library, using default values for 'CommonGeneratorOptions'. +axios :: AxiosOptions -> JavaScriptGenerator +axios aopts = axiosWith aopts defCommonGeneratorOptions + +-- | Generate regular javascript functions that use the axios library. +axiosWith :: AxiosOptions -> CommonGeneratorOptions -> JavaScriptGenerator +axiosWith aopts opts = T.intercalate "\n\n" . map (generateAxiosJSWith aopts opts) + +-- | js codegen using axios library using default options +generateAxiosJS :: AxiosOptions -> AjaxReq -> Text +generateAxiosJS aopts = generateAxiosJSWith aopts defCommonGeneratorOptions + +-- | js codegen using axios library +generateAxiosJSWith :: AxiosOptions -> CommonGeneratorOptions -> AjaxReq -> Text +generateAxiosJSWith aopts opts req = "\n" <> + fname <> " = function(" <> argsStr <> ")\n" + <> "{\n" + <> " return axios({ url: " <> url <> "\n" + <> " , method: '" <> method <> "'\n" + <> dataBody + <> reqheaders + <> withCreds + <> xsrfCookie + <> xsrfHeader + <> " });\n" + <> "}\n" + + where argsStr = T.intercalate ", " args + args = captures + ++ map (view $ queryArgName . argPath) queryparams + ++ body + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . argPath) + ) hs + + captures = map (view argPath . captureArg) + . filter isCapture + $ req ^. reqUrl.path + + hs = req ^. reqHeaders + + queryparams = req ^.. reqUrl.queryStr.traverse + + body = if isJust (req ^. reqBody) + then [requestBody opts] + else [] + + dataBody = + if isJust (req ^. reqBody) + then " , data: body\n" <> + " , responseType: 'json'\n" + else "" + + withCreds = + if withCredentials aopts + then " , withCredentials: true\n" + else "" + + xsrfCookie = + case xsrfCookieName aopts of + Just name -> " , xsrfCookieName: '" <> name <> "'\n" + Nothing -> "" + + xsrfHeader = + case xsrfHeaderName aopts of + Just name -> " , xsrfHeaderName: '" <> name <> "'\n" + Nothing -> "" + + reqheaders = + if null hs + then "" + else " , headers: { " <> headersStr <> " }\n" + + where + headersStr = T.intercalate ", " $ map headerStr hs + headerStr header = "\"" <> + header ^. headerArg . argPath <> + "\": " <> toJSHeader header + + namespace = + if hasNoModule + then "var " + else (moduleName opts) <> "." + where + hasNoModule = moduleName opts == "" + + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) + + method = T.toLower . decodeUtf8 $ req ^. reqMethod + url = if url' == "'" then "'/'" else url' + url' = "'" + <> urlPrefix opts + <> urlArgs + <> queryArgs + + urlArgs = jsSegments + $ req ^.. reqUrl.path.traverse + + queryArgs = if null queryparams + then "" + else " + '?" <> jsParams queryparams diff --git a/src/Servant/JS/Internal.hs b/src/Servant/JS/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Servant/JS/Internal.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Servant.JS.Internal + ( JavaScriptGenerator + , CommonGeneratorOptions(..) + , defCommonGeneratorOptions + , AjaxReq + , jsSegments + , segmentToStr + , segmentTypeToStr + , jsParams + , jsGParams + , paramToStr + , toValidFunctionName + , toJSHeader + -- re-exports + , (:<|>)(..) + , (:>) + , defReq + , reqHeaders + , HasForeign(..) + , HasForeignType(..) + , GenerateList(..) + , NoTypes + , HeaderArg + , ArgType(..) + , HeaderArg(..) + , QueryArg(..) + , Req(..) + , Segment(..) + , SegmentType(..) + , Url(..) + , Path + , Arg(..) + , FunctionName(..) + , PathSegment(..) + , concatCase + , snakeCase + , camelCase + , ReqBody + , JSON + , FormUrlEncoded + , Post + , Get + , Raw + , Header + ) where + +import Control.Lens hiding (List) +import qualified Data.CharSet as Set +import qualified Data.CharSet.Unicode.Category as Set +import Data.Monoid +import qualified Data.Text as T +import Data.Text (Text) +import Servant.Foreign + +type AjaxReq = Req () + +-- A 'JavascriptGenerator' just takes the data found in the API type +-- for each endpoint and generates Javascript code in a Text. Several +-- generators are available in this package. +type JavaScriptGenerator = [Req ()] -> Text + +-- | This structure is used by specific implementations to let you +-- customize the output +data CommonGeneratorOptions = CommonGeneratorOptions + { + functionNameBuilder :: FunctionName -> Text + -- ^ function generating function names + , requestBody :: Text + -- ^ name used when a user want to send the request body + -- (to let you redefine it) + , successCallback :: Text + -- ^ name of the callback parameter when the request was successful + , errorCallback :: Text + -- ^ name of the callback parameter when the request reported an error + , moduleName :: Text + -- ^ namespace on which we define the foreign function (empty mean local var) + , urlPrefix :: Text + -- ^ 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 = "" + } + +-- | Attempts to reduce the function name provided to that allowed by @'Foreign'@. +-- +-- 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 :: Text -> Text +toValidFunctionName t = + case T.uncons t of + Just (x,xs) -> + setFirstChar x `T.cons` T.filter remainder xs + Nothing -> "_" + where + setFirstChar c = if firstChar c then c else '_' + firstChar c = prefixOK c || Set.member c firstLetterOK + remainder c = prefixOK c || Set.member c remainderOK + prefixOK c = c `elem` ['$','_'] + firstLetterOK = mconcat + [ Set.lowercaseLetter + , Set.uppercaseLetter + , Set.titlecaseLetter + , Set.modifierLetter + , Set.otherLetter + , Set.letterNumber + ] + remainderOK = firstLetterOK + <> mconcat + [ Set.nonSpacingMark + , Set.spacingCombiningMark + , Set.decimalNumber + , Set.connectorPunctuation + ] + +toJSHeader :: HeaderArg f -> Text +toJSHeader (HeaderArg n) + = toValidFunctionName ("header" <> n ^. argName . _PathSegment) +toJSHeader (ReplaceHeaderArg n p) + | pn `T.isPrefixOf` p = pv <> " + \"" <> rp <> "\"" + | pn `T.isSuffixOf` p = "\"" <> rp <> "\" + " <> pv + | pn `T.isInfixOf` p = "\"" <> (T.replace pn ("\" + " <> pv <> " + \"") p) + <> "\"" + | otherwise = p + where + pv = toValidFunctionName ("header" <> n ^. argName . _PathSegment) + pn = "{" <> n ^. argName . _PathSegment <> "}" + rp = T.replace pn "" p + +jsSegments :: [Segment f] -> Text +jsSegments [] = "" +jsSegments [x] = "/" <> segmentToStr x False +jsSegments (x:xs) = "/" <> segmentToStr x True <> jsSegments xs + +segmentToStr :: Segment f -> Bool -> Text +segmentToStr (Segment st) notTheEnd = + segmentTypeToStr st <> if notTheEnd then "" else "'" + +segmentTypeToStr :: SegmentType f -> Text +segmentTypeToStr (Static s) = s ^. _PathSegment +segmentTypeToStr (Cap s) = + "' + encodeURIComponent(" <> s ^. argName . _PathSegment <> ") + '" + +jsGParams :: Text -> [QueryArg f] -> Text +jsGParams _ [] = "" +jsGParams _ [x] = paramToStr x False +jsGParams s (x:xs) = paramToStr x True <> s <> jsGParams s xs + +jsParams :: [QueryArg f] -> Text +jsParams = jsGParams "&" + +paramToStr :: QueryArg f -> Bool -> Text +paramToStr qarg notTheEnd = + case qarg ^. queryArgType of + Normal -> name + <> "=' + encodeURIComponent(" + <> name + <> if notTheEnd then ") + '" else ")" + Flag -> name <> "=" + List -> name + <> "[]=' + encodeURIComponent(" + <> name + <> if notTheEnd then ") + '" else ")" + where name = qarg ^. queryArgName . argName . _PathSegment diff --git a/src/Servant/JS/JQuery.hs b/src/Servant/JS/JQuery.hs new file mode 100644 --- /dev/null +++ b/src/Servant/JS/JQuery.hs @@ -0,0 +1,103 @@ +{-#LANGUAGE OverloadedStrings #-} +module Servant.JS.JQuery where + +import Control.Lens +import Data.Maybe (isJust) +import Data.Monoid +import qualified Data.Text as T +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Servant.Foreign +import Servant.JS.Internal + + +-- | Generate javascript functions that use the /jQuery/ library +-- to make the AJAX calls. Uses 'defCommonGeneratorOptions' +-- for the generator options. +jquery :: JavaScriptGenerator +jquery = mconcat . map generateJQueryJS + +-- | Generate javascript functions that use the /jQuery/ library +-- to make the AJAX calls. Lets you specify your own 'CommonGeneratorOptions'. +jqueryWith :: CommonGeneratorOptions -> JavaScriptGenerator +jqueryWith opts = mconcat . map (generateJQueryJSWith opts) + +-- | js codegen using JQuery using default options +generateJQueryJS :: AjaxReq -> Text +generateJQueryJS = generateJQueryJSWith defCommonGeneratorOptions + +-- | js codegen using JQuery +generateJQueryJSWith :: CommonGeneratorOptions -> AjaxReq -> Text +generateJQueryJSWith opts req = "\n" <> + fname <> " = function(" <> argsStr <> ")\n" + <> "{\n" + <> " $.ajax(\n" + <> " { url: " <> url <> "\n" + <> " , success: " <> onSuccess <> "\n" + <> dataBody + <> reqheaders + <> " , error: " <> onError <> "\n" + <> " , type: '" <> decodeUtf8 method <> "'\n" + <> " });\n" + <> "}\n" + + where argsStr = T.intercalate ", " args + args = captures + ++ map (view $ queryArgName . argPath) queryparams + ++ body + ++ map (toValidFunctionName + . (<>) "header" + . view (headerArg . argPath) + ) hs + ++ [onSuccess, onError] + + captures = map (view argPath . captureArg) + . filter isCapture + $ req ^. reqUrl.path + + hs = req ^. reqHeaders + + queryparams = req ^.. reqUrl.queryStr.traverse + + body = if isJust (req ^. reqBody) + then [requestBody opts] + else [] + + onSuccess = successCallback opts + onError = errorCallback opts + + dataBody = + if isJust $ req ^. reqBody + then " , data: JSON.stringify(body)\n" <> + " , contentType: 'application/json'\n" + else "" + + reqheaders = + if null hs + then "" + else " , headers: { " <> headersStr <> " }\n" + + where + headersStr = T.intercalate ", " $ map headerStr hs + headerStr header = "\"" <> + header ^. headerArg . argPath <> + "\": " <> toJSHeader header + + namespace = if (moduleName opts) == "" + then "var " + else (moduleName opts) <> "." + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) + + method = req ^. reqMethod + url = if url' == "'" then "'/'" else url' + url' = "'" + <> urlPrefix opts + <> urlArgs + <> queryArgs + + urlArgs = jsSegments + $ req ^.. reqUrl.path.traverse + + queryArgs = if null queryparams + then "" + else " + '?" <> jsParams queryparams diff --git a/src/Servant/JS/Vanilla.hs b/src/Servant/JS/Vanilla.hs new file mode 100644 --- /dev/null +++ b/src/Servant/JS/Vanilla.hs @@ -0,0 +1,114 @@ +{-#LANGUAGE OverloadedStrings #-} +module Servant.JS.Vanilla where + +import Control.Lens +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import qualified Data.Text as T +import Data.Monoid +import Servant.Foreign +import Servant.JS.Internal + +-- | Generate vanilla javascript functions to make AJAX requests +-- to your API, using /XMLHttpRequest/. Uses 'defCommonGeneratorOptions' +-- for the 'CommonGeneratorOptions'. +vanillaJS :: JavaScriptGenerator +vanillaJS = mconcat . map generateVanillaJS + +-- | Generate vanilla javascript functions to make AJAX requests +-- to your API, using /XMLHttpRequest/. Lets you specify your +-- own options. +vanillaJSWith :: CommonGeneratorOptions -> JavaScriptGenerator +vanillaJSWith opts = mconcat . map (generateVanillaJSWith opts) + +-- | js codegen using XmlHttpRequest using default generation options +generateVanillaJS :: AjaxReq -> Text +generateVanillaJS = generateVanillaJSWith defCommonGeneratorOptions + +-- | js codegen using XmlHttpRequest +generateVanillaJSWith :: CommonGeneratorOptions -> AjaxReq -> Text +generateVanillaJSWith opts req = "\n" <> + fname <> " = function(" <> argsStr <> ")\n" + <> "{\n" + <> " var xhr = new XMLHttpRequest();\n" + <> " xhr.open('" <> decodeUtf8 method <> "', " <> url <> ", true);\n" + <> reqheaders + <> " xhr.setRequestHeader(\"Accept\",\"application/json\");\n" + <> (if isJust (req ^. reqBody) then " xhr.setRequestHeader(\"Content-Type\",\"application/json\");\n" else "") + <> " xhr.onreadystatechange = function (e) {\n" + <> " if (xhr.readyState == 4) {\n" + <> " if (xhr.status == 204 || xhr.status == 205) {\n" + <> " onSuccess();\n" + <> " } else if (xhr.status >= 200 && xhr.status < 300) {\n" + <> " var value = JSON.parse(xhr.responseText);\n" + <> " onSuccess(value);\n" + <> " } else {\n" + <> " var value = JSON.parse(xhr.responseText);\n" + <> " onError(value);\n" + <> " }\n" + <> " }\n" + <> " }\n" + <> " xhr.send(" <> dataBody <> ");\n" + <> "}\n" + + where argsStr = T.intercalate ", " args + args = captures + ++ map (view $ queryArgName . argPath) queryparams + ++ body + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . argPath) + ) hs + ++ [onSuccess, onError] + + captures = map (view argPath . captureArg) + . filter isCapture + $ req ^. reqUrl.path + + hs = req ^. reqHeaders + + queryparams = req ^.. reqUrl.queryStr.traverse + + body = if isJust(req ^. reqBody) + then [requestBody opts] + else [] + + onSuccess = successCallback opts + onError = errorCallback opts + + dataBody = + if isJust (req ^. reqBody) + then "JSON.stringify(body)\n" + else "null" + + + reqheaders = + if null hs + then "" + else headersStr <> "\n" + + where + headersStr = T.intercalate "\n" $ map headerStr hs + headerStr header = " xhr.setRequestHeader(\"" <> + header ^. headerArg . argPath <> + "\", " <> toJSHeader header <> ");" + + namespace = if moduleName opts == "" + then "var " + else (moduleName opts) <> "." + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) + + method = req ^. reqMethod + url = if url' == "'" then "'/'" else url' + url' = "'" + <> urlPrefix opts + <> urlArgs + <> queryArgs + + urlArgs = jsSegments + $ req ^.. reqUrl.path.traverse + + queryArgs = if null queryparams + then "" + else " + '?" <> jsParams queryparams diff --git a/test/Servant/JSSpec.hs b/test/Servant/JSSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/JSSpec.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Servant.JSSpec where + +import Data.Either (isRight) +import Data.Monoid () +import Data.Monoid.Compat ((<>)) +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as T +import Language.ECMAScript3.Parser (program, parse) +import Prelude () +import Prelude.Compat +import Test.Hspec hiding (shouldContain, shouldNotContain) + +import Servant.API.Internal.Test.ComprehensiveAPI +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 +import qualified Servant.JS.Vanilla as JS +import Servant.JSSpec.CustomHeaders + +-- * comprehensive api + +-- This declaration simply checks that all instances are in place. +_ = jsForAPI comprehensiveAPI vanillaJS :: Text + +-- * specs + +type TestAPI = "simple" :> ReqBody '[JSON,FormUrlEncoded] Text :> Post '[JSON] Bool + :<|> "has.extension" :> Get '[FormUrlEncoded,JSON] Bool + +type TopLevelRawAPI = "something" :> Get '[JSON] Int + :<|> Raw + +type HeaderHandlingAPI = "something" :> Header "Foo" Text + :> Get '[JSON] Int + +type CustomAuthAPI = "something" :> Authorization "Basic" Text + :> Get '[JSON] Int + +type CustomHeaderAPI = "something" :> MyLovelyHorse Text + :> Get '[JSON] Int + +type CustomHeaderAPI2 = "something" :> WhatsForDinner Text + :> Get '[JSON] Int + +headerHandlingProxy :: Proxy HeaderHandlingAPI +headerHandlingProxy = Proxy + +customAuthProxy :: Proxy CustomAuthAPI +customAuthProxy = Proxy + +customHeaderProxy :: Proxy CustomHeaderAPI +customHeaderProxy = Proxy + +customHeaderProxy2 :: Proxy CustomHeaderAPI2 +customHeaderProxy2 = Proxy + +data TestNames = Vanilla + | VanillaCustom + | JQuery + | JQueryCustom + | Angular + | AngularCustom + | Axios + | AxiosCustom + deriving (Show, Eq) + +customOptions :: CommonGeneratorOptions +customOptions = defCommonGeneratorOptions + { successCallback = "okCallback" + , errorCallback = "errorCallback" + } + +spec :: Spec +spec = describe "Servant.JQuery" $ do + generateJSSpec Vanilla JS.generateVanillaJS + generateJSSpec VanillaCustom (JS.generateVanillaJSWith customOptions) + generateJSSpec JQuery JQ.generateJQueryJS + generateJSSpec JQueryCustom (JQ.generateJQueryJSWith customOptions) + 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 { AX.withCredentials = True }) customOptions) + + angularSpec Angular + axiosSpec + --angularSpec AngularCustom + +shouldContain :: Text -> Text -> Expectation +a `shouldContain` b = shouldSatisfy a (T.isInfixOf b) + +shouldNotContain :: Text -> Text -> Expectation +a `shouldNotContain` b = shouldNotSatisfy a (T.isInfixOf b) + +axiosSpec :: Spec +axiosSpec = describe specLabel $ do + let reqList = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) (Proxy :: Proxy TestAPI) + it "should add withCredentials when needed" $ do + let jsText = genJS withCredOpts $ reqList + output jsText + jsText `shouldContain` "withCredentials: true" + it "should add xsrfCookieName when needed" $ do + let jsText = genJS cookieOpts $ reqList + output jsText + jsText `shouldContain` ("xsrfCookieName: 'MyXSRFcookie'") + it "should add withCredentials when needed" $ do + let jsText = genJS headerOpts $ reqList + output jsText + jsText `shouldContain` ("xsrfHeaderName: 'MyXSRFheader'") + where + specLabel = "Axios" + output _ = return () + withCredOpts = AX.defAxiosOptions { AX.withCredentials = True } + cookieOpts = AX.defAxiosOptions { AX.xsrfCookieName = Just "MyXSRFcookie" } + headerOpts = AX.defAxiosOptions { AX.xsrfHeaderName = Just "MyXSRFheader" } + genJS :: AxiosOptions -> [AjaxReq] -> Text + genJS opts req = mconcat . map (AX.generateAxiosJS opts) $ req + +angularSpec :: TestNames -> Spec +angularSpec test = describe specLabel $ do + let reqList = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) (Proxy :: Proxy TestAPI) + it "should implement a service globally" $ do + let jsText = genJS reqList + output jsText + jsText `shouldContain` (".service('" <> testName <> "'") + + it "should depend on $http service globally" $ do + let jsText = genJS reqList + output jsText + jsText `shouldContain` ("('" <> testName <> "', function($http) {") + + it "should not depend on $http service in handlers" $ do + let jsText = genJS reqList + output jsText + jsText `shouldNotContain` "getsomething($http, " + where + specLabel = "AngularJS(" <> (show test) <> ")" + output _ = return () + testName = "MyService" + ngOpts = NG.defAngularOptions { NG.serviceName = testName } + genJS req = NG.angularService ngOpts req + +generateJSSpec :: TestNames -> (AjaxReq -> Text) -> Spec +generateJSSpec n gen = describe specLabel $ do + let parseFromText = parse program "" + it "should generate valid javascript" $ do + let s = jsForAPI (Proxy :: Proxy TestAPI) (mconcat . map gen) + parseFromText s `shouldSatisfy` isRight + + it "should use non-empty function names" $ do + let (_ :<|> topLevel) = javascript (Proxy :: Proxy TopLevelRawAPI) + output $ genJS (topLevel "GET") + parseFromText (genJS $ topLevel "GET") `shouldSatisfy` isRight + + it "should handle simple HTTP headers" $ do + let jsText = genJS $ javascript headerHandlingProxy + output jsText + parseFromText jsText `shouldSatisfy` isRight + jsText `shouldContain` "headerFoo" + jsText `shouldContain` (header n "Foo" $ "headerFoo") + + it "should handle complex HTTP headers" $ do + let jsText = genJS $ javascript customAuthProxy + output jsText + parseFromText jsText `shouldSatisfy` isRight + jsText `shouldContain` "headerAuthorization" + jsText `shouldContain` (header n "Authorization" $ "\"Basic \" + headerAuthorization") + + it "should handle complex, custom HTTP headers" $ do + let jsText = genJS $ javascript customHeaderProxy + output jsText + parseFromText jsText `shouldSatisfy` isRight + jsText `shouldContain` "headerXMyLovelyHorse" + jsText `shouldContain` (header n "X-MyLovelyHorse" $ "\"I am good friends with \" + headerXMyLovelyHorse") + + it "should handle complex, custom HTTP headers (template replacement)" $ do + let jsText = genJS $ javascript customHeaderProxy2 + output jsText + parseFromText jsText `shouldSatisfy` isRight + jsText `shouldContain` "headerXWhatsForDinner" + jsText `shouldContain` (header n "X-WhatsForDinner" $ "\"I would like \" + headerXWhatsForDinner + \" with a cherry on top.\"") + + it "can generate the whole javascript code string at once with jsForAPI" $ do + let jsStr = jsForAPI (Proxy :: Proxy TestAPI) (mconcat . map gen) + parseFromText jsStr `shouldSatisfy` isRight + where + specLabel = "generateJS(" <> (show n) <> ")" + output _ = return () + genJS req = gen req + header :: TestNames -> Text -> Text -> Text + header v headerName headerValue + | v `elem` [Vanilla, VanillaCustom] = "xhr.setRequestHeader(\"" <> headerName <> "\", " <> headerValue <> ");\n" + | otherwise = "headers: { \"" <> headerName <> "\": " <> headerValue <> " }\n" diff --git a/test/Servant/JSSpec/CustomHeaders.hs b/test/Servant/JSSpec/CustomHeaders.hs new file mode 100644 --- /dev/null +++ b/test/Servant/JSSpec/CustomHeaders.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Servant.JSSpec.CustomHeaders where + +import Control.Lens +import Data.Monoid +import Data.Proxy +import Data.Text (pack) +import GHC.TypeLits +import Servant.JS.Internal + +-- | This is a hypothetical combinator that fetches an Authorization header. +-- The symbol in the header denotes what kind of authentication we are +-- using -- Basic, Digest, whatever. +data Authorization (sym :: Symbol) a + +instance (KnownSymbol sym, HasForeign lang () sublayout) + => HasForeign lang () (Authorization sym a :> sublayout) where + type Foreign () (Authorization sym a :> sublayout) = Foreign () sublayout + + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $ + req & reqHeaders <>~ + [ ReplaceHeaderArg (Arg "Authorization" ()) + $ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ] + where + tokenType t = t <> " {Authorization}" + +-- | This is a combinator that fetches an X-MyLovelyHorse header. +data MyLovelyHorse a + +instance (HasForeign lang () sublayout) + => HasForeign lang () (MyLovelyHorse a :> sublayout) where + type Foreign () (MyLovelyHorse a :> sublayout) = Foreign () sublayout + + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $ + req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" ()) tpl ] + where + tpl = "I am good friends with {X-MyLovelyHorse}" + +-- | This is a combinator that fetches an X-WhatsForDinner header. +data WhatsForDinner a + +instance (HasForeign lang () sublayout) + => HasForeign lang () (WhatsForDinner a :> sublayout) where + type Foreign () (WhatsForDinner a :> sublayout) = Foreign () sublayout + + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $ + req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" ()) tpl ] + where + tpl = "I would like {X-WhatsForDinner} with a cherry on top." diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +