Merge remote-tracking branch 'servant-jquery/prepare-merge' into merge
This commit is contained in:
Julian K. Arni
commit
9da1f6ef40
18 changed files with 1083 additions and 0 deletions
12
servant-jquery/CHANGELOG.md
Normal file
12
servant-jquery/CHANGELOG.md
Normal file
|
|
@ -0,0 +1,12 @@
|
||||||
|
0.3
|
||||||
|
---
|
||||||
|
* 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)
|
||||||
30
servant-jquery/LICENSE
Normal file
30
servant-jquery/LICENSE
Normal file
|
|
@ -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.
|
||||||
97
servant-jquery/README.md
Normal file
97
servant-jquery/README.md
Normal file
|
|
@ -0,0 +1,97 @@
|
||||||
|
# servant-jquery
|
||||||
|
|
||||||
|
[](http://travis-ci.org/haskell-servant/servant-jquery)
|
||||||
|
[](https://coveralls.io/r/haskell-servant/servant-jquery)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
This library lets you derive automatically (JQuery based) Javascript functions that let you query each endpoint of a *servant* webservice.
|
||||||
|
|
||||||
|
## Example
|
||||||
|
|
||||||
|
Read more about the following example [here](https://github.com/haskell-servant/servant-jquery/tree/master/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.JQuery
|
||||||
|
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 Counter -- endpoint for increasing the counter
|
||||||
|
:<|> "counter" :> Get Counter -- endpoint to get the current value
|
||||||
|
:<|> Raw -- used for serving static files
|
||||||
|
|
||||||
|
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
|
||||||
|
:<|> 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)
|
||||||
|
|
||||||
|
-- * Generating the JQuery code
|
||||||
|
|
||||||
|
incCounterJS :<|> currentValueJS :<|> _ = jquery testApi
|
||||||
|
|
||||||
|
writeJS :: FilePath -> [AjaxReq] -> IO ()
|
||||||
|
writeJS fp functions = writeFile fp $
|
||||||
|
concatMap generateJS functions
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
-- write the JS code to www/api.js at startup
|
||||||
|
writeJS (www </> "api.js")
|
||||||
|
[ incCounterJS, currentValueJS ]
|
||||||
|
|
||||||
|
-- setup a shared counter
|
||||||
|
cnt <- newCounter
|
||||||
|
|
||||||
|
-- listen to requests on port 8080
|
||||||
|
runServer cnt 8080
|
||||||
|
```
|
||||||
2
servant-jquery/Setup.hs
Normal file
2
servant-jquery/Setup.hs
Normal file
|
|
@ -0,0 +1,2 @@
|
||||||
|
import Distribution.Simple
|
||||||
|
main = defaultMain
|
||||||
1
servant-jquery/TODO.md
Normal file
1
servant-jquery/TODO.md
Normal file
|
|
@ -0,0 +1 @@
|
||||||
|
- Investigate the best way to offer cross-origin requests
|
||||||
52
servant-jquery/docs.sh
Normal file
52
servant-jquery/docs.sh
Normal file
|
|
@ -0,0 +1,52 @@
|
||||||
|
SERVANT_DIR=/tmp/servant-jquery-gh-pages
|
||||||
|
|
||||||
|
# Make a temporary clone
|
||||||
|
|
||||||
|
rm -rf $SERVANT_DIR
|
||||||
|
|
||||||
|
git clone . $SERVANT_DIR
|
||||||
|
|
||||||
|
cd $SERVANT_DIR
|
||||||
|
|
||||||
|
# Make sure to pull the latest
|
||||||
|
|
||||||
|
git remote add haskell-servant git@github.com:haskell-servant/servant-jquery.git
|
||||||
|
|
||||||
|
git fetch haskell-servant
|
||||||
|
|
||||||
|
git reset --hard haskell-servant/gh-pages
|
||||||
|
|
||||||
|
# Clear everything away
|
||||||
|
|
||||||
|
git rm -rf $SERVANT_DIR/*
|
||||||
|
|
||||||
|
# Switch back and build the haddocks
|
||||||
|
|
||||||
|
cd -
|
||||||
|
|
||||||
|
cabal configure --builddir=$SERVANT_DIR
|
||||||
|
|
||||||
|
cabal haddock --hoogle --hyperlink-source --html-location='https://hackage.haskell.org/package/$pkg-$version/docs' --builddir=$SERVANT_DIR
|
||||||
|
|
||||||
|
commit_hash=$(git rev-parse HEAD)
|
||||||
|
|
||||||
|
# Move the HTML docs to the root
|
||||||
|
|
||||||
|
cd $SERVANT_DIR
|
||||||
|
|
||||||
|
rm *
|
||||||
|
rm -rf build
|
||||||
|
mv doc/html/servant-jquery/* .
|
||||||
|
rm -r doc/
|
||||||
|
|
||||||
|
# Add everything
|
||||||
|
|
||||||
|
git add .
|
||||||
|
|
||||||
|
git commit -m "Built from $commit_hash"
|
||||||
|
|
||||||
|
# Push to update the pages
|
||||||
|
|
||||||
|
git push haskell-servant HEAD:gh-pages
|
||||||
|
|
||||||
|
rm -rf $SERVANT_DIR
|
||||||
17
servant-jquery/examples/README.md
Normal file
17
servant-jquery/examples/README.md
Normal file
|
|
@ -0,0 +1,17 @@
|
||||||
|
# Examples
|
||||||
|
|
||||||
|
## counter
|
||||||
|
|
||||||
|
This example demonstrates a *servant* server that holds a shared variable (using a `TVar`) and exposes an endpoint for reading its current value and another one for increasing its current value by 1.
|
||||||
|
|
||||||
|
In addition to that, it shows how you can generate the jquery-powered javascript functions corresponding to each endpoint, i.e one for reading the current value and one for increasing the value, and integrates all of that in a very simple HTML page. All these static files are served using the `serveDirectory` function from *servant*.
|
||||||
|
|
||||||
|
To see this all in action, simply run:
|
||||||
|
|
||||||
|
``` bash
|
||||||
|
$ cabal run counter
|
||||||
|
```
|
||||||
|
|
||||||
|
And point your browser to [http://localhost:8080/index.html](http://localhost:8080/index.html).
|
||||||
|
|
||||||
|
Copies of the generated javascript functions and of the generated docs are included in `www/api.js` and `counter.md` respectively.
|
||||||
82
servant-jquery/examples/counter.hs
Normal file
82
servant-jquery/examples/counter.hs
Normal file
|
|
@ -0,0 +1,82 @@
|
||||||
|
{-# 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.JQuery
|
||||||
|
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 Counter -- endpoint for increasing the counter
|
||||||
|
:<|> "counter" :> Get Counter -- endpoint to get the current value
|
||||||
|
:<|> Raw -- used for serving static files
|
||||||
|
|
||||||
|
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
|
||||||
|
:<|> 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)
|
||||||
|
|
||||||
|
-- * Generating the JQuery code
|
||||||
|
|
||||||
|
incCounterJS :<|> currentValueJS :<|> _ = jquery testApi
|
||||||
|
|
||||||
|
writeJS :: FilePath -> [AjaxReq] -> IO ()
|
||||||
|
writeJS fp functions = writeFile fp $
|
||||||
|
concatMap generateJS functions
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
-- write the JS code to www/api.js at startup
|
||||||
|
writeJS (www </> "api.js")
|
||||||
|
[ incCounterJS, currentValueJS ]
|
||||||
|
|
||||||
|
-- setup a shared counter
|
||||||
|
cnt <- newCounter
|
||||||
|
|
||||||
|
-- listen to requests on port 8080
|
||||||
|
runServer cnt 8080
|
||||||
39
servant-jquery/examples/counter.md
Normal file
39
servant-jquery/examples/counter.md
Normal file
|
|
@ -0,0 +1,39 @@
|
||||||
|
POST /counter
|
||||||
|
-------------
|
||||||
|
|
||||||
|
**Response**:
|
||||||
|
|
||||||
|
- Status code 201
|
||||||
|
- Response body as below.
|
||||||
|
|
||||||
|
``` javascript
|
||||||
|
{"value":0}
|
||||||
|
```
|
||||||
|
|
||||||
|
GET /doc
|
||||||
|
--------
|
||||||
|
|
||||||
|
**Response**:
|
||||||
|
|
||||||
|
- Status code 200
|
||||||
|
- No response body
|
||||||
|
|
||||||
|
GET /counter
|
||||||
|
------------
|
||||||
|
|
||||||
|
**Response**:
|
||||||
|
|
||||||
|
- Status code 200
|
||||||
|
- Response body as below.
|
||||||
|
|
||||||
|
``` javascript
|
||||||
|
{"value":0}
|
||||||
|
```
|
||||||
|
|
||||||
|
GET /
|
||||||
|
-----
|
||||||
|
|
||||||
|
**Response**:
|
||||||
|
|
||||||
|
- Status code 200
|
||||||
|
- No response body
|
||||||
20
servant-jquery/examples/www/api.js
Normal file
20
servant-jquery/examples/www/api.js
Normal file
|
|
@ -0,0 +1,20 @@
|
||||||
|
|
||||||
|
function postcounter(onSuccess, onError)
|
||||||
|
{
|
||||||
|
$.ajax(
|
||||||
|
{ url: '/counter'
|
||||||
|
, success: onSuccess
|
||||||
|
, error: onError
|
||||||
|
, type: 'POST'
|
||||||
|
});
|
||||||
|
}
|
||||||
|
|
||||||
|
function getcounter(onSuccess, onError)
|
||||||
|
{
|
||||||
|
$.ajax(
|
||||||
|
{ url: '/counter'
|
||||||
|
, success: onSuccess
|
||||||
|
, error: onError
|
||||||
|
, type: 'GET'
|
||||||
|
});
|
||||||
|
}
|
||||||
40
servant-jquery/examples/www/index.html
Normal file
40
servant-jquery/examples/www/index.html
Normal file
|
|
@ -0,0 +1,40 @@
|
||||||
|
<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>
|
||||||
|
<span id="counter">Counter: 0</span>
|
||||||
|
<button id="inc">Increase</button>
|
||||||
|
or <a href="/doc">view the docs</a>
|
||||||
|
|
||||||
|
<script src="/jquery.min.js" type="text/javascript"></script>
|
||||||
|
<script src="/api.js" type="text/javascript"></script>
|
||||||
|
<script type="text/javascript">
|
||||||
|
$(document).ready(function() {
|
||||||
|
// we get the current value stored by the server when the page is loaded
|
||||||
|
getcounter(updateCounter, alert);
|
||||||
|
|
||||||
|
// we update the value every 1sec, in the same way
|
||||||
|
window.setInterval(function() {
|
||||||
|
getcounter(updateCounter, alert);
|
||||||
|
}, 1000);
|
||||||
|
});
|
||||||
|
|
||||||
|
function updateCounter(response)
|
||||||
|
{
|
||||||
|
$('#counter').html('Counter: ' + response.value);
|
||||||
|
}
|
||||||
|
|
||||||
|
// when the button is clicked, ask the server to increase
|
||||||
|
// the value by one
|
||||||
|
$('#inc').click(function() {
|
||||||
|
postcounter(updateCounter, alert);
|
||||||
|
});
|
||||||
|
</script>
|
||||||
|
</body>
|
||||||
|
</html>
|
||||||
4
servant-jquery/examples/www/jquery.min.js
vendored
Normal file
4
servant-jquery/examples/www/jquery.min.js
vendored
Normal file
File diff suppressed because one or more lines are too long
78
servant-jquery/servant-jquery.cabal
Normal file
78
servant-jquery/servant-jquery.cabal
Normal file
|
|
@ -0,0 +1,78 @@
|
||||||
|
name: servant-jquery
|
||||||
|
version: 0.2.2
|
||||||
|
synopsis: Automatically derive (jquery) javascript functions to query servant webservices
|
||||||
|
description:
|
||||||
|
Automatically derive jquery-based javascript functions to query servant webservices.
|
||||||
|
.
|
||||||
|
Example <https://github.com/haskell-servant/servant-jquery/blob/master/examples/counter.hs here> that serves the generated javascript to a webpage that lets you
|
||||||
|
trigger webservice calls.
|
||||||
|
license: BSD3
|
||||||
|
license-file: LICENSE
|
||||||
|
author: Alp Mestanogullari
|
||||||
|
maintainer: alpmestan@gmail.com
|
||||||
|
copyright: 2014 Alp Mestanogullari
|
||||||
|
category: Web
|
||||||
|
build-type: Simple
|
||||||
|
cabal-version: >=1.10
|
||||||
|
homepage: http://haskell-servant.github.io/
|
||||||
|
Bug-reports: http://github.com/haskell-servant/servant-jquery/issues
|
||||||
|
extra-source-files:
|
||||||
|
CHANGELOG.md
|
||||||
|
README.md
|
||||||
|
source-repository head
|
||||||
|
type: git
|
||||||
|
location: http://github.com/haskell-servant/servant-jquery.git
|
||||||
|
|
||||||
|
flag example
|
||||||
|
description: Build the example too
|
||||||
|
manual: True
|
||||||
|
default: False
|
||||||
|
|
||||||
|
library
|
||||||
|
exposed-modules: Servant.JQuery
|
||||||
|
other-modules: Servant.JQuery.Internal
|
||||||
|
build-depends: base >=4.5 && <5
|
||||||
|
, charset
|
||||||
|
, lens >= 4
|
||||||
|
, servant >= 0.2.2
|
||||||
|
, text
|
||||||
|
hs-source-dirs: src
|
||||||
|
default-language: Haskell2010
|
||||||
|
ghc-options: -Wall
|
||||||
|
|
||||||
|
executable counter
|
||||||
|
main-is: counter.hs
|
||||||
|
ghc-options: -O2 -Wall
|
||||||
|
hs-source-dirs: examples
|
||||||
|
|
||||||
|
if flag(example)
|
||||||
|
buildable: True
|
||||||
|
else
|
||||||
|
buildable: False
|
||||||
|
|
||||||
|
build-depends:
|
||||||
|
aeson
|
||||||
|
, base
|
||||||
|
, filepath
|
||||||
|
, servant >= 0.2.2
|
||||||
|
, servant-server >= 0.2.3
|
||||||
|
, servant-jquery >= 0.2.2
|
||||||
|
, 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
|
||||||
|
build-depends:
|
||||||
|
base == 4.*
|
||||||
|
, lens
|
||||||
|
, servant-jquery
|
||||||
|
, servant
|
||||||
|
, hspec >= 2.0
|
||||||
|
, hspec-expectations
|
||||||
|
, language-ecmascript >= 0.16
|
||||||
|
default-language: Haskell2010
|
||||||
117
servant-jquery/src/Servant/JQuery.hs
Normal file
117
servant-jquery/src/Servant/JQuery.hs
Normal file
|
|
@ -0,0 +1,117 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
-----------------------------------------------------------------------------
|
||||||
|
-- |
|
||||||
|
-- Module : Servant.JQuery
|
||||||
|
-- Copyright : (C) 2014 Alp Mestanogullari
|
||||||
|
-- License : BSD3
|
||||||
|
-- Maintainer : Alp Mestanogullari <alpmestan@gmail.com>
|
||||||
|
-- Stability : experimental
|
||||||
|
-- Portability : non-portable
|
||||||
|
module Servant.JQuery
|
||||||
|
( jquery
|
||||||
|
, generateJS
|
||||||
|
, jsForAPI
|
||||||
|
, printJS
|
||||||
|
, module Servant.JQuery.Internal
|
||||||
|
, GenerateCode(..)
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Lens
|
||||||
|
import Data.List
|
||||||
|
import Data.Monoid
|
||||||
|
import Data.Proxy
|
||||||
|
import Servant.API
|
||||||
|
import Servant.JQuery.Internal
|
||||||
|
|
||||||
|
jquery :: HasJQ (Canonicalize layout) => Proxy layout -> JQ layout
|
||||||
|
jquery p = jqueryFor (canonicalize p) defReq
|
||||||
|
|
||||||
|
-- js codegen
|
||||||
|
generateJS :: AjaxReq -> String
|
||||||
|
generateJS req = "\n" <>
|
||||||
|
"function " <> fname <> "(" <> argsStr <> ")\n"
|
||||||
|
<> "{\n"
|
||||||
|
<> " $.ajax(\n"
|
||||||
|
<> " { url: " <> url <> "\n"
|
||||||
|
<> " , success: onSuccess\n"
|
||||||
|
<> dataBody
|
||||||
|
<> reqheaders
|
||||||
|
<> " , error: onError\n"
|
||||||
|
<> " , type: '" <> method <> "'\n"
|
||||||
|
<> " });\n"
|
||||||
|
<> "}\n"
|
||||||
|
|
||||||
|
where argsStr = intercalate ", " args
|
||||||
|
args = captures
|
||||||
|
++ map (view argName) queryparams
|
||||||
|
++ body
|
||||||
|
++ map (toValidFunctionName . (<>) "header" . headerArgName) hs
|
||||||
|
++ ["onSuccess", "onError"]
|
||||||
|
|
||||||
|
captures = map captureArg
|
||||||
|
. filter isCapture
|
||||||
|
$ req ^. reqUrl.path
|
||||||
|
|
||||||
|
hs = req ^. reqHeaders
|
||||||
|
|
||||||
|
queryparams = req ^.. reqUrl.queryStr.traverse
|
||||||
|
|
||||||
|
body = if req ^. reqBody
|
||||||
|
then ["body"]
|
||||||
|
else []
|
||||||
|
|
||||||
|
dataBody =
|
||||||
|
if req ^. reqBody
|
||||||
|
then "\n , data: JSON.stringify(body)\n"
|
||||||
|
else ""
|
||||||
|
|
||||||
|
reqheaders =
|
||||||
|
if null hs
|
||||||
|
then ""
|
||||||
|
else "\n , headers: { " ++ headersStr ++ " }\n"
|
||||||
|
|
||||||
|
where headersStr = intercalate ", " $ map headerStr hs
|
||||||
|
headerStr header = "\"" ++
|
||||||
|
headerArgName header ++
|
||||||
|
"\": " ++ show header
|
||||||
|
|
||||||
|
fname = req ^. funcName
|
||||||
|
method = req ^. reqMethod
|
||||||
|
url = if url' == "'" then "'/'" else url'
|
||||||
|
url' = "'"
|
||||||
|
++ urlArgs
|
||||||
|
++ queryArgs
|
||||||
|
|
||||||
|
urlArgs = jsSegments
|
||||||
|
$ req ^.. reqUrl.path.traverse
|
||||||
|
|
||||||
|
queryArgs = if null queryparams
|
||||||
|
then ""
|
||||||
|
else " + '?" ++ jsParams queryparams
|
||||||
|
|
||||||
|
printJS :: AjaxReq -> IO ()
|
||||||
|
printJS = putStrLn . generateJS
|
||||||
|
|
||||||
|
-- | Utility class used by 'jsForAPI' which will
|
||||||
|
-- directly hand you all the Javascript code
|
||||||
|
-- instead of handing you a ':<|>'-separated list
|
||||||
|
-- of 'AjaxReq' like 'jquery' and then having to
|
||||||
|
-- use 'generateJS' on each 'AjaxReq'.
|
||||||
|
class GenerateCode reqs where
|
||||||
|
jsFor :: reqs -> String
|
||||||
|
|
||||||
|
instance GenerateCode AjaxReq where
|
||||||
|
jsFor = generateJS
|
||||||
|
|
||||||
|
instance GenerateCode rest => GenerateCode (AjaxReq :<|> rest) where
|
||||||
|
jsFor (req :<|> rest) = jsFor req ++ jsFor rest
|
||||||
|
|
||||||
|
-- | 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 :: (HasJQ (Canonicalize api), GenerateCode (JQ api))
|
||||||
|
=> Proxy api -> String
|
||||||
|
jsForAPI p = jsFor (jquery p)
|
||||||
339
servant-jquery/src/Servant/JQuery/Internal.hs
Normal file
339
servant-jquery/src/Servant/JQuery/Internal.hs
Normal file
|
|
@ -0,0 +1,339 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
module Servant.JQuery.Internal where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Control.Lens
|
||||||
|
import Data.Char (toLower)
|
||||||
|
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
|
||||||
|
|
||||||
|
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 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) || (or . map (Set.member c) $ firstLetterOK)
|
||||||
|
remainder c = (prefixOK c) || (or . map (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"
|
||||||
|
|
||||||
|
jsSegments :: [Segment] -> String
|
||||||
|
jsSegments [] = ""
|
||||||
|
jsSegments [x] = "/" ++ segmentToStr x False
|
||||||
|
jsSegments (x:xs) = "/" ++ segmentToStr x True ++ jsSegments xs
|
||||||
|
|
||||||
|
segmentToStr :: Segment -> Bool -> String
|
||||||
|
segmentToStr (Segment st ms) notTheEnd =
|
||||||
|
segmentTypeToStr st ++ jsMParams ms ++ if notTheEnd then "" else "'"
|
||||||
|
|
||||||
|
segmentTypeToStr :: SegmentType -> String
|
||||||
|
segmentTypeToStr (Static s) = s
|
||||||
|
segmentTypeToStr (Cap s) = "' + encodeURIComponent(" ++ s ++ ") + '"
|
||||||
|
|
||||||
|
jsGParams :: String -> [QueryArg] -> String
|
||||||
|
jsGParams _ [] = ""
|
||||||
|
jsGParams _ [x] = paramToStr x False
|
||||||
|
jsGParams s (x:xs) = paramToStr x True ++ s ++ jsGParams s xs
|
||||||
|
|
||||||
|
jsParams :: [QueryArg] -> String
|
||||||
|
jsParams = jsGParams "&"
|
||||||
|
|
||||||
|
jsMParams :: [MatrixArg] -> String
|
||||||
|
jsMParams [] = ""
|
||||||
|
jsMParams xs = ";" ++ jsGParams ";" xs
|
||||||
|
|
||||||
|
paramToStr :: QueryArg -> Bool -> String
|
||||||
|
paramToStr qarg notTheEnd =
|
||||||
|
case qarg ^. argType of
|
||||||
|
Normal -> name
|
||||||
|
++ "=' + 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 HasJQ (layout :: *) where
|
||||||
|
type JQ' layout :: *
|
||||||
|
jqueryFor :: Proxy layout -> AjaxReq -> JQ' layout
|
||||||
|
|
||||||
|
type JQ layout = JQ' (Canonicalize layout)
|
||||||
|
|
||||||
|
instance (HasJQ a, HasJQ b)
|
||||||
|
=> HasJQ (a :<|> b) where
|
||||||
|
type JQ' (a :<|> b) = JQ' a :<|> JQ' b
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
jqueryFor (Proxy :: Proxy a) req
|
||||||
|
:<|> jqueryFor (Proxy :: Proxy b) req
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, HasJQ sublayout)
|
||||||
|
=> HasJQ (Capture sym a :> sublayout) where
|
||||||
|
type JQ' (Capture sym a :> sublayout) = JQ' sublayout
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
jqueryFor (Proxy :: Proxy sublayout) $
|
||||||
|
req & reqUrl.path <>~ [Segment (Cap str) []]
|
||||||
|
|
||||||
|
where str = symbolVal (Proxy :: Proxy sym)
|
||||||
|
|
||||||
|
instance HasJQ Delete where
|
||||||
|
type JQ' Delete = AjaxReq
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
req & funcName %~ ("delete" <>)
|
||||||
|
& reqMethod .~ "DELETE"
|
||||||
|
|
||||||
|
instance Elem JSON list => HasJQ (Get list a) where
|
||||||
|
type JQ' (Get list a) = AjaxReq
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
req & funcName %~ ("get" <>)
|
||||||
|
& reqMethod .~ "GET"
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, HasJQ sublayout)
|
||||||
|
=> HasJQ (Header sym a :> sublayout) where
|
||||||
|
type JQ' (Header sym a :> sublayout) = JQ' sublayout
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname])
|
||||||
|
|
||||||
|
where hname = symbolVal (Proxy :: Proxy sym)
|
||||||
|
subP = Proxy :: Proxy sublayout
|
||||||
|
|
||||||
|
instance Elem JSON list => HasJQ (Post list a) where
|
||||||
|
type JQ' (Post list a) = AjaxReq
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
req & funcName %~ ("post" <>)
|
||||||
|
& reqMethod .~ "POST"
|
||||||
|
|
||||||
|
instance Elem JSON list => HasJQ (Put list a) where
|
||||||
|
type JQ' (Put list a) = AjaxReq
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
req & funcName %~ ("put" <>)
|
||||||
|
& reqMethod .~ "PUT"
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, HasJQ sublayout)
|
||||||
|
=> HasJQ (QueryParam sym a :> sublayout) where
|
||||||
|
type JQ' (QueryParam sym a :> sublayout) = JQ' sublayout
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
jqueryFor (Proxy :: Proxy sublayout) $
|
||||||
|
req & reqUrl.queryStr <>~ [QueryArg str Normal]
|
||||||
|
|
||||||
|
where str = symbolVal (Proxy :: Proxy sym)
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, HasJQ sublayout)
|
||||||
|
=> HasJQ (QueryParams sym a :> sublayout) where
|
||||||
|
type JQ' (QueryParams sym a :> sublayout) = JQ' sublayout
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
jqueryFor (Proxy :: Proxy sublayout) $
|
||||||
|
req & reqUrl.queryStr <>~ [QueryArg str List]
|
||||||
|
|
||||||
|
where str = symbolVal (Proxy :: Proxy sym)
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, HasJQ sublayout)
|
||||||
|
=> HasJQ (QueryFlag sym :> sublayout) where
|
||||||
|
type JQ' (QueryFlag sym :> sublayout) = JQ' sublayout
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
jqueryFor (Proxy :: Proxy sublayout) $
|
||||||
|
req & reqUrl.queryStr <>~ [QueryArg str Flag]
|
||||||
|
|
||||||
|
where str = symbolVal (Proxy :: Proxy sym)
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, HasJQ sublayout)
|
||||||
|
=> HasJQ (MatrixParam sym a :> sublayout) where
|
||||||
|
type JQ' (MatrixParam sym a :> sublayout) = JQ' sublayout
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
jqueryFor (Proxy :: Proxy sublayout) $
|
||||||
|
req & reqUrl.path._last.matrix <>~ [QueryArg strArg Normal]
|
||||||
|
|
||||||
|
where str = symbolVal (Proxy :: Proxy sym)
|
||||||
|
strArg = str ++ "Value"
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, HasJQ sublayout)
|
||||||
|
=> HasJQ (MatrixParams sym a :> sublayout) where
|
||||||
|
type JQ' (MatrixParams sym a :> sublayout) = JQ' sublayout
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
jqueryFor (Proxy :: Proxy sublayout) $
|
||||||
|
req & reqUrl.path._last.matrix <>~ [QueryArg str List]
|
||||||
|
|
||||||
|
where str = symbolVal (Proxy :: Proxy sym)
|
||||||
|
|
||||||
|
instance (KnownSymbol sym, HasJQ sublayout)
|
||||||
|
=> HasJQ (MatrixFlag sym :> sublayout) where
|
||||||
|
type JQ' (MatrixFlag sym :> sublayout) = JQ' sublayout
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
jqueryFor (Proxy :: Proxy sublayout) $
|
||||||
|
req & reqUrl.path._last.matrix <>~ [QueryArg str Flag]
|
||||||
|
|
||||||
|
where str = symbolVal (Proxy :: Proxy sym)
|
||||||
|
|
||||||
|
instance HasJQ Raw where
|
||||||
|
type JQ' Raw = Method -> AjaxReq
|
||||||
|
|
||||||
|
jqueryFor Proxy req method =
|
||||||
|
req & funcName %~ ((toLower <$> method) <>)
|
||||||
|
& reqMethod .~ method
|
||||||
|
|
||||||
|
instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout) where
|
||||||
|
type JQ' (ReqBody list a :> sublayout) = JQ' sublayout
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
jqueryFor (Proxy :: Proxy sublayout) $
|
||||||
|
req & reqBody .~ True
|
||||||
|
|
||||||
|
instance (KnownSymbol path, HasJQ sublayout)
|
||||||
|
=> HasJQ (path :> sublayout) where
|
||||||
|
type JQ' (path :> sublayout) = JQ' sublayout
|
||||||
|
|
||||||
|
jqueryFor Proxy req =
|
||||||
|
jqueryFor (Proxy :: Proxy sublayout) $
|
||||||
|
req & reqUrl.path <>~ [Segment (Static str) []]
|
||||||
|
& funcName %~ (str <>)
|
||||||
|
|
||||||
|
where str = map (\c -> if c == '.' then '_' else c) $ symbolVal (Proxy :: Proxy path)
|
||||||
96
servant-jquery/test/Servant/JQuerySpec.hs
Normal file
96
servant-jquery/test/Servant/JQuerySpec.hs
Normal file
|
|
@ -0,0 +1,96 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
module Servant.JQuerySpec where
|
||||||
|
|
||||||
|
import Data.Either (isRight)
|
||||||
|
import Data.Proxy
|
||||||
|
import Language.ECMAScript3.Parser (parseFromString)
|
||||||
|
import Test.Hspec
|
||||||
|
|
||||||
|
import Servant.API
|
||||||
|
import Servant.JQuery
|
||||||
|
import Servant.JQuerySpec.CustomHeaders
|
||||||
|
|
||||||
|
type TestAPI = "simple" :> ReqBody '[JSON,FormUrlEncoded] String :> Post '[JSON] Bool
|
||||||
|
:<|> "has.extension" :> Get '[FormUrlEncoded,JSON] Bool
|
||||||
|
|
||||||
|
type TopLevelRawAPI = "something" :> Get '[JSON] Int
|
||||||
|
:<|> Raw
|
||||||
|
|
||||||
|
type HeaderHandlingAPI = "something" :> Header "Foo" String
|
||||||
|
:> Get '[JSON] Int
|
||||||
|
|
||||||
|
type CustomAuthAPI = "something" :> Authorization "Basic" String
|
||||||
|
:> Get '[JSON] Int
|
||||||
|
|
||||||
|
type CustomHeaderAPI = "something" :> MyLovelyHorse String
|
||||||
|
:> Get '[JSON] Int
|
||||||
|
|
||||||
|
type CustomHeaderAPI2 = "something" :> WhatsForDinner String
|
||||||
|
:> Get '[JSON] Int
|
||||||
|
|
||||||
|
headerHandlingProxy :: Proxy HeaderHandlingAPI
|
||||||
|
headerHandlingProxy = Proxy
|
||||||
|
|
||||||
|
customAuthProxy :: Proxy CustomAuthAPI
|
||||||
|
customAuthProxy = Proxy
|
||||||
|
|
||||||
|
customHeaderProxy :: Proxy CustomHeaderAPI
|
||||||
|
customHeaderProxy = Proxy
|
||||||
|
|
||||||
|
customHeaderProxy2 :: Proxy CustomHeaderAPI2
|
||||||
|
customHeaderProxy2 = Proxy
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = describe "Servant.JQuery"
|
||||||
|
generateJSSpec
|
||||||
|
|
||||||
|
generateJSSpec :: Spec
|
||||||
|
generateJSSpec = describe "generateJS" $ do
|
||||||
|
it "should generate valid javascript" $ do
|
||||||
|
let (postSimple :<|> getHasExtension ) = jquery (Proxy :: Proxy TestAPI)
|
||||||
|
parseFromString (generateJS postSimple) `shouldSatisfy` isRight
|
||||||
|
parseFromString (generateJS getHasExtension) `shouldSatisfy` isRight
|
||||||
|
print $ generateJS getHasExtension
|
||||||
|
|
||||||
|
it "should use non-empty function names" $ do
|
||||||
|
let (_ :<|> topLevel) = jquery (Proxy :: Proxy TopLevelRawAPI)
|
||||||
|
print $ generateJS $ topLevel "GET"
|
||||||
|
parseFromString (generateJS $ topLevel "GET") `shouldSatisfy` isRight
|
||||||
|
|
||||||
|
it "should handle simple HTTP headers" $ do
|
||||||
|
let jsText = generateJS $ jquery headerHandlingProxy
|
||||||
|
print jsText
|
||||||
|
parseFromString jsText `shouldSatisfy` isRight
|
||||||
|
jsText `shouldContain` "headerFoo"
|
||||||
|
jsText `shouldContain` "headers: { \"Foo\": headerFoo }\n"
|
||||||
|
|
||||||
|
it "should handle complex HTTP headers" $ do
|
||||||
|
let jsText = generateJS $ jquery customAuthProxy
|
||||||
|
print jsText
|
||||||
|
parseFromString jsText `shouldSatisfy` isRight
|
||||||
|
jsText `shouldContain` "headerAuthorization"
|
||||||
|
jsText `shouldContain` "headers: { \"Authorization\": \"Basic \" + headerAuthorization }\n"
|
||||||
|
|
||||||
|
it "should handle complex, custom HTTP headers" $ do
|
||||||
|
let jsText = generateJS $ jquery customHeaderProxy
|
||||||
|
print jsText
|
||||||
|
parseFromString jsText `shouldSatisfy` isRight
|
||||||
|
jsText `shouldContain` "headerXMyLovelyHorse"
|
||||||
|
jsText `shouldContain` "headers: { \"X-MyLovelyHorse\": \"I am good friends with \" + headerXMyLovelyHorse }\n"
|
||||||
|
|
||||||
|
it "should handle complex, custom HTTP headers (template replacement)" $ do
|
||||||
|
let jsText = generateJS $ jquery customHeaderProxy2
|
||||||
|
print jsText
|
||||||
|
parseFromString jsText `shouldSatisfy` isRight
|
||||||
|
jsText `shouldContain` "headerXWhatsForDinner"
|
||||||
|
jsText `shouldContain` "headers: { \"X-WhatsForDinner\": \"I would like \" + headerXWhatsForDinner + \" with a cherry on top.\" }\n"
|
||||||
|
|
||||||
|
it "can generate the whole javascript code string at once with jsForAPI" $ do
|
||||||
|
let jsStr = jsForAPI (Proxy :: Proxy TestAPI)
|
||||||
|
parseFromString jsStr `shouldSatisfy` isRight
|
||||||
55
servant-jquery/test/Servant/JQuerySpec/CustomHeaders.hs
Normal file
55
servant-jquery/test/Servant/JQuerySpec/CustomHeaders.hs
Normal file
|
|
@ -0,0 +1,55 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE KindSignatures #-}
|
||||||
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
|
module Servant.JQuerySpec.CustomHeaders where
|
||||||
|
|
||||||
|
import Control.Lens
|
||||||
|
import Data.Monoid
|
||||||
|
import Data.Proxy
|
||||||
|
import GHC.TypeLits
|
||||||
|
import Servant.API
|
||||||
|
import Servant.JQuery
|
||||||
|
|
||||||
|
-- | 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, HasJQ sublayout)
|
||||||
|
=> HasJQ (Authorization sym a :> sublayout) where
|
||||||
|
type JQ' (Authorization sym a :> sublayout) = JQ' sublayout
|
||||||
|
|
||||||
|
jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
|
||||||
|
req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $
|
||||||
|
tokenType (symbolVal (Proxy :: Proxy sym)) ]
|
||||||
|
where
|
||||||
|
tokenType t = t <> " {Authorization}"
|
||||||
|
|
||||||
|
-- | This is a combinator that fetches an X-MyLovelyHorse header.
|
||||||
|
data MyLovelyHorse a
|
||||||
|
|
||||||
|
instance (HasJQ sublayout)
|
||||||
|
=> HasJQ (MyLovelyHorse a :> sublayout) where
|
||||||
|
type JQ' (MyLovelyHorse a :> sublayout) = JQ' sublayout
|
||||||
|
|
||||||
|
jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
|
||||||
|
req & reqHeaders <>~ [ ReplaceHeaderArg "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 (HasJQ sublayout)
|
||||||
|
=> HasJQ (WhatsForDinner a :> sublayout) where
|
||||||
|
type JQ' (WhatsForDinner a :> sublayout) = JQ' sublayout
|
||||||
|
|
||||||
|
jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $
|
||||||
|
req & reqHeaders <>~ [ ReplaceHeaderArg "X-WhatsForDinner" tpl ]
|
||||||
|
where
|
||||||
|
tpl = "I would like {X-WhatsForDinner} with a cherry on top."
|
||||||
2
servant-jquery/test/Spec.hs
Normal file
2
servant-jquery/test/Spec.hs
Normal file
|
|
@ -0,0 +1,2 @@
|
||||||
|
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||||
|
|
||||||
Loading…
Add table
Reference in a new issue