Merge pull request #232 from dredozubov/servant-foreign

Common code generation types and helpers extracted to servant-foreign

servant-foreign/CHANGELOG.md

@@ -0,0 +1,4 @@
+0.5
+-----
+
+* Extract javascript-oblivious types and helpers to *servant-foreign*

servant-foreign/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.

servant-foreign/README.md

@@ -0,0 +1,5 @@
+# servant-foreign
+
+![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
+
+Types and helpers for generating clients for *servant* servers in arbitrary programming languages.

servant-foreign/Setup.hs

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

servant-foreign/servant-foreign.cabal

@@ -0,0 +1,34 @@
+name:                servant-foreign
+version:             0.5
+synopsis:            Helpers for generating clients for servant APIs in any programming language
+description:
+  Helper types and functions for generating client functions for servant APIs in any programming language
+  .
+  This package provides types and functions that collect all the data needed to generate client functions in the programming language of your choice. This effectively means you only have to write the code that "pretty-prints" this data as some code in your target language.
+  .
+  See the servant-js package for an example
+  .
+  <https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md CHANGELOG>
+license:             BSD3
+license-file:        LICENSE
+author:              Denis Redozubov
+maintainer:          denis.redozubov@gmail.com
+copyright:           2015 Denis Redozubov, Alp Mestanogullari
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+extra-source-files:
+  CHANGELOG.md
+  README.md
+source-repository head
+  type: git
+  location: http://github.com/haskell-servant/servant.git
+
+library
+  exposed-modules:     Servant.Foreign
+  build-depends:       base    == 4.*
+                     , lens    == 4.*
+                     , servant == 0.5.*
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  ghc-options:         -Wall

servant-foreign/src/Servant/Foreign.hs

@@ -0,0 +1,323 @@
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NullaryTypeClasses    #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE UndecidableInstances  #-}
+
+-- | Generalizes all the data needed to make code generation work with
+-- arbitrary programming languages.
+module Servant.Foreign
+  ( HasForeign(..)
+  , Segment(..)
+  , SegmentType(..)
+  , MatrixArg
+  , FunctionName
+  , QueryArg(..)
+  , HeaderArg(..)
+  , ArgType(..)
+  , Req
+  , captureArg
+  , defReq
+  , concatCase
+  , snakeCase
+  , camelCase
+  -- lenses
+  , argType
+  , argName
+  , isCapture
+  , funcName
+  , path
+  , reqUrl
+  , reqBody
+  , reqHeaders
+  , reqMethod
+  , segment
+  , queryStr
+  -- re-exports
+  , module Servant.API
+  ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative
+#endif
+import Control.Lens hiding (List)
+import Data.Char (toLower, toUpper)
+import Data.List
+import Data.Proxy
+import GHC.Exts (Constraint)
+import GHC.TypeLits
+import Servant.API
+
+-- | Function name builder that simply concat each part together
+concatCase :: FunctionName -> String
+concatCase = concat
+
+-- | Function name builder using the snake_case convention.
+-- each part is separated by a single underscore character.
+snakeCase :: FunctionName -> String
+snakeCase = intercalate "_"
+
+-- | Function name builder using the CamelCase convention.
+-- each part begins with an upper case character.
+camelCase :: FunctionName -> String
+camelCase [] = ""
+camelCase (p:ps) = concat $ p : camelCase' ps
+   where camelCase' [] = []
+         camelCase' (r:rs) = capitalize r : camelCase' rs
+         capitalize [] = []
+         capitalize (x:xs) = toUpper x : xs
+
+type Arg = String
+
+data Segment = Segment { _segment :: SegmentType, _matrix :: [MatrixArg] }
+  deriving (Eq, Show)
+
+data SegmentType = Static String  -- ^ a static path segment. like "/foo"
+                 | Cap Arg        -- ^ a capture. like "/:userid"
+  deriving (Eq, Show)
+
+type Path = [Segment]
+
+data ArgType =
+    Normal
+  | Flag
+  | List
+  deriving (Eq, Show)
+
+data QueryArg = QueryArg
+  { _argName :: Arg
+  , _argType :: ArgType
+  } deriving (Eq, Show)
+
+data HeaderArg = HeaderArg
+    { headerArgName :: String
+    }
+  | ReplaceHeaderArg
+    { headerArgName :: String
+    , headerPattern :: String
+    } deriving (Eq, Show)
+
+
+type MatrixArg = QueryArg
+
+data Url = Url
+  { _path     :: Path
+  , _queryStr :: [QueryArg]
+  } deriving (Eq, Show)
+
+defUrl :: Url
+defUrl = Url [] []
+
+type FunctionName = [String]
+type Method = String
+
+data Req = Req
+  { _reqUrl     :: Url
+  , _reqMethod  :: Method
+  , _reqHeaders :: [HeaderArg]
+  , _reqBody    :: Bool
+  , _funcName   :: FunctionName
+  } deriving (Eq, Show)
+
+makeLenses ''QueryArg
+makeLenses ''Segment
+makeLenses ''Url
+makeLenses ''Req
+
+isCapture :: Segment -> Bool
+isCapture (Segment (Cap _) _) = True
+isCapture                  _  = False
+
+captureArg :: Segment -> Arg
+captureArg (Segment (Cap s) _) = s
+captureArg                  _  = error "captureArg called on non capture"
+
+defReq :: Req
+defReq = Req defUrl "GET" [] False []
+
+-- | To be used exclusively as a "negative" return type/constraint
+-- by @'Elem`@ type family.
+class NotFound
+
+type family Elem (a :: *) (ls::[*]) :: Constraint where
+  Elem a '[]         = NotFound
+  Elem a (a ': list) = ()
+  Elem a (b ': list) = Elem a list
+
+class HasForeign (layout :: *) where
+  type Foreign layout :: *
+  foreignFor :: Proxy layout -> Req -> Foreign layout
+
+instance (HasForeign a, HasForeign b)
+      => HasForeign (a :<|> b) where
+  type Foreign (a :<|> b) = Foreign a :<|> Foreign b
+
+  foreignFor Proxy req =
+         foreignFor (Proxy :: Proxy a) req
+    :<|> foreignFor (Proxy :: Proxy b) req
+
+instance (KnownSymbol sym, HasForeign sublayout)
+      => HasForeign (Capture sym a :> sublayout) where
+  type Foreign (Capture sym a :> sublayout) = Foreign sublayout
+
+  foreignFor Proxy req =
+    foreignFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.path <>~ [Segment (Cap str) []]
+          & funcName %~ (++ ["by", str])
+
+    where str = symbolVal (Proxy :: Proxy sym)
+
+instance Elem JSON list => HasForeign (Delete list a) where
+  type Foreign (Delete list a) = Req
+
+  foreignFor Proxy req =
+    req & funcName  %~ ("delete" :)
+        & reqMethod .~ "DELETE"
+
+instance Elem JSON list => HasForeign (Get list a) where
+  type Foreign (Get list a) = Req
+
+  foreignFor Proxy req =
+    req & funcName  %~ ("get" :)
+        & reqMethod .~ "GET"
+
+instance (KnownSymbol sym, HasForeign sublayout)
+      => HasForeign (Header sym a :> sublayout) where
+  type Foreign (Header sym a :> sublayout) = Foreign sublayout
+
+  foreignFor Proxy req =
+    foreignFor subP (req & reqHeaders <>~ [HeaderArg hname])
+
+    where hname = symbolVal (Proxy :: Proxy sym)
+          subP = Proxy :: Proxy sublayout
+
+instance Elem JSON list => HasForeign (Post list a) where
+  type Foreign (Post list a) = Req
+
+  foreignFor Proxy req =
+    req & funcName  %~ ("post" :)
+        & reqMethod .~ "POST"
+
+instance Elem JSON list => HasForeign (Put list a) where
+  type Foreign (Put list a) = Req
+
+  foreignFor Proxy req =
+    req & funcName  %~ ("put" :)
+        & reqMethod .~ "PUT"
+
+instance (KnownSymbol sym, HasForeign sublayout)
+      => HasForeign (QueryParam sym a :> sublayout) where
+  type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout
+
+  foreignFor Proxy req =
+    foreignFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.queryStr <>~ [QueryArg str Normal]
+
+    where str = symbolVal (Proxy :: Proxy sym)
+
+instance (KnownSymbol sym, HasForeign sublayout)
+      => HasForeign (QueryParams sym a :> sublayout) where
+  type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout
+
+  foreignFor Proxy req =
+    foreignFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.queryStr <>~ [QueryArg str List]
+
+    where str = symbolVal (Proxy :: Proxy sym)
+
+instance (KnownSymbol sym, HasForeign sublayout)
+      => HasForeign (QueryFlag sym :> sublayout) where
+  type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout
+
+  foreignFor Proxy req =
+    foreignFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.queryStr <>~ [QueryArg str Flag]
+
+    where str = symbolVal (Proxy :: Proxy sym)
+
+instance (KnownSymbol sym, HasForeign sublayout)
+      => HasForeign (MatrixParam sym a :> sublayout) where
+  type Foreign (MatrixParam sym a :> sublayout) = Foreign sublayout
+
+  foreignFor Proxy req =
+    foreignFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.path._last.matrix <>~ [QueryArg strArg Normal]
+
+    where str = symbolVal (Proxy :: Proxy sym)
+          strArg = str ++ "Value"
+
+instance (KnownSymbol sym, HasForeign sublayout)
+      => HasForeign (MatrixParams sym a :> sublayout) where
+  type Foreign (MatrixParams sym a :> sublayout) = Foreign sublayout
+
+  foreignFor Proxy req =
+    foreignFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.path._last.matrix  <>~ [QueryArg str List]
+
+    where str = symbolVal (Proxy :: Proxy sym)
+
+instance (KnownSymbol sym, HasForeign sublayout)
+      => HasForeign (MatrixFlag sym :> sublayout) where
+  type Foreign (MatrixFlag sym :> sublayout) = Foreign sublayout
+
+  foreignFor Proxy req =
+    foreignFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.path._last.matrix  <>~ [QueryArg str Flag]
+
+    where str = symbolVal (Proxy :: Proxy sym)
+
+instance HasForeign Raw where
+  type Foreign Raw = Method -> Req
+
+  foreignFor Proxy req method =
+    req & funcName %~ ((toLower <$> method) :)
+        & reqMethod .~ method
+
+instance (Elem JSON list, HasForeign sublayout) => HasForeign (ReqBody list a :> sublayout) where
+  type Foreign (ReqBody list a :> sublayout) = Foreign sublayout
+
+  foreignFor Proxy req =
+    foreignFor (Proxy :: Proxy sublayout) $
+      req & reqBody .~ True
+
+instance (KnownSymbol path, HasForeign sublayout)
+      => HasForeign (path :> sublayout) where
+  type Foreign (path :> sublayout) = Foreign sublayout
+
+  foreignFor Proxy req =
+    foreignFor (Proxy :: Proxy sublayout) $
+      req & reqUrl.path <>~ [Segment (Static str) []]
+          & funcName %~ (++ [str])
+
+    where str = map (\c -> if c == '.' then '_' else c) $ symbolVal (Proxy :: Proxy path)
+
+instance HasForeign sublayout => HasForeign (RemoteHost :> sublayout) where
+  type Foreign (RemoteHost :> sublayout) = Foreign sublayout
+
+  foreignFor Proxy req =
+    foreignFor (Proxy :: Proxy sublayout) req
+
+instance HasForeign sublayout => HasForeign (IsSecure :> sublayout) where
+  type Foreign (IsSecure :> sublayout) = Foreign sublayout
+
+  foreignFor Proxy req =
+    foreignFor (Proxy :: Proxy sublayout) req
+
+instance HasForeign sublayout => HasForeign (Vault :> sublayout) where
+  type Foreign (Vault :> sublayout) = Foreign sublayout
+
+  foreignFor Proxy req =
+    foreignFor (Proxy :: Proxy sublayout) req
+
+instance HasForeign sublayout => HasForeign (HttpVersion :> sublayout) where
+  type Foreign (HttpVersion :> sublayout) = Foreign sublayout
+
+  foreignFor Proxy req =
+    foreignFor (Proxy :: Proxy sublayout) req

servant-js/servant-js.cabal

@@ -37,14 +37,15 @@ library
   exposed-modules:     Servant.JS
                        Servant.JS.Angular
                        Servant.JS.Axios
+                       Servant.JS.Internal
                        Servant.JS.JQuery
                        Servant.JS.Vanilla
-                       Servant.JS.Internal
+  build-depends:       base            >= 4.5 && <5
-  build-depends:       base >=4.5 && <5
+                     , charset         >= 0.3
-                     , charset
                      , lens            >= 4
-                     , servant == 0.5.*
+                     , servant-foreign == 0.5.*
-                     , text
+                     , text            >= 1.2  && < 1.3
+
   hs-source-dirs:      src
   default-language:    Haskell2010
   ghc-options:         -Wall
@@ -59,13 +60,13 @@ executable counter
   else
     buildable: False
 
-  build-depends:
+  build-depends:    base             >= 4.7 && < 5
-      aeson
+                  , aeson            >= 0.7  && < 0.11
-    , base
+                  , filepath         >= 1
-    , filepath
+                  , lens             >= 4
                   , servant          == 0.5.*
                   , servant-server   == 0.5.*
-    , servant-js == 0.5.*
+                  , servant-js
                   , stm
                   , transformers
                   , warp
@@ -76,12 +77,12 @@ test-suite spec
   hs-source-dirs:    test
   ghc-options:       -Wall
   main-is:           Spec.hs
-  build-depends:
+  build-depends:     base
-      base == 4.*
-    , lens
-    , servant-js
-    , servant
                    , hspec >= 2.1.8
                    , hspec-expectations
                    , language-ecmascript >= 0.16
+                   , lens
+                   , servant
+                   , servant-js
+                   , text
   default-language:  Haskell2010

servant-js/src/Servant/JS.hs

@@ -76,7 +76,7 @@ module Servant.JS
   , JavaScriptGenerator
 
   , -- * Options common to all generators
-    CommonGeneratorOptions(..)
+    CommonGeneratorOptions
   , defCommonGeneratorOptions
 
   , -- * Function renamers
@@ -109,13 +109,10 @@ module Servant.JS
   , -- * Misc.
     listFromAPI
   , javascript
-  , HasJS(..)
   , GenerateList(..)
-  , AjaxReq
   ) where
 
 import           Data.Proxy
-import           Servant.API
 import           Servant.JS.Angular
 import           Servant.JS.Axios
 import           Servant.JS.Internal
@@ -125,13 +122,13 @@ import           Servant.JS.Vanilla
 -- | Generate the data necessary to generate javascript code
 --   for all the endpoints of an API, as ':<|>'-separated values
 --   of type 'AjaxReq'.
-javascript :: HasJS layout => Proxy layout -> JS layout
+javascript :: HasForeign layout => Proxy layout -> Foreign layout
-javascript p = javascriptFor p defReq
+javascript p = foreignFor p defReq
 
 -- | 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 :: (HasJS api, GenerateList (JS api))
+jsForAPI :: (HasForeign api, GenerateList (Foreign api))
          => Proxy api -- ^ proxy for your API type
          -> JavaScriptGenerator -- ^ js code generator to use (angular, vanilla js, jquery, others)
          -> String              -- ^ a string that you can embed in your pages or write to a file
@@ -140,7 +137,7 @@ jsForAPI p gen = gen (listFromAPI p)
 -- | Directly generate all the javascript functions for your API
 --   from a 'Proxy' for your API type using the given generator
 --   and write the resulting code to a file at the given path.
-writeJSForAPI :: (HasJS api, GenerateList (JS api))
+writeJSForAPI :: (HasForeign api, GenerateList (Foreign api))
               => Proxy api -- ^ proxy for your API type
               -> JavaScriptGenerator -- ^ js code generator to use (angular, vanilla js, jquery, others)
               -> FilePath -- ^ path to the file you want to write the resulting javascript code into
@@ -161,5 +158,6 @@ instance (GenerateList start, GenerateList rest) => GenerateList (start :<|> res
 
 -- | Generate the necessary data for JS codegen as a list, each 'AjaxReq'
 --   describing one endpoint from your API type.
-listFromAPI :: (HasJS api, GenerateList (JS api)) => Proxy api -> [AjaxReq]
+listFromAPI :: (HasForeign api, GenerateList (Foreign api)) => Proxy api -> [AjaxReq]
 listFromAPI p = generateList (javascript p)
+

servant-js/src/Servant/JS/Angular.hs

@@ -3,6 +3,7 @@ module Servant.JS.Angular where
 import           Control.Lens
 import           Data.List
 import           Data.Monoid
+import           Servant.Foreign
 import           Servant.JS.Internal
 
 -- | Options specific to the angular code generator
@@ -108,7 +109,7 @@ generateAngularJSWith ngOptions opts req = "\n" <>
           where headersStr = intercalate ", " $ map headerStr hs
                 headerStr header = "\"" ++
                   headerArgName header ++
-                  "\": " ++ show header
+                  "\": " ++ toJSHeader header
 
         namespace =
             if hasService

servant-js/src/Servant/JS/Axios.hs

@@ -4,6 +4,7 @@ import           Control.Lens
 import           Data.Char           (toLower)
 import           Data.List
 import           Data.Monoid
+import           Servant.Foreign
 import           Servant.JS.Internal
 
 -- | Axios 'configuration' type
@@ -103,7 +104,7 @@ generateAxiosJSWith aopts opts req = "\n" <>
           where headersStr = intercalate ", " $ map headerStr hs
                 headerStr header = "\"" ++
                   headerArgName header ++
-                  "\": " ++ show header
+                  "\": " ++ toJSHeader header
 
         namespace =
                if hasNoModule

servant-js/src/Servant/JS/Internal.hs

@@ -1,31 +1,52 @@
-{-# LANGUAGE CPP                  #-}
+module Servant.JS.Internal
-{-# LANGUAGE ConstraintKinds      #-}
+  ( JavaScriptGenerator
-{-# LANGUAGE DataKinds            #-}
+  , CommonGeneratorOptions(..)
-{-# LANGUAGE FlexibleContexts     #-}
+  , defCommonGeneratorOptions
-{-# LANGUAGE FlexibleInstances    #-}
+  , AjaxReq
-{-# LANGUAGE ScopedTypeVariables  #-}
+  , jsSegments
-{-# LANGUAGE TemplateHaskell      #-}
+  , segmentToStr
-{-# LANGUAGE TypeFamilies         #-}
+  , segmentTypeToStr
-{-# LANGUAGE TypeOperators        #-}
+  , jsParams
-{-# LANGUAGE UndecidableInstances #-}
+  , jsGParams
-module Servant.JS.Internal where
+  , jsMParams
+  , paramToStr
+  , toValidFunctionName
+  , toJSHeader
+  -- re-exports
+  , (:<|>)(..)
+  , (:>)
+  , defReq
+  , reqHeaders
+  , HasForeign(..)
+  , HeaderArg(..)
+  , concatCase
+  , snakeCase
+  , camelCase
+  , ReqBody
+  , JSON
+  , FormUrlEncoded
+  , Post
+  , Get
+  , Raw
+  , Header
+  ) where 
 
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
 import           Control.Lens hiding (List)
-import Data.Char (toLower, toUpper)
 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           Servant.Foreign
-import GHC.TypeLits
-import Servant.API
 
--- | this structure is used by JavaScriptGenerator implementations to let you
+type AjaxReq = Req
+
+-- A 'JavascriptGenerator' just takes the data found in the API type
+-- for each endpoint and generates Javascript code in a String. Several
+-- generators are available in this package.
+type JavaScriptGenerator = [Req] -> String
+
+-- | This structure is used by specific implementations to let you
 -- customize the output
 data CommonGeneratorOptions = CommonGeneratorOptions
   {
@@ -33,8 +54,8 @@ data CommonGeneratorOptions = CommonGeneratorOptions
   , requestBody :: String                -- ^ name used when a user want to send the request body (to let you redefine it)
   , successCallback :: String            -- ^ name of the callback parameter when the request was successful
   , errorCallback :: String              -- ^ name of the callback parameter when the request reported an error
-  , moduleName :: String                 -- ^ namespace on which we define the js function (empty mean local var)
+  , moduleName :: String                 -- ^ namespace on which we define the foreign function (empty mean local var)
-  , urlPrefix :: String                  -- ^ a prefix we should add to the Url in the JS codegen
+  , urlPrefix :: String                  -- ^ a prefix we should add to the Url in the codegen
   }
 
 -- | Default options.
@@ -60,87 +81,16 @@ defCommonGeneratorOptions = CommonGeneratorOptions
   , urlPrefix = ""
   }
 
--- | Function name builder that simply concat each part together
+-- | Attempts to reduce the function name provided to that allowed by @'Foreign'@.
-concatCase :: FunctionName -> String
+--
-concatCase = concat
-
--- | Function name builder using the snake_case convention.
--- each part is separated by a single underscore character.
-snakeCase :: FunctionName -> String
-snakeCase = intercalate "_"
-
--- | Function name builder using the CamelCase convention.
--- each part begins with an upper case character.
-camelCase :: FunctionName -> String
-camelCase [] = ""
-camelCase (p:ps) = concat $ p : camelCase' ps
-   where camelCase' [] = []
-         camelCase' (r:rs) = capitalize r : camelCase' rs
-         capitalize [] = []
-         capitalize (x:xs) = toUpper x : xs
-
-type Arg = String
-
--- A 'JavascriptGenerator' just takes the data found in the API type
--- for each endpoint and generates Javascript code in a String. Several
--- generators are available in this package.
-type JavaScriptGenerator = [AjaxReq] -> String
-
-data Segment = Segment { _segment :: SegmentType, _matrix :: [MatrixArg] }
-  deriving (Eq, Show)
-
-data SegmentType = Static String  -- ^ a static path segment. like "/foo"
-                 | Cap Arg        -- ^ a capture. like "/:userid"
-  deriving (Eq, Show)
-
-type Path = [Segment]
-
-data ArgType =
-    Normal
-  | Flag
-  | List
-  deriving (Eq, Show)
-
-data QueryArg = QueryArg
-  { _argName :: Arg
-  , _argType :: ArgType
-  } deriving (Eq, Show)
-
-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
+    setFirstChar c = if firstChar c then c else '_'
-        then c
-        else '_'
     firstChar c = prefixOK c || any (Set.member c) firstLetterOK
     remainder c = prefixOK c || any (Set.member c) remainderOK
     -- Valid prefixes
@@ -152,55 +102,29 @@ toValidFunctionName (x:xs) = [setFirstChar x] <> filter remainder xs
                     , Set.modifierLetter
                     , Set.otherLetter
                     , Set.letterNumber ]
-    remainderOK   = firstLetterOK <> [ Set.nonSpacingMark
+    remainderOK   = firstLetterOK
+               <> [ Set.nonSpacingMark
                   , Set.spacingCombiningMark
                   , Set.decimalNumber
                   , Set.connectorPunctuation ]
 toValidFunctionName [] = "_"
 
-type MatrixArg = QueryArg
+toJSHeader :: HeaderArg -> String
-
+toJSHeader (HeaderArg n)          = toValidFunctionName ("header" <> n)
-data Url = Url
+toJSHeader (ReplaceHeaderArg n p)
-  { _path     :: Path
+  | pn `isPrefixOf` p = pv <> " + \"" <> rp <> "\""
-  , _queryStr :: [QueryArg]
+  | pn `isSuffixOf` p = "\"" <> rp <> "\" + " <> pv
-  } deriving (Eq, Show)
+  | pn `isInfixOf` p  = "\"" <> (replace pn ("\" + " <> pv <> " + \"") p)
-
+                             <> "\""
-defUrl :: Url
+  | otherwise         = p
-defUrl = Url [] []
+  where
-
+    pv = toValidFunctionName ("header" <> n)
-type FunctionName = [String]
+    pn = "{" <> n <> "}"
-type Method = String
+    rp = replace pn "" p
-
+    -- Use replace method from Data.Text
-data AjaxReq = AjaxReq
+    replace old new = T.unpack
-  { _reqUrl     :: Url
+                    . T.replace (T.pack old) (T.pack new)
-  , _reqMethod  :: Method
+                    . T.pack
-  , _reqHeaders :: [HeaderArg]
-  , _reqBody    :: Bool
-  , _funcName   :: FunctionName
-  } 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 []  = ""
@@ -234,191 +158,9 @@ paramToStr qarg notTheEnd =
            ++ "=' + 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 []
-
-type family Elem (a :: *) (ls::[*]) :: Constraint where
-  Elem a '[] = 'False ~ 'True
-  Elem a (a ': list) = ()
-  Elem a (b ': list) = Elem a list
-
-class HasJS (layout :: *) where
-  type JS layout :: *
-  javascriptFor :: Proxy layout -> AjaxReq -> JS layout
-
-instance (HasJS a, HasJS b)
-      => HasJS (a :<|> b) where
-  type JS (a :<|> b) = JS a :<|> JS b
-
-  javascriptFor Proxy req =
-         javascriptFor (Proxy :: Proxy a) req
-    :<|> javascriptFor (Proxy :: Proxy b) req
-
-instance (KnownSymbol sym, HasJS sublayout)
-      => HasJS (Capture sym a :> sublayout) where
-  type JS (Capture sym a :> sublayout) = JS sublayout
-
-  javascriptFor Proxy req =
-    javascriptFor (Proxy :: Proxy sublayout) $
-      req & reqUrl.path <>~ [Segment (Cap str) []]
-          & funcName %~ (++ ["by", str])
-
-    where str = symbolVal (Proxy :: Proxy sym)
-
-instance Elem JSON list => HasJS (Delete list a) where
-  type JS (Delete list a) = AjaxReq
-
-  javascriptFor Proxy req =
-    req & funcName  %~ ("delete" :)
-        & reqMethod .~ "DELETE"
-
-instance Elem JSON list => HasJS (Get list a) where
-  type JS (Get list a) = AjaxReq
-
-  javascriptFor Proxy req =
-    req & funcName  %~ ("get" :)
-        & reqMethod .~ "GET"
-
-instance (KnownSymbol sym, HasJS sublayout)
-      => HasJS (Header sym a :> sublayout) where
-  type JS (Header sym a :> sublayout) = JS sublayout
-
-  javascriptFor Proxy req =
-    javascriptFor subP (req & reqHeaders <>~ [HeaderArg hname])
-
-    where hname = symbolVal (Proxy :: Proxy sym)
-          subP = Proxy :: Proxy sublayout
-
-instance Elem JSON list => HasJS (Post list a) where
-  type JS (Post list a) = AjaxReq
-
-  javascriptFor Proxy req =
-    req & funcName  %~ ("post" :)
-        & reqMethod .~ "POST"
-
-instance Elem JSON list => HasJS (Put list a) where
-  type JS (Put list a) = AjaxReq
-
-  javascriptFor Proxy req =
-    req & funcName  %~ ("put" :)
-        & reqMethod .~ "PUT"
-
-instance (KnownSymbol sym, HasJS sublayout)
-      => HasJS (QueryParam sym a :> sublayout) where
-  type JS (QueryParam sym a :> sublayout) = JS sublayout
-
-  javascriptFor Proxy req =
-    javascriptFor (Proxy :: Proxy sublayout) $
-      req & reqUrl.queryStr <>~ [QueryArg str Normal]
-
-    where str = symbolVal (Proxy :: Proxy sym)
-
-instance (KnownSymbol sym, HasJS sublayout)
-      => HasJS (QueryParams sym a :> sublayout) where
-  type JS (QueryParams sym a :> sublayout) = JS sublayout
-
-  javascriptFor Proxy req =
-    javascriptFor (Proxy :: Proxy sublayout) $
-      req & reqUrl.queryStr <>~ [QueryArg str List]
-
-    where str = symbolVal (Proxy :: Proxy sym)
-
-instance (KnownSymbol sym, HasJS sublayout)
-      => HasJS (QueryFlag sym :> sublayout) where
-  type JS (QueryFlag sym :> sublayout) = JS sublayout
-
-  javascriptFor Proxy req =
-    javascriptFor (Proxy :: Proxy sublayout) $
-      req & reqUrl.queryStr <>~ [QueryArg str Flag]
-
-    where str = symbolVal (Proxy :: Proxy sym)
-
-instance (KnownSymbol sym, HasJS sublayout)
-      => HasJS (MatrixParam sym a :> sublayout) where
-  type JS (MatrixParam sym a :> sublayout) = JS sublayout
-
-  javascriptFor Proxy req =
-    javascriptFor (Proxy :: Proxy sublayout) $
-      req & reqUrl.path._last.matrix <>~ [QueryArg strArg Normal]
-
-    where str = symbolVal (Proxy :: Proxy sym)
-          strArg = str ++ "Value"
-
-instance (KnownSymbol sym, HasJS sublayout)
-      => HasJS (MatrixParams sym a :> sublayout) where
-  type JS (MatrixParams sym a :> sublayout) = JS sublayout
-
-  javascriptFor Proxy req =
-    javascriptFor (Proxy :: Proxy sublayout) $
-      req & reqUrl.path._last.matrix  <>~ [QueryArg str List]
-
-    where str = symbolVal (Proxy :: Proxy sym)
-
-instance (KnownSymbol sym, HasJS sublayout)
-      => HasJS (MatrixFlag sym :> sublayout) where
-  type JS (MatrixFlag sym :> sublayout) = JS sublayout
-
-  javascriptFor Proxy req =
-    javascriptFor (Proxy :: Proxy sublayout) $
-      req & reqUrl.path._last.matrix  <>~ [QueryArg str Flag]
-
-    where str = symbolVal (Proxy :: Proxy sym)
-
-instance HasJS Raw where
-  type JS Raw = Method -> AjaxReq
-
-  javascriptFor Proxy req method =
-    req & funcName %~ ((toLower <$> method) :)
-        & reqMethod .~ method
-
-instance (Elem JSON list, HasJS sublayout) => HasJS (ReqBody list a :> sublayout) where
-  type JS (ReqBody list a :> sublayout) = JS sublayout
-
-  javascriptFor Proxy req =
-    javascriptFor (Proxy :: Proxy sublayout) $
-      req & reqBody .~ True
-
-instance (KnownSymbol path, HasJS sublayout)
-      => HasJS (path :> sublayout) where
-  type JS (path :> sublayout) = JS sublayout
-
-  javascriptFor Proxy req =
-    javascriptFor (Proxy :: Proxy sublayout) $
-      req & reqUrl.path <>~ [Segment (Static str) []]
-          & funcName %~ (++ [str])
-
-    where str = map (\c -> if c == '.' then '_' else c) $ symbolVal (Proxy :: Proxy path)
-
-instance HasJS sublayout => HasJS (RemoteHost :> sublayout) where
-  type JS (RemoteHost :> sublayout) = JS sublayout
-
-  javascriptFor Proxy req =
-    javascriptFor (Proxy :: Proxy sublayout) req
-
-instance HasJS sublayout => HasJS (IsSecure :> sublayout) where
-  type JS (IsSecure :> sublayout) = JS sublayout
-
-  javascriptFor Proxy req =
-    javascriptFor (Proxy :: Proxy sublayout) req
-
-instance HasJS sublayout => HasJS (Vault :> sublayout) where
-  type JS (Vault :> sublayout) = JS sublayout
-
-  javascriptFor Proxy req =
-    javascriptFor (Proxy :: Proxy sublayout) req
-
-instance HasJS sublayout => HasJS (HttpVersion :> sublayout) where
-  type JS (HttpVersion :> sublayout) = JS sublayout
-
-  javascriptFor Proxy req =
-    javascriptFor (Proxy :: Proxy sublayout) req

servant-js/src/Servant/JS/JQuery.hs

@@ -3,6 +3,7 @@ module Servant.JS.JQuery where
 import           Control.Lens
 import           Data.List
 import           Data.Monoid
+import           Servant.Foreign
 import           Servant.JS.Internal
 
 -- | Generate javascript functions that use the /jQuery/ library
@@ -71,7 +72,7 @@ generateJQueryJSWith opts req = "\n" <>
           where headersStr = intercalate ", " $ map headerStr hs
                 headerStr header = "\"" ++
                   headerArgName header ++
-                  "\": " ++ show header
+                  "\": " ++ toJSHeader header
 
         namespace = if null (moduleName opts)
                        then "var "

servant-js/src/Servant/JS/Vanilla.hs

@@ -3,6 +3,7 @@ module Servant.JS.Vanilla where
 import           Control.Lens
 import           Data.List
 import           Data.Monoid
+import           Servant.Foreign
 import           Servant.JS.Internal
 
 -- | Generate vanilla javascript functions to make AJAX requests
@@ -78,7 +79,7 @@ generateVanillaJSWith opts req = "\n" <>
           where headersStr = intercalate "\n" $ map headerStr hs
                 headerStr header = "  xhr.setRequestHeader(\"" ++
                   headerArgName header ++
-                  "\", " ++ show header ++ ");"
+                  "\", " ++ toJSHeader header ++ ");"
 
         namespace = if null (moduleName opts)
                        then "var "

servant-js/test/Servant/JSSpec.hs

@@ -12,8 +12,8 @@ import           Data.Proxy
 import           Language.ECMAScript3.Parser  (parseFromString)
 import           Test.Hspec
 
-import           Servant.API
 import           Servant.JS
+import           Servant.JS.Internal
 import qualified Servant.JS.Angular           as NG
 import qualified Servant.JS.Axios             as AX
 import qualified Servant.JS.JQuery            as JQ
@@ -75,7 +75,7 @@ spec = describe "Servant.JQuery" $ do
     generateJSSpec Angular       (NG.generateAngularJS NG.defAngularOptions)
     generateJSSpec AngularCustom (NG.generateAngularJSWith NG.defAngularOptions customOptions)
     generateJSSpec Axios        (AX.generateAxiosJS AX.defAxiosOptions)
-    generateJSSpec AxiosCustom  (AX.generateAxiosJSWith (AX.defAxiosOptions { withCredentials = True }) customOptions)
+    generateJSSpec AxiosCustom  (AX.generateAxiosJSWith (AX.defAxiosOptions { AX.withCredentials = True }) customOptions)
 
     angularSpec    Angular
     axiosSpec

servant-js/test/Servant/JSSpec/CustomHeaders.hs

@@ -12,8 +12,6 @@ import           Control.Lens
 import           Data.Monoid
 import           Data.Proxy
 import           GHC.TypeLits
-import           Servant.API
-import           Servant.JS
 import           Servant.JS.Internal
 
 -- | This is a hypothetical combinator that fetches an Authorization header.
@@ -21,11 +19,11 @@ import           Servant.JS.Internal
 -- using -- Basic, Digest, whatever.
 data Authorization (sym :: Symbol) a
 
-instance (KnownSymbol sym, HasJS sublayout)
+instance (KnownSymbol sym, HasForeign sublayout)
-    => HasJS (Authorization sym a :> sublayout) where
+    => HasForeign (Authorization sym a :> sublayout) where
-    type JS (Authorization sym a :> sublayout) = JS sublayout
+    type Foreign (Authorization sym a :> sublayout) = Foreign sublayout
 
-    javascriptFor Proxy req = javascriptFor (Proxy :: Proxy sublayout) $
+    foreignFor Proxy req = foreignFor (Proxy :: Proxy sublayout) $
         req & reqHeaders <>~ [ ReplaceHeaderArg "Authorization" $
                                tokenType (symbolVal (Proxy :: Proxy sym)) ]
       where
@@ -34,11 +32,11 @@ instance (KnownSymbol sym, HasJS sublayout)
 -- | This is a combinator that fetches an X-MyLovelyHorse header.
 data MyLovelyHorse a
 
-instance (HasJS sublayout)
+instance (HasForeign sublayout)
-    => HasJS (MyLovelyHorse a :> sublayout) where
+    => HasForeign (MyLovelyHorse a :> sublayout) where
-    type JS (MyLovelyHorse a :> sublayout) = JS sublayout
+    type Foreign (MyLovelyHorse a :> sublayout) = Foreign sublayout
 
-    javascriptFor Proxy req = javascriptFor (Proxy :: Proxy sublayout) $
+    foreignFor Proxy req = foreignFor (Proxy :: Proxy sublayout) $
         req & reqHeaders <>~ [ ReplaceHeaderArg "X-MyLovelyHorse" tpl ]
       where
         tpl = "I am good friends with {X-MyLovelyHorse}"
@@ -46,11 +44,11 @@ instance (HasJS sublayout)
 -- | This is a combinator that fetches an X-WhatsForDinner header.
 data WhatsForDinner a
 
-instance (HasJS sublayout)
+instance (HasForeign sublayout)
-    => HasJS (WhatsForDinner a :> sublayout) where
+    => HasForeign (WhatsForDinner a :> sublayout) where
-    type JS (WhatsForDinner a :> sublayout) = JS sublayout
+    type Foreign (WhatsForDinner a :> sublayout) = Foreign sublayout
 
-    javascriptFor Proxy req = javascriptFor (Proxy :: Proxy sublayout) $
+    foreignFor Proxy req = foreignFor (Proxy :: Proxy sublayout) $
         req & reqHeaders <>~ [ ReplaceHeaderArg "X-WhatsForDinner" tpl ]
       where
         tpl = "I would like {X-WhatsForDinner} with a cherry on top."

sources.txt

@@ -2,6 +2,7 @@ servant
 servant-cassava
 servant-client
 servant-docs
+servant-foreign
 servant-js
 servant-server
 servant-examples

stack-ghc-7.8.4.yaml

@@ -6,6 +6,7 @@ packages:
 - servant-client/
 - servant-lucid/
 - servant-mock/
+- servant-foreign/
 - servant-js/
 - servant/
 - servant-server/

stack.yaml

@@ -8,6 +8,7 @@ packages:
 - servant-client/
 - servant-docs/
 - servant-examples/
+- servant-foreign/
 - servant-js/
 - servant-lucid/
 - servant-mock/