first shot for jquery codegen based on a servant API type
This commit is contained in:
commit
06d8c8005a
7 changed files with 366 additions and 0 deletions
30
LICENSE
Normal file
30
LICENSE
Normal file
|
@ -0,0 +1,30 @@
|
||||||
|
Copyright (c) 2014, Alp Mestanogullari
|
||||||
|
|
||||||
|
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 Alp Mestanogullari 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.
|
2
Setup.hs
Normal file
2
Setup.hs
Normal file
|
@ -0,0 +1,2 @@
|
||||||
|
import Distribution.Simple
|
||||||
|
main = defaultMain
|
1
TODO.md
Normal file
1
TODO.md
Normal file
|
@ -0,0 +1 @@
|
||||||
|
- Investigate the best way to offer cross-origin requests
|
25
example/greet.hs
Normal file
25
example/greet.hs
Normal file
|
@ -0,0 +1,25 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
|
import Data.Proxy
|
||||||
|
import Servant
|
||||||
|
import Servant.JQuery
|
||||||
|
|
||||||
|
data Greet = Greet
|
||||||
|
|
||||||
|
type TestApi =
|
||||||
|
"hello" :> Capture "name" String :> QueryParam "capital" Bool :> QueryParam "q" String :> Get Greet
|
||||||
|
:<|> "greet" :> ReqBody Greet :> Post Greet
|
||||||
|
:<|> "delete" :> Capture "greetid" String :> "haha" :> Delete
|
||||||
|
|
||||||
|
testApi :: Proxy TestApi
|
||||||
|
testApi = Proxy
|
||||||
|
|
||||||
|
getHello :<|> postGreet :<|> deleteGreet = jquery testApi
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main =
|
||||||
|
mapM_ printJS [ getHello "getHello"
|
||||||
|
, postGreet "postGreet"
|
||||||
|
, deleteGreet "deleteGreet"
|
||||||
|
]
|
29
servant-jquery.cabal
Normal file
29
servant-jquery.cabal
Normal file
|
@ -0,0 +1,29 @@
|
||||||
|
name: servant-jquery
|
||||||
|
version: 0.2
|
||||||
|
synopsis: Automatically derive jquery-based javascript functions to query servant webservices
|
||||||
|
description: Automatically derive jquery-based javascript functions to query servant webservices
|
||||||
|
homepage: http://github.com/alpmestan/servant
|
||||||
|
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
|
||||||
|
|
||||||
|
library
|
||||||
|
exposed-modules: Servant.JQuery
|
||||||
|
other-modules: Servant.JQuery.Internal
|
||||||
|
-- other-extensions:
|
||||||
|
build-depends: base >=4.5 && <5, servant >= 0.2, lens >= 4, interpolate
|
||||||
|
hs-source-dirs: src
|
||||||
|
default-language: Haskell2010
|
||||||
|
ghc-options: -O2 -Wall
|
||||||
|
|
||||||
|
executable greet
|
||||||
|
main-is: greet.hs
|
||||||
|
ghc-options: -O2 -Wall
|
||||||
|
hs-source-dirs: example
|
||||||
|
build-depends: base, servant, servant-jquery
|
||||||
|
default-language: Haskell2010
|
76
src/Servant/JQuery.hs
Normal file
76
src/Servant/JQuery.hs
Normal file
|
@ -0,0 +1,76 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
-----------------------------------------------------------------------------
|
||||||
|
-- |
|
||||||
|
-- Module : Servant.JQuery
|
||||||
|
-- Copyright : (C) 2014 Alp Mestanogullari
|
||||||
|
-- License : BSD3
|
||||||
|
-- Maintainer : Alp Mestanogullari <alpmestan@gmail.com>
|
||||||
|
-- Stability : experimental
|
||||||
|
-- Portability : non-portable
|
||||||
|
--
|
||||||
|
-- Usage:
|
||||||
|
module Servant.JQuery where
|
||||||
|
|
||||||
|
import Control.Lens
|
||||||
|
import Data.List
|
||||||
|
import Data.Proxy
|
||||||
|
import Data.String.Interpolate
|
||||||
|
import Servant.JQuery.Internal
|
||||||
|
|
||||||
|
jquery :: HasJQ layout => Proxy layout -> JQ layout
|
||||||
|
jquery p = jqueryFor p defReq
|
||||||
|
|
||||||
|
-- js codegen
|
||||||
|
generateJS :: AjaxReq -> String
|
||||||
|
generateJS req =
|
||||||
|
[i|
|
||||||
|
function #{fname}(#{argsStr})
|
||||||
|
{
|
||||||
|
$.ajax(
|
||||||
|
{ url: #{url}
|
||||||
|
, success: onSuccess #{dataBody}
|
||||||
|
, error: onError
|
||||||
|
, type: '#{method}'
|
||||||
|
});
|
||||||
|
}
|
||||||
|
|]
|
||||||
|
|
||||||
|
where argsStr = intercalate ", " args
|
||||||
|
args = captures
|
||||||
|
++ map (view argName) queryparams
|
||||||
|
++ body
|
||||||
|
++ ["onSuccess", "onError"]
|
||||||
|
|
||||||
|
captures = map captureArg
|
||||||
|
. filter isCapture
|
||||||
|
$ req ^. reqUrl.path
|
||||||
|
|
||||||
|
queryparams = req ^.. reqUrl.queryStr.traverse
|
||||||
|
|
||||||
|
body = if req ^. reqBody
|
||||||
|
then ["body"]
|
||||||
|
else []
|
||||||
|
|
||||||
|
dataBody =
|
||||||
|
if req ^. reqBody
|
||||||
|
then "\n , data: JSON.stringify(body)"
|
||||||
|
else ""
|
||||||
|
|
||||||
|
fname = req ^. funcName
|
||||||
|
method = req ^. reqMethod
|
||||||
|
url = "'"
|
||||||
|
++ urlArgs
|
||||||
|
++ queryArgs
|
||||||
|
|
||||||
|
urlArgs = jsSegments
|
||||||
|
$ req ^.. reqUrl.path.traverse
|
||||||
|
|
||||||
|
queryArgs = if null queryparams
|
||||||
|
then ""
|
||||||
|
else " + '?" ++ jsParams queryparams
|
||||||
|
|
||||||
|
printJS :: AjaxReq -> IO ()
|
||||||
|
printJS = putStrLn . generateJS
|
203
src/Servant/JQuery/Internal.hs
Normal file
203
src/Servant/JQuery/Internal.hs
Normal file
|
@ -0,0 +1,203 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
module Servant.JQuery.Internal where
|
||||||
|
|
||||||
|
import Control.Lens
|
||||||
|
import Data.Proxy
|
||||||
|
import GHC.TypeLits
|
||||||
|
import Servant.API
|
||||||
|
|
||||||
|
type Arg = String
|
||||||
|
|
||||||
|
data Segment = Static String -- ^ a static path segment. like "/foo"
|
||||||
|
| Cap Arg -- ^ a capture. like "/:userid"
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
|
||||||
|
isCapture :: Segment -> Bool
|
||||||
|
isCapture (Cap _) = True
|
||||||
|
isCapture _ = False
|
||||||
|
|
||||||
|
captureArg :: Segment -> Arg
|
||||||
|
captureArg (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 (Static s) notTheEnd =
|
||||||
|
if notTheEnd then s else s ++ "'"
|
||||||
|
segmentToStr (Cap s) notTheEnd =
|
||||||
|
"' + " ++ s ++ if notTheEnd then " + '" else ""
|
||||||
|
|
||||||
|
type Path = [Segment]
|
||||||
|
|
||||||
|
data ArgType =
|
||||||
|
Normal
|
||||||
|
| Flag
|
||||||
|
| List
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
data QueryArg = QueryArg
|
||||||
|
{ _argName :: Arg
|
||||||
|
, _argType :: ArgType
|
||||||
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
|
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
|
||||||
|
, _reqBody :: Bool
|
||||||
|
, _funcName :: FunctionName
|
||||||
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
|
makeLenses ''QueryArg
|
||||||
|
makeLenses ''Url
|
||||||
|
makeLenses ''AjaxReq
|
||||||
|
|
||||||
|
jsParams :: [QueryArg] -> String
|
||||||
|
jsParams [] = ""
|
||||||
|
jsParams [x] = paramToStr x False
|
||||||
|
jsParams (x:xs) = paramToStr x True ++ "&" ++ jsParams 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 ""
|
||||||
|
|
||||||
|
class HasJQ layout where
|
||||||
|
type JQ layout :: *
|
||||||
|
jqueryFor :: Proxy layout -> AjaxReq -> JQ 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 <>~ [Cap str]
|
||||||
|
|
||||||
|
where str = symbolVal (Proxy :: Proxy sym)
|
||||||
|
|
||||||
|
instance HasJQ Delete where
|
||||||
|
type JQ Delete = FunctionName -> AjaxReq
|
||||||
|
|
||||||
|
jqueryFor Proxy req fName =
|
||||||
|
req & funcName .~ fName
|
||||||
|
& reqMethod .~ "DELETE"
|
||||||
|
|
||||||
|
instance HasJQ (Get a) where
|
||||||
|
type JQ (Get a) = FunctionName -> AjaxReq
|
||||||
|
|
||||||
|
jqueryFor Proxy req fName =
|
||||||
|
req & funcName .~ fName
|
||||||
|
& reqMethod .~ "GET"
|
||||||
|
|
||||||
|
instance HasJQ (Post a) where
|
||||||
|
type JQ (Post a) = FunctionName -> AjaxReq
|
||||||
|
|
||||||
|
jqueryFor Proxy req fName =
|
||||||
|
req & funcName .~ fName
|
||||||
|
& reqMethod .~ "POST"
|
||||||
|
|
||||||
|
instance HasJQ (Put a) where
|
||||||
|
type JQ (Put a) = FunctionName -> AjaxReq
|
||||||
|
|
||||||
|
jqueryFor Proxy req fName =
|
||||||
|
req & funcName .~ fName
|
||||||
|
& 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)
|
||||||
|
strArg = str ++ "Value"
|
||||||
|
|
||||||
|
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 HasJQ Raw where
|
||||||
|
type JQ Raw = Method -> FunctionName -> AjaxReq
|
||||||
|
|
||||||
|
jqueryFor Proxy req method fName =
|
||||||
|
req & reqMethod .~ method
|
||||||
|
& funcName .~ fName
|
||||||
|
|
||||||
|
instance HasJQ sublayout => HasJQ (ReqBody a :> sublayout) where
|
||||||
|
type JQ (ReqBody 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 <>~ [Static str]
|
||||||
|
|
||||||
|
where str = symbolVal (Proxy :: Proxy path)
|
Loading…
Add table
Reference in a new issue