Clone https://github.com/anchor/servant-purescript/pull/3

servant-purescript/.gitignore

@@ -0,0 +1,14 @@
+dist/
+cabal.sandbox.config
+.cabal-sandbox
+*/**/*.swp
+*/**/*.swo
+examples/*/bower_components/**/*
+examples/*/output/**/*
+
+# Auto-generated
+examples/counter/temp/api.purs
+examples/counter/www/api.js
+examples/todo/src/App/App.Ajax.purs
+examples/todo/www/app.js
+

servant-purescript/.travis.yml

@@ -0,0 +1,13 @@
+language: haskell
+ghc:
+  - 7.8
+notifications:
+  email:
+    on_success: change
+    on_failure: change
+before_install:
+  - cabal sandbox init
+  - git clone https://github.com/haskell-servant/servant.git
+  - cabal sandbox add-source servant/
+  - git clone https://github.com/haskell-servant/servant-jquery.git
+  - cabal sandbox add-source servant-jquery/

servant-purescript/HLint.hs

@@ -0,0 +1,9 @@
+{-# LANGUAGE PackageImports #-}
+module HLint.HLint where
+
+import           "hint" HLint.Builtin.All
+import           "hint" HLint.Default
+import           "hint" HLint.Dollar
+import           "hint" HLint.Generalise
+
+ignore "Redundant bracket" = Domains.Rest.Client

servant-purescript/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2015, Geoffrey Roberts
+
+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 Geoffrey Roberts 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-purescript/README.md

@@ -0,0 +1,164 @@
+# servant-purescript
+
+[![Build Status](https://travis-ci.org/anchor/servant-purescript.svg?branch=master)](https://travis-ci.org/anchor/servant-purescript)
+
+This library lets you automatically derive Purescript functions (using jQuery's AJAX capabilities) that let you query each endpoint of a [*servant*](http://haskell-servant.github.io) webservice.
+
+© Anchor 2015
+
+## Purescript dependencies
+
+Projects that use *servant-purescript* will depend on the following Purescript libraries:
+
+* [purescript-affjax](https://github.com/slamdata/purescript-affjax)
+* [purescript-arrays](https://github.com/purescript/purescript-arrays)
+* [purescript-control](https://github.com/purescript/purescript-control)
+* [purescript-either](https://github.com/purescript/purescript-either)
+* [purescript-foldable-traversable](https://github.com/purescript/purescript-foldable-traversable)
+* [purescript-foreign](https://github.com/purescript/purescript-foreign)
+* [purescript-maybe](https://github.com/purescript/purescript-maybe)
+* [purescript-monoid](https://github.com/purescript/purescript-monoid)
+* [purescript-tuples](https://github.com/purescript/purescript-tuples)
+
+You should be able to get all these libraries if you require `purescript-foreign` on its own.
+
+It's recommended that you use [bower](http://bower.io) to manage dependencies for your project. Use the bower.json file in examples as a reference.
+
+## Usage example
+
+The following example is ported from the example provided with [*servant-jquery*](https://github.com/haskell-servant/servant-jquery).
+
+To build it (and the tests), run the following:
+
+`cabal configure --enable-tests --flags="example"`
+
+And to run:
+
+`cabal run counter`
+
+Here's [more information about the original example](https://github.com/haskell-servant/servant-jquery/tree/master/examples#examples) that will explain how it works and how it should run.
+
+The PureScript version is a direct port of this. The *servant-purescript* bindings are invoked within Javascript.
+
+```haskell
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Aeson
+import Data.List
+import Data.Monoid
+import Data.Proxy
+import GHC.Generics
+import Network.Wai.Handler.Warp (run)
+import Servant
+import Servant.JQuery
+import Servant.PureScript
+import System.FilePath
+import System.FilePath.Glob
+import System.Process
+
+-- * 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"
+
+-- where temporary files reside
+tmp :: FilePath
+tmp = "examples/temp"
+
+-- 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
+
+writePS :: FilePath -> [AjaxReq] -> IO ()
+writePS fp functions = writeFile fp $
+    generatePSModule defaultSettings "App" functions
+
+main :: IO ()
+main = do
+    -- Write the PureScript module
+    writePS (tmp </> "api.purs") [ incCounterJS
+                                 , currentValueJS
+                                 ]
+
+    -- Run bower to import dependencies
+    _ <- system "cd examples && bower install"
+
+    (matches, _) <- globDir [compile "examples/bower_components/**/*.purs"] "."
+
+    -- Compile PureScript to JS
+    let cmd = "psc "
+            <> (intercalate " " $ head matches)
+            <> " "
+            <> (tmp </> "api.purs")
+            <> " > "
+            <> (www </> "api.js")
+
+    putStrLn cmd
+
+    _ <- system cmd
+
+    -- setup a shared counter
+    cnt <- newCounter
+
+    -- listen to requests on port 8080
+    runServer cnt 8080
+```
+
+## Another example
+
+There is a simple todo list example that can be built using this command:
+
+`cabal configure --enable-tests --flags="example"`
+
+The example can then be run using this command:
+
+`cabal run todolist`

servant-purescript/Setup.hs

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

servant-purescript/servant-purescript.cabal

@@ -0,0 +1,57 @@
+name:                servant-purescript
+version:             0.1
+synopsis:            Automatically derive purescript functions to query servant webservices
+description:
+  Automatically derive purescript functions to query servant webservices.
+license:             BSD3
+license-file:        LICENSE
+author:              Anchor Engineering <engineering@anchor.com.au>
+maintainer:          Anchor Engineering <engineering@anchor.com.au>
+copyright:           2015 Anchor
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+Bug-reports:         http://github.com/anchor/servant-purescript/issues
+source-repository head
+  type: git
+  location: http://github.com/anchor/servant-purescript.git
+
+flag example
+  description: Build the example too
+  manual:      True
+  default:     False
+
+library
+  exposed-modules:     Servant.PureScript
+  build-depends:       base >=4.8.1.0 && <5
+                     , lens >=4
+                     , purescript >=0.7.5.3
+                     , servant >=0.5
+                     , servant-foreign >=0.5
+                     , servant-js >=0.5
+                     , string-conversions
+                     , text
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  ghc-options:         -Wall
+
+test-suite spec
+  type:              exitcode-stdio-1.0
+  hs-source-dirs:    test
+  ghc-options:       -Wall
+  main-is:           Spec.hs
+  build-depends:
+      base >=4.8.1.0 && <5
+    , hspec >=2.0
+    , hspec-expectations
+    , language-ecmascript >=0.17
+    , lens >= 4
+    , parsec
+    , process
+    , purescript >=0.7.5.3
+    , servant >=0.5
+    , servant-foreign >=0.5
+    , servant-js >=0.5
+    , servant-purescript ==0.0.2
+    , string-conversions
+  default-language: Haskell2010

servant-purescript/src/Servant/PureScript.hs

@@ -0,0 +1,230 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+
+module Servant.PureScript (
+  generatePSModule,
+  generatePSUtilModule,
+  generatePS,
+  PSSettings(..),
+  baseURL,
+  defaultSettings
+) where
+
+import           Control.Arrow ((&&&))
+import           Control.Lens (makeLenses, (^.), (^..), view)
+import           Data.Char (toUpper, toLower)
+import           Data.Proxy (Proxy(Proxy))
+import           Data.String.Conversions (ConvertibleStrings, ST, cs, (<>))
+import qualified Data.Text as T
+import qualified Servant.JS as JS
+import qualified Servant.JS.Internal as JS
+import qualified Servant.Foreign as F
+
+
+-- | PureScript rendering settings
+data PSSettings = PSSettings {
+    _baseURL :: String, -- ^ Base URL for AJAX requests
+    _utilModuleName :: ST  -- ^ module that all generated ajax modules depend on
+}
+
+makeLenses ''PSSettings
+
+-- | (may be obsoleted by https://github.com/purescript/purescript-globals/pull/7 at some point.)
+generatePSUtilModule :: PSSettings -> (ST, ST)
+generatePSUtilModule settings = (purs, js)
+  where
+    purs = T.unlines
+        [ "module " <> (settings ^. utilModuleName) <> " where"
+        , "foreign import encodeURIComponent :: String -> String"
+        ]
+    js = T.unlines
+        [ "\"use strict\";"
+        , "// module " <> (settings ^. utilModuleName)
+        , "exports.encodeURIComponent = encodeURIComponent;"
+        ]
+
+-- | Given a servant api, generate a PureScript module containing a list of functions for AJAX
+-- requests.
+generatePSModule :: (JS.GenerateList (F.Foreign api), F.HasForeign api) => PSSettings -> ST -> Proxy api -> ST
+generatePSModule settings mname proxy =
+    generatePSModule' settings mname $ JS.generateList (F.foreignFor proxy F.defReq)
+
+-- | Given a list of foreign requests, generate a PureScript module containing a list of functions
+-- for AJAX requests.
+generatePSModule'
+    :: PSSettings -- ^ PureScript rendering settings
+    -> ST -- ^ Name of PureScript module
+    -> [F.Req] -- ^ List of AJAX requests to render in module
+    -> ST -- ^ Rendered PureScript module
+generatePSModule' settings mname reqs = T.unlines $
+        [ "module " <> mname <> " where"
+        , ""
+        , "import Prelude"
+        , "import Data.Foreign"
+        , "import Data.Maybe"
+        , "import Network.HTTP.Affjax"
+        , "import Network.HTTP.Method"
+        , "import Network.HTTP.RequestHeader"
+        , "import " <> (settings ^. utilModuleName) <> " (encodeURIComponent)"
+        , ""
+        , T.intercalate "\n" (generatePS settings <$> reqs)
+        ]
+
+-- | Generate a single PureScript function for an AJAX request.
+-- To prevent conflicts, generates a unique function name for every available
+-- function name and set of captures.
+generatePS
+    :: PSSettings -- ^ PureScript rendering settings
+    -> F.Req -- ^ AJAX request to render
+    -> ST -- ^ Rendered PureScript
+generatePS settings req = ajaxRequest
+  where
+    args :: [ST]
+    args = captures <> queryArgs <> body <> fmap (fst . snd) headerArgs
+
+    captures :: [ST]
+    captures = fmap (F.captureArg) . filter F.isCapture $ req ^. F.reqUrl . F.path
+
+    queryArgs :: [ST]
+    queryArgs  = fmap ((<>) "query" . view F.argName) queryParams
+
+    headerArgs :: [(T.Text, (T.Text, F.HeaderArg))]
+    headerArgs = fmap ( decapitalise . F.headerArgName &&&
+                        JS.toValidFunctionName . (<>) "header" . F.headerArgName &&&
+                        id )
+                      (req ^. F.reqHeaders)
+
+    fname :: ST
+    fname = F.camelCase (req ^. F.funcName)
+         <> if null captures then "" else "With"
+         <> T.intercalate "And" (fmap capitalise captures)
+
+    queryParams :: [F.QueryArg]
+    queryParams = req ^.. F.reqUrl . F.queryStr . traverse
+
+    body :: [ST]
+    body = ["body" | req ^. F.reqBody]
+
+    wrapHeaders :: [(T.Text, T.Text)] -> [(T.Text, (T.Text, F.HeaderArg))] -> ST
+    wrapHeaders ihs hs =
+        "[" <>
+        (T.intercalate ", " (concat $
+            [wrapImplicitHeader <$> ihs | not $ null ihs] ++
+            [wrapHeader <$> hs | not $ null hs])) <>
+        "]"
+
+    wrapHeader :: (T.Text, (T.Text, F.HeaderArg)) -> ST
+    wrapHeader (h, (_, o)) = "RequestHeader " <> cs (show h) <> " " <> psHeaderArg o
+
+    wrapImplicitHeader :: (T.Text, T.Text) -> ST
+    wrapImplicitHeader (k, v) = "RequestHeader " <> cs (show k) <> " " <> cs (show v)
+
+    implicitHeaderArgs :: [(T.Text, T.Text)]
+    implicitHeaderArgs =
+        [ ("content-type", "application/json")
+        , ("accept", "application/json")
+        ]
+
+    ajaxRequest :: ST
+    ajaxRequest = T.unlines $
+        typeSig :
+        (fname <> argString <> " = affjax $ defaultRequest") :
+        ("    { method = " <> req ^. F.reqMethod) :
+        ("    , url = " <> urlString) :
+        ("    , headers = " <> wrapHeaders implicitHeaderArgs headerArgs) :
+        ["    , content = Just body" | req ^. F.reqBody] ++
+        "    }" :
+        []
+      where
+        typeSig :: ST
+        typeSig = T.concat
+            [ fname
+            , " :: forall eff. "
+            , T.intercalate " -> " typedArgs
+            , if null args then "" else " -> "
+            , "Affjax eff Foreign"
+            ]
+
+        typedArgs :: [ST]
+        typedArgs = concat $
+            [ fmap (const "String") captures
+            , fmap (const "Maybe String") queryArgs ]
+            <> [ bodyArgType ]
+            <> [ fmap (const "String") headerArgs ]
+
+        argString :: ST
+        argString = case T.unwords args of
+            "" -> ""
+            s -> " " <> s
+
+        urlString :: ST
+        urlString = T.concat
+            [ "\""
+            , cs $ settings ^. baseURL
+            , "/"
+            , psPathSegments $ req ^.. F.reqUrl . F.path . traverse
+            , if null queryParams then "\"" else "?\" <> " <> psParams queryParams
+            ]
+
+        bodyArgType :: [ST]
+        bodyArgType = [ "String" | req ^. F.reqBody ]
+
+-- | Show HeaderArg instance from Servant.JS, changes to use PureScript
+-- monoidal bindings
+psHeaderArg :: F.HeaderArg -> ST
+psHeaderArg (F.HeaderArg n) = JS.toValidFunctionName ("header" <> n)
+psHeaderArg (F.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 = JS.toValidFunctionName ("header" <> n)
+    pn = "{" <> n <> "}"
+    rp = T.replace pn "" p
+
+-- | Default PureScript settings: specifies an empty base URL
+defaultSettings :: PSSettings
+defaultSettings = PSSettings "" "Util"
+
+-- | Capitalise a string for use in PureScript variable name
+capitalise :: (ConvertibleStrings s String, ConvertibleStrings String s) => s -> s
+capitalise = cs . capitalise' . cs
+
+capitalise' :: String -> String
+capitalise' [] = []
+capitalise' (x:xs) = [toUpper x] <> xs
+
+-- | Decapitalise a string for use as a Purescript variable name
+decapitalise :: (ConvertibleStrings s String, ConvertibleStrings String s) => s -> s
+decapitalise = cs . decapitalise' . cs
+
+decapitalise' :: String -> String
+decapitalise' [] = []
+decapitalise' (x:xs) = [toLower x] <> xs
+
+-- | Turn a list of path segments into a URL string
+psPathSegments :: [F.Segment] -> ST
+psPathSegments = T.intercalate "/" . fmap psSegmentToStr
+
+-- | Turn an individual path segment into a PureScript variable handler
+psSegmentToStr :: F.Segment -> ST
+psSegmentToStr (F.Segment (F.Static s)) = s
+psSegmentToStr (F.Segment (F.Cap s))    = "\" <> encodeURIComponent " <> s <> " <> \""
+
+-- | Turn a list of query string params into a URL string
+psParams :: [F.QueryArg] -> ST
+psParams qa = "(intercalate \"&\" <<< catMaybes $ [" <> T.intercalate ", " (psParamToStr <$> qa) <> "])"
+
+-- | Turn an individual query string param into a PureScript variable handler
+--
+-- Must handle Maybe String as the input value
+psParamToStr :: F.QueryArg -> ST
+psParamToStr qarg = case qarg ^. F.argType of
+    F.Normal -> "((\"" <> name <> "=\" <>) <<< encodeURIComponent) <$> " <> qname
+    F.List   -> "((\"" <> name <> "[]=\" <>) <<< encodeURIComponent) <$> " <> qname
+    F.Flag   -> "\"" <> name <> "=\""
+  where
+    name = qarg ^. F.argName
+    qname = "query" <> name

servant-purescript/test/Spec.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Main where
+
+import           Control.Monad
+import           Control.Monad.IO.Class
+import           Data.Either (isRight)
+import           Data.Proxy
+import           Data.String.Conversions
+import qualified Data.Text.IO as ST
+import qualified Language.PureScript as P
+import           Servant.API
+import           Servant.Foreign as F
+import           Servant.JS
+import           Servant.PureScript
+import           Test.Hspec
+import qualified Text.Parsec as TP
+
+
+type TestAPI = "simple" :> ReqBody '[JSON] String :> Post '[JSON] Bool
+          :<|> "has.extension" :> Get '[JSON] Bool
+
+type TopLevelRawAPI = "rwa" :> Get '[JSON] Int
+                  :<|> Raw
+
+type HeaderHandlingAPI = "oiy" :> Header "Foo" String :> Get '[JSON] Int
+
+type QueryHandlingAPI = "urq" :> QueryParam "Bar" String :> Get '[JSON] Int
+
+-- | 'Raw' has 'Foreign', but its type is @Method -> Req@, which doesn't have a 'GenerateList'
+-- instance.  Since @Foreign.Method@ is not exported, we need to keep it polymorphic.
+instance {-# OVERLAPPABLE #-} GenerateList (a -> F.Req) where
+    generateList _ = []
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = describe "generateJS" $ do
+        it "should generate valid purescript" $ do
+            let m = generatePSModule defaultSettings "Main" (Proxy :: Proxy TestAPI)
+            shouldParse m
+        it "should use non-empty function names" $ do
+            let m = generatePSModule defaultSettings "Main" (Proxy :: Proxy TopLevelRawAPI)
+            shouldParse m
+            (cs m :: String) `shouldContain` "getRwa :: "
+        it "should generate valid header variables" $ do
+            let m = generatePSModule defaultSettings "Main" (Proxy :: Proxy HeaderHandlingAPI)
+            shouldParse m
+            (cs m :: String) `shouldContain` "String"
+            (cs m :: String) `shouldContain` "headerFoo"
+            (cs m :: String) `shouldContain` "RequestHeader \"foo\" headerFoo"
+        it "should generate valid query params" $ do
+            let m = generatePSModule defaultSettings "Main" (Proxy :: Proxy QueryHandlingAPI)
+            shouldParse m
+
+
+shouldParse :: ST -> Expectation
+shouldParse =
+    (`shouldSatisfy` isRight) . (TP.runParser P.parseModule (P.ParseState 0) "" <=< P.lex "") . cs