Merge remote-tracking branch 'servant-jquery/prepare-merge' into merge

servant-jquery/CHANGELOG.md

@@ -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)

servant-jquery/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2014, Zalora South East Asia Pte Ltd
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Zalora South East Asia Pte Ltd nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

servant-jquery/README.md

@@ -0,0 +1,97 @@
+# servant-jquery
+
+[![Build Status](https://secure.travis-ci.org/haskell-servant/servant-jquery.svg)](http://travis-ci.org/haskell-servant/servant-jquery)
+[![Coverage Status](https://coveralls.io/repos/haskell-servant/servant-jquery/badge.svg)](https://coveralls.io/r/haskell-servant/servant-jquery)
+
+![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
+
+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
+```

servant-jquery/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

servant-jquery/TODO.md

@@ -0,0 +1 @@
+- Investigate the best way to offer cross-origin requests

servant-jquery/docs.sh

@@ -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

servant-jquery/examples/README.md

@@ -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.

servant-jquery/examples/counter.hs

@@ -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

servant-jquery/examples/counter.md

@@ -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

servant-jquery/examples/www/api.js

@@ -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'
+    });
+}

servant-jquery/examples/www/index.html

@@ -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>

servant-jquery/servant-jquery.cabal

@@ -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

servant-jquery/src/Servant/JQuery.hs

@@ -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)

servant-jquery/src/Servant/JQuery/Internal.hs

@@ -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)

servant-jquery/test/Servant/JQuerySpec.hs

@@ -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

servant-jquery/test/Servant/JQuerySpec/CustomHeaders.hs

@@ -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."

servant-jquery/test/Spec.hs

@@ -0,0 +1,2 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+