first shot for jquery codegen based on a servant API type

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.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

TODO.md

@@ -0,0 +1 @@
+- Investigate the best way to offer cross-origin requests

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"
+                ]

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

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 <alpmestan@gmail.com>
+-- 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

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)