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