git.iko.soy/typeable/servant
on 8ee9b60 help sign in
typeable/servant/src/Servant/JQuery/Internal.hs
358 lines 11 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE ConstraintKinds #-}
5{-# LANGUAGE TemplateHaskell #-}
6{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE UndecidableInstances #-}
10module Servant.JQuery.Internal where
12import Control.Applicative
13import Control.Lens
14import Data.Char (toLower)
15import qualified Data.CharSet as Set
16import qualified Data.CharSet.Unicode.Category as Set
17import Data.List
18import Data.Monoid
19import Data.Proxy
20import qualified Data.Text as T
21import GHC.Exts (Constraint)
22import GHC.TypeLits
23import Servant.API
25type Arg = String
27data Segment = Segment { _segment :: SegmentType, _matrix :: [MatrixArg] }
28 deriving (Eq, Show)
30data SegmentType = Static String -- ^ a static path segment. like "/foo"
31 | Cap Arg -- ^ a capture. like "/:userid"
32 deriving (Eq, Show)
34isCapture :: Segment -> Bool
35isCapture (Cap _) = True
36isCapture _ = False
38captureArg :: Segment -> Arg
39captureArg (Cap s) = s
40captureArg _ = error "captureArg called on non capture"
42jsSegments :: [Segment] -> String
43jsSegments [] = "/'"
44jsSegments [x] = "/" ++ segmentToStr x False
45jsSegments (x:xs) = "/" ++ segmentToStr x True ++ jsSegments xs
47segmentToStr :: Segment -> Bool -> String
48segmentToStr (Static s) notTheEnd =
49 if notTheEnd then s else s ++ "'"
50segmentToStr (Cap s) notTheEnd =
51 "' + encodeURIComponent(" ++ s ++ if notTheEnd then ") + '" else ")"
53type Path = [Segment]
55data ArgType =
56 Normal
57 | Flag
58 | List
59 deriving (Eq, Show)
61data QueryArg = QueryArg
62 { _argName :: Arg
63 , _argType :: ArgType
64 } deriving (Eq, Show)
66data HeaderArg = HeaderArg
67 { headerArgName :: String
68 }
69 | ReplaceHeaderArg
70 { headerArgName :: String
71 , headerPattern :: String
72 } deriving (Eq)
74instance Show HeaderArg where
75 show (HeaderArg n) = toValidFunctionName ("header" <> n)
76 show (ReplaceHeaderArg n p)
77 | pn `isPrefixOf` p = pv <> " + \"" <> rp <> "\""
78 | pn `isSuffixOf` p = "\"" <> rp <> "\" + " <> pv
79 | pn `isInfixOf` p = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p)
80 <> "\""
81 | otherwise = p
82 where
83 pv = toValidFunctionName ("header" <> n)
84 pn = "{" <> n <> "}"
85 rp = replace pn "" p
86 -- Use replace method from Data.Text
87 replace old new = T.unpack .
88 T.replace (T.pack old) (T.pack new) .
89 T.pack
91-- | Attempts to reduce the function name provided to that allowed by JS.
92-- https://mathiasbynens.be/notes/javascript-identifiers
93-- Couldn't work out how to handle zero-width characters.
94-- @TODO: specify better default function name, or throw error?
95toValidFunctionName :: String -> String
96toValidFunctionName (x:xs) = [setFirstChar x] <> filter remainder xs
97 where
98 setFirstChar c = if firstChar c
99 then c
100 else '_'
101 firstChar c = (prefixOK c) || (or . map (Set.member c) $ firstLetterOK)
102 remainder c = (prefixOK c) || (or . map (Set.member c) $ remainderOK)
103 -- Valid prefixes
104 prefixOK c = c `elem` ['$','_']
105 -- Unicode character sets
106 firstLetterOK = [ Set.lowercaseLetter
107 , Set.uppercaseLetter
108 , Set.titlecaseLetter
109 , Set.modifierLetter
110 , Set.otherLetter
111 , Set.letterNumber ]
112 remainderOK = firstLetterOK <> [ Set.nonSpacingMark
113 , Set.spacingCombiningMark
114 , Set.decimalNumber
115 , Set.connectorPunctuation ]
116toValidFunctionName [] = "_"
118type MatrixArg = QueryArg
120type MatrixArg = QueryArg
122data Url = Url
123 { _path :: Path
124 , _queryStr :: [QueryArg]
125 } deriving (Eq, Show)
127defUrl :: Url
128defUrl = Url [] []
130type FunctionName = String
131type Method = String
133data AjaxReq = AjaxReq
134 { _reqUrl :: Url
135 , _reqMethod :: Method
136 , _reqHeaders :: [HeaderArg]
137 , _reqBody :: Bool
138 , _funcName :: FunctionName
139 } deriving (Eq, Show)
141makeLenses ''QueryArg
142makeLenses ''Segment
143makeLenses ''Url
144makeLenses ''AjaxReq
146isCapture :: Segment -> Bool
147isCapture (Segment (Cap _) _) = True
148isCapture _ = False
150hasMatrixArgs :: Segment -> Bool
151hasMatrixArgs (Segment _ (_:_)) = True
152hasMatrixArgs _ = False
154hasArgs :: Segment -> Bool
155hasArgs s = isCapture s || hasMatrixArgs s
157matrixArgs :: Segment -> [MatrixArg]
158matrixArgs (Segment _ ms) = ms
160captureArg :: Segment -> Arg
161captureArg (Segment (Cap s) _) = s
162captureArg _ = error "captureArg called on non capture"
164jsSegments :: [Segment] -> String
165jsSegments [] = ""
166jsSegments [x] = "/" ++ segmentToStr x False
167jsSegments (x:xs) = "/" ++ segmentToStr x True ++ jsSegments xs
169segmentToStr :: Segment -> Bool -> String
170segmentToStr (Segment st ms) notTheEnd =
171 segmentTypeToStr st ++ jsMParams ms ++ if notTheEnd then "" else "'"
173segmentTypeToStr :: SegmentType -> String
174segmentTypeToStr (Static s) = s
175segmentTypeToStr (Cap s) = "' + encodeURIComponent(" ++ s ++ ") + '"
177jsGParams :: String -> [QueryArg] -> String
178jsGParams _ [] = ""
179jsGParams _ [x] = paramToStr x False
180jsGParams s (x:xs) = paramToStr x True ++ s ++ jsGParams s xs
182jsParams :: [QueryArg] -> String
183jsParams = jsGParams "&"
185jsMParams :: [MatrixArg] -> String
186jsMParams [] = ""
187jsMParams xs = ";" ++ jsGParams ";" xs
189paramToStr :: QueryArg -> Bool -> String
190paramToStr qarg notTheEnd =
191 case qarg ^. argType of
192 Normal -> name
193 ++ "=' + encodeURIComponent("
194 ++ name
195 ++ if notTheEnd then ") + '" else ")"
197 Flag -> name ++ "="
199 List -> name
200 ++ "[]=' + encodeURIComponent("
201 ++ name
202 ++ if notTheEnd then ") + '" else ")"
204 where name = qarg ^. argName
206defReq :: AjaxReq
207defReq = AjaxReq defUrl "GET" [] False ""
209type family Elem (a :: *) (ls::[*]) :: Constraint where
210 Elem a '[] = 'False ~ 'True
211 Elem a (a ': list) = ()
212 Elem a (b ': list) = Elem a list
214class HasJQ (layout :: *) where
215 type JQ layout :: *
216 jqueryFor :: Proxy layout -> AjaxReq -> JQ layout
218instance (HasJQ a, HasJQ b)
219 => HasJQ (a :<|> b) where
220 type JQ (a :<|> b) = JQ a :<|> JQ b
222 jqueryFor Proxy req =
223 jqueryFor (Proxy :: Proxy a) req
224 :<|> jqueryFor (Proxy :: Proxy b) req
226instance (KnownSymbol sym, HasJQ sublayout)
227 => HasJQ (Capture sym a :> sublayout) where
228 type JQ (Capture sym a :> sublayout) = JQ sublayout
230 jqueryFor Proxy req =
231 jqueryFor (Proxy :: Proxy sublayout) $
232 req & reqUrl.path <>~ [Segment (Cap str) []]
234 where str = symbolVal (Proxy :: Proxy sym)
236instance HasJQ Delete where
237 type JQ Delete = AjaxReq
239 jqueryFor Proxy req =
240 req & funcName %~ ("delete" <>)
241 & reqMethod .~ "DELETE"
243instance Elem JSON list => HasJQ (Get list a) where
244 type JQ (Get list a) = AjaxReq
246 jqueryFor Proxy req =
247 req & funcName %~ ("get" <>)
248 & reqMethod .~ "GET"
250instance (KnownSymbol sym, HasJQ sublayout)
251 => HasJQ (Header sym a :> sublayout) where
252 type JQ (Header sym a :> sublayout) = JQ sublayout
254 jqueryFor Proxy req =
255 jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname])
257 where hname = symbolVal (Proxy :: Proxy sym)
258 subP = Proxy :: Proxy sublayout
260instance Elem JSON list => HasJQ (Post list a) where
261 type JQ (Post list a) = AjaxReq
263 jqueryFor Proxy req =
264 req & funcName %~ ("post" <>)
265 & reqMethod .~ "POST"
267instance Elem JSON list => HasJQ (Put list a) where
268 type JQ (Put list a) = AjaxReq
270 jqueryFor Proxy req =
271 req & funcName %~ ("put" <>)
272 & reqMethod .~ "PUT"
274instance (KnownSymbol sym, HasJQ sublayout)
275 => HasJQ (QueryParam sym a :> sublayout) where
276 type JQ (QueryParam sym a :> sublayout) = JQ sublayout
278 jqueryFor Proxy req =
279 jqueryFor (Proxy :: Proxy sublayout) $
280 req & reqUrl.queryStr <>~ [QueryArg str Normal]
282 where str = symbolVal (Proxy :: Proxy sym)
284instance (KnownSymbol sym, HasJQ sublayout)
285 => HasJQ (QueryParams sym a :> sublayout) where
286 type JQ (QueryParams sym a :> sublayout) = JQ sublayout
288 jqueryFor Proxy req =
289 jqueryFor (Proxy :: Proxy sublayout) $
290 req & reqUrl.queryStr <>~ [QueryArg str List]
292 where str = symbolVal (Proxy :: Proxy sym)
294instance (KnownSymbol sym, HasJQ sublayout)
295 => HasJQ (QueryFlag sym :> sublayout) where
296 type JQ (QueryFlag sym :> sublayout) = JQ sublayout
298 jqueryFor Proxy req =
299 jqueryFor (Proxy :: Proxy sublayout) $
300 req & reqUrl.queryStr <>~ [QueryArg str Flag]
302 where str = symbolVal (Proxy :: Proxy sym)
304instance (KnownSymbol sym, HasJQ sublayout)
305 => HasJQ (MatrixParam sym a :> sublayout) where
306 type JQ (MatrixParam sym a :> sublayout) = JQ sublayout
308 jqueryFor Proxy req =
309 jqueryFor (Proxy :: Proxy sublayout) $
310 req & reqUrl.path._last.matrix <>~ [QueryArg str Normal]
312 where str = symbolVal (Proxy :: Proxy sym)
313 strArg = str ++ "Value"
315instance (KnownSymbol sym, HasJQ sublayout)
316 => HasJQ (MatrixParams sym a :> sublayout) where
317 type JQ (MatrixParams sym a :> sublayout) = JQ sublayout
319 jqueryFor Proxy req =
320 jqueryFor (Proxy :: Proxy sublayout) $
321 req & reqUrl.path._last.matrix <>~ [QueryArg str List]
323 where str = symbolVal (Proxy :: Proxy sym)
325instance (KnownSymbol sym, HasJQ sublayout)
326 => HasJQ (MatrixFlag sym :> sublayout) where
327 type JQ (MatrixFlag sym :> sublayout) = JQ sublayout
329 jqueryFor Proxy req =
330 jqueryFor (Proxy :: Proxy sublayout) $
331 req & reqUrl.path._last.matrix <>~ [QueryArg str Flag]
333 where str = symbolVal (Proxy :: Proxy sym)
335instance HasJQ Raw where
336 type JQ Raw = Method -> AjaxReq
338 jqueryFor Proxy req method =
339 req & funcName %~ ((toLower <$> method) <>)
340 & reqMethod .~ method
342instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout) where
343 type JQ (ReqBody list a :> sublayout) = JQ sublayout
345 jqueryFor Proxy req =
346 jqueryFor (Proxy :: Proxy sublayout) $
347 req & reqBody .~ True
349instance (KnownSymbol path, HasJQ sublayout)
350 => HasJQ (path :> sublayout) where
351 type JQ (path :> sublayout) = JQ sublayout
353 jqueryFor Proxy req =
354 jqueryFor (Proxy :: Proxy sublayout) $
355 req & reqUrl.path <>~ [Segment (Static str) []]
356 & funcName %~ (str <>)
358 where str = map (\c -> if c == '.' then '_' else c) $ symbolVal (Proxy :: Proxy path)