servant-jquery 0.2.2.1 → 0.4.0
raw patch · 5 files changed
+226/−64 lines, 5 filesdep +charsetdep +hspec-expectationsdep +textdep ~lensdep ~servantdep ~servant-jquery
Dependencies added: charset, hspec-expectations, text
Dependency ranges changed: lens, servant, servant-jquery, servant-server
Files
- CHANGELOG.md +8/−0
- README.md +2/−4
- servant-jquery.cabal +18/−9
- src/Servant/JQuery.hs +32/−5
- src/Servant/JQuery/Internal.hs +166/−46
CHANGELOG.md view
@@ -1,3 +1,11 @@+0.4+---+* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body+* Extend `HeaderArg` to support more advanced HTTP header handling (https://github.com/haskell-servant/servant-jquery/pull/6)+* Support content-type aware combinators (but require that endpoints support JSON)+* Add support for Matrix params (https://github.com/haskell-servant/servant-jquery/pull/11)+* Add functions that directly generate the Javascript code from the API type without having to manually pattern match on the result.+ 0.2.2 -----
README.md view
@@ -1,14 +1,12 @@ # servant-jquery -[](http://travis-ci.org/haskell-servant/servant-jquery)-  This library lets you derive automatically (JQuery based) Javascript functions that let you query each endpoint of a *servant* webservice. ## Example -Read more about the following example [here](https://github.com/haskell-servant/servant-jquery/tree/master/examples#examples).+Read more about the following example [here](https://github.com/haskell-servant/servant/tree/master/servant-jquery/tree/master/examples#examples). ``` haskell {-# LANGUAGE DataKinds #-}@@ -52,7 +50,7 @@ -- * Our API type type TestApi = "counter" :> Post Counter -- endpoint for increasing the counter :<|> "counter" :> Get Counter -- endpoint to get the current value- :<|> Raw -- used for serving static files + :<|> Raw -- used for serving static files testApi :: Proxy TestApi testApi = Proxy
servant-jquery.cabal view
@@ -1,11 +1,14 @@ name: servant-jquery-version: 0.2.2.1+version: 0.4.0 synopsis: Automatically derive (jquery) javascript functions to query servant webservices description: Automatically derive jquery-based javascript functions to query servant webservices. .- Example <https://github.com/haskell-servant/servant-jquery/blob/master/examples/counter.hs here> that serves the generated javascript to a webpage that lets you- trigger webservice calls.+ You can find an example <https://github.com/haskell-servant/servant/blob/master/servant-jquery/examples/counter.hs here>+ which serves the generated javascript to a webpage that allows you to trigger+ webservice calls.+ .+ <https://github.com/haskell-servant/servant/blob/master/servant-jquery/CHANGELOG.md CHANGELOG> license: BSD3 license-file: LICENSE author: Alp Mestanogullari@@ -15,13 +18,13 @@ build-type: Simple cabal-version: >=1.10 homepage: http://haskell-servant.github.io/-Bug-reports: http://github.com/haskell-servant/servant-jquery/issues+Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: CHANGELOG.md README.md source-repository head type: git- location: http://github.com/haskell-servant/servant-jquery.git+ location: http://github.com/haskell-servant/servant.git flag example description: Build the example too@@ -31,7 +34,11 @@ library exposed-modules: Servant.JQuery other-modules: Servant.JQuery.Internal- build-depends: base >=4.5 && <5, servant >= 0.2.1, lens >= 4+ build-depends: base >=4.5 && <5+ , charset+ , lens >= 4+ , servant == 0.4.*+ , text hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall@@ -50,9 +57,9 @@ aeson , base , filepath- , servant >= 0.2.1- , servant-server >= 0.2.1- , servant-jquery >= 0.2.1+ , servant == 0.4.*+ , servant-server == 0.4.*+ , servant-jquery == 0.4.* , stm , transformers , warp@@ -65,8 +72,10 @@ main-is: Spec.hs build-depends: base == 4.*+ , lens , servant-jquery , servant , hspec >= 2.0+ , hspec-expectations , language-ecmascript >= 0.16 default-language: Haskell2010
src/Servant/JQuery.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- |@@ -12,14 +13,17 @@ module Servant.JQuery ( jquery , generateJS+ , jsForAPI , printJS , module Servant.JQuery.Internal+ , GenerateCode(..) ) where import Control.Lens import Data.List import Data.Monoid import Data.Proxy+import Servant.API import Servant.JQuery.Internal jquery :: HasJQ layout => Proxy layout -> JQ layout@@ -44,9 +48,9 @@ args = captures ++ map (view argName) queryparams ++ body- ++ map ("header"++) hs+ ++ map (toValidFunctionName . (<>) "header" . headerArgName) hs ++ ["onSuccess", "onError"]- + captures = map captureArg . filter isCapture $ req ^. reqUrl.path@@ -67,14 +71,17 @@ reqheaders = if null hs then ""- else "\n , headers: { " ++ headersStr ++ " } }\n"+ else "\n , headers: { " ++ headersStr ++ " }\n" where headersStr = intercalate ", " $ map headerStr hs- headerStr hname = "\"" ++ hname ++ "\": header" ++ hname+ headerStr header = "\"" +++ headerArgName header +++ "\": " ++ show header fname = req ^. funcName method = req ^. reqMethod- url = "'"+ url = if url' == "'" then "'/'" else url'+ url' = "'" ++ urlArgs ++ queryArgs @@ -87,3 +94,23 @@ printJS :: AjaxReq -> IO () printJS = putStrLn . generateJS++-- | Utility class used by 'jsForAPI' which will+-- directly hand you all the Javascript code+-- instead of handing you a ':<|>'-separated list+-- of 'AjaxReq' like 'jquery' and then having to+-- use 'generateJS' on each 'AjaxReq'.+class GenerateCode reqs where+ jsFor :: reqs -> String++instance GenerateCode AjaxReq where+ jsFor = generateJS++instance GenerateCode rest => GenerateCode (AjaxReq :<|> rest) where+ jsFor (req :<|> rest) = jsFor req ++ jsFor rest++-- | Directly generate all the javascript functions for your API+-- from a 'Proxy' for your API type. You can then write it to+-- a file or integrate it in a page, for example.+jsForAPI :: (HasJQ api, GenerateCode (JQ api)) => Proxy api -> String+jsForAPI p = jsFor (jquery p)
src/Servant/JQuery/Internal.hs view
@@ -1,44 +1,38 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module Servant.JQuery.Internal where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative+#endif import Control.Lens import Data.Char (toLower)+import qualified Data.CharSet as Set+import qualified Data.CharSet.Unicode.Category as Set+import Data.List import Data.Monoid import Data.Proxy+import qualified Data.Text as T+import GHC.Exts (Constraint) 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"+data Segment = Segment { _segment :: SegmentType, _matrix :: [MatrixArg] } 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 =- "' + encodeURIComponent(" ++ s ++ if notTheEnd then ") + '" else ")"+data SegmentType = Static String -- ^ a static path segment. like "/foo"+ | Cap Arg -- ^ a capture. like "/:userid"+ deriving (Eq, Show) type Path = [Segment] @@ -53,8 +47,60 @@ , _argType :: ArgType } deriving (Eq, Show) -type HeaderArg = String+data HeaderArg = HeaderArg+ { headerArgName :: String+ }+ | ReplaceHeaderArg+ { headerArgName :: String+ , headerPattern :: String+ } deriving (Eq) +instance Show HeaderArg where+ show (HeaderArg n) = toValidFunctionName ("header" <> n)+ show (ReplaceHeaderArg n p)+ | pn `isPrefixOf` p = pv <> " + \"" <> rp <> "\""+ | pn `isSuffixOf` p = "\"" <> rp <> "\" + " <> pv+ | pn `isInfixOf` p = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p)+ <> "\""+ | otherwise = p+ where+ pv = toValidFunctionName ("header" <> n)+ pn = "{" <> n <> "}"+ rp = replace pn "" p+ -- Use replace method from Data.Text+ replace old new = T.unpack .+ T.replace (T.pack old) (T.pack new) .+ T.pack++-- | Attempts to reduce the function name provided to that allowed by JS.+-- https://mathiasbynens.be/notes/javascript-identifiers+-- Couldn't work out how to handle zero-width characters.+-- @TODO: specify better default function name, or throw error?+toValidFunctionName :: String -> String+toValidFunctionName (x:xs) = [setFirstChar x] <> filter remainder xs+ where+ setFirstChar c = if firstChar c+ then c+ else '_'+ firstChar c = (prefixOK c) || (or . map (Set.member c) $ firstLetterOK)+ remainder c = (prefixOK c) || (or . map (Set.member c) $ remainderOK)+ -- Valid prefixes+ prefixOK c = c `elem` ['$','_']+ -- Unicode character sets+ firstLetterOK = [ Set.lowercaseLetter+ , Set.uppercaseLetter+ , Set.titlecaseLetter+ , Set.modifierLetter+ , Set.otherLetter+ , Set.letterNumber ]+ remainderOK = firstLetterOK <> [ Set.nonSpacingMark+ , Set.spacingCombiningMark+ , Set.decimalNumber+ , Set.connectorPunctuation ]+toValidFunctionName [] = "_"++type MatrixArg = QueryArg+ data Url = Url { _path :: Path , _queryStr :: [QueryArg]@@ -75,14 +121,53 @@ } deriving (Eq, Show) makeLenses ''QueryArg+makeLenses ''Segment makeLenses ''Url makeLenses ''AjaxReq +isCapture :: Segment -> Bool+isCapture (Segment (Cap _) _) = True+isCapture _ = False++hasMatrixArgs :: Segment -> Bool+hasMatrixArgs (Segment _ (_:_)) = True+hasMatrixArgs _ = False++hasArgs :: Segment -> Bool+hasArgs s = isCapture s || hasMatrixArgs s++matrixArgs :: Segment -> [MatrixArg]+matrixArgs (Segment _ ms) = ms++captureArg :: Segment -> Arg+captureArg (Segment (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 (Segment st ms) notTheEnd =+ segmentTypeToStr st ++ jsMParams ms ++ if notTheEnd then "" else "'"++segmentTypeToStr :: SegmentType -> String+segmentTypeToStr (Static s) = s+segmentTypeToStr (Cap s) = "' + encodeURIComponent(" ++ s ++ ") + '"++jsGParams :: String -> [QueryArg] -> String+jsGParams _ [] = ""+jsGParams _ [x] = paramToStr x False+jsGParams s (x:xs) = paramToStr x True ++ s ++ jsGParams s xs+ jsParams :: [QueryArg] -> String-jsParams [] = ""-jsParams [x] = paramToStr x False-jsParams (x:xs) = paramToStr x True ++ "&" ++ jsParams xs+jsParams = jsGParams "&" +jsMParams :: [MatrixArg] -> String+jsMParams [] = ""+jsMParams xs = ";" ++ jsGParams ";" xs+ paramToStr :: QueryArg -> Bool -> String paramToStr qarg notTheEnd = case qarg ^. argType of@@ -103,7 +188,12 @@ defReq :: AjaxReq defReq = AjaxReq defUrl "GET" [] False "" -class HasJQ layout where+type family Elem (a :: *) (ls::[*]) :: Constraint where+ Elem a '[] = 'False ~ 'True+ Elem a (a ': list) = ()+ Elem a (b ': list) = Elem a list++class HasJQ (layout :: *) where type JQ layout :: * jqueryFor :: Proxy layout -> AjaxReq -> JQ layout @@ -121,19 +211,19 @@ jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $- req & reqUrl.path <>~ [Cap str]+ req & reqUrl.path <>~ [Segment (Cap str) []] where str = symbolVal (Proxy :: Proxy sym) -instance HasJQ Delete where- type JQ Delete = AjaxReq+instance Elem JSON list => HasJQ (Delete list a) where+ type JQ (Delete list a) = AjaxReq jqueryFor Proxy req = req & funcName %~ ("delete" <>) & reqMethod .~ "DELETE" -instance HasJQ (Get a) where- type JQ (Get a) = AjaxReq+instance Elem JSON list => HasJQ (Get list a) where+ type JQ (Get list a) = AjaxReq jqueryFor Proxy req = req & funcName %~ ("get" <>)@@ -144,20 +234,20 @@ type JQ (Header sym a :> sublayout) = JQ sublayout jqueryFor Proxy req =- jqueryFor subP (req & reqHeaders <>~ [hname])+ jqueryFor subP (req & reqHeaders <>~ [HeaderArg hname]) where hname = symbolVal (Proxy :: Proxy sym) subP = Proxy :: Proxy sublayout -instance HasJQ (Post a) where- type JQ (Post a) = AjaxReq+instance Elem JSON list => HasJQ (Post list a) where+ type JQ (Post list a) = AjaxReq jqueryFor Proxy req = req & funcName %~ ("post" <>) & reqMethod .~ "POST" -instance HasJQ (Put a) where- type JQ (Put a) = AjaxReq+instance Elem JSON list => HasJQ (Put list a) where+ type JQ (Put list a) = AjaxReq jqueryFor Proxy req = req & funcName %~ ("put" <>)@@ -172,7 +262,6 @@ 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@@ -194,6 +283,37 @@ where str = symbolVal (Proxy :: Proxy sym) +instance (KnownSymbol sym, HasJQ sublayout)+ => HasJQ (MatrixParam sym a :> sublayout) where+ type JQ (MatrixParam sym a :> sublayout) = JQ sublayout++ jqueryFor Proxy req =+ jqueryFor (Proxy :: Proxy sublayout) $+ req & reqUrl.path._last.matrix <>~ [QueryArg strArg Normal]++ where str = symbolVal (Proxy :: Proxy sym)+ strArg = str ++ "Value"++instance (KnownSymbol sym, HasJQ sublayout)+ => HasJQ (MatrixParams sym a :> sublayout) where+ type JQ (MatrixParams sym a :> sublayout) = JQ sublayout++ jqueryFor Proxy req =+ jqueryFor (Proxy :: Proxy sublayout) $+ req & reqUrl.path._last.matrix <>~ [QueryArg str List]++ where str = symbolVal (Proxy :: Proxy sym)++instance (KnownSymbol sym, HasJQ sublayout)+ => HasJQ (MatrixFlag sym :> sublayout) where+ type JQ (MatrixFlag sym :> sublayout) = JQ sublayout++ jqueryFor Proxy req =+ jqueryFor (Proxy :: Proxy sublayout) $+ req & reqUrl.path._last.matrix <>~ [QueryArg str Flag]++ where str = symbolVal (Proxy :: Proxy sym)+ instance HasJQ Raw where type JQ Raw = Method -> AjaxReq @@ -201,8 +321,8 @@ req & funcName %~ ((toLower <$> method) <>) & reqMethod .~ method -instance HasJQ sublayout => HasJQ (ReqBody a :> sublayout) where- type JQ (ReqBody a :> sublayout) = JQ sublayout+instance (Elem JSON list, HasJQ sublayout) => HasJQ (ReqBody list a :> sublayout) where+ type JQ (ReqBody list a :> sublayout) = JQ sublayout jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $@@ -214,7 +334,7 @@ jqueryFor Proxy req = jqueryFor (Proxy :: Proxy sublayout) $- req & reqUrl.path <>~ [Static str]+ req & reqUrl.path <>~ [Segment (Static str) []] & funcName %~ (str <>) where str = map (\c -> if c == '.' then '_' else c) $ symbolVal (Proxy :: Proxy path)