Extract common code-generation stuff to servant-foreign

servant-foreign/CHANGELOG.md

@@ -0,0 +1,4 @@
+0.1
+-----
+
+* 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,29 @@
+name:                servant-foreign
+version:             0.1.0.0
+synopsis:            Abstract all necessary info for client code-generation in arbitrary programming language.
+description:         Consolidates such projects as servant-js and lackey.
+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.8 && <5
+                     , charset
+                     , lens >= 4
+                     , servant >= 0.5
+                     , text
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  ghc-options:         -Wall

servant-foreign/src/Servant/Foreign.hs

@@ -0,0 +1,409 @@
+{-# LANGUAGE CPP                  #-}
+{-# LANGUAGE ConstraintKinds      #-}
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# 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
+  , CommonGeneratorOptions(..)
+  , defCommonGeneratorOptions
+  , toValidFunctionName
+  , 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 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
+
+-- | This structure is used by specific implementations to let you
+-- customize the output
+data CommonGeneratorOptions = CommonGeneratorOptions
+  {
+    functionNameBuilder :: FunctionName -> String  -- ^ function generating function names
+  , 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 foreign function (empty mean local var)
+  , urlPrefix :: String                  -- ^ a prefix we should add to the Url in the codegen
+  }
+
+-- | Default options.
+--
+-- @
+-- > defCommonGeneratorOptions = CommonGeneratorOptions
+-- >   { functionNameBuilder = camelCase
+-- >   , requestBody = "body"
+-- >   , successCallback = "onSuccess"
+-- >   , errorCallback = "onError"
+-- >   , moduleName = ""
+-- >   , urlPrefix = ""
+-- >   }
+-- @
+defCommonGeneratorOptions :: CommonGeneratorOptions
+defCommonGeneratorOptions = CommonGeneratorOptions
+  {
+    functionNameBuilder = camelCase
+  , requestBody = "body"
+  , successCallback = "onSuccess"
+  , errorCallback = "onError"
+  , moduleName = ""
+  , urlPrefix = ""
+  }
+
+-- | 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)
+
+
+-- | 
+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 @'Foreign'@.
+--
+-- Here we are making an assumption that js identifiers are common enough.
+-- https://mathiasbynens.be/notes/javascript-identifiers
+-- Couldn't work out how to handle zero-width characters.
+-- TODO: compare it with other generated languages(such as ruby via lackey)
+-- and generalize.
+-- 
+-- @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 || any (Set.member c) firstLetterOK
+    remainder c = prefixOK c || any (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]
+  } 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 []
+
+type family Elem (a :: *) (ls::[*]) :: Constraint where
+  Elem a '[] = 'False ~ 'True
+  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,12 @@ 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
-                     , charset
                      , lens >= 4
-                     , servant == 0.5.*
+                     , servant-foreign
-                     , text
   hs-source-dirs:      src
   default-language:    Haskell2010
   ghc-options:         -Wall
@@ -59,16 +57,16 @@ executable counter
   else
     buildable: False
 
-  build-depends:
+  build-depends:    aeson
-      aeson
+                  , base
-    , base
+                  , filepath
-    , filepath
+                  , lens >= 4
-    , servant == 0.5.*
+                  , servant
-    , servant-server == 0.5.*
+                  , servant-server
-    , servant-js == 0.5.*
+                  , servant-js
-    , stm
+                  , stm
-    , transformers
+                  , transformers
-    , warp
+                  , warp
   default-language: Haskell2010
 
 test-suite spec
@@ -76,12 +74,12 @@ test-suite spec
   hs-source-dirs:    test
   ghc-options:       -Wall
   main-is:           Spec.hs
-  build-depends:
+  build-depends:     base == 4.*
-      base == 4.*
+                   , hspec >= 2.1.8
-    , lens
+                   , hspec-expectations
-    , servant-js
+                   , language-ecmascript >= 0.16
-    , servant
+                   , lens
-    , hspec >= 2.1.8
+                   , lens >= 4
-    , hspec-expectations
+                   , servant
-    , language-ecmascript >= 0.16
+                   , servant-js
-  default-language: Haskell2010
+  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

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

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

@@ -1,206 +1,43 @@
-{-# LANGUAGE CPP                  #-}
+module Servant.JS.Internal
-{-# LANGUAGE ConstraintKinds      #-}
+  ( JavaScriptGenerator
-{-# LANGUAGE DataKinds            #-}
+  , AjaxReq
-{-# LANGUAGE FlexibleContexts     #-}
+  , jsSegments
-{-# LANGUAGE FlexibleInstances    #-}
+  , segmentToStr
-{-# LANGUAGE ScopedTypeVariables  #-}
+  , segmentTypeToStr
-{-# LANGUAGE TemplateHaskell      #-}
+  , jsParams
-{-# LANGUAGE TypeFamilies         #-}
+  , jsGParams
-{-# LANGUAGE TypeOperators        #-}
+  , jsMParams
-{-# LANGUAGE UndecidableInstances #-}
+  , paramToStr
-module Servant.JS.Internal where
+  -- re-exports
+  , (:<|>)(..)
+  , (:>)
+  , defReq
+  , defCommonGeneratorOptions
+  , reqHeaders
+  , CommonGeneratorOptions(..)
+  , 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 Servant.Foreign
-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
 
--- | this structure is used by JavaScriptGenerator implementations to let you
+type AjaxReq = Req
--- customize the output
-data CommonGeneratorOptions = CommonGeneratorOptions
-  {
-    functionNameBuilder :: FunctionName -> String  -- ^ function generating function names
-  , 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)
-  , urlPrefix :: String                  -- ^ a prefix we should add to the Url in the JS codegen
-  }
-
--- | Default options.
---
--- @
--- > defCommonGeneratorOptions = CommonGeneratorOptions
--- >   { functionNameBuilder = camelCase
--- >   , requestBody = "body"
--- >   , successCallback = "onSuccess"
--- >   , errorCallback = "onError"
--- >   , moduleName = ""
--- >   , urlPrefix = ""
--- >   }
--- @
-defCommonGeneratorOptions :: CommonGeneratorOptions
-defCommonGeneratorOptions = CommonGeneratorOptions
-  {
-    functionNameBuilder = camelCase
-  , requestBody = "body"
-  , successCallback = "onSuccess"
-  , errorCallback = "onError"
-  , moduleName = ""
-  , urlPrefix = ""
-  }
-
--- | 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
 
 -- 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
+type JavaScriptGenerator = [Req] -> 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
-        then c
-        else '_'
-    firstChar c = prefixOK c || any (Set.member c) firstLetterOK
-    remainder c = prefixOK c || any (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]
-  } 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 ''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 []  = ""
@@ -216,8 +53,8 @@ segmentTypeToStr (Static s) = s
 segmentTypeToStr (Cap s)    = "' + encodeURIComponent(" ++ s ++ ") + '"
 
 jsGParams :: String -> [QueryArg] -> String
-jsGParams _ []  = ""
+jsGParams _ []     = ""
-jsGParams _ [x] = paramToStr x False
+jsGParams _ [x]    = paramToStr x False
 jsGParams s (x:xs) = paramToStr x True ++ s ++ jsGParams s xs
 
 jsParams :: [QueryArg] -> String
@@ -234,191 +71,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

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

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.yaml

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