diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ----- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,14 +1,12 @@ # servant-jquery -[![Build Status](https://secure.travis-ci.org/haskell-servant/servant-jquery.svg)](http://travis-ci.org/haskell-servant/servant-jquery) - ![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) 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 diff --git a/servant-jquery.cabal b/servant-jquery.cabal --- a/servant-jquery.cabal +++ b/servant-jquery.cabal @@ -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 that serves the generated javascript to a webpage that lets you - trigger webservice calls. + You can find an example + which serves the generated javascript to a webpage that allows you to trigger + webservice calls. + . + 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 diff --git a/src/Servant/JQuery.hs b/src/Servant/JQuery.hs --- a/src/Servant/JQuery.hs +++ b/src/Servant/JQuery.hs @@ -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) diff --git a/src/Servant/JQuery/Internal.hs b/src/Servant/JQuery/Internal.hs --- a/src/Servant/JQuery/Internal.hs +++ b/src/Servant/JQuery/Internal.hs @@ -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)