eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

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

Browse source
This commit is contained in:
Matthias Fischmann 2015-11-21 16:33:52 +01:00
parent fdd1829c8f
commit 589f8757f9
9 changed files with 584 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
servant-purescript/.gitignore vendored Normal file
View file

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

13
servant-purescript/.travis.yml Normal file
View file

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

9
servant-purescript/HLint.hs Normal file
View file

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

30
servant-purescript/LICENSE Normal file
View file

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

164
servant-purescript/README.md Normal file
View file

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

2
servant-purescript/Setup.hs Normal file
View file

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

57
servant-purescript/servant-purescript.cabal Normal file
View file

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

230
servant-purescript/src/Servant/PureScript.hs Normal file
View file

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

65
servant-purescript/test/Spec.hs Normal file
View file

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