git.iko.soy/typeable/servant
on 9e5bed2 help sign in
typeable/servant/src/Servant/JQuery/Internal.hs
356 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
120data Url = Url
121 { _path :: Path
122 , _queryStr :: [QueryArg]
123 } deriving (Eq, Show)
125defUrl :: Url
126defUrl = Url [] []
128type FunctionName = String
129type Method = String
131data AjaxReq = AjaxReq
132 { _reqUrl :: Url
133 , _reqMethod :: Method
134 , _reqHeaders :: [HeaderArg]
135 , _reqBody :: Bool
136 , _funcName :: FunctionName
137 } deriving (Eq, Show)
139makeLenses ''QueryArg
140makeLenses ''Segment
141makeLenses ''Url
142makeLenses ''AjaxReq
144isCapture :: Segment -> Bool
145isCapture (Segment (Cap _) _) = True
146isCapture _ = False
148hasMatrixArgs :: Segment -> Bool
149hasMatrixArgs (Segment _ (_:_)) = True
150hasMatrixArgs _ = False
152hasArgs :: Segment -> Bool
153hasArgs s = isCapture s || hasMatrixArgs s
155matrixArgs :: Segment -> [MatrixArg]
156matrixArgs (Segment _ ms) = ms
158captureArg :: Segment -> Arg
159captureArg (Segment (Cap s) _) = s
160captureArg _ = error "captureArg called on non capture"
162jsSegments :: [Segment] -> String
163jsSegments [] = ""
164jsSegments [x] = "/" ++ segmentToStr x False
165jsSegments (x:xs) = "/" ++ segmentToStr x True ++ jsSegments xs
167segmentToStr :: Segment -> Bool -> String
168segmentToStr (Segment st ms) notTheEnd =
169 segmentTypeToStr st ++ jsMParams ms ++ if notTheEnd then "" else "'"
171segmentTypeToStr :: SegmentType -> String
172segmentTypeToStr (Static s) = s
173segmentTypeToStr (Cap s) = "' + encodeURIComponent(" ++ s ++ ") + '"
175jsGParams :: String -> [QueryArg] -> String
176jsGParams _ [] = ""
177jsGParams _ [x] = paramToStr x False
178jsGParams s (x:xs) = paramToStr x True ++ s ++ jsGParams s xs
180jsParams :: [QueryArg] -> String
181jsParams = jsGParams "&"
183jsMParams :: [MatrixArg] -> String
184jsMParams [] = ""
185jsMParams xs = ";" ++ jsGParams ";" xs
187paramToStr :: QueryArg -> Bool -> String
188paramToStr qarg notTheEnd =
189 case qarg ^. argType of
190 Normal -> name
191 ++ "=' + encodeURIComponent("
192 ++ name
193 ++ if notTheEnd then ") + '" else ")"
195 Flag -> name ++ "="
197 List -> name
198 ++ "[]=' + encodeURIComponent("
199 ++ name
200 ++ if notTheEnd then ") + '" else ")"
202 where name = qarg ^. argName
204defReq :: AjaxReq
205defReq = AjaxReq defUrl "GET" [] False ""
207type family Elem (a :: *) (ls::[*]) :: Constraint where
208 Elem a '[] = 'False ~ 'True
209 Elem a (a ': list) = ()
210 Elem a (b ': list) = Elem a list
212class HasJQ (layout :: *) where
213 type JQ layout :: *
214 jqueryFor :: Proxy layout -> AjaxReq -> JQ layout
216instance (HasJQ a, HasJQ b)
217 => HasJQ (a :<|> b) where
218 type JQ (a :<|> b) = JQ a :<|> JQ b
220 jqueryFor Proxy req =
221 jqueryFor (Proxy :: Proxy a) req
222 :<|> jqueryFor (Proxy :: Proxy b) req
224instance (KnownSymbol sym, HasJQ sublayout)
225 => HasJQ (Capture sym a :> sublayout) where
226 type JQ (Capture sym a :> sublayout) = JQ sublayout
228 jqueryFor Proxy req =
229 jqueryFor (Proxy :: Proxy sublayout) $
230 req & reqUrl.path <>~ [Segment (Cap str) []]
232 where str = symbolVal (Proxy :: Proxy sym)
234instance HasJQ Delete where
235 type JQ Delete = AjaxReq
237 jqueryFor Proxy req =
238 req & funcName %~ ("delete" <>)
239 & reqMethod .~ "DELETE"
241instance Elem JSON list => HasJQ (Get list a) where
242 type JQ (Get list a) = AjaxReq
244 jqueryFor Proxy req =
245 req & funcName %~ ("get" <>)
246 & reqMethod .~ "GET"
248instance (KnownSymbol sym, HasJQ sublayout)
249 => HasJQ (Header sym a :> sublayout) where
250 type JQ (Header sym a :> sublayout) = JQ sublayout
252 jqueryFor Proxy req =
253 jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname])
255 where hname = symbolVal (Proxy :: Proxy sym)
256 subP = Proxy :: Proxy sublayout
258instance Elem JSON list => HasJQ (Post list a) where
259 type JQ (Post list a) = AjaxReq
261 jqueryFor Proxy req =
262 req & funcName %~ ("post" <>)
263 & reqMethod .~ "POST"
265instance Elem JSON list => HasJQ (Put list a) where
266 type JQ (Put list a) = AjaxReq
268 jqueryFor Proxy req =
269 req & funcName %~ ("put" <>)
270 & reqMethod .~ "PUT"
272instance (KnownSymbol sym, HasJQ sublayout)
273 => HasJQ (QueryParam sym a :> sublayout) where
274 type JQ (QueryParam sym a :> sublayout) = JQ sublayout
276 jqueryFor Proxy req =
277 jqueryFor (Proxy :: Proxy sublayout) $
278 req & reqUrl.queryStr <>~ [QueryArg str Normal]
280 where str = symbolVal (Proxy :: Proxy sym)
282instance (KnownSymbol sym, HasJQ sublayout)
283 => HasJQ (QueryParams sym a :> sublayout) where
284 type JQ (QueryParams sym a :> sublayout) = JQ sublayout
286 jqueryFor Proxy req =
287 jqueryFor (Proxy :: Proxy sublayout) $
288 req & reqUrl.queryStr <>~ [QueryArg str List]
290 where str = symbolVal (Proxy :: Proxy sym)
292instance (KnownSymbol sym, HasJQ sublayout)
293 => HasJQ (QueryFlag sym :> sublayout) where
294 type JQ (QueryFlag sym :> sublayout) = JQ sublayout
296 jqueryFor Proxy req =
297 jqueryFor (Proxy :: Proxy sublayout) $
298 req & reqUrl.queryStr <>~ [QueryArg str Flag]
300 where str = symbolVal (Proxy :: Proxy sym)
302instance (KnownSymbol sym, HasJQ sublayout)
303 => HasJQ (MatrixParam sym a :> sublayout) where
304 type JQ (MatrixParam sym a :> sublayout) = JQ sublayout
306 jqueryFor Proxy req =
307 jqueryFor (Proxy :: Proxy sublayout) $
308 req & reqUrl.path._last.matrix <>~ [QueryArg str Normal]
310 where str = symbolVal (Proxy :: Proxy sym)
311 strArg = str ++ "Value"
313instance (KnownSymbol sym, HasJQ sublayout)
314 => HasJQ (MatrixParams sym a :> sublayout) where
315 type JQ (MatrixParams sym a :> sublayout) = JQ sublayout
317 jqueryFor Proxy req =
318 jqueryFor (Proxy :: Proxy sublayout) $
319 req & reqUrl.path._last.matrix <>~ [QueryArg str List]
321 where str = symbolVal (Proxy :: Proxy sym)
323instance (KnownSymbol sym, HasJQ sublayout)
324 => HasJQ (MatrixFlag sym :> sublayout) where
325 type JQ (MatrixFlag sym :> sublayout) = JQ sublayout
327 jqueryFor Proxy req =
328 jqueryFor (Proxy :: Proxy sublayout) $
329 req & reqUrl.path._last.matrix <>~ [QueryArg str Flag]
331 where str = symbolVal (Proxy :: Proxy sym)
333instance HasJQ Raw where
334 type JQ Raw = Method -> AjaxReq
336 jqueryFor Proxy req method =
337 req & funcName %~ ((toLower <$> method) <>)
338 & reqMethod .~ method
340instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout) where
341 type JQ (ReqBody list a :> sublayout) = JQ sublayout
343 jqueryFor Proxy req =
344 jqueryFor (Proxy :: Proxy sublayout) $
345 req & reqBody .~ True
347instance (KnownSymbol path, HasJQ sublayout)
348 => HasJQ (path :> sublayout) where
349 type JQ (path :> sublayout) = JQ sublayout
351 jqueryFor Proxy req =
352 jqueryFor (Proxy :: Proxy sublayout) $
353 req & reqUrl.path <>~ [Segment (Static str) []]
354 & funcName %~ (str <>)
356 where str = map (\c -> if c == '.' then '_' else c) $ symbolVal (Proxy :: Proxy path)