eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Verb for -mock, -js and -foreign.

Browse source
This commit is contained in:
Julian K. Arni 2016-01-06 18:20:20 +01:00
parent 208bcf5986
commit bd77b4acba
8 changed files with 38 additions and 74 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
servant-foreign/servant-foreign.cabal
View file

@ -27,10 +27,11 @@ source-repository head
library
exposed-modules: Servant.Foreign, Servant.Foreign.Internal
build-depends: base == 4.*
, lens == 4.*
, servant == 0.5.*
, text >= 1.2 && < 1.3
build-depends: base == 4.*
, lens == 4.*
, servant == 0.5.*
, text >= 1.2 && < 1.3
, http-types
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
@ -41,6 +42,7 @@ test-suite spec
type: exitcode-stdio-1.0
hs-source-dirs: test
ghc-options: -Wall
include-dirs: include
main-is: Spec.hs
other-modules:
Servant.ForeignSpec

66
servant-foreign/src/Servant/Foreign/Internal.hs
View file

@ -13,18 +13,21 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
-- | Generalizes all the data needed to make code generation work with
-- arbitrary programming languages.
module Servant.Foreign.Internal where
import Control.Lens (makeLenses, (%~), (&), (.~), (<>~))
import qualified Data.Char as C
import Control.Lens (makeLenses, (%~), (&), (.~), (<>~))
import qualified Data.Char as C
import Data.Proxy
import Data.Text
import GHC.Exts (Constraint)
import Data.Text.Encoding (decodeUtf8)
import GHC.Exts (Constraint)
import GHC.TypeLits
import Prelude hiding (concat)
import qualified Network.HTTP.Types as HTTP
import Prelude hiding (concat)
import Servant.API
-- | Function name builder that simply concat each part together
@ -86,11 +89,10 @@ defUrl :: Url
defUrl = Url [] []
type FunctionName = [Text]
type Method = Text
data Req = Req
{ _reqUrl :: Url
, _reqMethod :: Method
, _reqMethod :: HTTP.Method
, _reqHeaders :: [HeaderArg]
, _reqBody :: Maybe ForeignType
, _reqReturnType :: ForeignType
@ -185,27 +187,18 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (str, typeFor lang (Proxy :: Proxy a))
instance (Elem JSON list, HasForeignType lang a)
=> HasForeign lang (Delete list a) where
type Foreign (Delete list a) = Req
instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)
=> HasForeign lang (Verb method status list a) where
type Foreign (Verb method status list a) = Req
foreignFor lang Proxy req =
req & funcName %~ ("delete" :)
& reqMethod .~ "DELETE"
req & funcName %~ (methodLC :)
& reqMethod .~ method
& reqReturnType .~ retType
where
retType = typeFor lang (Proxy :: Proxy a)
instance (Elem JSON list, HasForeignType lang a)
=> HasForeign lang (Get list a) where
type Foreign (Get list a) = Req
foreignFor lang Proxy req =
req & funcName %~ ("get" :)
& reqMethod .~ "GET"
& reqReturnType .~ retType
where
retType = typeFor lang (Proxy :: Proxy a)
retType = typeFor lang (Proxy :: Proxy a)
method = reflectMethod (Proxy :: Proxy method)
methodLC = toLower $ decodeUtf8 method
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
=> HasForeign lang (Header sym a :> sublayout) where
@ -220,28 +213,6 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
arg = (hname, typeFor lang (Proxy :: Proxy a))
subP = Proxy :: Proxy sublayout
instance (Elem JSON list, HasForeignType lang a)
=> HasForeign lang (Post list a) where
type Foreign (Post list a) = Req
foreignFor lang Proxy req =
req & funcName %~ ("post" :)
& reqMethod .~ "POST"
& reqReturnType .~ retType
where
retType = typeFor lang (Proxy :: Proxy a)
instance (Elem JSON list, HasForeignType lang a)
=> HasForeign lang (Put list a) where
type Foreign (Put list a) = Req
foreignFor lang Proxy req =
req & funcName %~ ("put" :)
& reqMethod .~ "PUT"
& reqReturnType .~ retType
where
retType = typeFor lang (Proxy :: Proxy a)
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
=> HasForeign lang (QueryParam sym a :> sublayout) where
type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout
@ -279,10 +250,10 @@ instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang subl
arg = (str, typeFor lang (Proxy :: Proxy a))
instance HasForeign lang Raw where
type Foreign Raw = Method -> Req
type Foreign Raw = HTTP.Method -> Req
foreignFor _ Proxy req method =
req & funcName %~ ((toLower method) :)
req & funcName %~ ((toLower $ decodeUtf8 method) :)
& reqMethod .~ method
instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout)
@ -346,4 +317,3 @@ instance (GenerateList start, GenerateList rest) => GenerateList (start :<|> res
-- describing one endpoint from your API type.
listFromAPI :: (HasForeign lang api, GenerateList (Foreign api)) => Proxy lang -> Proxy api -> [Req]
listFromAPI lang p = generateList (foreignFor lang p defReq)

9
servant-foreign/test/Servant/ForeignSpec.hs
View file

@ -7,9 +7,8 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#endif
#include "overlapping-compat.h"
module Servant.ForeignSpec where
@ -41,9 +40,9 @@ instance HasForeignType LangX Int where
typeFor _ _ = "intX"
instance HasForeignType LangX Bool where
typeFor _ _ = "boolX"
instance {-# Overlapping #-} HasForeignType LangX String where
instance OVERLAPPING_ HasForeignType LangX String where
typeFor _ _ = "stringX"
instance {-# Overlappable #-} HasForeignType LangX a => HasForeignType LangX [a] where
instance OVERLAPPABLE_ HasForeignType LangX a => HasForeignType LangX [a] where
typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a)
type TestApi

3
servant-js/src/Servant/JS/Angular.hs
View file

@ -6,6 +6,7 @@ import Data.Maybe (isJust)
import Data.Monoid
import qualified Data.Text as T
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Servant.Foreign
import Servant.JS.Internal
@ -68,7 +69,7 @@ generateAngularJSWith ngOptions opts req = "\n" <>
<> " { url: " <> url <> "\n"
<> dataBody
<> reqheaders
<> " , method: '" <> method <> "'\n"
<> " , method: '" <> decodeUtf8 method <> "'\n"
<> " });\n"
<> "}\n"

3
servant-js/src/Servant/JS/Axios.hs
View file

@ -5,6 +5,7 @@ import Control.Lens
import Data.Maybe (isJust)
import Data.Monoid
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text as T
import Servant.Foreign
import Servant.JS.Internal
@ -117,7 +118,7 @@ generateAxiosJSWith aopts opts req = "\n" <>
fname = namespace <> (functionNameBuilder opts $ req ^. funcName)
method = T.toLower $ req ^. reqMethod
method = T.toLower . decodeUtf8 $ req ^. reqMethod
url = if url' == "'" then "'/'" else url'
url' = "'"
<> urlPrefix opts

3
servant-js/src/Servant/JS/JQuery.hs
View file

@ -6,6 +6,7 @@ import Data.Maybe (isJust)
import Data.Monoid
import qualified Data.Text as T
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Servant.Foreign
import Servant.JS.Internal
@ -35,7 +36,7 @@ generateJQueryJSWith opts req = "\n" <>
<> dataBody
<> reqheaders
<> " , error: " <> onError <> "\n"
<> " , type: '" <> method <> "'\n"
<> " , type: '" <> decodeUtf8 method <> "'\n"
<> " });\n"
<> "}\n"

3
servant-js/src/Servant/JS/Vanilla.hs
View file

@ -4,6 +4,7 @@ module Servant.JS.Vanilla where
import Control.Lens
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text as T
import Data.Monoid
import Servant.Foreign
@ -31,7 +32,7 @@ generateVanillaJSWith opts req = "\n" <>
fname <> " = function(" <> argsStr <> ")\n"
<> "{\n"
<> " var xhr = new XMLHttpRequest();\n"
<> " xhr.open('" <> method <> "', " <> url <> ", true);\n"
<> " xhr.open('" <> decodeUtf8 method <> "', " <> url <> ", true);\n"
<> reqheaders
<> " xhr.setRequestHeader(\"Accept\",\"application/json\");\n"
<> (if isJust (req ^. reqBody) then " xhr.setRequestHeader(\"Content-Type\",\"application/json\");\n" else "")

15
servant-mock/src/Servant/Mock.hs
View file

@ -139,19 +139,8 @@ instance (KnownSymbol s, HasMock rest) => HasMock (QueryFlag s :> rest) where
instance (KnownSymbol h, FromHttpApiData a, HasMock rest) => HasMock (Header h a :> rest) where
mock _ = \_ -> mock (Proxy :: Proxy rest)
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Delete ctypes a) where
mock _ = mockArbitrary
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Get ctypes a) where
mock _ = mockArbitrary
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Patch ctypes a) where
mock _ = mockArbitrary
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Post ctypes a) where
mock _ = mockArbitrary
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Put ctypes a) where
instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
=> HasMock (Verb method status ctypes a) where
mock _ = mockArbitrary
instance HasMock Raw where