From 589f8757f9ab093a2498b63e2b6307d7f6ccacf8 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Sat, 21 Nov 2015 16:33:52 +0100 Subject: [PATCH] Clone https://github.com/anchor/servant-purescript/pull/3 --- servant-purescript/.gitignore | 14 ++ servant-purescript/.travis.yml | 13 ++ servant-purescript/HLint.hs | 9 + servant-purescript/LICENSE | 30 +++ servant-purescript/README.md | 164 +++++++++++++ servant-purescript/Setup.hs | 2 + servant-purescript/servant-purescript.cabal | 57 +++++ servant-purescript/src/Servant/PureScript.hs | 230 +++++++++++++++++++ servant-purescript/test/Spec.hs | 65 ++++++ 9 files changed, 584 insertions(+) create mode 100644 servant-purescript/.gitignore create mode 100644 servant-purescript/.travis.yml create mode 100644 servant-purescript/HLint.hs create mode 100644 servant-purescript/LICENSE create mode 100644 servant-purescript/README.md create mode 100644 servant-purescript/Setup.hs create mode 100644 servant-purescript/servant-purescript.cabal create mode 100644 servant-purescript/src/Servant/PureScript.hs create mode 100644 servant-purescript/test/Spec.hs diff --git a/servant-purescript/.gitignore b/servant-purescript/.gitignore new file mode 100644 index 00000000..119aca49 --- /dev/null +++ b/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 + diff --git a/servant-purescript/.travis.yml b/servant-purescript/.travis.yml new file mode 100644 index 00000000..57d6e12b --- /dev/null +++ b/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/ diff --git a/servant-purescript/HLint.hs b/servant-purescript/HLint.hs new file mode 100644 index 00000000..b4a45942 --- /dev/null +++ b/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 diff --git a/servant-purescript/LICENSE b/servant-purescript/LICENSE new file mode 100644 index 00000000..f5179e0b --- /dev/null +++ b/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. diff --git a/servant-purescript/README.md b/servant-purescript/README.md new file mode 100644 index 00000000..642ecaca --- /dev/null +++ b/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` diff --git a/servant-purescript/Setup.hs b/servant-purescript/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/servant-purescript/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-purescript/servant-purescript.cabal b/servant-purescript/servant-purescript.cabal new file mode 100644 index 00000000..cc3cc855 --- /dev/null +++ b/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 +maintainer: Anchor Engineering +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 diff --git a/servant-purescript/src/Servant/PureScript.hs b/servant-purescript/src/Servant/PureScript.hs new file mode 100644 index 00000000..e26bbde0 --- /dev/null +++ b/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 diff --git a/servant-purescript/test/Spec.hs b/servant-purescript/test/Spec.hs new file mode 100644 index 00000000..c3aef072 --- /dev/null +++ b/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