haskell-servant · shrynx · Jul 30, 2018 · Jul 30, 2018 · Jul 30, 2018
diff --git a/.gitignore b/.gitignore
@@ -1,3 +1,5 @@
 dist/
 dist-newstyle/
 .stack-work/
+examples/**/*/api.js
+examples/**/*/api.service.js
diff --git a/examples/counter.hs b/examples/counter.hs
@@ -95,6 +95,8 @@ main = do
 
   writeJSForAPI testApi (axios defAxiosOptions) (www </> "axios" </> "api.js")
 
+  writeJSForAPI testApi (fetch defFetchOptions) (www </> "fetch" </> "api.js")
+
   writeServiceJS (www </> "angular" </> "api.service.js")
 
   -- setup a shared counter

diff --git a/examples/www/fetch/index.html b/examples/www/fetch/index.html
@@ -0,0 +1,39 @@
+<html>
+<head>
+  <title>Servant: counter</title>
+  <style>
+  body { text-align: center; }
+  #counter { color: green; }
+  #inc { margin: 0px 20px; background-color: green; color: white; }
+  </style>
+</head>
+<body>
+<h1>Fetch version</h1>
+<span id="counter">Counter: 0</span>
+<button id="inc">Increase</button>
+
+<script src="api.js" type="text/javascript"></script>
+<script type="text/javascript">
+window.addEventListener('load', function() {
+  // we get the current value stored by the server when the page is loaded
+  getCounter().then(res => res.json()).then(updateCounter).catch(alert);
+
+  // we update the value every 1sec, in the same way
+  window.setInterval(function() {
+    getCounter().then(res => res.json()).then(updateCounter).catch(alert);
+  }, 1000);
+});
+
+function updateCounter(response)
+{
+  document.getElementById('counter').innerHTML = 'Counter: ' + response.value;
+}
+
+// when the button is clicked, ask the server to increase
+// the value by one
+document.getElementById('inc').addEventListener('click', function() {
+  postCounter().then(res => res.json()).then(updateCounter).catch(alert);
+});
+</script>
+</body>
+</html>
diff --git a/examples/www/index.html b/examples/www/index.html
@@ -15,5 +15,6 @@
 <iframe src="angular/"></iframe>
 <iframe src="angular/service.html"></iframe>
 <iframe src="axios/"></iframe>
+<iframe src="fetch/"></iframe>
 </body>
 </html>
diff --git a/servant-js.cabal b/servant-js.cabal
@@ -43,6 +43,7 @@ library
                        Servant.JS.Internal
                        Servant.JS.JQuery
                        Servant.JS.Vanilla
+                       Servant.JS.Fetch
   build-depends:       base            >= 4.7 && <4.12
                      , base-compat     >= 0.9
                      , charset         >= 0.3

diff --git a/src/Servant/JS.hs b/src/Servant/JS.hs
@@ -107,6 +107,12 @@ module Servant.JS
   , AxiosOptions(..)
   , defAxiosOptions
 
+  , -- * Fetch code generation
+    fetch
+  , fetchWith
+  , FetchOptions(..)
+  , defFetchOptions
+
   , -- * Misc.
     listFromAPI
   , javascript
@@ -122,6 +128,7 @@ import           Data.Text.IO        (writeFile)
 import           Servant.API.ContentTypes
 import           Servant.JS.Angular
 import           Servant.JS.Axios
+import           Servant.JS.Fetch
 import           Servant.JS.Internal
 import           Servant.JS.JQuery
 import           Servant.JS.Vanilla

