diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Zalora South East Asia Pte Ltd + +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 Zalora South East Asia Pte Ltd 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 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/counter.hs b/examples/counter.hs new file mode 100644 --- /dev/null +++ b/examples/counter.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Data.Aeson +import Data.Proxy +import GHC.Generics +import Network.Wai.Handler.Warp (run) +import Servant +import Servant.JQuery +import System.FilePath + +-- * A simple Counter data type +newtype Counter = Counter { value :: Int } + deriving (Generic, Show, Num) + +instance ToJSON Counter + +-- * Shared counter operations + +-- Creating a counter that starts from 0 +newCounter :: IO (TVar Counter) +newCounter = newTVarIO 0 + +-- Increasing the counter by 1 +counterPlusOne :: MonadIO m => TVar Counter -> m Counter +counterPlusOne counter = liftIO . atomically $ do + oldValue <- readTVar counter + let newValue = oldValue + 1 + writeTVar counter newValue + return newValue + +currentValue :: MonadIO m => TVar Counter -> m Counter +currentValue counter = liftIO $ readTVarIO counter + +-- * 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 + +testApi :: Proxy TestApi +testApi = Proxy + +-- * Server-side handler + +-- where our static files reside +www :: FilePath +www = "examples/www" + +-- defining handlers +server :: TVar Counter -> Server TestApi +server counter = counterPlusOne counter -- (+1) on the TVar + :<|> currentValue counter -- read the TVar + :<|> serveDirectory www -- serve static files + +runServer :: TVar Counter -- ^ shared variable for the counter + -> Int -- ^ port the server should listen on + -> IO () +runServer var port = run port (serve testApi $ server var) + +-- * Generating the JQuery code + +incCounterJS :<|> currentValueJS :<|> _ = jquery testApi + +writeJS :: FilePath -> [AjaxReq] -> IO () +writeJS fp functions = writeFile fp $ + concatMap generateJS functions + +main :: IO () +main = do + -- write the JS code to www/api.js at startup + writeJS (www "api.js") + [ incCounterJS, currentValueJS ] + + -- setup a shared counter + cnt <- newCounter + + -- listen to requests on port 8080 + runServer cnt 8080 diff --git a/servant-jquery.cabal b/servant-jquery.cabal new file mode 100644 --- /dev/null +++ b/servant-jquery.cabal @@ -0,0 +1,127 @@ +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. + . + Example below that serves the generated javascript to a webpage that lets you + trigger webservice calls. + . + > {-# LANGUAGE DataKinds #-} + > {-# LANGUAGE TypeOperators #-} + > {-# LANGUAGE DeriveGeneric #-} + > {-# LANGUAGE GeneralizedNewtypeDeriving #-} + > + > import Control.Concurrent.STM + > import Control.Monad.IO.Class + > import Data.Aeson + > import Data.Proxy + > import GHC.Generics + > import Network.Wai.Handler.Warp (run) + > import Servant + > import Servant.JQuery + > import System.FilePath + > + > -- * A simple Counter data type + > newtype Counter = Counter { value :: Int } + > deriving (Generic, Show, Num) + > + > instance ToJSON Counter + > + > -- * Shared counter operations + > + > -- Creating a counter that starts from 0 + > newCounter :: IO (TVar Counter) + > newCounter = newTVarIO 0 + > + > -- Increasing the counter by 1 + > counterPlusOne :: MonadIO m => TVar Counter -> m Counter + > counterPlusOne counter = liftIO . atomically $ do + > oldValue <- readTVar counter + > let newValue = oldValue + 1 + > writeTVar counter newValue + > return newValue + > + > currentValue :: MonadIO m => TVar Counter -> m Counter + > currentValue counter = liftIO $ readTVarIO counter + > + > -- * 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 + > + > testApi :: Proxy TestApi + > testApi = Proxy + > + > -- * Server-side handler + > + > -- where our static files reside + > www :: FilePath + > www = "examples/www" + > + > -- defining handlers + > server :: TVar Counter -> Server TestApi + > server counter = counterPlusOne counter -- (+1) on the TVar + > :<|> currentValue counter -- read the TVar + > :<|> serveDirectory www -- serve static files + > + > runServer :: TVar Counter -- ^ shared variable for the counter + > -> Int -- ^ port the server should listen on + > -> IO () + > runServer var port = run port (serve testApi $ server var) + > + > -- * Generating the JQuery code + > + > incCounterJS :<|> currentValueJS :<|> _ = jquery testApi + > + > writeJS :: FilePath -> [AjaxReq] -> IO () + > writeJS fp functions = writeFile fp $ + > concatMap generateJS functions + > + > main :: IO () + > main = do + > -- write the JS code to www/api.js at startup + > writeJS (www "api.js") + > [ incCounterJS, currentValueJS ] + > + > -- setup a shared counter + > cnt <- newCounter + > + > -- listen to requests on port 8080 + > runServer cnt 8080 +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 +homepage: http://haskell-servant.github.io/ +Bug-reports: http://github.com/haskell-servant/servant-jquery/issues +source-repository head + type: git + location: http://github.com/haskell-servant/servant-jquery.git + +library + exposed-modules: Servant.JQuery + other-modules: Servant.JQuery.Internal + build-depends: base >=4.5 && <5, servant >= 0.2, lens >= 4 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +executable counter + main-is: counter.hs + ghc-options: -O2 -Wall + hs-source-dirs: examples + build-depends: + aeson + , base + , filepath + , servant >= 0.2 + , servant-jquery >= 0.2 + , stm + , transformers + , warp + default-language: Haskell2010 diff --git a/src/Servant/JQuery.hs b/src/Servant/JQuery.hs new file mode 100644 --- /dev/null +++ b/src/Servant/JQuery.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Servant.JQuery +-- Copyright : (C) 2014 Alp Mestanogullari +-- License : BSD3 +-- Maintainer : Alp Mestanogullari +-- Stability : experimental +-- Portability : non-portable +module Servant.JQuery + ( jquery + , generateJS + , printJS + , module Servant.JQuery.Internal + ) where + +import Control.Lens +import Data.List +import Data.Monoid +import Data.Proxy +import Servant.JQuery.Internal + +jquery :: HasJQ layout => Proxy layout -> JQ layout +jquery p = jqueryFor p defReq + +-- js codegen +generateJS :: AjaxReq -> String +generateJS req = "\n" <> + "function " <> fname <> "(" <> argsStr <> ")\n" + <> "{\n" + <> " $.ajax(\n" + <> " { url: " <> url <> "\n" + <> " , success: onSuccess\n" + <> dataBody + <> reqheaders + <> " , error: onError\n" + <> " , type: '" <> method <> "'\n" + <> " });\n" + <> "}\n" + + where argsStr = intercalate ", " args + args = captures + ++ map (view argName) queryparams + ++ body + ++ map ("header"++) hs + ++ ["onSuccess", "onError"] + + captures = map captureArg + . filter isCapture + $ req ^. reqUrl.path + + hs = req ^. reqHeaders + + queryparams = req ^.. reqUrl.queryStr.traverse + + body = if req ^. reqBody + then ["body"] + else [] + + dataBody = + if req ^. reqBody + then "\n , data: JSON.stringify(body)\n" + else "" + + reqheaders = + if null hs + then "" + else "\n , headers: { " ++ headersStr ++ " } }\n" + + where headersStr = intercalate ", " $ map headerStr hs + headerStr hname = "\"" ++ hname ++ "\": header" ++ hname + + 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 --- /dev/null +++ b/src/Servant/JQuery/Internal.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant.JQuery.Internal where + +import Control.Lens +import Data.Monoid +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 = + "' + encodeURIComponent(" ++ 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) + +type HeaderArg = String + +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 + , _reqHeaders :: [HeaderArg] + , _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 = AjaxReq + + jqueryFor Proxy req = + req & funcName %~ ("delete" <>) + & reqMethod .~ "DELETE" + +instance HasJQ (Get a) where + type JQ (Get a) = AjaxReq + + jqueryFor Proxy req = + req & funcName %~ ("get" <>) + & reqMethod .~ "GET" + +instance (KnownSymbol sym, HasJQ sublayout) + => HasJQ (Header sym a :> sublayout) where + type JQ (Header sym a :> sublayout) = JQ sublayout + + jqueryFor Proxy req = + jqueryFor subP (req & reqHeaders <>~ [hname]) + + where hname = symbolVal (Proxy :: Proxy sym) + subP = Proxy :: Proxy sublayout + +instance HasJQ (Post a) where + type JQ (Post a) = AjaxReq + + jqueryFor Proxy req = + req & funcName %~ ("post" <>) + & reqMethod .~ "POST" + +instance HasJQ (Put a) where + type JQ (Put a) = AjaxReq + + jqueryFor Proxy req = + req & funcName %~ ("put" <>) + & 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 -> AjaxReq + + jqueryFor Proxy req method = + req & reqMethod .~ method + +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] + & funcName %~ (str <>) + + where str = symbolVal (Proxy :: Proxy path)