git.iko.soy/servant
on master help sign in
first shot for jquery codegen based on a servant API type
06d8c80Alp Mestanogullari
LICENSEnew file+30
compare with master
unifiedsplit
@@ -0,0 +1,30 @@
1+Copyright (c) 2014, Alp Mestanogullari
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Alp Mestanogullari nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
TODO.mdnew file+1
@@ -0,0 +1 @@
1+- Investigate the best way to offer cross-origin requests
example/greet.hsnew file+25
@@ -0,0 +1,25 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TypeOperators #-}
3+
4+import Data.Proxy
5+import Servant
6+import Servant.JQuery
7+
8+data Greet = Greet
9+
10+type TestApi =
11+ "hello" :> Capture "name" String :> QueryParam "capital" Bool :> QueryParam "q" String :> Get Greet
12+ :<|> "greet" :> ReqBody Greet :> Post Greet
13+ :<|> "delete" :> Capture "greetid" String :> "haha" :> Delete
14+
15+testApi :: Proxy TestApi
16+testApi = Proxy
17+
18+getHello :<|> postGreet :<|> deleteGreet = jquery testApi
19+
20+main :: IO ()
21+main =
22+ mapM_ printJS [ getHello "getHello"
23+ , postGreet "postGreet"
24+ , deleteGreet "deleteGreet"
25+ ]
servant-jquery.cabalnew file+29
@@ -0,0 +1,29 @@
1+name: servant-jquery
2+version: 0.2
3+synopsis: Automatically derive jquery-based javascript functions to query servant webservices
4+description: Automatically derive jquery-based javascript functions to query servant webservices
5+homepage: http://github.com/alpmestan/servant
6+license: BSD3
7+license-file: LICENSE
8+author: Alp Mestanogullari
9+maintainer: alpmestan@gmail.com
10+copyright: 2014 Alp Mestanogullari
11+category: Web
12+build-type: Simple
13+cabal-version: >=1.10
14+
15+library
16+ exposed-modules: Servant.JQuery
17+ other-modules: Servant.JQuery.Internal
18+ -- other-extensions:
19+ build-depends: base >=4.5 && <5, servant >= 0.2, lens >= 4, interpolate
20+ hs-source-dirs: src
21+ default-language: Haskell2010
22+ ghc-options: -O2 -Wall
23+
24+executable greet
25+ main-is: greet.hs
26+ ghc-options: -O2 -Wall
27+ hs-source-dirs: example
28+ build-depends: base, servant, servant-jquery
29+ default-language: Haskell2010
src/Servant/JQuery.hsnew file+76
@@ -0,0 +1,76 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE QuasiQuotes #-}
3+{-# LANGUAGE TypeOperators #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+-----------------------------------------------------------------------------
6+-- |
7+-- Module : Servant.JQuery
8+-- Copyright : (C) 2014 Alp Mestanogullari
9+-- License : BSD3
10+-- Maintainer : Alp Mestanogullari <alpmestan@gmail.com>
11+-- Stability : experimental
12+-- Portability : non-portable
13+--
14+-- Usage:
15+module Servant.JQuery where
16+
17+import Control.Lens
18+import Data.List
19+import Data.Proxy
20+import Data.String.Interpolate
21+import Servant.JQuery.Internal
22+
23+jquery :: HasJQ layout => Proxy layout -> JQ layout
24+jquery p = jqueryFor p defReq
25+
26+-- js codegen
27+generateJS :: AjaxReq -> String
28+generateJS req =
29+ [i|
30+function #{fname}(#{argsStr})
31+{
32+ $.ajax(
33+ { url: #{url}
34+ , success: onSuccess #{dataBody}
35+ , error: onError
36+ , type: '#{method}'
37+ });
38+}
39+ |]
40+
41+ where argsStr = intercalate ", " args
42+ args = captures
43+ ++ map (view argName) queryparams
44+ ++ body
45+ ++ ["onSuccess", "onError"]
46+
47+ captures = map captureArg
48+ . filter isCapture
49+ $ req ^. reqUrl.path
50+
51+ queryparams = req ^.. reqUrl.queryStr.traverse
52+
53+ body = if req ^. reqBody
54+ then ["body"]
55+ else []
56+
57+ dataBody =
58+ if req ^. reqBody
59+ then "\n , data: JSON.stringify(body)"
60+ else ""
61+
62+ fname = req ^. funcName
63+ method = req ^. reqMethod
64+ url = "'"
65+ ++ urlArgs
66+ ++ queryArgs
67+
68+ urlArgs = jsSegments
69+ $ req ^.. reqUrl.path.traverse
70+
71+ queryArgs = if null queryparams
72+ then ""
73+ else " + '?" ++ jsParams queryparams
74+
75+printJS :: AjaxReq -> IO ()
76+printJS = putStrLn . generateJS
src/Servant/JQuery/Internal.hsnew file+203
@@ -0,0 +1,203 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE TypeOperators #-}
4+{-# LANGUAGE TemplateHaskell #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+module Servant.JQuery.Internal where
8+
9+import Control.Lens
10+import Data.Proxy
11+import GHC.TypeLits
12+import Servant.API
13+
14+type Arg = String
15+
16+data Segment = Static String -- ^ a static path segment. like "/foo"
17+ | Cap Arg -- ^ a capture. like "/:userid"
18+ deriving (Eq, Show)
19+
20+
21+isCapture :: Segment -> Bool
22+isCapture (Cap _) = True
23+isCapture _ = False
24+
25+captureArg :: Segment -> Arg
26+captureArg (Cap s) = s
27+captureArg _ = error "captureArg called on non capture"
28+
29+jsSegments :: [Segment] -> String
30+jsSegments [] = ""
31+jsSegments [x] = "/" ++ segmentToStr x False
32+jsSegments (x:xs) = "/" ++ segmentToStr x True ++ jsSegments xs
33+
34+segmentToStr :: Segment -> Bool -> String
35+segmentToStr (Static s) notTheEnd =
36+ if notTheEnd then s else s ++ "'"
37+segmentToStr (Cap s) notTheEnd =
38+ "' + " ++ s ++ if notTheEnd then " + '" else ""
39+
40+type Path = [Segment]
41+
42+data ArgType =
43+ Normal
44+ | Flag
45+ | List
46+ deriving (Eq, Show)
47+
48+data QueryArg = QueryArg
49+ { _argName :: Arg
50+ , _argType :: ArgType
51+ } deriving (Eq, Show)
52+
53+data Url = Url
54+ { _path :: Path
55+ , _queryStr :: [QueryArg]
56+ } deriving (Eq, Show)
57+
58+defUrl :: Url
59+defUrl = Url [] []
60+
61+type FunctionName = String
62+type Method = String
63+
64+data AjaxReq = AjaxReq
65+ { _reqUrl :: Url
66+ , _reqMethod :: Method
67+ , _reqBody :: Bool
68+ , _funcName :: FunctionName
69+ } deriving (Eq, Show)
70+
71+makeLenses ''QueryArg
72+makeLenses ''Url
73+makeLenses ''AjaxReq
74+
75+jsParams :: [QueryArg] -> String
76+jsParams [] = ""
77+jsParams [x] = paramToStr x False
78+jsParams (x:xs) = paramToStr x True ++ "&" ++ jsParams xs
79+
80+paramToStr :: QueryArg -> Bool -> String
81+paramToStr qarg notTheEnd =
82+ case qarg ^. argType of
83+ Normal -> name
84+ ++ "=' + encodeURIComponent("
85+ ++ name
86+ ++ if notTheEnd then ") + '" else ")"
87+
88+ Flag -> name ++ "="
89+
90+ List -> name
91+ ++ "[]=' + encodeURIComponent("
92+ ++ name
93+ ++ if notTheEnd then ") + '" else ")"
94+
95+ where name = qarg ^. argName
96+
97+defReq :: AjaxReq
98+defReq = AjaxReq defUrl "GET" False ""
99+
100+class HasJQ layout where
101+ type JQ layout :: *
102+ jqueryFor :: Proxy layout -> AjaxReq -> JQ layout
103+
104+instance (HasJQ a, HasJQ b)
105+ => HasJQ (a :<|> b) where
106+ type JQ (a :<|> b) = JQ a :<|> JQ b
107+
108+ jqueryFor Proxy req =
109+ jqueryFor (Proxy :: Proxy a) req
110+ :<|> jqueryFor (Proxy :: Proxy b) req
111+
112+instance (KnownSymbol sym, HasJQ sublayout)
113+ => HasJQ (Capture sym a :> sublayout) where
114+ type JQ (Capture sym a :> sublayout) = JQ sublayout
115+
116+ jqueryFor Proxy req =
117+ jqueryFor (Proxy :: Proxy sublayout) $
118+ req & reqUrl.path <>~ [Cap str]
119+
120+ where str = symbolVal (Proxy :: Proxy sym)
121+
122+instance HasJQ Delete where
123+ type JQ Delete = FunctionName -> AjaxReq
124+
125+ jqueryFor Proxy req fName =
126+ req & funcName .~ fName
127+ & reqMethod .~ "DELETE"
128+
129+instance HasJQ (Get a) where
130+ type JQ (Get a) = FunctionName -> AjaxReq
131+
132+ jqueryFor Proxy req fName =
133+ req & funcName .~ fName
134+ & reqMethod .~ "GET"
135+
136+instance HasJQ (Post a) where
137+ type JQ (Post a) = FunctionName -> AjaxReq
138+
139+ jqueryFor Proxy req fName =
140+ req & funcName .~ fName
141+ & reqMethod .~ "POST"
142+
143+instance HasJQ (Put a) where
144+ type JQ (Put a) = FunctionName -> AjaxReq
145+
146+ jqueryFor Proxy req fName =
147+ req & funcName .~ fName
148+ & reqMethod .~ "PUT"
149+
150+instance (KnownSymbol sym, HasJQ sublayout)
151+ => HasJQ (QueryParam sym a :> sublayout) where
152+ type JQ (QueryParam sym a :> sublayout) = JQ sublayout
153+
154+ jqueryFor Proxy req =
155+ jqueryFor (Proxy :: Proxy sublayout) $
156+ req & reqUrl.queryStr <>~ [QueryArg str Normal]
157+
158+ where str = symbolVal (Proxy :: Proxy sym)
159+ strArg = str ++ "Value"
160+
161+instance (KnownSymbol sym, HasJQ sublayout)
162+ => HasJQ (QueryParams sym a :> sublayout) where
163+ type JQ (QueryParams sym a :> sublayout) = JQ sublayout
164+
165+ jqueryFor Proxy req =
166+ jqueryFor (Proxy :: Proxy sublayout) $
167+ req & reqUrl.queryStr <>~ [QueryArg str List]
168+
169+ where str = symbolVal (Proxy :: Proxy sym)
170+
171+instance (KnownSymbol sym, HasJQ sublayout)
172+ => HasJQ (QueryFlag sym :> sublayout) where
173+ type JQ (QueryFlag sym :> sublayout) = JQ sublayout
174+
175+ jqueryFor Proxy req =
176+ jqueryFor (Proxy :: Proxy sublayout) $
177+ req & reqUrl.queryStr <>~ [QueryArg str Flag]
178+
179+ where str = symbolVal (Proxy :: Proxy sym)
180+
181+instance HasJQ Raw where
182+ type JQ Raw = Method -> FunctionName -> AjaxReq
183+
184+ jqueryFor Proxy req method fName =
185+ req & reqMethod .~ method
186+ & funcName .~ fName
187+
188+instance HasJQ sublayout => HasJQ (ReqBody a :> sublayout) where
189+ type JQ (ReqBody a :> sublayout) = JQ sublayout
190+
191+ jqueryFor Proxy req =
192+ jqueryFor (Proxy :: Proxy sublayout) $
193+ req & reqBody .~ True
194+
195+instance (KnownSymbol path, HasJQ sublayout)
196+ => HasJQ (path :> sublayout) where
197+ type JQ (path :> sublayout) = JQ sublayout
198+
199+ jqueryFor Proxy req =
200+ jqueryFor (Proxy :: Proxy sublayout) $
201+ req & reqUrl.path <>~ [Static str]
202+
203+ where str = symbolVal (Proxy :: Proxy path)