From bd77b4acba4a81608827bad72ac70e93cb13271c Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 6 Jan 2016 18:20:20 +0100 Subject: [PATCH] Verb for -mock, -js and -foreign. --- servant-foreign/servant-foreign.cabal | 10 +-- .../src/Servant/Foreign/Internal.hs | 66 +++++-------------- servant-foreign/test/Servant/ForeignSpec.hs | 9 ++- servant-js/src/Servant/JS/Angular.hs | 3 +- servant-js/src/Servant/JS/Axios.hs | 3 +- servant-js/src/Servant/JS/JQuery.hs | 3 +- servant-js/src/Servant/JS/Vanilla.hs | 3 +- servant-mock/src/Servant/Mock.hs | 15 +---- 8 files changed, 38 insertions(+), 74 deletions(-) diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index be1f2696..ca92b43a 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -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 diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 27f0e411..ae199202 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -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) - diff --git a/servant-foreign/test/Servant/ForeignSpec.hs b/servant-foreign/test/Servant/ForeignSpec.hs index a5bad431..06e722cc 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -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 diff --git a/servant-js/src/Servant/JS/Angular.hs b/servant-js/src/Servant/JS/Angular.hs index 2f1b42fb..8530b03f 100644 --- a/servant-js/src/Servant/JS/Angular.hs +++ b/servant-js/src/Servant/JS/Angular.hs @@ -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" diff --git a/servant-js/src/Servant/JS/Axios.hs b/servant-js/src/Servant/JS/Axios.hs index 50bed9eb..25e92df3 100644 --- a/servant-js/src/Servant/JS/Axios.hs +++ b/servant-js/src/Servant/JS/Axios.hs @@ -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 diff --git a/servant-js/src/Servant/JS/JQuery.hs b/servant-js/src/Servant/JS/JQuery.hs index 722d9c07..71147006 100644 --- a/servant-js/src/Servant/JS/JQuery.hs +++ b/servant-js/src/Servant/JS/JQuery.hs @@ -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" diff --git a/servant-js/src/Servant/JS/Vanilla.hs b/servant-js/src/Servant/JS/Vanilla.hs index ea390e2f..f623e2a6 100644 --- a/servant-js/src/Servant/JS/Vanilla.hs +++ b/servant-js/src/Servant/JS/Vanilla.hs @@ -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 "") diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index 3fa5d077..e4437fba 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -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