From 06d8c8005a4e1b76d982aaf854c61ac5fa471b04 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Tue, 25 Nov 2014 01:36:34 +0100 Subject: [PATCH] first shot for jquery codegen based on a servant API type --- LICENSE | 30 +++++ Setup.hs | 2 + TODO.md | 1 + example/greet.hs | 25 ++++ servant-jquery.cabal | 29 +++++ src/Servant/JQuery.hs | 76 ++++++++++++ src/Servant/JQuery/Internal.hs | 203 +++++++++++++++++++++++++++++++++ 7 files changed, 366 insertions(+) create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 TODO.md create mode 100644 example/greet.hs create mode 100644 servant-jquery.cabal create mode 100644 src/Servant/JQuery.hs create mode 100644 src/Servant/JQuery/Internal.hs diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..1f6f3e42 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Alp Mestanogullari + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alp Mestanogullari nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TODO.md b/TODO.md new file mode 100644 index 00000000..8ee2b547 --- /dev/null +++ b/TODO.md @@ -0,0 +1 @@ +- Investigate the best way to offer cross-origin requests \ No newline at end of file diff --git a/example/greet.hs b/example/greet.hs new file mode 100644 index 00000000..ee22eadc --- /dev/null +++ b/example/greet.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +import Data.Proxy +import Servant +import Servant.JQuery + +data Greet = Greet + +type TestApi = + "hello" :> Capture "name" String :> QueryParam "capital" Bool :> QueryParam "q" String :> Get Greet + :<|> "greet" :> ReqBody Greet :> Post Greet + :<|> "delete" :> Capture "greetid" String :> "haha" :> Delete + +testApi :: Proxy TestApi +testApi = Proxy + +getHello :<|> postGreet :<|> deleteGreet = jquery testApi + +main :: IO () +main = + mapM_ printJS [ getHello "getHello" + , postGreet "postGreet" + , deleteGreet "deleteGreet" + ] \ No newline at end of file diff --git a/servant-jquery.cabal b/servant-jquery.cabal new file mode 100644 index 00000000..508e56b2 --- /dev/null +++ b/servant-jquery.cabal @@ -0,0 +1,29 @@ +name: servant-jquery +version: 0.2 +synopsis: Automatically derive jquery-based javascript functions to query servant webservices +description: Automatically derive jquery-based javascript functions to query servant webservices +homepage: http://github.com/alpmestan/servant +license: BSD3 +license-file: LICENSE +author: Alp Mestanogullari +maintainer: alpmestan@gmail.com +copyright: 2014 Alp Mestanogullari +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Servant.JQuery + other-modules: Servant.JQuery.Internal + -- other-extensions: + build-depends: base >=4.5 && <5, servant >= 0.2, lens >= 4, interpolate + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -O2 -Wall + +executable greet + main-is: greet.hs + ghc-options: -O2 -Wall + hs-source-dirs: example + build-depends: base, servant, servant-jquery + default-language: Haskell2010 diff --git a/src/Servant/JQuery.hs b/src/Servant/JQuery.hs new file mode 100644 index 00000000..de9dbad9 --- /dev/null +++ b/src/Servant/JQuery.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Servant.JQuery +-- Copyright : (C) 2014 Alp Mestanogullari +-- License : BSD3 +-- Maintainer : Alp Mestanogullari +-- Stability : experimental +-- Portability : non-portable +-- +-- Usage: +module Servant.JQuery where + +import Control.Lens +import Data.List +import Data.Proxy +import Data.String.Interpolate +import Servant.JQuery.Internal + +jquery :: HasJQ layout => Proxy layout -> JQ layout +jquery p = jqueryFor p defReq + +-- js codegen +generateJS :: AjaxReq -> String +generateJS req = + [i| +function #{fname}(#{argsStr}) +{ + $.ajax( + { url: #{url} + , success: onSuccess #{dataBody} + , error: onError + , type: '#{method}' + }); +} + |] + + where argsStr = intercalate ", " args + args = captures + ++ map (view argName) queryparams + ++ body + ++ ["onSuccess", "onError"] + + captures = map captureArg + . filter isCapture + $ req ^. reqUrl.path + + queryparams = req ^.. reqUrl.queryStr.traverse + + body = if req ^. reqBody + then ["body"] + else [] + + dataBody = + if req ^. reqBody + then "\n , data: JSON.stringify(body)" + else "" + + fname = req ^. funcName + method = req ^. reqMethod + url = "'" + ++ urlArgs + ++ queryArgs + + urlArgs = jsSegments + $ req ^.. reqUrl.path.traverse + + queryArgs = if null queryparams + then "" + else " + '?" ++ jsParams queryparams + +printJS :: AjaxReq -> IO () +printJS = putStrLn . generateJS diff --git a/src/Servant/JQuery/Internal.hs b/src/Servant/JQuery/Internal.hs new file mode 100644 index 00000000..817134a6 --- /dev/null +++ b/src/Servant/JQuery/Internal.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant.JQuery.Internal where + +import Control.Lens +import Data.Proxy +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" + 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 = + "' + " ++ s ++ if notTheEnd then " + '" else "" + +type Path = [Segment] + +data ArgType = + Normal + | Flag + | List + deriving (Eq, Show) + +data QueryArg = QueryArg + { _argName :: Arg + , _argType :: ArgType + } deriving (Eq, Show) + +data Url = Url + { _path :: Path + , _queryStr :: [QueryArg] + } deriving (Eq, Show) + +defUrl :: Url +defUrl = Url [] [] + +type FunctionName = String +type Method = String + +data AjaxReq = AjaxReq + { _reqUrl :: Url + , _reqMethod :: Method + , _reqBody :: Bool + , _funcName :: FunctionName + } deriving (Eq, Show) + +makeLenses ''QueryArg +makeLenses ''Url +makeLenses ''AjaxReq + +jsParams :: [QueryArg] -> String +jsParams [] = "" +jsParams [x] = paramToStr x False +jsParams (x:xs) = paramToStr x True ++ "&" ++ jsParams xs + +paramToStr :: QueryArg -> Bool -> String +paramToStr qarg notTheEnd = + case qarg ^. argType of + Normal -> name + ++ "=' + encodeURIComponent(" + ++ name + ++ if notTheEnd then ") + '" else ")" + + Flag -> name ++ "=" + + List -> name + ++ "[]=' + encodeURIComponent(" + ++ name + ++ if notTheEnd then ") + '" else ")" + + where name = qarg ^. argName + +defReq :: AjaxReq +defReq = AjaxReq defUrl "GET" False "" + +class HasJQ layout where + type JQ layout :: * + jqueryFor :: Proxy layout -> AjaxReq -> JQ layout + +instance (HasJQ a, HasJQ b) + => HasJQ (a :<|> b) where + type JQ (a :<|> b) = JQ a :<|> JQ b + + jqueryFor Proxy req = + jqueryFor (Proxy :: Proxy a) req + :<|> jqueryFor (Proxy :: Proxy b) req + +instance (KnownSymbol sym, HasJQ sublayout) + => HasJQ (Capture sym a :> sublayout) where + type JQ (Capture sym a :> sublayout) = JQ sublayout + + jqueryFor Proxy req = + jqueryFor (Proxy :: Proxy sublayout) $ + req & reqUrl.path <>~ [Cap str] + + where str = symbolVal (Proxy :: Proxy sym) + +instance HasJQ Delete where + type JQ Delete = FunctionName -> AjaxReq + + jqueryFor Proxy req fName = + req & funcName .~ fName + & reqMethod .~ "DELETE" + +instance HasJQ (Get a) where + type JQ (Get a) = FunctionName -> AjaxReq + + jqueryFor Proxy req fName = + req & funcName .~ fName + & reqMethod .~ "GET" + +instance HasJQ (Post a) where + type JQ (Post a) = FunctionName -> AjaxReq + + jqueryFor Proxy req fName = + req & funcName .~ fName + & reqMethod .~ "POST" + +instance HasJQ (Put a) where + type JQ (Put a) = FunctionName -> AjaxReq + + jqueryFor Proxy req fName = + req & funcName .~ fName + & reqMethod .~ "PUT" + +instance (KnownSymbol sym, HasJQ sublayout) + => HasJQ (QueryParam sym a :> sublayout) where + type JQ (QueryParam sym a :> sublayout) = JQ sublayout + + jqueryFor Proxy req = + jqueryFor (Proxy :: Proxy sublayout) $ + 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 + type JQ (QueryParams sym a :> sublayout) = JQ sublayout + + jqueryFor Proxy req = + jqueryFor (Proxy :: Proxy sublayout) $ + req & reqUrl.queryStr <>~ [QueryArg str List] + + where str = symbolVal (Proxy :: Proxy sym) + +instance (KnownSymbol sym, HasJQ sublayout) + => HasJQ (QueryFlag sym :> sublayout) where + type JQ (QueryFlag sym :> sublayout) = JQ sublayout + + jqueryFor Proxy req = + jqueryFor (Proxy :: Proxy sublayout) $ + req & reqUrl.queryStr <>~ [QueryArg str Flag] + + where str = symbolVal (Proxy :: Proxy sym) + +instance HasJQ Raw where + type JQ Raw = Method -> FunctionName -> AjaxReq + + jqueryFor Proxy req method fName = + req & reqMethod .~ method + & funcName .~ fName + +instance HasJQ sublayout => HasJQ (ReqBody a :> sublayout) where + type JQ (ReqBody a :> sublayout) = JQ sublayout + + jqueryFor Proxy req = + jqueryFor (Proxy :: Proxy sublayout) $ + req & reqBody .~ True + +instance (KnownSymbol path, HasJQ sublayout) + => HasJQ (path :> sublayout) where + type JQ (path :> sublayout) = JQ sublayout + + jqueryFor Proxy req = + jqueryFor (Proxy :: Proxy sublayout) $ + req & reqUrl.path <>~ [Static str] + + where str = symbolVal (Proxy :: Proxy path)