diff --git a/src/Servant/JS/Fetch.hs b/src/Servant/JS/Fetch.hs
@@ -0,0 +1,188 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Servant.JS.Fetch where
+
+import           Control.Lens
+import           Data.Maybe          (isJust)
+import           Data.Monoid         ((<>))
+import           Data.Text           (Text)
+import qualified Data.Text           as T
+import           Data.Text.Encoding  (decodeUtf8)
+import           Servant.Foreign
+import           Servant.JS.Internal
+
+data ModeOpts =
+    ModeNotSpecified
+  | Navigate
+  | Cors 
+  | NoCors 
+  | SameOrigin
+
+instance Show ModeOpts where
+  show ModeNotSpecified = ""
+  show Navigate = "navigate"
+  show Cors = "cors"
+  show NoCors = "no-cors"
+  show SameOrigin = "same-origin"
+
+data CacheOpts = 
+    CacheNotSpecified 
+  | Default  
+  | NoStore
+  | Reload
+  | NoCache
+  | ForceCache
+  | OnlyIfCached
+
+instance Show CacheOpts where
+  show CacheNotSpecified = ""
+  show Default = "default"
+  show NoStore = "no-store"
+  show Reload = "reload"
+  show NoCache = "no-cache"
+  show ForceCache = "force-cache"
+  show OnlyIfCached = "only-if-cached"
+
+data CredentialOpts =
+    CredentialNotSpecified
+  | Omit
+  | Include
+  | SameOriginCredential
+
+instance Show CredentialOpts where
+  show CredentialNotSpecified = ""
+  show Omit = "omit"
+  show Include = "include"
+  show SameOriginCredential = "same-origin"
+
+-- | Fetch 'configuration' type
+-- Let you customize the generation using Fetch capabilities
+data FetchOptions = FetchOptions
+  { -- allows setting mode for cors 
+    mode :: !ModeOpts
+  -- allows specifying caching policy
+  , cache :: !CacheOpts
+  -- allows setting wether credentials should be sent with request
+  , credential :: !CredentialOpts
+  }
+
+instance Show CommonGeneratorOptions
+-- | Default instance of the FetchOptions
+-- Defines the settings as they are in the Fetch documentation
+-- by default
+defFetchOptions :: FetchOptions
+defFetchOptions = FetchOptions
+  { mode = ModeNotSpecified
+  , cache = CacheNotSpecified
+  , credential = CredentialNotSpecified
+  }
+
+-- | Generate regular javacript functions that use
+--   the fetch library, using default values for 'CommonGeneratorOptions'.
+fetch :: FetchOptions -> JavaScriptGenerator
+fetch aopts = fetchWith aopts defCommonGeneratorOptions
+
+-- | Generate regular javascript functions that use the fetch library.
+fetchWith :: FetchOptions -> CommonGeneratorOptions -> JavaScriptGenerator
+fetchWith aopts opts = T.intercalate "\n" . map (generateFetchJSWith aopts opts)
+
+-- | js codegen using fetch library using default options
+generateFetchJS :: FetchOptions -> AjaxReq -> Text
+generateFetchJS aopts = generateFetchJSWith aopts defCommonGeneratorOptions
+
+
+-- | js codegen using fetch library
+generateFetchJSWith :: FetchOptions -> CommonGeneratorOptions -> AjaxReq -> Text
+generateFetchJSWith aopts opts req =
+    fname <> " = function(" <> argsStr <> ") {\n"
+ <> "  return fetch(" <> url <>", {\n"
+ <> "    method: '" <> method <> "',\n"
+ <> dataBody
+ <> reqheaders
+ <> withMode
+ <> withCache
+ <> withCreds
+ <> "  });\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
+
+        hasBody = isJust (req ^. reqBody)
+
+        body = [requestBody opts | hasBody]
+
+        dataBody =
+          if hasBody
+            then "    data: JSON.stringify(body),\n" 
+            else ""
+
+        withMode = 
+          let modeType = mode aopts in 
+          case modeType of 
+            ModeNotSpecified -> ""
+            _ -> "    mode: "<> (T.pack . show) modeType <> ",\n"
+
+        withCache = 
+          let cacheType = cache aopts in 
+          case cacheType of 
+            CacheNotSpecified -> ""
+            _ -> "    cache: "<> (T.pack . show) cacheType <> ",\n"
+
+        withCreds =
+          let credType = credential aopts in 
+          case credType of
+            CredentialNotSpecified -> ""
+            _ -> "    credentials: "<> (T.pack . show) credType <> ",\n"
+
+        reqBodyHeader = "\"Content-Type\": \"application/json; charset=utf-8\""
+
+        reqheaders =
+          if null hs
+            then if hasBody
+              then "    headers: { " <> headersStr (reqBodyHeader : generatedHeader) <> " },\n"
+              else ""
+            else "    headers: { " <> headersStr generatedHeader <> " },\n"
+
+          where
+            headersStr = T.intercalate ", " 
+            generatedHeader = map headerStr hs
+            headerStr header = "\"" <>
+              header ^. headerArg . argPath <>
+              "\": " <> toJSHeader header
+
+        namespace =
+               if hasNoModule
+                  then "var "
+                  else moduleName opts <> "."
+               where
+                  hasNoModule = moduleName opts == ""
+
+        fname = namespace <> toValidFunctionName (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