From a15d1d931451125770928de79dc676b647220985 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Sun, 27 Dec 2015 14:05:32 +0100 Subject: [PATCH 001/180] Fix 294 --- servant-js/src/Servant/JS/Vanilla.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/servant-js/src/Servant/JS/Vanilla.hs b/servant-js/src/Servant/JS/Vanilla.hs index 22b29b4c..0179f16f 100644 --- a/servant-js/src/Servant/JS/Vanilla.hs +++ b/servant-js/src/Servant/JS/Vanilla.hs @@ -37,10 +37,13 @@ generateVanillaJSWith opts req = "\n" <> <> (if isJust (req ^. reqBody) then " xhr.setRequestHeader(\"Content-Type\",\"application/json\");\n" else "") <> " xhr.onreadystatechange = function (e) {\n" <> " if (xhr.readyState == 4) {\n" + <> " if (xhr.status == 204) {\n" + <> " onSuccess();\n" + <> " } else if (xhr.status >= 200 && xhr.status < 300) {\n" <> " var value = JSON.parse(xhr.responseText);\n" - <> " if (xhr.status == 200 || xhr.status == 201) {\n" <> " onSuccess(value);\n" <> " } else {\n" + <> " var value = JSON.parse(xhr.responseText);\n" <> " onError(value);\n" <> " }\n" <> " }\n" From 82fa23507f9475791e6a19f68ff0320755ee4be9 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Sun, 27 Dec 2015 17:23:46 +0100 Subject: [PATCH 002/180] Add 205 --- servant-js/src/Servant/JS/Vanilla.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-js/src/Servant/JS/Vanilla.hs b/servant-js/src/Servant/JS/Vanilla.hs index 0179f16f..ea390e2f 100644 --- a/servant-js/src/Servant/JS/Vanilla.hs +++ b/servant-js/src/Servant/JS/Vanilla.hs @@ -37,7 +37,7 @@ generateVanillaJSWith opts req = "\n" <> <> (if isJust (req ^. reqBody) then " xhr.setRequestHeader(\"Content-Type\",\"application/json\");\n" else "") <> " xhr.onreadystatechange = function (e) {\n" <> " if (xhr.readyState == 4) {\n" - <> " if (xhr.status == 204) {\n" + <> " if (xhr.status == 204 || xhr.status == 205) {\n" <> " onSuccess();\n" <> " } else if (xhr.status >= 200 && xhr.status < 300) {\n" <> " var value = JSON.parse(xhr.responseText);\n" From e7c90849171a5bf32cb635e6bee451dd9ef95386 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 27 Dec 2015 17:54:29 +0100 Subject: [PATCH 003/180] less OverlappingInstances noise --- servant-blaze/include/overlapping-compat.h | 8 ++ servant-blaze/servant-blaze.cabal | 1 + servant-blaze/src/Servant/HTML/Blaze.hs | 16 +--- servant-cassava/include/overlapping-compat.h | 8 ++ servant-cassava/servant-cassava.cabal | 1 + servant-client/include/overlapping-compat.h | 8 ++ servant-client/servant-client.cabal | 1 + servant-client/src/Servant/Client.hs | 80 ++++--------------- servant-client/test/Servant/ClientSpec.hs | 24 ++---- servant-docs/include/overlapping-compat.h | 8 ++ servant-docs/servant-docs.cabal | 1 + servant-docs/src/Servant/Docs/Internal.hs | 50 +++--------- servant-examples/include/overlapping-compat.h | 8 ++ servant-foreign/include/overlapping-compat.h | 8 ++ servant-foreign/servant-foreign.cabal | 1 + servant-jquery/include/overlapping-compat.h | 8 ++ servant-js/include/overlapping-compat.h | 8 ++ servant-js/servant-js.cabal | 1 + servant-lucid/include/overlapping-compat.h | 8 ++ servant-lucid/servant-lucid.cabal | 1 + servant-lucid/src/Servant/HTML/Lucid.hs | 15 +--- servant-mock/include/overlapping-compat.h | 8 ++ servant-mock/servant-mock.cabal | 1 + servant-property/include/overlapping-compat.h | 8 ++ servant-server/include/overlapping-compat.h | 8 ++ servant-server/servant-server.cabal | 2 + servant-server/src/Servant/Server/Internal.hs | 80 ++++--------------- servant-session/include/overlapping-compat.h | 8 ++ servant/include/overlapping-compat.h | 8 ++ servant/servant.cabal | 2 + servant/src/Servant/API/ResponseHeaders.hs | 65 ++++----------- 31 files changed, 197 insertions(+), 257 deletions(-) create mode 100644 servant-blaze/include/overlapping-compat.h create mode 100644 servant-cassava/include/overlapping-compat.h create mode 100644 servant-client/include/overlapping-compat.h create mode 100644 servant-docs/include/overlapping-compat.h create mode 100644 servant-examples/include/overlapping-compat.h create mode 100644 servant-foreign/include/overlapping-compat.h create mode 100644 servant-jquery/include/overlapping-compat.h create mode 100644 servant-js/include/overlapping-compat.h create mode 100644 servant-lucid/include/overlapping-compat.h create mode 100644 servant-mock/include/overlapping-compat.h create mode 100644 servant-property/include/overlapping-compat.h create mode 100644 servant-server/include/overlapping-compat.h create mode 100644 servant-session/include/overlapping-compat.h create mode 100644 servant/include/overlapping-compat.h diff --git a/servant-blaze/include/overlapping-compat.h b/servant-blaze/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-blaze/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal index 08b27e24..a82076f6 100644 --- a/servant-blaze/servant-blaze.cabal +++ b/servant-blaze/servant-blaze.cabal @@ -30,3 +30,4 @@ library , blaze-html hs-source-dirs: src default-language: Haskell2010 + include-dirs: include diff --git a/servant-blaze/src/Servant/HTML/Blaze.hs b/servant-blaze/src/Servant/HTML/Blaze.hs index 7870022d..822a7ae9 100644 --- a/servant-blaze/src/Servant/HTML/Blaze.hs +++ b/servant-blaze/src/Servant/HTML/Blaze.hs @@ -3,10 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif +#include "overlapping-compat.h" -- | An @HTML@ empty data type with `MimeRender` instances for @blaze-html@'s -- `ToMarkup` class and `Html` datatype. -- You should only need to import this module for it's instances and the @@ -29,17 +27,9 @@ data HTML deriving Typeable instance Accept HTML where contentType _ = "text" M.// "html" M./: ("charset", "utf-8") -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ToMarkup a => MimeRender HTML a where +instance OVERLAPPABLE_ ToMarkup a => MimeRender HTML a where mimeRender _ = renderHtml . toHtml -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - MimeRender HTML Html where +instance OVERLAPPING_ MimeRender HTML Html where mimeRender _ = renderHtml diff --git a/servant-cassava/include/overlapping-compat.h b/servant-cassava/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-cassava/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal index 4d74612a..db18986c 100644 --- a/servant-cassava/servant-cassava.cabal +++ b/servant-cassava/servant-cassava.cabal @@ -27,3 +27,4 @@ library , vector hs-source-dirs: src default-language: Haskell2010 + include-dirs: include diff --git a/servant-client/include/overlapping-compat.h b/servant-client/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-client/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 7fe69521..1ddf8bf4 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -49,6 +49,7 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include test-suite spec type: exitcode-stdio-1.0 diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 987a2bd4..408850ca 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -8,9 +8,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" -- | This module provides 'client' which can automatically generate -- querying functions for each endpoint just from the type representing your -- API. @@ -123,19 +122,13 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where type Client (Delete cts' a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasClient (Delete cts ()) where type Client (Delete cts ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = @@ -143,10 +136,7 @@ instance -- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts) ) => HasClient (Delete cts' (Headers ls a)) where type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a) @@ -160,19 +150,13 @@ instance -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where type Client (Get (ct ': cts) result) = ExceptT ServantError IO result clientWithRoute Proxy req baseurl manager = snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasClient (Get (ct ': cts) ()) where type Client (Get (ct ': cts) ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = @@ -180,10 +164,7 @@ instance -- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( MimeUnrender ct a, BuildHeadersTo ls ) => HasClient (Get (ct ': cts) (Headers ls a)) where type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) @@ -240,19 +221,13 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where type Client (Post (ct ': cts) a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasClient (Post (ct ': cts) ()) where type Client (Post (ct ': cts) ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = @@ -260,10 +235,7 @@ instance -- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( MimeUnrender ct a, BuildHeadersTo ls ) => HasClient (Post (ct ': cts) (Headers ls a)) where type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) @@ -277,19 +249,13 @@ instance -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where type Client (Put (ct ': cts) a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasClient (Put (ct ': cts) ()) where type Client (Put (ct ': cts) ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = @@ -297,10 +263,7 @@ instance -- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( MimeUnrender ct a, BuildHeadersTo ls ) => HasClient (Put (ct ': cts) (Headers ls a)) where type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) @@ -314,19 +277,13 @@ instance -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasClient (Patch (ct ': cts) ()) where type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = @@ -334,10 +291,7 @@ instance -- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( MimeUnrender ct a, BuildHeadersTo ls ) => HasClient (Patch (ct ': cts) (Headers ls a)) where type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index fc3cdcfb..b1980d1a 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -6,9 +6,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} @@ -20,6 +17,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} +#include "overlapping-compat.h" module Servant.ClientSpec where #if !MIN_VERSION_base(4,8,0) @@ -323,33 +321,21 @@ pathGen = fmap NonEmpty path class GetNth (n :: Nat) a b | n a -> b where getNth :: Proxy n -> a -> b -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ GetNth 0 (x :<|> y) x where getNth _ (x :<|> _) = x -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x class GetLast a b | a -> b where getLast :: a -> b -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ (GetLast b c) => GetLast (a :<|> b) c where getLast (_ :<|> b) = getLast b -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ GetLast a a where getLast a = a diff --git a/servant-docs/include/overlapping-compat.h b/servant-docs/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-docs/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index b88bc612..7bd34a7a 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -49,6 +49,7 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include executable greet-docs main-is: greet.hs diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 33cb86a0..c1d26142 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -16,9 +16,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" module Servant.Docs.Internal where import Control.Applicative @@ -661,10 +660,7 @@ markdown api = unlines $ -- | The generated docs for @a ':<|>' b@ just appends the docs -- for @a@ with the docs for @b@. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (HasDocs layout1, HasDocs layout2) => HasDocs (layout1 :<|> layout2) where @@ -692,10 +688,7 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout) symP = Proxy :: Proxy sym -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLe #-} -#endif +instance OVERLAPPABLE_ (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Delete cts a) where docsFor Proxy (endpoint, action) DocOptions{..} = @@ -707,10 +700,7 @@ instance t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ (ToSample a, IsNonEmpty cts, AllMimeRender cts a , AllHeaderSamples ls , GetHeaders (HList ls) ) => HasDocs (Delete cts (Headers ls a)) where @@ -725,10 +715,7 @@ instance t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLe #-} -#endif +instance OVERLAPPABLE_ (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Get cts a) where docsFor Proxy (endpoint, action) DocOptions{..} = @@ -740,10 +727,7 @@ instance t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ (ToSample a, IsNonEmpty cts, AllMimeRender cts a , AllHeaderSamples ls , GetHeaders (HList ls) ) => HasDocs (Get cts (Headers ls a)) where @@ -767,10 +751,7 @@ instance (KnownSymbol sym, HasDocs sublayout) action' = over headers (|> headername) action headername = pack $ symbolVal (Proxy :: Proxy sym) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Post cts a) where docsFor Proxy (endpoint, action) DocOptions{..} = @@ -783,10 +764,7 @@ instance t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ (ToSample a, IsNonEmpty cts, AllMimeRender cts a , AllHeaderSamples ls , GetHeaders (HList ls) ) => HasDocs (Post cts (Headers ls a)) where @@ -802,10 +780,7 @@ instance t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Put cts a) where docsFor Proxy (endpoint, action) DocOptions{..} = @@ -818,10 +793,7 @@ instance t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( ToSample a, IsNonEmpty cts, AllMimeRender cts a, AllHeaderSamples ls , GetHeaders (HList ls) ) => HasDocs (Put cts (Headers ls a)) where diff --git a/servant-examples/include/overlapping-compat.h b/servant-examples/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-examples/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-foreign/include/overlapping-compat.h b/servant-foreign/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-foreign/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 0ec296ae..d565b636 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -33,6 +33,7 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include test-suite spec diff --git a/servant-jquery/include/overlapping-compat.h b/servant-jquery/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-jquery/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-js/include/overlapping-compat.h b/servant-js/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-js/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index 53a74e9d..a47ecd34 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -49,6 +49,7 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include executable counter main-is: counter.hs diff --git a/servant-lucid/include/overlapping-compat.h b/servant-lucid/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-lucid/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal index 77cf3ee1..e4438f42 100644 --- a/servant-lucid/servant-lucid.cabal +++ b/servant-lucid/servant-lucid.cabal @@ -30,3 +30,4 @@ library , servant == 0.5.* hs-source-dirs: src default-language: Haskell2010 + include-dirs: include diff --git a/servant-lucid/src/Servant/HTML/Lucid.hs b/servant-lucid/src/Servant/HTML/Lucid.hs index f222c6ac..ec62a21c 100644 --- a/servant-lucid/src/Servant/HTML/Lucid.hs +++ b/servant-lucid/src/Servant/HTML/Lucid.hs @@ -3,9 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" -- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s -- `ToHtml` class and `Html` datatype. @@ -28,16 +27,10 @@ data HTML deriving Typeable instance Accept HTML where contentType _ = "text" M.// "html" M./: ("charset", "utf-8") -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ToHtml a => MimeRender HTML a where mimeRender _ = renderBS . toHtml -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ MimeRender HTML (Html a) where mimeRender _ = renderBS diff --git a/servant-mock/include/overlapping-compat.h b/servant-mock/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-mock/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 0bb605db..66f41f22 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -34,6 +34,7 @@ library wai >= 3.0 && <3.1 hs-source-dirs: src default-language: Haskell2010 + include-dirs: include executable mock-app main-is: main.hs diff --git a/servant-property/include/overlapping-compat.h b/servant-property/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-property/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-server/include/overlapping-compat.h b/servant-server/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-server/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 7e36387e..a2e1463b 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -69,6 +69,7 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include executable greet main-is: greet.hs @@ -134,3 +135,4 @@ test-suite doctests buildable: True default-language: Haskell2010 ghc-options: -threaded + include-dirs: include diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 4200d052..48aed938 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -8,9 +8,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" module Servant.Server.Internal ( module Servant.Server.Internal @@ -206,10 +205,7 @@ methodRouterEmpty method action = LeafRouter route' -- to be returned. You can use 'Control.Monad.Trans.Except.throwE' to -- painlessly error out if the conditions for a successful deletion -- are not met. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ( AllCTRender ctypes a ) => HasServer (Delete ctypes a) where @@ -217,10 +213,7 @@ instance route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200 -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasServer (Delete ctypes ()) where type ServerT (Delete ctypes ()) m = m () @@ -228,10 +221,7 @@ instance route Proxy = methodRouterEmpty methodDelete -- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( GetHeaders (Headers h v), AllCTRender ctypes v ) => HasServer (Delete ctypes (Headers h v)) where @@ -252,10 +242,7 @@ instance -- (returning a status code of 200). If there was no @Accept@ header or it -- was @*\/\*@, we return encode using the first @Content-Type@ type on the -- list. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where type ServerT (Get ctypes a) m = m a @@ -263,10 +250,7 @@ instance route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200 -- '()' ==> 204 No Content -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasServer (Get ctypes ()) where type ServerT (Get ctypes ()) m = m () @@ -274,10 +258,7 @@ instance route Proxy = methodRouterEmpty methodGet -- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( GetHeaders (Headers h v), AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where @@ -329,10 +310,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) -- (returning a status code of 201). If there was no @Accept@ header or it -- was @*\/\*@, we return encode using the first @Content-Type@ type on the -- list. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ( AllCTRender ctypes a ) => HasServer (Post ctypes a) where @@ -340,10 +318,7 @@ instance route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201 -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasServer (Post ctypes ()) where type ServerT (Post ctypes ()) m = m () @@ -351,10 +326,7 @@ instance route Proxy = methodRouterEmpty methodPost -- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( GetHeaders (Headers h v), AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where @@ -375,20 +347,14 @@ instance -- (returning a status code of 200). If there was no @Accept@ header or it -- was @*\/\*@, we return encode using the first @Content-Type@ type on the -- list. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ( AllCTRender ctypes a) => HasServer (Put ctypes a) where type ServerT (Put ctypes a) m = m a route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200 -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasServer (Put ctypes ()) where type ServerT (Put ctypes ()) m = m () @@ -396,10 +362,7 @@ instance route Proxy = methodRouterEmpty methodPut -- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( GetHeaders (Headers h v), AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where @@ -418,20 +381,14 @@ instance -- If successfully returning a value, we just require that its type has -- a 'ToJSON' instance and servant takes care of encoding it for you, -- yielding status code 200 along the way. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where type ServerT (Patch ctypes a) m = m a route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200 -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasServer (Patch ctypes ()) where type ServerT (Patch ctypes ()) m = m () @@ -439,10 +396,7 @@ instance route Proxy = methodRouterEmpty methodPatch -- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( GetHeaders (Headers h v), AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where diff --git a/servant-session/include/overlapping-compat.h b/servant-session/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-session/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant/include/overlapping-compat.h b/servant/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant/servant.cabal b/servant/servant.cabal index f717eab3..99455ab9 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -81,6 +81,7 @@ library , TypeSynonymInstances , UndecidableInstances ghc-options: -Wall + include-dirs: include test-suite spec type: exitcode-stdio-1.0 @@ -118,3 +119,4 @@ test-suite doctests buildable: True default-language: Haskell2010 ghc-options: -threaded + include-dirs: include diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index 1fcbd035..dc73a8e0 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -12,11 +12,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif {-# OPTIONS_HADDOCK not-home #-} +#include "overlapping-compat.h" -- | This module provides facilities for adding headers to a response. -- -- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int @@ -68,19 +66,12 @@ class BuildHeadersTo hs where -- the values are interspersed with commas before deserialization (see -- ) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - BuildHeadersTo '[] where +instance OVERLAPPING_ BuildHeadersTo '[] where buildHeadersTo _ = HNil -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( FromByteString v, BuildHeadersTo xs, KnownSymbol h, Contains h xs ~ 'False - ) => BuildHeadersTo ((Header h v) ': xs) where +instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h + , Contains h xs ~ 'False) + => BuildHeadersTo ((Header h v) ': xs) where buildHeadersTo headers = let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers @@ -96,38 +87,22 @@ instance class GetHeaders ls where getHeaders :: ls -> [HTTP.Header] -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - GetHeaders (HList '[]) where +instance OVERLAPPING_ GetHeaders (HList '[]) where getHeaders _ = [] -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( KnownSymbol h, ToByteString x, GetHeaders (HList xs) - ) => GetHeaders (HList (Header h x ': xs)) where +instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs)) + => GetHeaders (HList (Header h x ': xs)) where getHeaders hdrs = case hdrs of Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest UndecodableHeader h `HCons` rest -> (headerName, h) : getHeaders rest MissingHeader `HCons` rest -> getHeaders rest where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - GetHeaders (Headers '[] a) where +instance OVERLAPPING_ GetHeaders (Headers '[] a) where getHeaders _ = [] -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( KnownSymbol h, GetHeaders (HList rest), ToByteString v - ) => GetHeaders (Headers (Header h v ': rest) a) where +instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v) + => GetHeaders (Headers (Header h v ': rest) a) where getHeaders hs = getHeaders $ getHeadersHList hs -- * Adding @@ -138,21 +113,13 @@ class AddHeader h v orig new addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False - ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where +instance OVERLAPPING_ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False) + => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( KnownSymbol h, ToByteString v - , new ~ (Headers '[Header h v] a) - ) => AddHeader h v a new where +instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v + , new ~ (Headers '[Header h v] a)) + => AddHeader h v a new where addHeader a resp = Headers resp (HCons (Header a) HNil) type family Contains x xs where From a4a0f1988b74d3eed09686b7ac8946eba02f669d Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 4 Jan 2016 17:21:14 +0100 Subject: [PATCH 004/180] Bump wai and warp upper bound to < 3.3. --- servant-mock/servant-mock.cabal | 2 +- servant-server/servant-server.cabal | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 0bb605db..14455c99 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -31,7 +31,7 @@ library servant-server >= 0.4, transformers >= 0.3 && <0.5, QuickCheck >= 2.7 && <2.9, - wai >= 3.0 && <3.1 + wai >= 3.0 && <3.3 hs-source-dirs: src default-language: Haskell2010 diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 7e36387e..ff2fb200 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -62,9 +62,9 @@ library , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.5 , transformers-compat>= 0.4 - , wai >= 3.0 && < 3.1 + , wai >= 3.0 && < 3.3 , wai-app-static >= 3.0 && < 3.2 - , warp >= 3.0 && < 3.2 + , warp >= 3.0 && < 3.3 hs-source-dirs: src default-language: Haskell2010 From 79d4f944a4f34bb5e80cd460d976373354404195 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 27 Dec 2015 17:54:29 +0100 Subject: [PATCH 005/180] less OverlappingInstances noise --- servant-blaze/include/overlapping-compat.h | 8 ++ servant-blaze/servant-blaze.cabal | 1 + servant-blaze/src/Servant/HTML/Blaze.hs | 16 +--- servant-cassava/include/overlapping-compat.h | 8 ++ servant-cassava/servant-cassava.cabal | 1 + servant-client/include/overlapping-compat.h | 8 ++ servant-client/servant-client.cabal | 1 + servant-client/src/Servant/Client.hs | 80 ++++--------------- servant-client/test/Servant/ClientSpec.hs | 24 ++---- servant-docs/include/overlapping-compat.h | 8 ++ servant-docs/servant-docs.cabal | 1 + servant-docs/src/Servant/Docs/Internal.hs | 50 +++--------- servant-examples/include/overlapping-compat.h | 8 ++ servant-foreign/include/overlapping-compat.h | 8 ++ servant-foreign/servant-foreign.cabal | 1 + servant-jquery/include/overlapping-compat.h | 8 ++ servant-js/include/overlapping-compat.h | 8 ++ servant-js/servant-js.cabal | 1 + servant-lucid/include/overlapping-compat.h | 8 ++ servant-lucid/servant-lucid.cabal | 1 + servant-lucid/src/Servant/HTML/Lucid.hs | 15 +--- servant-mock/include/overlapping-compat.h | 8 ++ servant-mock/servant-mock.cabal | 1 + servant-property/include/overlapping-compat.h | 8 ++ servant-server/include/overlapping-compat.h | 8 ++ servant-server/servant-server.cabal | 2 + servant-server/src/Servant/Server/Internal.hs | 80 ++++--------------- servant-server/test/Doctests.hs | 2 +- servant-session/include/overlapping-compat.h | 8 ++ servant/include/overlapping-compat.h | 8 ++ servant/servant.cabal | 2 + servant/src/Servant/API/ResponseHeaders.hs | 65 ++++----------- servant/test/Doctests.hs | 2 +- 33 files changed, 199 insertions(+), 259 deletions(-) create mode 100644 servant-blaze/include/overlapping-compat.h create mode 100644 servant-cassava/include/overlapping-compat.h create mode 100644 servant-client/include/overlapping-compat.h create mode 100644 servant-docs/include/overlapping-compat.h create mode 100644 servant-examples/include/overlapping-compat.h create mode 100644 servant-foreign/include/overlapping-compat.h create mode 100644 servant-jquery/include/overlapping-compat.h create mode 100644 servant-js/include/overlapping-compat.h create mode 100644 servant-lucid/include/overlapping-compat.h create mode 100644 servant-mock/include/overlapping-compat.h create mode 100644 servant-property/include/overlapping-compat.h create mode 100644 servant-server/include/overlapping-compat.h create mode 100644 servant-session/include/overlapping-compat.h create mode 100644 servant/include/overlapping-compat.h diff --git a/servant-blaze/include/overlapping-compat.h b/servant-blaze/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-blaze/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal index 08b27e24..a82076f6 100644 --- a/servant-blaze/servant-blaze.cabal +++ b/servant-blaze/servant-blaze.cabal @@ -30,3 +30,4 @@ library , blaze-html hs-source-dirs: src default-language: Haskell2010 + include-dirs: include diff --git a/servant-blaze/src/Servant/HTML/Blaze.hs b/servant-blaze/src/Servant/HTML/Blaze.hs index 7870022d..822a7ae9 100644 --- a/servant-blaze/src/Servant/HTML/Blaze.hs +++ b/servant-blaze/src/Servant/HTML/Blaze.hs @@ -3,10 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif +#include "overlapping-compat.h" -- | An @HTML@ empty data type with `MimeRender` instances for @blaze-html@'s -- `ToMarkup` class and `Html` datatype. -- You should only need to import this module for it's instances and the @@ -29,17 +27,9 @@ data HTML deriving Typeable instance Accept HTML where contentType _ = "text" M.// "html" M./: ("charset", "utf-8") -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ToMarkup a => MimeRender HTML a where +instance OVERLAPPABLE_ ToMarkup a => MimeRender HTML a where mimeRender _ = renderHtml . toHtml -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - MimeRender HTML Html where +instance OVERLAPPING_ MimeRender HTML Html where mimeRender _ = renderHtml diff --git a/servant-cassava/include/overlapping-compat.h b/servant-cassava/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-cassava/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal index 4d74612a..db18986c 100644 --- a/servant-cassava/servant-cassava.cabal +++ b/servant-cassava/servant-cassava.cabal @@ -27,3 +27,4 @@ library , vector hs-source-dirs: src default-language: Haskell2010 + include-dirs: include diff --git a/servant-client/include/overlapping-compat.h b/servant-client/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-client/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 7fe69521..1ddf8bf4 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -49,6 +49,7 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include test-suite spec type: exitcode-stdio-1.0 diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 987a2bd4..408850ca 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -8,9 +8,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" -- | This module provides 'client' which can automatically generate -- querying functions for each endpoint just from the type representing your -- API. @@ -123,19 +122,13 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where type Client (Delete cts' a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasClient (Delete cts ()) where type Client (Delete cts ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = @@ -143,10 +136,7 @@ instance -- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts) ) => HasClient (Delete cts' (Headers ls a)) where type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a) @@ -160,19 +150,13 @@ instance -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where type Client (Get (ct ': cts) result) = ExceptT ServantError IO result clientWithRoute Proxy req baseurl manager = snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasClient (Get (ct ': cts) ()) where type Client (Get (ct ': cts) ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = @@ -180,10 +164,7 @@ instance -- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( MimeUnrender ct a, BuildHeadersTo ls ) => HasClient (Get (ct ': cts) (Headers ls a)) where type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) @@ -240,19 +221,13 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where type Client (Post (ct ': cts) a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasClient (Post (ct ': cts) ()) where type Client (Post (ct ': cts) ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = @@ -260,10 +235,7 @@ instance -- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( MimeUnrender ct a, BuildHeadersTo ls ) => HasClient (Post (ct ': cts) (Headers ls a)) where type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) @@ -277,19 +249,13 @@ instance -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where type Client (Put (ct ': cts) a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasClient (Put (ct ': cts) ()) where type Client (Put (ct ': cts) ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = @@ -297,10 +263,7 @@ instance -- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( MimeUnrender ct a, BuildHeadersTo ls ) => HasClient (Put (ct ': cts) (Headers ls a)) where type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) @@ -314,19 +277,13 @@ instance -- side querying function that is created when calling 'client' -- will just require an argument that specifies the scheme, host -- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasClient (Patch (ct ': cts) ()) where type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = @@ -334,10 +291,7 @@ instance -- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the -- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( MimeUnrender ct a, BuildHeadersTo ls ) => HasClient (Patch (ct ': cts) (Headers ls a)) where type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index fc3cdcfb..b1980d1a 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -6,9 +6,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} @@ -20,6 +17,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} +#include "overlapping-compat.h" module Servant.ClientSpec where #if !MIN_VERSION_base(4,8,0) @@ -323,33 +321,21 @@ pathGen = fmap NonEmpty path class GetNth (n :: Nat) a b | n a -> b where getNth :: Proxy n -> a -> b -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ GetNth 0 (x :<|> y) x where getNth _ (x :<|> _) = x -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x class GetLast a b | a -> b where getLast :: a -> b -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ (GetLast b c) => GetLast (a :<|> b) c where getLast (_ :<|> b) = getLast b -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ GetLast a a where getLast a = a diff --git a/servant-docs/include/overlapping-compat.h b/servant-docs/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-docs/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index b88bc612..7bd34a7a 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -49,6 +49,7 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include executable greet-docs main-is: greet.hs diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 33cb86a0..c1d26142 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -16,9 +16,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" module Servant.Docs.Internal where import Control.Applicative @@ -661,10 +660,7 @@ markdown api = unlines $ -- | The generated docs for @a ':<|>' b@ just appends the docs -- for @a@ with the docs for @b@. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (HasDocs layout1, HasDocs layout2) => HasDocs (layout1 :<|> layout2) where @@ -692,10 +688,7 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout) symP = Proxy :: Proxy sym -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLe #-} -#endif +instance OVERLAPPABLE_ (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Delete cts a) where docsFor Proxy (endpoint, action) DocOptions{..} = @@ -707,10 +700,7 @@ instance t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ (ToSample a, IsNonEmpty cts, AllMimeRender cts a , AllHeaderSamples ls , GetHeaders (HList ls) ) => HasDocs (Delete cts (Headers ls a)) where @@ -725,10 +715,7 @@ instance t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLe #-} -#endif +instance OVERLAPPABLE_ (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Get cts a) where docsFor Proxy (endpoint, action) DocOptions{..} = @@ -740,10 +727,7 @@ instance t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ (ToSample a, IsNonEmpty cts, AllMimeRender cts a , AllHeaderSamples ls , GetHeaders (HList ls) ) => HasDocs (Get cts (Headers ls a)) where @@ -767,10 +751,7 @@ instance (KnownSymbol sym, HasDocs sublayout) action' = over headers (|> headername) action headername = pack $ symbolVal (Proxy :: Proxy sym) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Post cts a) where docsFor Proxy (endpoint, action) DocOptions{..} = @@ -783,10 +764,7 @@ instance t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ (ToSample a, IsNonEmpty cts, AllMimeRender cts a , AllHeaderSamples ls , GetHeaders (HList ls) ) => HasDocs (Post cts (Headers ls a)) where @@ -802,10 +780,7 @@ instance t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (ToSample a, IsNonEmpty cts, AllMimeRender cts a) => HasDocs (Put cts a) where docsFor Proxy (endpoint, action) DocOptions{..} = @@ -818,10 +793,7 @@ instance t = Proxy :: Proxy cts p = Proxy :: Proxy a -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( ToSample a, IsNonEmpty cts, AllMimeRender cts a, AllHeaderSamples ls , GetHeaders (HList ls) ) => HasDocs (Put cts (Headers ls a)) where diff --git a/servant-examples/include/overlapping-compat.h b/servant-examples/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-examples/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-foreign/include/overlapping-compat.h b/servant-foreign/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-foreign/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 0ec296ae..d565b636 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -33,6 +33,7 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include test-suite spec diff --git a/servant-jquery/include/overlapping-compat.h b/servant-jquery/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-jquery/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-js/include/overlapping-compat.h b/servant-js/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-js/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index 53a74e9d..a47ecd34 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -49,6 +49,7 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include executable counter main-is: counter.hs diff --git a/servant-lucid/include/overlapping-compat.h b/servant-lucid/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-lucid/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal index 77cf3ee1..e4438f42 100644 --- a/servant-lucid/servant-lucid.cabal +++ b/servant-lucid/servant-lucid.cabal @@ -30,3 +30,4 @@ library , servant == 0.5.* hs-source-dirs: src default-language: Haskell2010 + include-dirs: include diff --git a/servant-lucid/src/Servant/HTML/Lucid.hs b/servant-lucid/src/Servant/HTML/Lucid.hs index f222c6ac..ec62a21c 100644 --- a/servant-lucid/src/Servant/HTML/Lucid.hs +++ b/servant-lucid/src/Servant/HTML/Lucid.hs @@ -3,9 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" -- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s -- `ToHtml` class and `Html` datatype. @@ -28,16 +27,10 @@ data HTML deriving Typeable instance Accept HTML where contentType _ = "text" M.// "html" M./: ("charset", "utf-8") -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ToHtml a => MimeRender HTML a where mimeRender _ = renderBS . toHtml -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ MimeRender HTML (Html a) where mimeRender _ = renderBS diff --git a/servant-mock/include/overlapping-compat.h b/servant-mock/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-mock/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 14455c99..e1df69e4 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -34,6 +34,7 @@ library wai >= 3.0 && <3.3 hs-source-dirs: src default-language: Haskell2010 + include-dirs: include executable mock-app main-is: main.hs diff --git a/servant-property/include/overlapping-compat.h b/servant-property/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-property/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-server/include/overlapping-compat.h b/servant-server/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-server/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index ff2fb200..5d6ccaa2 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -69,6 +69,7 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include executable greet main-is: greet.hs @@ -134,3 +135,4 @@ test-suite doctests buildable: True default-language: Haskell2010 ghc-options: -threaded + include-dirs: include diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 4200d052..48aed938 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -8,9 +8,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" module Servant.Server.Internal ( module Servant.Server.Internal @@ -206,10 +205,7 @@ methodRouterEmpty method action = LeafRouter route' -- to be returned. You can use 'Control.Monad.Trans.Except.throwE' to -- painlessly error out if the conditions for a successful deletion -- are not met. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ( AllCTRender ctypes a ) => HasServer (Delete ctypes a) where @@ -217,10 +213,7 @@ instance route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200 -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasServer (Delete ctypes ()) where type ServerT (Delete ctypes ()) m = m () @@ -228,10 +221,7 @@ instance route Proxy = methodRouterEmpty methodDelete -- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( GetHeaders (Headers h v), AllCTRender ctypes v ) => HasServer (Delete ctypes (Headers h v)) where @@ -252,10 +242,7 @@ instance -- (returning a status code of 200). If there was no @Accept@ header or it -- was @*\/\*@, we return encode using the first @Content-Type@ type on the -- list. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where type ServerT (Get ctypes a) m = m a @@ -263,10 +250,7 @@ instance route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200 -- '()' ==> 204 No Content -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasServer (Get ctypes ()) where type ServerT (Get ctypes ()) m = m () @@ -274,10 +258,7 @@ instance route Proxy = methodRouterEmpty methodGet -- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( GetHeaders (Headers h v), AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where @@ -329,10 +310,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) -- (returning a status code of 201). If there was no @Accept@ header or it -- was @*\/\*@, we return encode using the first @Content-Type@ type on the -- list. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ( AllCTRender ctypes a ) => HasServer (Post ctypes a) where @@ -340,10 +318,7 @@ instance route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201 -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasServer (Post ctypes ()) where type ServerT (Post ctypes ()) m = m () @@ -351,10 +326,7 @@ instance route Proxy = methodRouterEmpty methodPost -- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( GetHeaders (Headers h v), AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where @@ -375,20 +347,14 @@ instance -- (returning a status code of 200). If there was no @Accept@ header or it -- was @*\/\*@, we return encode using the first @Content-Type@ type on the -- list. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ( AllCTRender ctypes a) => HasServer (Put ctypes a) where type ServerT (Put ctypes a) m = m a route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200 -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasServer (Put ctypes ()) where type ServerT (Put ctypes ()) m = m () @@ -396,10 +362,7 @@ instance route Proxy = methodRouterEmpty methodPut -- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( GetHeaders (Headers h v), AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where @@ -418,20 +381,14 @@ instance -- If successfully returning a value, we just require that its type has -- a 'ToJSON' instance and servant takes care of encoding it for you, -- yielding status code 200 along the way. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where type ServerT (Patch ctypes a) m = m a route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200 -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ HasServer (Patch ctypes ()) where type ServerT (Patch ctypes ()) m = m () @@ -439,10 +396,7 @@ instance route Proxy = methodRouterEmpty methodPatch -- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ ( GetHeaders (Headers h v), AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where diff --git a/servant-server/test/Doctests.hs b/servant-server/test/Doctests.hs index 572461aa..663f8768 100644 --- a/servant-server/test/Doctests.hs +++ b/servant-server/test/Doctests.hs @@ -10,7 +10,7 @@ main :: IO () main = do files <- find always (extension ==? ".hs") "src" mCabalMacrosFile <- getCabalMacrosFile - doctest $ "-isrc" : + doctest $ "-isrc" : "-Iinclude" : (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++ "-XOverloadedStrings" : "-XFlexibleInstances" : diff --git a/servant-session/include/overlapping-compat.h b/servant-session/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-session/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant/include/overlapping-compat.h b/servant/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant/servant.cabal b/servant/servant.cabal index f717eab3..99455ab9 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -81,6 +81,7 @@ library , TypeSynonymInstances , UndecidableInstances ghc-options: -Wall + include-dirs: include test-suite spec type: exitcode-stdio-1.0 @@ -118,3 +119,4 @@ test-suite doctests buildable: True default-language: Haskell2010 ghc-options: -threaded + include-dirs: include diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index 1fcbd035..dc73a8e0 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -12,11 +12,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif {-# OPTIONS_HADDOCK not-home #-} +#include "overlapping-compat.h" -- | This module provides facilities for adding headers to a response. -- -- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int @@ -68,19 +66,12 @@ class BuildHeadersTo hs where -- the values are interspersed with commas before deserialization (see -- ) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - BuildHeadersTo '[] where +instance OVERLAPPING_ BuildHeadersTo '[] where buildHeadersTo _ = HNil -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( FromByteString v, BuildHeadersTo xs, KnownSymbol h, Contains h xs ~ 'False - ) => BuildHeadersTo ((Header h v) ': xs) where +instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h + , Contains h xs ~ 'False) + => BuildHeadersTo ((Header h v) ': xs) where buildHeadersTo headers = let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers @@ -96,38 +87,22 @@ instance class GetHeaders ls where getHeaders :: ls -> [HTTP.Header] -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - GetHeaders (HList '[]) where +instance OVERLAPPING_ GetHeaders (HList '[]) where getHeaders _ = [] -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( KnownSymbol h, ToByteString x, GetHeaders (HList xs) - ) => GetHeaders (HList (Header h x ': xs)) where +instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs)) + => GetHeaders (HList (Header h x ': xs)) where getHeaders hdrs = case hdrs of Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest UndecodableHeader h `HCons` rest -> (headerName, h) : getHeaders rest MissingHeader `HCons` rest -> getHeaders rest where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - GetHeaders (Headers '[] a) where +instance OVERLAPPING_ GetHeaders (Headers '[] a) where getHeaders _ = [] -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( KnownSymbol h, GetHeaders (HList rest), ToByteString v - ) => GetHeaders (Headers (Header h v ': rest) a) where +instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v) + => GetHeaders (Headers (Header h v ': rest) a) where getHeaders hs = getHeaders $ getHeadersHList hs -- * Adding @@ -138,21 +113,13 @@ class AddHeader h v orig new addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False - ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where +instance OVERLAPPING_ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False) + => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( KnownSymbol h, ToByteString v - , new ~ (Headers '[Header h v] a) - ) => AddHeader h v a new where +instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v + , new ~ (Headers '[Header h v] a)) + => AddHeader h v a new where addHeader a resp = Headers resp (HCons (Header a) HNil) type family Contains x xs where diff --git a/servant/test/Doctests.hs b/servant/test/Doctests.hs index bf6bcd23..d9116823 100644 --- a/servant/test/Doctests.hs +++ b/servant/test/Doctests.hs @@ -11,7 +11,7 @@ main = do files <- find always (extension ==? ".hs") "src" tfiles <- find always (extension ==? ".hs") "test/Servant" mCabalMacrosFile <- getCabalMacrosFile - doctest $ "-isrc" : + doctest $ "-isrc" : "-Iinclude" : (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++ "-XOverloadedStrings" : "-XFlexibleInstances" : From 8a497c473cac4682e3a583d935b8c3a03751be70 Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Mon, 4 Jan 2016 23:03:26 -0500 Subject: [PATCH 006/180] delete extra committed header files --- servant-jquery/include/overlapping-compat.h | 8 -------- servant-property/include/overlapping-compat.h | 8 -------- servant-session/include/overlapping-compat.h | 8 -------- 3 files changed, 24 deletions(-) delete mode 100644 servant-jquery/include/overlapping-compat.h delete mode 100644 servant-property/include/overlapping-compat.h delete mode 100644 servant-session/include/overlapping-compat.h diff --git a/servant-jquery/include/overlapping-compat.h b/servant-jquery/include/overlapping-compat.h deleted file mode 100644 index eef9d4ea..00000000 --- a/servant-jquery/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/servant-property/include/overlapping-compat.h b/servant-property/include/overlapping-compat.h deleted file mode 100644 index eef9d4ea..00000000 --- a/servant-property/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/servant-session/include/overlapping-compat.h b/servant-session/include/overlapping-compat.h deleted file mode 100644 index eef9d4ea..00000000 --- a/servant-session/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif From 17fcc25d871d67278867c01581c1cf742b2b83e3 Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Mon, 4 Jan 2016 23:05:05 -0500 Subject: [PATCH 007/180] add include header files to extra-source-files --- servant-blaze/servant-blaze.cabal | 2 +- servant-cassava/servant-cassava.cabal | 2 +- servant-client/servant-client.cabal | 1 + servant-docs/servant-docs.cabal | 1 + servant-foreign/servant-foreign.cabal | 1 + servant-js/servant-js.cabal | 1 + servant-lucid/servant-lucid.cabal | 2 +- servant-mock/servant-mock.cabal | 1 + servant-server/servant-server.cabal | 1 + servant/servant.cabal | 1 + 10 files changed, 10 insertions(+), 3 deletions(-) diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal index a82076f6..cc4ea34d 100644 --- a/servant-blaze/servant-blaze.cabal +++ b/servant-blaze/servant-blaze.cabal @@ -13,7 +13,7 @@ maintainer: jkarni@gmail.com -- copyright: category: Web build-type: Simple --- extra-source-files: +extra-source-files: include/*.h cabal-version: >=1.10 bug-reports: http://github.com/haskell-servant/servant/issues source-repository head diff --git a/servant-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal index db18986c..e2e7c964 100644 --- a/servant-cassava/servant-cassava.cabal +++ b/servant-cassava/servant-cassava.cabal @@ -13,7 +13,7 @@ maintainer: jkarni@gmail.com -- copyright: -- category: build-type: Simple --- extra-source-files: +extra-source-files: include/*.h cabal-version: >=1.10 library diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 1ddf8bf4..087920dc 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -15,6 +15,7 @@ maintainer: alpmestan@gmail.com copyright: 2014 Zalora South East Asia Pte Ltd category: Web build-type: Simple +extra-source-files: include/*.h cabal-version: >=1.10 tested-with: GHC >= 7.8 homepage: http://haskell-servant.github.io/ diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 7bd34a7a..b1be264d 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -19,6 +19,7 @@ tested-with: GHC >= 7.8 homepage: http://haskell-servant.github.io/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: + include/*.h CHANGELOG.md README.md source-repository head diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index d565b636..be1f2696 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -18,6 +18,7 @@ category: Web build-type: Simple cabal-version: >=1.10 extra-source-files: + include/*.h CHANGELOG.md README.md source-repository head diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index a47ecd34..28005e60 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -22,6 +22,7 @@ cabal-version: >=1.10 homepage: http://haskell-servant.github.io/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: + include/*.h CHANGELOG.md README.md source-repository head diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal index e4438f42..f2be1eb5 100644 --- a/servant-lucid/servant-lucid.cabal +++ b/servant-lucid/servant-lucid.cabal @@ -13,7 +13,7 @@ maintainer: jkarni@gmail.com -- copyright: category: Web build-type: Simple --- extra-source-files: +extra-source-files: include/*.h cabal-version: >=1.10 bug-reports: http://github.com/haskell-servant/servant/issues source-repository head diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index e1df69e4..7d8589d0 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -13,6 +13,7 @@ maintainer: alpmestan@gmail.com copyright: 2015 Alp Mestanogullari category: Web build-type: Simple +extra-source-files: include/*.h cabal-version: >=1.10 flag example diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 5d6ccaa2..c4ec6edc 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -23,6 +23,7 @@ build-type: Simple cabal-version: >=1.10 tested-with: GHC >= 7.8 extra-source-files: + include/*.h CHANGELOG.md README.md bug-reports: http://github.com/haskell-servant/servant/issues diff --git a/servant/servant.cabal b/servant/servant.cabal index 99455ab9..895b9f32 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -16,6 +16,7 @@ maintainer: alpmestan@gmail.com copyright: 2014 Zalora South East Asia Pte Ltd category: Web build-type: Simple +extra-source-files: include/*.h cabal-version: >=1.10 tested-with: GHC >= 7.8 source-repository head From f66981fc8a10a2db6cfb38ad3736619b824779f9 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 7 Jan 2016 00:53:17 +0100 Subject: [PATCH 008/180] First pass at CONTRIBUTING --- CONTRIBUTING.md | 76 +++++++++++++++++++++++++++++++++++++++++++++++++ README.md | 27 +----------------- 2 files changed, 77 insertions(+), 26 deletions(-) create mode 100644 CONTRIBUTING.md diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 00000000..74577d3f --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,76 @@ +# Contributing Guidelines + +Contributions are very welcome! To hack on the github version, clone the +repository. You can use `cabal`: + +```shell +./scripts/start-sandbox.sh # Initialize the sandbox and add-source the packages +./scripts/test-all.sh # Run all the tests +``` + +`stack`: + +```shell +stack build # Install and build packages +stack test # Run all the tests +``` + +Or `nix`: +```shell +./scripts/generate-nix-files.sh # Get up-to-date shell.nix files +``` + + +## General + +Some things we like: + +- Explicit imports +- Upper and lower bounds for packages +- Few dependencies +- -Werror-compatible + +Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs` +files in the repository provide a good baseline for consistency. + +Please include a description of the changes in your PR in the `CHANGELOG.md` of +the packages you've changed. And of course, write tests! + +## PR process + +We require two +1 from the maintainers of the repo. If you feel like there has +not been a timely response to a PR, you can ping the Maintainers group (with +`@Maintainers`). + +## New combinators + +We encourage people to experiment with new combinators and instances - it is +one of the most powerful ways of using `servant`, and a wonderful way of +getting to know it better. If you do write a new combinator, we would love to +know about it! Either hop on #servant on freenode and let us know, or open an +issue with the `news` tag (which we will close when we read it). + +As for adding them to the main repo: maintaining combinators can be expensive, +since official combinators must have instances for all classes (and new classes +come along fairly frequently). We therefore have to be quite selective about +those that we accept. If you're considering writing a new combinator, open an +issue to discuss it first! + + +## New classes + +The main benefit of having a new class and package in the main servant repo is +that we get to see via CI whether changes to other packages break the build. +Open an issue to discuss whether a package should be added to the main repo. If +we decide that it can, you can still keep maintainership over it. + +Whether or not you want your package to be in the repo, create an issue with +the `news` label if you make a new package so we can know about it! + +## Release policy + +We are currently moving to a more aggresive release policy, so that you can get +what you contribute from Hackage fairly soon. However, note that prior to major +releases it may take some time in between releases. If you think you're change +is small enough that you should be backported to released major versions, say +so in the issue or PR. diff --git a/README.md b/README.md index 0f13f495..3cf786ea 100644 --- a/README.md +++ b/README.md @@ -17,29 +17,4 @@ list](https://groups.google.com/forum/#!forum/haskell-servant). ## Contributing -Contributions are very welcome! To hack on the github version, clone the -repository. You can use `cabal`: - -```shell -./scripts/start-sandbox.sh # Initialize the sandbox and add-source the packages -./scripts/test-all.sh # Run all the tests -``` - -`stack`: - -```shell -stack build # Install and build packages -stack test # Run all the tests -``` - -Or `nix`: -```shell -./scripts/generate-nix-files.sh # Get up-to-date shell.nix files -``` - -Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs` -files in the repository provide a good baseline for consistency. - -Please include a description of the changes in your PR in the `CHANGELOG.md` of -the packages you've changed. And of course, write tests! - +See `CONTRIBUTING.md` From 832f1b985ffa9278e1d7b1fad8f7cdc743058469 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 7 Jan 2016 13:05:13 +0100 Subject: [PATCH 009/180] Review fixes and note about CI. --- CONTRIBUTING.md | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 74577d3f..0c76f11f 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -28,7 +28,7 @@ Some things we like: - Explicit imports - Upper and lower bounds for packages - Few dependencies -- -Werror-compatible +- -Werror-compatible (for both 7.8 and 7.10) Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs` files in the repository provide a good baseline for consistency. @@ -38,6 +38,10 @@ the packages you've changed. And of course, write tests! ## PR process +We try to give timely reviews to PRs that pass CI. If CI for your PR fails, we +may close the PR if it has been open for too long (though you should feel free +to reopen when the issues have been fixed). + We require two +1 from the maintainers of the repo. If you feel like there has not been a timely response to a PR, you can ping the Maintainers group (with `@Maintainers`). @@ -53,7 +57,7 @@ issue with the `news` tag (which we will close when we read it). As for adding them to the main repo: maintaining combinators can be expensive, since official combinators must have instances for all classes (and new classes come along fairly frequently). We therefore have to be quite selective about -those that we accept. If you're considering writing a new combinator, open an +those that we accept. If your considering writing a new combinator, open an issue to discuss it first! @@ -72,5 +76,5 @@ the `news` label if you make a new package so we can know about it! We are currently moving to a more aggresive release policy, so that you can get what you contribute from Hackage fairly soon. However, note that prior to major releases it may take some time in between releases. If you think you're change -is small enough that you should be backported to released major versions, say +is small enough that it should be backported to released major versions, say so in the issue or PR. From cda8bcf17cbe5a23696fcf0e320f1d8ec99d0505 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 27 Nov 2015 02:05:34 +0100 Subject: [PATCH 010/180] Simplify verb combinators. Create a single 'Verb' combinator with parameters for status code and method. Make existing combinators type synonyms of 'Verb'. --- servant-client/src/Servant/Client.hs | 168 ++++-------- servant-client/src/Servant/Common/Req.hs | 19 +- servant-client/test/Servant/ClientSpec.hs | 4 +- servant-docs/src/Servant/Docs/Internal.hs | 63 ++--- servant-server/src/Servant/Server/Internal.hs | 249 +++--------------- .../test/Servant/Server/ErrorSpec.hs | 2 +- .../test/Servant/Server/Internal/EnterSpec.hs | 2 +- servant-server/test/Servant/ServerSpec.hs | 48 ++-- .../test/Servant/Utils/StaticFilesSpec.hs | 7 +- servant/servant.cabal | 6 +- servant/src/Servant/API.hs | 23 +- servant/src/Servant/API/ContentTypes.hs | 66 +++-- servant/src/Servant/API/Delete.hs | 24 -- servant/src/Servant/API/Get.hs | 22 -- servant/src/Servant/API/Patch.hs | 29 -- servant/src/Servant/API/Post.hs | 27 -- servant/src/Servant/API/Put.hs | 25 -- servant/src/Servant/API/Verbs.hs | 60 +++++ servant/src/Servant/Utils/Links.hs | 37 +-- 19 files changed, 279 insertions(+), 602 deletions(-) delete mode 100644 servant/src/Servant/API/Delete.hs delete mode 100644 servant/src/Servant/API/Get.hs delete mode 100644 servant/src/Servant/API/Patch.hs delete mode 100644 servant/src/Servant/API/Post.hs delete mode 100644 servant/src/Servant/API/Put.hs create mode 100644 servant/src/Servant/API/Verbs.hs diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 408850ca..4eac1b2d 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -44,7 +45,7 @@ import Servant.Common.Req -- | 'client' allows you to produce operations to query an API from a client. -- -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy @@ -118,62 +119,48 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) where p = unpack (toUrlPiece val) --- | If you have a 'Delete' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. instance OVERLAPPABLE_ - (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where - type Client (Delete cts' a) = ExceptT ServantError IO a + -- Note [Non-Empty Content Types] + (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient (Verb method status cts' a) where + type Client (Verb method status cts' a) = ExceptT ServantError IO a clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager + snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager + where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ - HasClient (Delete cts ()) where - type Client (Delete cts ()) = ExceptT ServantError IO () + (ReflectMethod method) => HasClient (Verb method status cts ()) where + type Client (Verb method status cts ()) = ExceptT ServantError IO () clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodDelete req baseurl manager + void $ performRequestNoBody method req baseurl manager + where method = reflectMethod (Proxy :: Proxy method) --- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. instance OVERLAPPING_ - ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts) - ) => HasClient (Delete cts' (Headers ls a)) where - type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a) + -- Note [Non-Empty Content Types] + ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient (Verb method status cts' (Headers ls a)) where + type Client (Verb method status cts' (Headers ls a)) + = ExceptT ServantError IO (Headers ls a) clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager + let method = reflectMethod (Proxy :: Proxy method) + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } --- | If you have a 'Get' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance OVERLAPPABLE_ - (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where - type Client (Get (ct ': cts) result) = ExceptT ServantError IO result - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager - instance OVERLAPPING_ - HasClient (Get (ct ': cts) ()) where - type Client (Get (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - performRequestNoBody H.methodGet req baseurl manager - --- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance OVERLAPPING_ - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Get (ct ': cts) (Headers ls a)) where - type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) + ( BuildHeadersTo ls, ReflectMethod method + ) => HasClient (Verb method status cts (Headers ls ())) where + type Client (Verb method status cts (Headers ls ())) + = ExceptT ServantError IO (Headers ls ()) clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager - return $ Headers { getResponse = resp + let method = reflectMethod (Proxy :: Proxy method) + hdrs <- performRequestNoBody method req baseurl manager + return $ Headers { getResponse = () , getHeadersHList = buildHeadersTo hdrs } + -- | If you use a 'Header' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'Header', @@ -217,90 +204,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) where hname = symbolVal (Proxy :: Proxy sym) --- | If you have a 'Post' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance OVERLAPPABLE_ - (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where - type Client (Post (ct ': cts) a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager - -instance OVERLAPPING_ - HasClient (Post (ct ': cts) ()) where - type Client (Post (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPost req baseurl manager - --- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance OVERLAPPING_ - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Post (ct ': cts) (Headers ls a)) where - type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } - --- | If you have a 'Put' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance OVERLAPPABLE_ - (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where - type Client (Put (ct ': cts) a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager - -instance OVERLAPPING_ - HasClient (Put (ct ': cts) ()) where - type Client (Put (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPut req baseurl manager - --- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance OVERLAPPING_ - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Put (ct ': cts) (Headers ls a)) where - type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager= do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } - --- | If you have a 'Patch' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance OVERLAPPABLE_ - (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where - type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager - -instance OVERLAPPING_ - HasClient (Patch (ct ': cts) ()) where - type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPatch req baseurl manager - --- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance OVERLAPPING_ - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Patch (ct ': cts) (Headers ls a)) where - type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } - -- | If you use a 'QueryParam' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'QueryParam', @@ -503,3 +406,20 @@ instance HasClient api => HasClient (IsSecure :> api) where clientWithRoute Proxy req baseurl manager = clientWithRoute (Proxy :: Proxy api) req baseurl manager + + +{- Note [Non-Empty Content Types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rather than have + + instance (..., cts' ~ (ct ': cts)) => ... cts' ... + +It may seem to make more sense to have: + + instance (...) => ... (ct ': cts) ... + +But this means that if another instance exists that does *not* require +non-empty lists, but is otherwise more specific, no instance will be overall +more specific. This in turns generally means adding yet another instance (one +for empty and one for non-empty lists). +-} diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 38aa39b5..32d572aa 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -142,7 +142,7 @@ performRequest reqMethod req reqHost manager = do Right response -> do let status = Client.responseStatus response body = Client.responseBody response - hrds = Client.responseHeaders response + hdrs = Client.responseHeaders response status_code = statusCode status ct <- case lookup "Content-Type" $ Client.responseHeaders response of Nothing -> pure $ "application"//"octet-stream" @@ -151,23 +151,26 @@ performRequest reqMethod req reqHost manager = do Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ throwE $ FailureResponse status ct body - return (status_code, body, ct, hrds, response) + return (status_code, body, ct, hdrs, response) performRequestCT :: MimeUnrender ct result => - Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result) + Proxy ct -> Method -> Req -> BaseUrl -> Manager + -> ExceptT ServantError IO ([HTTP.Header], result) performRequestCT ct reqMethod req reqHost manager = do let acceptCT = contentType ct - (_status, respBody, respCT, hrds, _response) <- + (_status, respBody, respCT, hdrs, _response) <- performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of Left err -> throwE $ DecodeFailure err respCT respBody - Right val -> return (hrds, val) + Right val -> return (hdrs, val) -performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO () -performRequestNoBody reqMethod req reqHost manager = - void $ performRequest reqMethod req reqHost manager +performRequestNoBody :: Method -> Req -> BaseUrl -> Manager + -> ExceptT ServantError IO [HTTP.Header] +performRequestNoBody reqMethod req reqHost manager = do + (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager + return hdrs catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError action = diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index b1980d1a..e289873d 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -90,7 +90,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] type Api = "get" :> Get '[JSON] Person - :<|> "deleteEmpty" :> Delete '[] () + :<|> "deleteEmpty" :> Delete '[JSON] () :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person @@ -283,7 +283,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where - WrappedApi :: (HasServer api, Server api ~ ExceptT ServantErr IO a, + WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a, HasClient api, Client api ~ ExceptT ServantError IO ()) => Proxy api -> WrappedApi diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index c1d26142..41754c31 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -476,8 +476,8 @@ instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h) -- | Synthesise a sample value of a type, encoded in the specified media types. sampleByteString - :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) - => Proxy ctypes + :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a) + => Proxy (ct ': cts) -> Proxy a -> [(M.MediaType, ByteString)] sampleByteString ctypes@Proxy Proxy = @@ -486,8 +486,8 @@ sampleByteString ctypes@Proxy Proxy = -- | Synthesise a list of sample values of a particular type, encoded in the -- specified media types. sampleByteStrings - :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) - => Proxy ctypes + :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a) + => Proxy (ct ': cts) -> Proxy a -> [(Text, M.MediaType, ByteString)] sampleByteStrings ctypes@Proxy Proxy = @@ -689,21 +689,21 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout) instance OVERLAPPABLE_ - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Delete cts a) where + (ToSample a, AllMimeRender (ct ': cts) a) + => HasDocs (Delete (ct ': cts) a) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' where endpoint' = endpoint & method .~ DocDELETE action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance OVERLAPPING_ - (ToSample a, IsNonEmpty cts, AllMimeRender cts a + (ToSample a, AllMimeRender (ct ': cts) a , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Delete cts (Headers ls a)) where + => HasDocs (Delete (ct ': cts) (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -712,25 +712,26 @@ instance OVERLAPPING_ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance OVERLAPPABLE_ - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Get cts a) where + (ToSample a, AllMimeRender (ct ': cts) a) + => HasDocs (Get (ct ': cts) a) where +>>>>>>> Simplify verb combinators. docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' where endpoint' = endpoint & method .~ DocGET action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance OVERLAPPING_ - (ToSample a, IsNonEmpty cts, AllMimeRender cts a + (ToSample a, AllMimeRender (ct ': cts) a , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Get cts (Headers ls a)) where + => HasDocs (Get (ct ': cts) (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -739,7 +740,7 @@ instance OVERLAPPING_ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance (KnownSymbol sym, HasDocs sublayout) @@ -752,8 +753,8 @@ instance (KnownSymbol sym, HasDocs sublayout) headername = pack $ symbolVal (Proxy :: Proxy sym) instance OVERLAPPABLE_ - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Post cts a) where + (ToSample a, AllMimeRender (ct ': cts) a) + => HasDocs (Post (ct ': cts) a) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -761,13 +762,13 @@ instance OVERLAPPABLE_ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t & response.respStatus .~ 201 - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance OVERLAPPING_ - (ToSample a, IsNonEmpty cts, AllMimeRender cts a + (ToSample a, AllMimeRender (ct ': cts) a , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Post cts (Headers ls a)) where + => HasDocs (Post (ct ': cts) (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -777,12 +778,12 @@ instance OVERLAPPING_ & response.respTypes .~ allMime t & response.respStatus .~ 201 & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance OVERLAPPABLE_ - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Put cts a) where + (ToSample a, AllMimeRender (ct ': cts) a) + => HasDocs (Put (ct ': cts) a) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -790,13 +791,13 @@ instance OVERLAPPABLE_ action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t & response.respStatus .~ 200 - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance OVERLAPPING_ - ( ToSample a, IsNonEmpty cts, AllMimeRender cts a, + ( ToSample a, AllMimeRender (ct ': cts) a, AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Put cts (Headers ls a)) where + => HasDocs (Put (ct ': cts) (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' @@ -806,7 +807,7 @@ instance OVERLAPPING_ & response.respTypes .~ allMime t & response.respStatus .~ 200 & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) @@ -849,8 +850,8 @@ instance HasDocs Raw where -- example data. However, there's no reason to believe that the instances of -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that -- both are even defined) for any particular type. -instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout) - => HasDocs (ReqBody cts a :> sublayout) where +instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout) + => HasDocs (ReqBody (ct ': cts) a :> sublayout) where docsFor Proxy (endpoint, action) = docsFor sublayoutP (endpoint, action') @@ -858,7 +859,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout) where sublayoutP = Proxy :: Proxy sublayout action' = action & rqbody .~ sampleByteString t p & rqtypes .~ allMime t - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 48aed938..5c08c4d4 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -21,26 +21,33 @@ module Servant.Server.Internal #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad.Trans.Except (ExceptT) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Map as M -import Data.Maybe (fromMaybe, mapMaybe) -import Data.String (fromString) -import Data.String.Conversions (ConvertibleStrings, cs, (<>)) -import Data.Text (Text) +import Control.Monad.Trans.Except (ExceptT) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map as M +import Data.Maybe (fromMaybe, mapMaybe) +import Data.String (fromString) +import Data.String.Conversions (cs, (<>)) +import Data.Text (Text) import Data.Typeable -import GHC.TypeLits (KnownSymbol, symbolVal) -import Network.HTTP.Types hiding (Header, ResponseHeaders) -import Network.Socket (SockAddr) -import Network.Wai (Application, lazyRequestBody, - rawQueryString, requestHeaders, - requestMethod, responseLBS, remoteHost, - isSecure, vault, httpVersion, Response, - Request, pathInfo) +import GHC.TypeLits (KnownNat, KnownSymbol, natVal, + symbolVal) +import Network.HTTP.Types hiding (Header, ResponseHeaders) +import Network.Socket (SockAddr) +import Network.Wai (Application, Request, Response, + httpVersion, isSecure, + lazyRequestBody, pathInfo, + rawQueryString, remoteHost, + requestHeaders, requestMethod, + responseLBS, vault) +import Web.HttpApiData (FromHttpApiData) +import Web.HttpApiData.Internal (parseHeaderMaybe, + parseQueryParamMaybe, + parseUrlPieceMaybe) + import Servant.API ((:<|>) (..), (:>), Capture, - Delete, Get, Header, - IsSecure(..), Patch, Post, Put, + Verb, ReflectMethod(reflectMethod), + IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, Vault) import Servant.API.ContentTypes (AcceptHeader (..), @@ -55,8 +62,6 @@ import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr -import Web.HttpApiData (FromHttpApiData) -import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe) class HasServer layout where type ServerT layout (m :: * -> *) :: * @@ -129,12 +134,12 @@ allowedMethodHead method request = method == methodGet && requestMethod request allowedMethod :: Method -> Request -> Bool allowedMethod method request = allowedMethodHead method request || requestMethod request == method -processMethodRouter :: forall a. ConvertibleStrings a B.ByteString - => Maybe (a, BL.ByteString) -> Status -> Method +processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method -> Maybe [(HeaderName, B.ByteString)] -> Request -> RouteResult Response processMethodRouter handleA status method headers request = case handleA of Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does + Just (_, "") -> Route $ responseLBS status204 (fromMaybe [] headers) "" Just (contentT, body) -> Route $ responseLBS status hdrs bdy where bdy = if allowedMethodHead method request then "" else body @@ -160,7 +165,7 @@ methodRouter method proxy status action = LeafRouter route' | pathIsEmpty request = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request - `addAcceptCheck` acceptCheck proxy accH + `addAcceptCheck` acceptCheck proxy accH ) respond $ \ output -> do let handleA = handleAcceptH proxy (AcceptHeader accH) output processMethodRouter handleA status method Nothing request @@ -176,95 +181,34 @@ methodRouterHeaders method proxy status action = LeafRouter route' | pathIsEmpty request = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request - `addAcceptCheck` acceptCheck proxy accH + `addAcceptCheck` acceptCheck proxy accH ) respond $ \ output -> do let headers = getHeaders output handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) processMethodRouter handleA status method (Just headers) request | otherwise = respond $ Fail err404 -methodRouterEmpty :: Method - -> Delayed (ExceptT ServantErr IO ()) - -> Router -methodRouterEmpty method action = LeafRouter route' - where - route' request respond - | pathIsEmpty request = do - runAction (addMethodCheck action (methodCheck method request)) respond $ \ () -> - Route $! responseLBS noContent204 [] "" - | otherwise = respond $ Fail err404 - --- | If you have a 'Delete' endpoint in your API, --- the handler for this endpoint is meant to delete --- a resource. --- --- The code of the handler will, just like --- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and --- 'Servant.API.Put.Put', run in @ExceptT ServantErr IO ()@. --- The 'Int' represents the status code and the 'String' a message --- to be returned. You can use 'Control.Monad.Trans.Except.throwE' to --- painlessly error out if the conditions for a successful deletion --- are not met. instance OVERLAPPABLE_ - ( AllCTRender ctypes a - ) => HasServer (Delete ctypes a) where + ( AllCTRender ctypes a, ReflectMethod method, KnownNat status + ) => HasServer (Verb method status ctypes a) where - type ServerT (Delete ctypes a) m = m a + type ServerT (Verb method status ctypes a) m = m a - route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200 + route Proxy = methodRouter method (Proxy :: Proxy ctypes) status + where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) instance OVERLAPPING_ - HasServer (Delete ctypes ()) where +instance + ( AllCTRender ctypes a, ReflectMethod method, KnownNat status + , GetHeaders (Headers h a) + ) => HasServer (Verb method status ctypes (Headers h a)) where - type ServerT (Delete ctypes ()) m = m () + type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) - route Proxy = methodRouterEmpty methodDelete - --- Add response headers -instance OVERLAPPING_ - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Delete ctypes (Headers h v)) where - - type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200 - --- | When implementing the handler for a 'Get' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' --- and 'Servant.API.Put.Put', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we use the type-level list, combined --- with the request's @Accept@ header, to encode the value for you --- (returning a status code of 200). If there was no @Accept@ header or it --- was @*\/\*@, we return encode using the first @Content-Type@ type on the --- list. -instance OVERLAPPABLE_ - ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where - - type ServerT (Get ctypes a) m = m a - - route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200 - --- '()' ==> 204 No Content -instance OVERLAPPING_ - HasServer (Get ctypes ()) where - - type ServerT (Get ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodGet - --- Add response headers -instance OVERLAPPING_ - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Get ctypes (Headers h v)) where - - type ServerT (Get ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200 + route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status + where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -297,113 +241,6 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) in route (Proxy :: Proxy sublayout) (passToServer subserver mheader) where str = fromString $ symbolVal (Proxy :: Proxy sym) --- | When implementing the handler for a 'Post' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' --- and 'Servant.API.Put.Put', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we use the type-level list, combined --- with the request's @Accept@ header, to encode the value for you --- (returning a status code of 201). If there was no @Accept@ header or it --- was @*\/\*@, we return encode using the first @Content-Type@ type on the --- list. -instance OVERLAPPABLE_ - ( AllCTRender ctypes a - ) => HasServer (Post ctypes a) where - - type ServerT (Post ctypes a) m = m a - - route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201 - -instance OVERLAPPING_ - HasServer (Post ctypes ()) where - - type ServerT (Post ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodPost - --- Add response headers -instance OVERLAPPING_ - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Post ctypes (Headers h v)) where - - type ServerT (Post ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201 - --- | When implementing the handler for a 'Put' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' --- and 'Servant.API.Post.Post', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we use the type-level list, combined --- with the request's @Accept@ header, to encode the value for you --- (returning a status code of 200). If there was no @Accept@ header or it --- was @*\/\*@, we return encode using the first @Content-Type@ type on the --- list. -instance OVERLAPPABLE_ - ( AllCTRender ctypes a) => HasServer (Put ctypes a) where - - type ServerT (Put ctypes a) m = m a - - route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200 - -instance OVERLAPPING_ - HasServer (Put ctypes ()) where - - type ServerT (Put ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodPut - --- Add response headers -instance OVERLAPPING_ - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Put ctypes (Headers h v)) where - - type ServerT (Put ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200 - --- | When implementing the handler for a 'Patch' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' --- and 'Servant.API.Put.Put', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we just require that its type has --- a 'ToJSON' instance and servant takes care of encoding it for you, --- yielding status code 200 along the way. -instance OVERLAPPABLE_ - ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where - - type ServerT (Patch ctypes a) m = m a - - route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200 - -instance OVERLAPPING_ - HasServer (Patch ctypes ()) where - - type ServerT (Patch ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodPatch - --- Add response headers -instance OVERLAPPING_ - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Patch ctypes (Headers h v)) where - - type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200 - -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @'Maybe' 'Text'@. diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 2e93cc2a..500a0069 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -162,7 +162,7 @@ errorRetrySpec = describe "Handler search" it "should continue when URLs don't match" $ do request methodPost "" [jsonCT, jsonAccept] jsonBody - `shouldRespondWith` 201 { matchBody = Just $ encode (7 :: Int) } + `shouldRespondWith` 200 { matchBody = Just $ encode (7 :: Int) } it "should continue when methods don't match" $ do request methodGet "a" [jsonCT, jsonAccept] jsonBody diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs index 973e1f89..8b450377 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -52,7 +52,7 @@ enterSpec = describe "Enter" $ do it "allows running arbitrary monads" $ do get "int" `shouldRespondWith` "1797" - post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 } + post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 } with (return (serve combinedAPI combinedReaderServer)) $ do it "allows combnation of enters" $ do diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index e017d399..ad7a3556 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -130,15 +130,21 @@ captureSpec = do type GetApi = Get '[JSON] Person - :<|> "empty" :> Get '[] () - :<|> "post" :> Post '[] () + :<|> "empty" :> Get '[JSON] () + :<|> "emptyWithHeaders" :> Get '[JSON] (Headers '[Header "H" Int] ()) + :<|> "post" :> Post '[JSON] () + getApi :: Proxy GetApi getApi = Proxy getSpec :: Spec getSpec = do describe "Servant.API.Get" $ do - let server = return alice :<|> return () :<|> return () + let server = return alice + :<|> return () + :<|> return (addHeader 5 ()) + :<|> return () + with (return $ serve getApi server) $ do it "allows to GET a Person" $ do @@ -150,8 +156,8 @@ getSpec = do post "/" "" `shouldRespondWith` 405 post "/empty" "" `shouldRespondWith` 405 - it "returns 204 if the type is '()'" $ do - get "/empty" `shouldRespondWith` ""{ matchStatus = 204 } + it "returns headers" $ do + get "/emptyWithHeaders" `shouldRespondWith` 204 { matchHeaders = [ "H" <:> "5" ] } it "returns 406 if the Accept header is not supported" $ do Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" @@ -161,7 +167,10 @@ getSpec = do headSpec :: Spec headSpec = do describe "Servant.API.Head" $ do - let server = return alice :<|> return () :<|> return () + let server = return alice + :<|> return () + :<|> return (addHeader 5 ()) + :<|> return () with (return $ serve getApi server) $ do it "allows to GET a Person" $ do @@ -177,10 +186,6 @@ headSpec = do post "/" "" `shouldRespondWith` 405 post "/empty" "" `shouldRespondWith` 405 - it "returns 204 if the type is '()'" $ do - response <- Test.Hspec.Wai.request methodHead "/empty" [] "" - return response `shouldRespondWith` ""{ matchStatus = 204 } - it "returns 406 if the Accept header is not supported" $ do Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] "" `shouldRespondWith` 406 @@ -272,7 +277,7 @@ queryParamSpec = do type PostApi = ReqBody '[JSON] Person :> Post '[JSON] Integer :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer - :<|> "empty" :> Post '[] () + :<|> "empty" :> Post '[JSON] () postApi :: Proxy PostApi postApi = Proxy @@ -287,25 +292,22 @@ postSpec = do it "allows to POST a Person" $ do post' "/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 201 + matchStatus = 200 } it "allows alternative routes if all have request bodies" $ do post' "/bla" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 201 + matchStatus = 200 } it "handles trailing '/' gracefully" $ do post' "/bla/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 201 + matchStatus = 200 } it "correctly rejects invalid request bodies with status 400" $ do post' "/" "some invalid body" `shouldRespondWith` 400 - it "returns 204 if the type is '()'" $ do - post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } - it "responds with 415 if the request body media type is unsupported" $ do let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType , "application/nonsense")] @@ -314,7 +316,7 @@ postSpec = do type PutApi = ReqBody '[JSON] Person :> Put '[JSON] Integer :<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer - :<|> "empty" :> Put '[] () + :<|> "empty" :> Put '[JSON] () putApi :: Proxy PutApi putApi = Proxy @@ -345,9 +347,6 @@ putSpec = do it "correctly rejects invalid request bodies with status 400" $ do put' "/" "some invalid body" `shouldRespondWith` 400 - it "returns 204 if the type is '()'" $ do - put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } - it "responds with 415 if the request body media type is unsupported" $ do let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType , "application/nonsense")] @@ -356,7 +355,7 @@ putSpec = do type PatchApi = ReqBody '[JSON] Person :> Patch '[JSON] Integer :<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer - :<|> "empty" :> Patch '[] () + :<|> "empty" :> Patch '[JSON] () patchApi :: Proxy PatchApi patchApi = Proxy @@ -387,9 +386,6 @@ patchSpec = do it "correctly rejects invalid request bodies with status 400" $ do patch' "/" "some invalid body" `shouldRespondWith` 400 - it "returns 204 if the type is '()'" $ do - patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } - it "responds with 415 if the request body media type is unsupported" $ do let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType , "application/nonsense")] @@ -505,7 +501,7 @@ responseHeadersSpec :: Spec responseHeadersSpec = describe "ResponseHeaders" $ do with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do - let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)] + let methods = [(methodGet, 200), (methodPost, 200), (methodPut, 200), (methodPatch, 200)] it "includes the headers in the response" $ forM_ methods $ \(method, expected) -> diff --git a/servant-server/test/Servant/Utils/StaticFilesSpec.hs b/servant-server/test/Servant/Utils/StaticFilesSpec.hs index 3630b313..94c63f18 100644 --- a/servant-server/test/Servant/Utils/StaticFilesSpec.hs +++ b/servant-server/test/Servant/Utils/StaticFilesSpec.hs @@ -15,12 +15,7 @@ import System.IO.Temp (withSystemTempDirectory) import Test.Hspec (Spec, around_, describe, it) import Test.Hspec.Wai (get, shouldRespondWith, with) -import Servant.API (JSON) -import Servant.API.Alternative ((:<|>) ((:<|>))) -import Servant.API.Capture (Capture) -import Servant.API.Get (Get) -import Servant.API.Raw (Raw) -import Servant.API.Sub ((:>)) +import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON) import Servant.Server (Server, serve) import Servant.ServerSpec (Person (Person)) import Servant.Utils.StaticFiles (serveDirectory) diff --git a/servant/servant.cabal b/servant/servant.cabal index 895b9f32..451eb166 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -29,14 +29,9 @@ library Servant.API.Alternative Servant.API.Capture Servant.API.ContentTypes - Servant.API.Delete - Servant.API.Get Servant.API.Header Servant.API.HttpVersion Servant.API.IsSecure - Servant.API.Patch - Servant.API.Post - Servant.API.Put Servant.API.QueryParam Servant.API.Raw Servant.API.RemoteHost @@ -44,6 +39,7 @@ library Servant.API.ResponseHeaders Servant.API.Sub Servant.API.Vault + Servant.API.Verbs Servant.Utils.Links build-depends: base >=4.7 && <5 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 2e6abb2a..2565149f 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -25,16 +25,7 @@ module Servant.API ( -- | Access the location for arbitrary data to be shared by applications and middleware -- * Actual endpoints, distinguished by HTTP method - module Servant.API.Get, - -- | @GET@ requests - module Servant.API.Post, - -- | @POST@ requests - module Servant.API.Delete, - -- | @DELETE@ requests - module Servant.API.Put, - -- | @PUT@ requests - module Servant.API.Patch, - -- | @PATCH@ requests + module Servant.API.Verbs, -- * Content Types module Servant.API.ContentTypes, @@ -64,14 +55,9 @@ import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, MimeRender (..), MimeUnrender (..), OctetStream, PlainText, ToFormUrlEncoded (..)) -import Servant.API.Delete (Delete) -import Servant.API.Get (Get) import Servant.API.Header (Header (..)) import Servant.API.HttpVersion (HttpVersion (..)) import Servant.API.IsSecure (IsSecure (..)) -import Servant.API.Patch (Patch) -import Servant.API.Post (Post) -import Servant.API.Put (Put) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.Raw (Raw) @@ -84,7 +70,10 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader), getHeadersHList, getResponse) import Servant.API.Sub ((:>)) import Servant.API.Vault (Vault) -import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) +import Servant.API.Verbs (Delete, Get, Patch, Post, Put, + ReflectMethod (reflectMethod), + Verb) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', URI (..), safeLink) - +import Web.HttpApiData (FromHttpApiData (..), + ToHttpApiData (..)) diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index ab857ce2..85ddbb02 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -10,6 +11,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +#if !MIN_VERSION_base(4,8,0) +{-# LANGUAGE OverlappingInstances #-} +#endif {-# OPTIONS_HADDOCK not-home #-} -- | A collection of basic Content-Types (also known as Internet Media @@ -19,7 +23,7 @@ -- -- Content-Types are used in `ReqBody` and the method combinators: -- --- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] :> Book +-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] Book -- -- Meaning the endpoint accepts requests of Content-Type @application/json@ -- or @text/plain;charset-utf8@, and returns data in either one of those @@ -62,7 +66,6 @@ module Servant.API.ContentTypes , AllMimeUnrender(..) , FromFormUrlEncoded(..) , ToFormUrlEncoded(..) - , IsNonEmpty , eitherDecodeLenient , canHandleAcceptH ) where @@ -91,7 +94,7 @@ import qualified Data.Text.Encoding as TextS import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy.Encoding as TextL import Data.Typeable -import GHC.Exts (Constraint) +import GHC.Generics (Generic) import qualified Network.HTTP.Media as M import Network.URI (escapeURIString, isUnreserved, unEscapeString) @@ -137,7 +140,7 @@ instance Accept OctetStream where contentType _ = "application" M.// "octet-stream" newtype AcceptHeader = AcceptHeader BS.ByteString - deriving (Eq, Show) + deriving (Eq, Show, Read, Typeable, Generic) -- * Render (serializing) @@ -159,19 +162,22 @@ newtype AcceptHeader = AcceptHeader BS.ByteString class Accept ctype => MimeRender ctype a where mimeRender :: Proxy ctype -> a -> ByteString -class (AllMimeRender list a) => AllCTRender (list :: [*]) a where +class (AllMime list) => AllCTRender (list :: [*]) a where -- If the Accept header can be matched, returns (Just) a tuple of the -- Content-Type and response (serialization of @a@ into the appropriate -- mimetype). handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) -instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + (AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept - where pctyps = Proxy :: Proxy ctyps + where pctyps = Proxy :: Proxy (ct ': cts) amrs = allMimeRender pctyps val lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs - -------------------------------------------------------------------------- -- * Unrender @@ -199,14 +205,13 @@ instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where class Accept ctype => MimeUnrender ctype a where mimeUnrender :: Proxy ctype -> ByteString -> Either String a -class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where +class AllCTUnrender (list :: [*]) a where handleCTypeH :: Proxy list -> ByteString -- Content-Type header -> ByteString -- Request body -> Maybe (Either String a) -instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps - ) => AllCTUnrender ctyps a where +instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH) where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body @@ -247,8 +252,7 @@ instance ( MimeRender ctyp a where pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy (ctyp' ': ctyps) - -instance AllMimeRender '[] a where +instance AllMimeRender '[] () where allMimeRender _ _ = [] -------------------------------------------------------------------------- @@ -270,21 +274,25 @@ instance ( MimeUnrender ctyp a where pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy ctyps -type family IsNonEmpty (list :: [*]) :: Constraint where - IsNonEmpty (x ': xs) = () - - -------------------------------------------------------------------------- -- * MimeRender Instances -- | `encode` -instance ToJSON a => MimeRender JSON a where +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + ToJSON a => MimeRender JSON a where mimeRender _ = encode -- | @encodeFormUrlEncoded . toFormUrlEncoded@ -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- holds if every element of x is non-null (i.e., not @("", "")@) -instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + ToFormUrlEncoded a => MimeRender FormUrlEncoded a where mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded -- | `TextL.encodeUtf8` @@ -307,6 +315,26 @@ instance MimeRender OctetStream ByteString where instance MimeRender OctetStream BS.ByteString where mimeRender _ = fromStrict +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + MimeRender JSON () where + mimeRender _ _ = "" + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + MimeRender PlainText () where + mimeRender _ _ = "" + +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + MimeRender OctetStream () where + mimeRender _ _ = "" -------------------------------------------------------------------------- -- * MimeUnrender Instances diff --git a/servant/src/Servant/API/Delete.hs b/servant/src/Servant/API/Delete.hs deleted file mode 100644 index de792a28..00000000 --- a/servant/src/Servant/API/Delete.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Delete (Delete) where - -import Data.Typeable (Typeable) - --- | Combinator for DELETE requests. --- --- Example: --- --- >>> -- DELETE /books/:isbn --- >>> type MyApi = "books" :> Capture "isbn" Text :> Delete '[] () -data Delete (contentTypes :: [*]) a - deriving Typeable - - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Get.hs b/servant/src/Servant/API/Get.hs deleted file mode 100644 index 073bfda6..00000000 --- a/servant/src/Servant/API/Get.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Get (Get) where - -import Data.Typeable (Typeable) - --- | Endpoint for simple GET requests. Serves the result as JSON. --- --- Example: --- --- >>> type MyApi = "books" :> Get '[JSON] [Book] -data Get (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Patch.hs b/servant/src/Servant/API/Patch.hs deleted file mode 100644 index 715cf905..00000000 --- a/servant/src/Servant/API/Patch.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Patch (Patch) where - -import Data.Typeable (Typeable) - --- | Endpoint for PATCH requests. The type variable represents the type of the --- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for --- that). --- --- If the HTTP response is empty, only () is supported. --- --- Example: --- --- >>> -- PATCH /books --- >>> -- with a JSON encoded Book as the request body --- >>> -- returning the just-created Book --- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Patch '[JSON] Book -data Patch (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Post.hs b/servant/src/Servant/API/Post.hs deleted file mode 100644 index 72bc59cc..00000000 --- a/servant/src/Servant/API/Post.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Post (Post) where - -import Data.Typeable (Typeable) - --- | Endpoint for POST requests. The type variable represents the type of the --- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for --- that). --- --- Example: --- --- >>> -- POST /books --- >>> -- with a JSON encoded Book as the request body --- >>> -- returning the just-created Book --- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -data Post (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Put.hs b/servant/src/Servant/API/Put.hs deleted file mode 100644 index 0b09d961..00000000 --- a/servant/src/Servant/API/Put.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Put (Put) where - -import Data.Typeable (Typeable) - --- | Endpoint for PUT requests, usually used to update a ressource. --- The type @a@ is the type of the response body that's returned. --- --- Example: --- --- >>> -- PUT /books/:isbn --- >>> -- with a Book as request body, returning the updated Book --- >>> type MyApi = "books" :> Capture "isbn" Text :> ReqBody '[JSON] Book :> Put '[JSON] Book -data Put (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs new file mode 100644 index 00000000..9ab9c74c --- /dev/null +++ b/servant/src/Servant/API/Verbs.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +module Servant.API.Verbs where + +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import GHC.TypeLits (Nat) +import Network.HTTP.Types.Method (Method, StdMethod (..), + methodDelete, methodGet, methodHead, + methodPatch, methodPost, methodPut) + +-- | @Verb@ is a general type for representing HTTP verbs/methods. For +-- convenience, type synonyms for each verb with a 200 response code are +-- provided, but you are free to define your own: +-- +-- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a +data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) a + deriving (Typeable, Generic) + +-- 'GET' with 200 status code. +type Get contentTypes a = Verb 'GET 200 contentTypes a + +-- 'POST' with 200 status code. +type Post contentTypes a = Verb 'POST 200 contentTypes a + +-- 'PUT' with 200 status code. +type Put contentTypes a = Verb 'PUT 200 contentTypes a + +-- 'DELETE' with 200 status code. +type Delete contentTypes a = Verb 'DELETE 200 contentTypes a + +-- 'PATCH' with 200 status code. +type Patch contentTypes a = Verb 'PATCH 200 contentTypes a + +-- 'HEAD' with 200 status code. +type Head contentTypes a = Verb 'HEAD 200 contentTypes a + +class ReflectMethod a where + reflectMethod :: proxy a -> Method + +instance ReflectMethod 'GET where + reflectMethod _ = methodGet + +instance ReflectMethod 'POST where + reflectMethod _ = methodPost + +instance ReflectMethod 'PUT where + reflectMethod _ = methodPut + +instance ReflectMethod 'DELETE where + reflectMethod _ = methodDelete + +instance ReflectMethod 'PATCH where + reflectMethod _ = methodPatch + +instance ReflectMethod 'HEAD where + reflectMethod _ = methodHead diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index f218377f..38f791ec 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -74,7 +74,9 @@ -- >>> safeLink api bad_link -- ... -- Could not deduce (Or --- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int)) +-- (IsElem' +-- (Verb 'Network.HTTP.Types.Method.DELETE 200 '[JSON] ()) +-- (Verb 'Network.HTTP.Types.Method.GET 200 '[JSON] Int)) -- (IsElem' -- ("hello" :> Delete '[JSON] ()) -- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ())))) @@ -119,11 +121,7 @@ import Servant.API.Capture ( Capture ) import Servant.API.ReqBody ( ReqBody ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) import Servant.API.Header ( Header ) -import Servant.API.Get ( Get ) -import Servant.API.Post ( Post ) -import Servant.API.Put ( Put ) -import Servant.API.Patch ( Patch ) -import Servant.API.Delete ( Delete ) +import Servant.API.Verbs ( Verb ) import Servant.API.Sub ( type (:>) ) import Servant.API.Raw ( Raw ) import Servant.API.Alternative ( type (:<|>) ) @@ -177,11 +175,8 @@ type family IsElem endpoint api :: Constraint where IsElem sa (QueryParam x y :> sb) = IsElem sa sb IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryFlag x :> sb) = IsElem sa sb - IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct' - IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct' - IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct' - IsElem (Patch ct typ) (Patch ct' typ) = IsSubList ct ct' - IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct' + IsElem (Verb m s ct typ) (Verb m s ct' typ) + = IsSubList ct ct' IsElem e e = () IsElem e a = IsElem' e a @@ -303,24 +298,8 @@ instance HasLink sub => HasLink (Header sym a :> sub) where toLink _ = toLink (Proxy :: Proxy sub) -- Verb (terminal) instances -instance HasLink (Get y r) where - type MkLink (Get y r) = URI - toLink _ = linkURI - -instance HasLink (Post y r) where - type MkLink (Post y r) = URI - toLink _ = linkURI - -instance HasLink (Put y r) where - type MkLink (Put y r) = URI - toLink _ = linkURI - -instance HasLink (Patch y r) where - type MkLink (Patch y r) = URI - toLink _ = linkURI - -instance HasLink (Delete y r) where - type MkLink (Delete y r) = URI +instance HasLink (Verb m s ct a) where + type MkLink (Verb m s ct a) = URI toLink _ = linkURI instance HasLink Raw where From 190c75a364b38063bafa0f48351dc3358ceaee14 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 27 Dec 2015 02:00:31 +0100 Subject: [PATCH 011/180] Add descriptive type synonyms for success responses. --- servant/src/Servant/API/Verbs.hs | 128 ++++++++++++++++++++++++++++--- 1 file changed, 117 insertions(+), 11 deletions(-) diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs index 9ab9c74c..63232aa1 100644 --- a/servant/src/Servant/API/Verbs.hs +++ b/servant/src/Servant/API/Verbs.hs @@ -20,23 +20,129 @@ import Network.HTTP.Types.Method (Method, StdMethod (..), data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) a deriving (Typeable, Generic) --- 'GET' with 200 status code. +-- * 200 responses +-- +-- The 200 response is the workhorse of web servers, but also fairly generic. +-- When appropriate, you should prefer the more specific success combinators. +-- More information about the definitions of status codes can be found in +-- and +-- ; +-- the relevant information is summarily presented here. + +-- | 'GET' with 200 status code. type Get contentTypes a = Verb 'GET 200 contentTypes a - --- 'POST' with 200 status code. +-- | 'POST' with 200 status code. type Post contentTypes a = Verb 'POST 200 contentTypes a - --- 'PUT' with 200 status code. +-- | 'PUT' with 200 status code. type Put contentTypes a = Verb 'PUT 200 contentTypes a - --- 'DELETE' with 200 status code. +-- | 'DELETE' with 200 status code. type Delete contentTypes a = Verb 'DELETE 200 contentTypes a - --- 'PATCH' with 200 status code. +-- | 'PATCH' with 200 status code. type Patch contentTypes a = Verb 'PATCH 200 contentTypes a --- 'HEAD' with 200 status code. -type Head contentTypes a = Verb 'HEAD 200 contentTypes a +-- * Other responses + +-- ** 201 Created +-- +-- Indicates that a new resource has been created. The URI corresponding to the +-- resource should be given in the @Location@ header field. +-- +-- If the resource cannot be created immediately, use 'PostAccepted'. +-- +-- Consider using 'Servant.Utils.Links.safeLink' for the @Location@ header +-- field. + +-- | 'POST' with 201 status code. +-- +type Created contentTypes a = Verb 'POST 201 contentTypes a + + +-- ** 202 Accepted +-- +-- Indicates that the request has been accepted for processing, but the +-- processing has not yet completed. The status of the processing should be +-- included, as well as either a link to a status monitoring endpoint or an +-- estimate of when the processing will be finished. + +-- | 'GET' with 202 status code. +type GetAccepted contentTypes a = Verb 'GET 202 contentTypes a +-- | 'POST' with 202 status code. +type PostAccepted contentTypes a = Verb 'POST 202 contentTypes a +-- | 'DELETE' with 202 status code. +type DeleteAccepted contentTypes a = Verb 'DELETE 202 contentTypes a +-- | 'PATCH' with 202 status code. +type PatchAccepted contentTypes a = Verb 'PATCH 202 contentTypes a +-- | 'PUT' with 202 status code. +type PutAccepted contentTypes a = Verb 'PUT 202 contentTypes a + + +-- ** 203 Non-Authoritative Information +-- +-- Indicates that the request has been successfully processed, but the +-- information may come from a third-party. + +-- | 'GET' with 203 status code. +type GetNonAuthoritative contentTypes a = Verb 'GET 203 contentTypes a +-- | 'POST' with 203 status code. +type PostNonAuthoritative contentTypes a = Verb 'POST 203 contentTypes a +-- | 'DELETE' with 203 status code. +type DeleteNonAuthoritative contentTypes a = Verb 'DELETE 203 contentTypes a +-- | 'PATCH' with 203 status code. +type PatchNonAuthoritative contentTypes a = Verb 'PATCH 203 contentTypes a +-- | 'PUT' with 203 status code. +type PutNonAuthoritative contentTypes a = Verb 'PUT 203 contentTypes a + + +-- ** 204 No Content +-- +-- Indicates that no response body is being returned. Handlers for these must +-- return 'NoContent'. +-- +-- If the document view should be reset, use @205 Reset Content@. + +-- | 'GET' with 204 status code. +type GetNoContent contentTypes = Verb 'GET 204 contentTypes NoContent +-- | 'POST' with 204 status code. +type PostNoContent contentTypes = Verb 'POST 204 contentTypes NoContent +-- | 'DELETE' with 204 status code. +type DeleteNoContent contentTypes = Verb 'DELETE 204 contentTypes NoContent +-- | 'PATCH' with 204 status code. +type PatchNoContent contentTypes = Verb 'PATCH 204 contentTypes NoContent +-- | 'PUT' with 204 status code. +type PutNoContent contentTypes = Verb 'PUT 204 contentTypes NoContent + + +-- ** 205 Reset Content +-- +-- Indicates that no response body is being returned. Handlers for these must +-- return 'NoContent'. +-- +-- If the document view should not be reset, use @204 No Content@. + +-- | 'GET' with 205 status code. +type GetResetContent contentTypes = Verb 'GET 205 contentTypes NoContent +-- | 'POST' with 205 status code. +type PostResetContent contentTypes = Verb 'POST 205 contentTypes NoContent +-- | 'DELETE' with 205 status code. +type DeleteResetContent contentTypes = Verb 'DELETE 205 contentTypes NoContent +-- | 'PATCH' with 205 status code. +type PatchResetContent contentTypes = Verb 'PATCH 205 contentTypes NoContent +-- | 'PUT' with 205 status code. +type PutResetContent contentTypes = Verb 'PUT 205 contentTypes NoContent + + +-- ** 206 Partial Content +-- +-- Indicates that the server is delivering part of the resource due to a range +-- header in the request. +-- +-- For more information, see + +-- | 'GET' with 206 status code. +type GetPartialContent contentTypes = Verb 'GET 205 contentTypes NoContent + +data NoContent = NoContent class ReflectMethod a where reflectMethod :: proxy a -> Method From c6071bfb02de5815facf9acce4d4c7fbda7d92ef Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 27 Dec 2015 02:05:36 +0100 Subject: [PATCH 012/180] Don't override status code on empty body. --- servant-server/src/Servant/Server/Internal.hs | 1 - servant-server/test/Servant/ServerSpec.hs | 10 +++++----- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 5c08c4d4..4dcacb75 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -139,7 +139,6 @@ processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method -> Request -> RouteResult Response processMethodRouter handleA status method headers request = case handleA of Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does - Just (_, "") -> Route $ responseLBS status204 (fromMaybe [] headers) "" Just (contentT, body) -> Route $ responseLBS status hdrs bdy where bdy = if allowedMethodHead method request then "" else body diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index ad7a3556..0a45c70a 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -157,7 +157,7 @@ getSpec = do post "/empty" "" `shouldRespondWith` 405 it "returns headers" $ do - get "/emptyWithHeaders" `shouldRespondWith` 204 { matchHeaders = [ "H" <:> "5" ] } + get "/emptyWithHeaders" `shouldRespondWith` 200 { matchHeaders = [ "H" <:> "5" ] } it "returns 406 if the Accept header is not supported" $ do Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" @@ -407,16 +407,16 @@ headerSpec = describe "Servant.API.Header" $ do expectsString Nothing = error "Expected a string" with (return (serve headerApi expectsInt)) $ do - let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")] + let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")] it "passes the header to the handler (Int)" $ - delete' "/" "" `shouldRespondWith` 204 + delete' "/" "" `shouldRespondWith` 200 with (return (serve headerApi expectsString)) $ do - let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")] + let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")] it "passes the header to the handler (String)" $ - delete' "/" "" `shouldRespondWith` 204 + delete' "/" "" `shouldRespondWith` 200 type RawApi = "foo" :> Raw From 20ae7dcc316ea6b43312d5f47d174ac0c85689f1 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 27 Dec 2015 14:47:05 +0100 Subject: [PATCH 013/180] Update CHANGELOG for Verbs change. --- servant/CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index ddbe1a90..7890e0f1 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -7,6 +7,8 @@ HEAD * Use `http-api-data` instead of `Servant.Common.Text` * Remove matrix params. * Add PlainText String MimeRender and MimeUnrender instances. +* Add new `Verbs` combinator, and make all existing and new verb combinators +type synonyms of it. 0.4.2 ----- From 9b2d7a7b3829bceefe4823cd360330df2693e2e8 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 27 Dec 2015 16:30:22 +0100 Subject: [PATCH 014/180] Remove unnecesary () AllMimeRender instance. --- servant/src/Servant/API/ContentTypes.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index 85ddbb02..8e9c75ac 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -252,9 +252,6 @@ instance ( MimeRender ctyp a where pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy (ctyp' ': ctyps) -instance AllMimeRender '[] () where - allMimeRender _ _ = [] - -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeUnrender -------------------------------------------------------------------------- From 5909a6df7aa8764db805594d0e08a474a0d398a9 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 6 Jan 2016 17:17:14 +0100 Subject: [PATCH 015/180] Fix rebase issues. --- servant-docs/src/Servant/Docs/Internal.hs | 1 - servant-server/src/Servant/Server/Internal.hs | 1 - 2 files changed, 2 deletions(-) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 41754c31..17e0b10c 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -718,7 +718,6 @@ instance OVERLAPPING_ instance OVERLAPPABLE_ (ToSample a, AllMimeRender (ct ': cts) a) => HasDocs (Get (ct ': cts) a) where ->>>>>>> Simplify verb combinators. docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 4dcacb75..730e96d5 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -198,7 +198,6 @@ instance OVERLAPPABLE_ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) instance OVERLAPPING_ -instance ( AllCTRender ctypes a, ReflectMethod method, KnownNat status , GetHeaders (Headers h a) ) => HasServer (Verb method status ctypes (Headers h a)) where From 208bcf5986f0c9dd806ffc2f93eae7923d863a80 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 6 Jan 2016 17:31:40 +0100 Subject: [PATCH 016/180] Use Verb for servant-docs --- servant-docs/src/Servant/Docs.hs | 3 +- servant-docs/src/Servant/Docs/Internal.hs | 146 ++++------------------ servant-docs/test/Servant/DocsSpec.hs | 1 - 3 files changed, 23 insertions(+), 127 deletions(-) diff --git a/servant-docs/src/Servant/Docs.hs b/servant-docs/src/Servant/Docs.hs index 193b4e60..9805285f 100644 --- a/servant-docs/src/Servant/Docs.hs +++ b/servant-docs/src/Servant/Docs.hs @@ -41,8 +41,7 @@ module Servant.Docs , ToCapture(..) , -- * ADTs to represent an 'API' - Method(..) - , Endpoint, path, method, defEndpoint + Endpoint, path, method, defEndpoint , API, apiIntros, apiEndpoints, emptyAPI , DocCapture(..), capSymbol, capDesc , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 17e0b10c..0c3e30ac 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -36,7 +36,7 @@ import Data.Monoid import Data.Ord (comparing) import Data.Proxy (Proxy(Proxy)) import Data.String.Conversions (cs) -import Data.Text (Text, pack, unpack) +import Data.Text (Text, unpack) import GHC.Exts (Constraint) import GHC.Generics import GHC.TypeLits @@ -49,21 +49,6 @@ import qualified Data.Text as T import qualified Network.HTTP.Media as M import qualified Network.HTTP.Types as HTTP --- | Supported HTTP request methods -data Method = DocDELETE -- ^ the DELETE method - | DocGET -- ^ the GET method - | DocPOST -- ^ the POST method - | DocPUT -- ^ the PUT method - deriving (Eq, Ord, Generic) - -instance Show Method where - show DocGET = "GET" - show DocPOST = "POST" - show DocDELETE = "DELETE" - show DocPUT = "PUT" - -instance Hashable Method - -- | An 'Endpoint' type that holds the 'path' and the 'method'. -- -- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint' @@ -75,12 +60,12 @@ instance Hashable Method -- GET / -- λ> 'defEndpoint' & 'path' '<>~' ["foo"] -- GET /foo --- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST' +-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost' -- POST /foo -- @ data Endpoint = Endpoint - { _path :: [String] -- type collected - , _method :: Method -- type collected + { _path :: [String] -- type collected + , _method :: HTTP.Method -- type collected } deriving (Eq, Ord, Generic) instance Show Endpoint where @@ -94,7 +79,7 @@ showPath :: [String] -> String showPath [] = "/" showPath ps = concatMap ('/' :) ps --- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET' +-- | An 'Endpoint' whose path is `"/"` and whose method is @GET@ -- -- Here's how you can modify it: -- @@ -103,11 +88,11 @@ showPath ps = concatMap ('/' :) ps -- GET / -- λ> 'defEndpoint' & 'path' '<>~' ["foo"] -- GET /foo --- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST' +-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost' -- POST /foo -- @ defEndpoint :: Endpoint -defEndpoint = Endpoint [] DocGET +defEndpoint = Endpoint [] HTTP.methodGet instance Hashable Endpoint @@ -689,124 +674,37 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout) instance OVERLAPPABLE_ - (ToSample a, AllMimeRender (ct ': cts) a) - => HasDocs (Delete (ct ': cts) a) where + (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status + , ReflectMethod method) + => HasDocs (Verb method status (ct ': cts) a) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' - where endpoint' = endpoint & method .~ DocDELETE + where endpoint' = endpoint & method .~ method' action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t + & response.respStatus .~ status t = Proxy :: Proxy (ct ': cts) + method' = reflectMethod (Proxy :: Proxy method) + status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a instance OVERLAPPING_ - (ToSample a, AllMimeRender (ct ': cts) a - , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Delete (ct ': cts) (Headers ls a)) where + (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status + , ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls)) + => HasDocs (Verb method status (ct ': cts) (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocDELETE + where endpoint' = endpoint & method .~ method' action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t + & response.respStatus .~ status & response.respHeaders .~ hdrs t = Proxy :: Proxy (ct ': cts) - p = Proxy :: Proxy a - -instance OVERLAPPABLE_ - (ToSample a, AllMimeRender (ct ': cts) a) - => HasDocs (Get (ct ': cts) a) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where endpoint' = endpoint & method .~ DocGET - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - t = Proxy :: Proxy (ct ': cts) - p = Proxy :: Proxy a - -instance OVERLAPPING_ - (ToSample a, AllMimeRender (ct ': cts) a - , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Get (ct ': cts) (Headers ls a)) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocGET - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respHeaders .~ hdrs - t = Proxy :: Proxy (ct ': cts) - p = Proxy :: Proxy a - -instance (KnownSymbol sym, HasDocs sublayout) - => HasDocs (Header sym a :> sublayout) where - docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') - - where sublayoutP = Proxy :: Proxy sublayout - action' = over headers (|> headername) action - headername = pack $ symbolVal (Proxy :: Proxy sym) - -instance OVERLAPPABLE_ - (ToSample a, AllMimeRender (ct ': cts) a) - => HasDocs (Post (ct ': cts) a) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where endpoint' = endpoint & method .~ DocPOST - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respStatus .~ 201 - t = Proxy :: Proxy (ct ': cts) - p = Proxy :: Proxy a - -instance OVERLAPPING_ - (ToSample a, AllMimeRender (ct ': cts) a - , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Post (ct ': cts) (Headers ls a)) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocPOST - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respStatus .~ 201 - & response.respHeaders .~ hdrs - t = Proxy :: Proxy (ct ': cts) - p = Proxy :: Proxy a - -instance OVERLAPPABLE_ - (ToSample a, AllMimeRender (ct ': cts) a) - => HasDocs (Put (ct ': cts) a) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where endpoint' = endpoint & method .~ DocPUT - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respStatus .~ 200 - t = Proxy :: Proxy (ct ': cts) - p = Proxy :: Proxy a - -instance OVERLAPPING_ - ( ToSample a, AllMimeRender (ct ': cts) a, - AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Put (ct ': cts) (Headers ls a)) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocPUT - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respStatus .~ 200 - & response.respHeaders .~ hdrs - t = Proxy :: Proxy (ct ': cts) + hdrs = allHeaderToSample (Proxy :: Proxy ls) + method' = reflectMethod (Proxy :: Proxy method) + status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 5375b0c3..d37f78c9 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -71,7 +71,6 @@ spec = describe "Servant.Docs" $ do it "mentions status codes" $ do md `shouldContain` "Status code 200" - md `shouldContain` "Status code 201" it "mentions methods" $ do md `shouldContain` "POST" From bd77b4acba4a81608827bad72ac70e93cb13271c Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 6 Jan 2016 18:20:20 +0100 Subject: [PATCH 017/180] 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 From 574e9c48cdc7e22830e5f49f0a470d5b819b53cf Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 7 Jan 2016 13:44:08 +0100 Subject: [PATCH 018/180] Export all Verb methods. --- servant/src/Servant/API.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 2565149f..ff1e24ec 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -70,7 +70,22 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader), getHeadersHList, getResponse) import Servant.API.Sub ((:>)) import Servant.API.Vault (Vault) -import Servant.API.Verbs (Delete, Get, Patch, Post, Put, +import Servant.API.Verbs (Created, Delete, DeleteAccepted, + DeleteNoContent, + DeleteNonAuthoritative, Get, + GetAccepted, GetNoContent, + GetNonAuthoritative, + GetPartialContent, + GetResetContent, + NoContent (NoContent), Patch, + PatchAccepted, PatchNoContent, + PatchNoContent, + PatchNonAuthoritative, Post, + PostAccepted, PostNoContent, + PostNonAuthoritative, + PostResetContent, Put, + PutAccepted, PutNoContent, + PutNoContent, PutNonAuthoritative, ReflectMethod (reflectMethod), Verb) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', From 783a849c6741de37b5b09755a96f7ba5a843d8b1 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 7 Jan 2016 14:30:08 +0100 Subject: [PATCH 019/180] Make NoContent still take an arg. For consistency with other combinators, and to make using headers easier. --- servant-client/src/Servant/Client.hs | 14 +++--- servant-client/test/Servant/ClientSpec.hs | 12 ++--- servant-server/test/Servant/ServerSpec.hs | 24 +++++----- servant/src/Servant/API.hs | 4 +- servant/src/Servant/API/ContentTypes.hs | 58 ++++++++++------------- servant/src/Servant/API/Verbs.hs | 32 ++++++------- 6 files changed, 69 insertions(+), 75 deletions(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 4eac1b2d..c7dbeb80 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -129,10 +129,10 @@ instance OVERLAPPABLE_ where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ - (ReflectMethod method) => HasClient (Verb method status cts ()) where - type Client (Verb method status cts ()) = ExceptT ServantError IO () + (ReflectMethod method) => HasClient (Verb method status cts NoContent) where + type Client (Verb method status cts NoContent) = ExceptT ServantError IO NoContent clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody method req baseurl manager + performRequestNoBody method req baseurl manager >> return NoContent where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ @@ -150,13 +150,13 @@ instance OVERLAPPING_ instance OVERLAPPING_ ( BuildHeadersTo ls, ReflectMethod method - ) => HasClient (Verb method status cts (Headers ls ())) where - type Client (Verb method status cts (Headers ls ())) - = ExceptT ServantError IO (Headers ls ()) + ) => HasClient (Verb method status cts (Headers ls NoContent)) where + type Client (Verb method status cts (Headers ls NoContent)) + = ExceptT ServantError IO (Headers ls NoContent) clientWithRoute Proxy req baseurl manager = do let method = reflectMethod (Proxy :: Proxy method) hdrs <- performRequestNoBody method req baseurl manager - return $ Headers { getResponse = () + return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo hdrs } diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index e289873d..245a7216 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -90,7 +90,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] type Api = "get" :> Get '[JSON] Person - :<|> "deleteEmpty" :> Delete '[JSON] () + :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person @@ -105,14 +105,14 @@ type Api = ReqBody '[JSON] [(String, [Rational])] :> Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) - :<|> "deleteContentType" :> Delete '[JSON] () + :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent api :: Proxy Api api = Proxy server :: Application server = serve api ( return alice - :<|> return () + :<|> return NoContent :<|> (\ name -> return $ Person name 0) :<|> return :<|> (\ name -> case name of @@ -125,7 +125,7 @@ server = serve api ( :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) - :<|> return () + :<|> return NoContent ) @@ -157,11 +157,11 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do describe "Servant.API.Delete" $ do it "allows empty content type" $ \(_, baseUrl) -> do let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager - (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right () + (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do let getDeleteContentType = getLast $ client api baseUrl manager - (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right () + (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right NoContent it "Servant.API.Capture" $ \(_, baseUrl) -> do let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 0a45c70a..9bb5e340 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -38,8 +38,8 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete, HttpVersion, IsSecure (..), JSON, Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, - addHeader) + Raw, RemoteHost, ReqBody, GetNoContent, + PostNoContent, addHeader, NoContent(..)) import Servant.Server (Server, serve, ServantErr(..), err404) import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.Wai (get, liftIO, matchHeaders, @@ -130,9 +130,9 @@ captureSpec = do type GetApi = Get '[JSON] Person - :<|> "empty" :> Get '[JSON] () - :<|> "emptyWithHeaders" :> Get '[JSON] (Headers '[Header "H" Int] ()) - :<|> "post" :> Post '[JSON] () + :<|> "empty" :> GetNoContent '[JSON] NoContent + :<|> "emptyWithHeaders" :> GetNoContent '[JSON] (Headers '[Header "H" Int] NoContent) + :<|> "post" :> PostNoContent '[JSON] NoContent getApi :: Proxy GetApi getApi = Proxy @@ -141,9 +141,9 @@ getSpec :: Spec getSpec = do describe "Servant.API.Get" $ do let server = return alice - :<|> return () - :<|> return (addHeader 5 ()) - :<|> return () + :<|> return NoContent + :<|> return (addHeader 5 NoContent) + :<|> return NoContent with (return $ serve getApi server) $ do @@ -157,7 +157,7 @@ getSpec = do post "/empty" "" `shouldRespondWith` 405 it "returns headers" $ do - get "/emptyWithHeaders" `shouldRespondWith` 200 { matchHeaders = [ "H" <:> "5" ] } + get "/emptyWithHeaders" `shouldRespondWith` 204 { matchHeaders = [ "H" <:> "5" ] } it "returns 406 if the Accept header is not supported" $ do Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" @@ -168,9 +168,9 @@ headSpec :: Spec headSpec = do describe "Servant.API.Head" $ do let server = return alice - :<|> return () - :<|> return (addHeader 5 ()) - :<|> return () + :<|> return NoContent + :<|> return (addHeader 5 NoContent) + :<|> return NoContent with (return $ serve getApi server) $ do it "allows to GET a Person" $ do diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index ff1e24ec..2afae7af 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -52,7 +52,7 @@ import Servant.API.Alternative ((:<|>) (..)) import Servant.API.Capture (Capture) import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, FromFormUrlEncoded (..), JSON, - MimeRender (..), + MimeRender (..), NoContent (NoContent), MimeUnrender (..), OctetStream, PlainText, ToFormUrlEncoded (..)) import Servant.API.Header (Header (..)) @@ -77,7 +77,7 @@ import Servant.API.Verbs (Created, Delete, DeleteAccepted, GetNonAuthoritative, GetPartialContent, GetResetContent, - NoContent (NoContent), Patch, + Patch, PatchAccepted, PatchNoContent, PatchNoContent, PatchNonAuthoritative, Post, diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index 8e9c75ac..365381f7 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -11,11 +11,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif {-# OPTIONS_HADDOCK not-home #-} +#include "overlapping-compat.h" + -- | A collection of basic Content-Types (also known as Internet Media -- Types, or MIME types). Additionally, this module provides classes that -- encapsulate how to serialize or deserialize values to or from @@ -57,6 +56,9 @@ module Servant.API.ContentTypes , MimeRender(..) , MimeUnrender(..) + -- * NoContent + , NoContent(..) + -- * Internal , AcceptHeader(..) , AllCTRender(..) @@ -75,8 +77,7 @@ import Control.Applicative ((*>), (<*)) #endif import Control.Arrow (left) import Control.Monad -import Data.Aeson (FromJSON, ToJSON, encode, - parseJSON) +import Data.Aeson (FromJSON(..), ToJSON(..), encode) import Data.Aeson.Parser (value) import Data.Aeson.Types (parseEither) import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly, @@ -168,10 +169,7 @@ class (AllMime list) => AllCTRender (list :: [*]) a where -- mimetype). handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept where pctyps = Proxy :: Proxy (ct ': cts) @@ -275,20 +273,14 @@ instance ( MimeUnrender ctyp a -- * MimeRender Instances -- | `encode` -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ToJSON a => MimeRender JSON a where mimeRender _ = encode -- | @encodeFormUrlEncoded . toFormUrlEncoded@ -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- holds if every element of x is non-null (i.e., not @("", "")@) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ToFormUrlEncoded a => MimeRender FormUrlEncoded a where mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded @@ -312,25 +304,27 @@ instance MimeRender OctetStream ByteString where instance MimeRender OctetStream BS.ByteString where mimeRender _ = fromStrict -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - MimeRender JSON () where +-- | A type for responses with content-body. +data NoContent = NoContent + deriving (Show, Eq, Read) + +instance FromJSON NoContent where + parseJSON _ = return NoContent + +instance ToJSON NoContent where + toJSON _ = "" + + +instance OVERLAPPING_ + MimeRender JSON NoContent where mimeRender _ _ = "" -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - MimeRender PlainText () where +instance OVERLAPPING_ + MimeRender PlainText NoContent where mimeRender _ _ = "" -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - MimeRender OctetStream () where +instance OVERLAPPING_ + MimeRender OctetStream NoContent where mimeRender _ _ = "" -------------------------------------------------------------------------- diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs index 63232aa1..c1462503 100644 --- a/servant/src/Servant/API/Verbs.hs +++ b/servant/src/Servant/API/Verbs.hs @@ -11,6 +11,7 @@ import GHC.TypeLits (Nat) import Network.HTTP.Types.Method (Method, StdMethod (..), methodDelete, methodGet, methodHead, methodPatch, methodPost, methodPut) +import Servant.API.ContentTypes (NoContent(..)) -- | @Verb@ is a general type for representing HTTP verbs/methods. For -- convenience, type synonyms for each verb with a 200 response code are @@ -95,40 +96,40 @@ type PutNonAuthoritative contentTypes a = Verb 'PUT 203 contentTypes a -- ** 204 No Content -- --- Indicates that no response body is being returned. Handlers for these must --- return 'NoContent'. +-- Indicates that no response body is being returned. Handlers for these should +-- return 'NoContent', possibly with headers. -- -- If the document view should be reset, use @205 Reset Content@. -- | 'GET' with 204 status code. -type GetNoContent contentTypes = Verb 'GET 204 contentTypes NoContent +type GetNoContent contentTypes noContent = Verb 'GET 204 contentTypes noContent -- | 'POST' with 204 status code. -type PostNoContent contentTypes = Verb 'POST 204 contentTypes NoContent +type PostNoContent contentTypes noContent = Verb 'POST 204 contentTypes noContent -- | 'DELETE' with 204 status code. -type DeleteNoContent contentTypes = Verb 'DELETE 204 contentTypes NoContent +type DeleteNoContent contentTypes noContent = Verb 'DELETE 204 contentTypes noContent -- | 'PATCH' with 204 status code. -type PatchNoContent contentTypes = Verb 'PATCH 204 contentTypes NoContent +type PatchNoContent contentTypes noContent = Verb 'PATCH 204 contentTypes noContent -- | 'PUT' with 204 status code. -type PutNoContent contentTypes = Verb 'PUT 204 contentTypes NoContent +type PutNoContent contentTypes noContent = Verb 'PUT 204 contentTypes noContent -- ** 205 Reset Content -- --- Indicates that no response body is being returned. Handlers for these must --- return 'NoContent'. +-- Indicates that no response body is being returned. Handlers for these should +-- return 'NoContent', possibly with Headers. -- -- If the document view should not be reset, use @204 No Content@. -- | 'GET' with 205 status code. -type GetResetContent contentTypes = Verb 'GET 205 contentTypes NoContent +type GetResetContent contentTypes noContent = Verb 'GET 205 contentTypes noContent -- | 'POST' with 205 status code. -type PostResetContent contentTypes = Verb 'POST 205 contentTypes NoContent +type PostResetContent contentTypes noContent = Verb 'POST 205 contentTypes noContent -- | 'DELETE' with 205 status code. -type DeleteResetContent contentTypes = Verb 'DELETE 205 contentTypes NoContent +type DeleteResetContent contentTypes noContent = Verb 'DELETE 205 contentTypes noContent -- | 'PATCH' with 205 status code. -type PatchResetContent contentTypes = Verb 'PATCH 205 contentTypes NoContent +type PatchResetContent contentTypes noContent = Verb 'PATCH 205 contentTypes noContent -- | 'PUT' with 205 status code. -type PutResetContent contentTypes = Verb 'PUT 205 contentTypes NoContent +type PutResetContent contentTypes noContent = Verb 'PUT 205 contentTypes noContent -- ** 206 Partial Content @@ -140,9 +141,8 @@ type PutResetContent contentTypes = Verb 'PUT 205 contentTypes NoContent -- RFC7233 Section 4.1> -- | 'GET' with 206 status code. -type GetPartialContent contentTypes = Verb 'GET 205 contentTypes NoContent +type GetPartialContent contentTypes noContent = Verb 'GET 205 contentTypes noContent -data NoContent = NoContent class ReflectMethod a where reflectMethod :: proxy a -> Method From 32612c903c844903651f4cc87d802f8b41a63dc5 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 7 Jan 2016 17:18:46 +0100 Subject: [PATCH 020/180] Review fixes --- CONTRIBUTING.md | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 0c76f11f..335f6094 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -57,8 +57,9 @@ issue with the `news` tag (which we will close when we read it). As for adding them to the main repo: maintaining combinators can be expensive, since official combinators must have instances for all classes (and new classes come along fairly frequently). We therefore have to be quite selective about -those that we accept. If your considering writing a new combinator, open an -issue to discuss it first! +those that we accept. If you're considering writing a new combinator, open an +issue to discuss it first! (You could release your combinator as a separate +package, of course.) ## New classes @@ -75,6 +76,4 @@ the `news` label if you make a new package so we can know about it! We are currently moving to a more aggresive release policy, so that you can get what you contribute from Hackage fairly soon. However, note that prior to major -releases it may take some time in between releases. If you think you're change -is small enough that it should be backported to released major versions, say -so in the issue or PR. +releases it may take some time in between releases. From feef8caea2dea1f725e993ac4f69dcfb8a23ee80 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 7 Jan 2016 23:59:54 +0100 Subject: [PATCH 021/180] add servant/.ghci --- servant/.ghci | 1 + 1 file changed, 1 insertion(+) create mode 100644 servant/.ghci diff --git a/servant/.ghci b/servant/.ghci new file mode 100644 index 00000000..e5c6777e --- /dev/null +++ b/servant/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -Iinclude -optP-include -optPdist/build/autogen/cabal_macros.h From f1b6603c523008bdbbca029f9645c8bb07bbafed Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 8 Jan 2016 17:43:10 +0100 Subject: [PATCH 022/180] Review fixes --- servant-client/src/Servant/Client.hs | 3 +- servant-client/src/Servant/Common/Req.hs | 2 +- servant-server/test/Servant/ServerSpec.hs | 466 +++++++++++----------- servant/src/Servant/API.hs | 4 +- servant/src/Servant/API/ContentTypes.hs | 2 +- servant/src/Servant/API/Verbs.hs | 15 +- servant/src/Servant/Utils/Links.hs | 4 +- 7 files changed, 237 insertions(+), 259 deletions(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index c7dbeb80..e9bab748 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -24,7 +24,6 @@ module Servant.Client #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad import Control.Monad.Trans.Except import Data.ByteString.Lazy (ByteString) import Data.List @@ -420,6 +419,6 @@ It may seem to make more sense to have: But this means that if another instance exists that does *not* require non-empty lists, but is otherwise more specific, no instance will be overall -more specific. This in turns generally means adding yet another instance (one +more specific. This in turn generally means adding yet another instance (one for empty and one for non-empty lists). -} diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 32d572aa..3d72acd9 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -156,7 +156,7 @@ performRequest reqMethod req reqHost manager = do performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req -> BaseUrl -> Manager - -> ExceptT ServantError IO ([HTTP.Header], result) + -> ExceptT ServantError IO ([HTTP.Header], result) performRequestCT ct reqMethod req reqHost manager = do let acceptCT = contentType ct (_status, respBody, respCT, hdrs, _response) <- diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 9bb5e340..e4069b0f 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -3,8 +3,10 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} @@ -13,7 +15,7 @@ module Servant.ServerSpec where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad (forM_, when) +import Control.Monad (forM_, when, unless) import Control.Monad.Trans.Except (ExceptT, throwE) import Data.Aeson (FromJSON, ToJSON, decode', encode) import Data.ByteString.Conversion () @@ -23,82 +25,144 @@ import Data.String (fromString) import Data.String.Conversions (cs) import qualified Data.Text as T import GHC.Generics (Generic) -import Network.HTTP.Types (hAccept, hContentType, - methodDelete, methodGet, methodHead, - methodPatch, methodPost, methodPut, - ok200, parseQuery, Status(..)) +import Network.HTTP.Types (Status (..), hAccept, hContentType, + methodDelete, methodGet, + methodHead, methodPatch, + methodPost, methodPut, ok200, + parseQuery) import Network.Wai (Application, Request, pathInfo, queryString, rawQueryString, - responseLBS, responseBuilder) -import Network.Wai.Internal (Response(ResponseBuilder)) + responseBuilder, responseLBS) +import Network.Wai.Internal (Response (ResponseBuilder)) import Network.Wai.Test (defaultRequest, request, - runSession, simpleBody) + runSession, simpleBody, + simpleHeaders, simpleStatus) import Servant.API ((:<|>) (..), (:>), Capture, Delete, - Get, Header (..), Headers, - HttpVersion, IsSecure (..), JSON, - Patch, PlainText, Post, Put, + Get, Header (..), + Headers, HttpVersion, + IsSecure (..), JSON, + NoContent (..), Patch, PlainText, + Post, Put, QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, GetNoContent, - PostNoContent, addHeader, NoContent(..)) -import Servant.Server (Server, serve, ServantErr(..), err404) -import Test.Hspec (Spec, describe, it, shouldBe) + Raw, RemoteHost, ReqBody, + StdMethod (..), Verb, addHeader) +import Servant.Server (ServantErr (..), Server, err404, + serve) +import Test.Hspec (Spec, context, describe, it, + shouldBe, shouldContain) import Test.Hspec.Wai (get, liftIO, matchHeaders, - matchStatus, post, request, + matchStatus, request, shouldRespondWith, with, (<:>)) -import Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..)) + +import Servant.Server.Internal.RoutingApplication + (toApplication, RouteResult(..)) import Servant.Server.Internal.Router (tweakResponse, runRouter, Router, Router'(LeafRouter)) --- * test data types - -data Person = Person { - name :: String, - age :: Integer - } - deriving (Eq, Show, Generic) - -instance ToJSON Person -instance FromJSON Person - -alice :: Person -alice = Person "Alice" 42 - -data Animal = Animal { - species :: String, - numberOfLegs :: Integer - } - deriving (Eq, Show, Generic) - -instance ToJSON Animal -instance FromJSON Animal - -jerry :: Animal -jerry = Animal "Mouse" 4 - -tweety :: Animal -tweety = Animal "Bird" 2 - - --- * specs +-- * Specs spec :: Spec spec = do + verbSpec captureSpec - getSpec - headSpec - postSpec - putSpec - patchSpec queryParamSpec + reqBodySpec headerSpec rawSpec - unionSpec - routerSpec + alternativeSpec responseHeadersSpec - miscReqCombinatorsSpec + routerSpec + miscCombinatorSpec +------------------------------------------------------------------------------ +-- * verbSpec {{{ +------------------------------------------------------------------------------ + +type VerbApi method status + = Verb method status '[JSON] Person + :<|> "noContent" :> Verb method status '[JSON] NoContent + :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person) + :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent) + +verbSpec :: Spec +verbSpec = describe "Servant.API.Verb" $ do + let server :: Server (VerbApi method status) + server = return alice + :<|> return NoContent + :<|> return (addHeader 5 alice) + :<|> return (addHeader 10 NoContent) + get200 = Proxy :: Proxy (VerbApi 'GET 200) + post210 = Proxy :: Proxy (VerbApi 'POST 210) + put203 = Proxy :: Proxy (VerbApi 'PUT 203) + delete280 = Proxy :: Proxy (VerbApi 'DELETE 280) + patch214 = Proxy :: Proxy (VerbApi 'PATCH 214) + wrongMethod m = if m == methodPatch then methodPost else methodPatch + test desc api method (status :: Int) = context desc $ + + with (return $ serve api server) $ do + + -- HEAD and 214/215 need not return bodies + unless (status `elem` [214, 215] || method == methodHead) $ + it "returns the person" $ do + response <- Test.Hspec.Wai.request method "/" [] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + liftIO $ decode' (simpleBody response) `shouldBe` Just alice + + it "returns no content on NoContent" $ do + response <- Test.Hspec.Wai.request method "/noContent" [] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + liftIO $ simpleBody response `shouldBe` "" + + -- HEAD should not return body + when (method == methodHead) $ + it "HEAD returns no content body" $ do + response <- Test.Hspec.Wai.request method "/" [] "" + liftIO $ simpleBody response `shouldBe` "" + + it "throws 405 on wrong method " $ do + Test.Hspec.Wai.request (wrongMethod method) "/" [] "" + `shouldRespondWith` 405 + + it "returns headers" $ do + response1 <- Test.Hspec.Wai.request method "/header" [] "" + liftIO $ statusCode (simpleStatus response1) `shouldBe` status + liftIO $ simpleHeaders response1 `shouldContain` [("H", "5")] + + response2 <- Test.Hspec.Wai.request method "/header" [] "" + liftIO $ statusCode (simpleStatus response2) `shouldBe` status + liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")] + + it "handles trailing '/' gracefully" $ do + response <- Test.Hspec.Wai.request method "/headerNC/" [] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + + it "returns 406 if the Accept header is not supported" $ do + Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" + `shouldRespondWith` 406 + + it "responds if the Accept header is supported" $ do + response <- Test.Hspec.Wai.request method "" + [(hAccept, "application/json")] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + + it "sets the Content-Type header" $ do + response <- Test.Hspec.Wai.request method "" [] "" + liftIO $ simpleHeaders response `shouldContain` + [("Content-Type", "application/json")] + + test "GET 200" get200 methodGet 200 + test "POST 210" post210 methodPost 210 + test "PUT 203" put203 methodPut 203 + test "DELETE 280" delete280 methodDelete 280 + test "PATCH 214" patch214 methodPatch 214 + test "GET 200 with HEAD" get200 methodHead 200 + +-- }}} +------------------------------------------------------------------------------ +-- * captureSpec {{{ +------------------------------------------------------------------------------ type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal captureApi :: Proxy CaptureApi @@ -128,68 +192,10 @@ captureSpec = do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) - -type GetApi = Get '[JSON] Person - :<|> "empty" :> GetNoContent '[JSON] NoContent - :<|> "emptyWithHeaders" :> GetNoContent '[JSON] (Headers '[Header "H" Int] NoContent) - :<|> "post" :> PostNoContent '[JSON] NoContent - -getApi :: Proxy GetApi -getApi = Proxy - -getSpec :: Spec -getSpec = do - describe "Servant.API.Get" $ do - let server = return alice - :<|> return NoContent - :<|> return (addHeader 5 NoContent) - :<|> return NoContent - - with (return $ serve getApi server) $ do - - it "allows to GET a Person" $ do - response <- get "/" - return response `shouldRespondWith` 200 - liftIO $ decode' (simpleBody response) `shouldBe` Just alice - - it "throws 405 (wrong method) on POSTs" $ do - post "/" "" `shouldRespondWith` 405 - post "/empty" "" `shouldRespondWith` 405 - - it "returns headers" $ do - get "/emptyWithHeaders" `shouldRespondWith` 204 { matchHeaders = [ "H" <:> "5" ] } - - it "returns 406 if the Accept header is not supported" $ do - Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" - `shouldRespondWith` 406 - - -headSpec :: Spec -headSpec = do - describe "Servant.API.Head" $ do - let server = return alice - :<|> return NoContent - :<|> return (addHeader 5 NoContent) - :<|> return NoContent - with (return $ serve getApi server) $ do - - it "allows to GET a Person" $ do - response <- Test.Hspec.Wai.request methodHead "/" [] "" - return response `shouldRespondWith` 200 - liftIO $ decode' (simpleBody response) `shouldBe` (Nothing :: Maybe Person) - - it "does not allow HEAD to POST route" $ do - response <- Test.Hspec.Wai.request methodHead "/post" [] "" - return response `shouldRespondWith` 405 - - it "throws 405 (wrong method) on POSTs" $ do - post "/" "" `shouldRespondWith` 405 - post "/empty" "" `shouldRespondWith` 405 - - it "returns 406 if the Accept header is not supported" $ do - Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] "" - `shouldRespondWith` 406 - +-- }}} +------------------------------------------------------------------------------ +-- * queryParamSpec {{{ +------------------------------------------------------------------------------ type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person @@ -274,122 +280,41 @@ queryParamSpec = do name = "Alice" } -type PostApi = - ReqBody '[JSON] Person :> Post '[JSON] Integer - :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer - :<|> "empty" :> Post '[JSON] () +-- }}} +------------------------------------------------------------------------------ +-- * reqBodySpec {{{ +------------------------------------------------------------------------------ +type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person + :<|> "blah" :> ReqBody '[JSON] Person :> Put '[JSON] Integer -postApi :: Proxy PostApi -postApi = Proxy +reqBodyApi :: Proxy ReqBodyApi +reqBodyApi = Proxy -postSpec :: Spec -postSpec = do - describe "Servant.API.Post and .ReqBody" $ do - let server = return . age :<|> return . age :<|> return () - with (return $ serve postApi server) $ do - let post' x = Test.Hspec.Wai.request methodPost x [(hContentType - , "application/json;charset=utf-8")] +reqBodySpec :: Spec +reqBodySpec = describe "Servant.API.ReqBody" $ do - it "allows to POST a Person" $ do - post' "/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } + let server :: Server ReqBodyApi + server = return :<|> return . age + mkReq method x = Test.Hspec.Wai.request method x + [(hContentType, "application/json;charset=utf-8")] - it "allows alternative routes if all have request bodies" $ do - post' "/bla" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } + with (return $ serve reqBodyApi server) $ do - it "handles trailing '/' gracefully" $ do - post' "/bla/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } + it "passes the argument to the handler" $ do + response <- mkReq methodPost "" (encode alice) + liftIO $ decode' (simpleBody response) `shouldBe` Just alice - it "correctly rejects invalid request bodies with status 400" $ do - post' "/" "some invalid body" `shouldRespondWith` 400 + it "rejects invalid request bodies with status 400" $ do + mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400 - it "responds with 415 if the request body media type is unsupported" $ do - let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType - , "application/nonsense")] - post'' "/" "anything at all" `shouldRespondWith` 415 + it "responds with 415 if the request body media type is unsupported" $ do + Test.Hspec.Wai.request methodPost "/" + [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415 -type PutApi = - ReqBody '[JSON] Person :> Put '[JSON] Integer - :<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer - :<|> "empty" :> Put '[JSON] () - -putApi :: Proxy PutApi -putApi = Proxy - -putSpec :: Spec -putSpec = do - describe "Servant.API.Put and .ReqBody" $ do - let server = return . age :<|> return . age :<|> return () - with (return $ serve putApi server) $ do - let put' x = Test.Hspec.Wai.request methodPut x [(hContentType - , "application/json;charset=utf-8")] - - it "allows to put a Person" $ do - put' "/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "allows alternative routes if all have request bodies" $ do - put' "/bla" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "handles trailing '/' gracefully" $ do - put' "/bla/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "correctly rejects invalid request bodies with status 400" $ do - put' "/" "some invalid body" `shouldRespondWith` 400 - - it "responds with 415 if the request body media type is unsupported" $ do - let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType - , "application/nonsense")] - put'' "/" "anything at all" `shouldRespondWith` 415 - -type PatchApi = - ReqBody '[JSON] Person :> Patch '[JSON] Integer - :<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer - :<|> "empty" :> Patch '[JSON] () - -patchApi :: Proxy PatchApi -patchApi = Proxy - -patchSpec :: Spec -patchSpec = do - describe "Servant.API.Patch and .ReqBody" $ do - let server = return . age :<|> return . age :<|> return () - with (return $ serve patchApi server) $ do - let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType - , "application/json;charset=utf-8")] - - it "allows to patch a Person" $ do - patch' "/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "allows alternative routes if all have request bodies" $ do - patch' "/bla" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "handles trailing '/' gracefully" $ do - patch' "/bla/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "correctly rejects invalid request bodies with status 400" $ do - patch' "/" "some invalid body" `shouldRespondWith` 400 - - it "responds with 415 if the request body media type is unsupported" $ do - let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType - , "application/nonsense")] - patch'' "/" "anything at all" `shouldRespondWith` 415 +-- }}} +------------------------------------------------------------------------------ +-- * headerSpec {{{ +------------------------------------------------------------------------------ type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] () headerApi :: Proxy (HeaderApi a) @@ -418,12 +343,19 @@ headerSpec = describe "Servant.API.Header" $ do it "passes the header to the handler (String)" $ delete' "/" "" `shouldRespondWith` 200 +-- }}} +------------------------------------------------------------------------------ +-- * rawSpec {{{ +------------------------------------------------------------------------------ type RawApi = "foo" :> Raw + rawApi :: Proxy RawApi rawApi = Proxy + rawApplication :: Show a => (Request -> a) -> Application -rawApplication f request_ respond = respond $ responseLBS ok200 [] (cs $ show $ f request_) +rawApplication f request_ respond = respond $ responseLBS ok200 [] + (cs $ show $ f request_) rawSpec :: Spec rawSpec = do @@ -444,7 +376,10 @@ rawSpec = do liftIO $ do simpleBody response `shouldBe` cs (show ["bar" :: String]) - +-- }}} +------------------------------------------------------------------------------ +-- * alternativeSpec {{{ +------------------------------------------------------------------------------ type AlternativeApi = "foo" :> Get '[JSON] Person :<|> "bar" :> Get '[JSON] Animal @@ -452,11 +387,12 @@ type AlternativeApi = :<|> "bar" :> Post '[JSON] Animal :<|> "bar" :> Put '[JSON] Animal :<|> "bar" :> Delete '[JSON] () -unionApi :: Proxy AlternativeApi -unionApi = Proxy -unionServer :: Server AlternativeApi -unionServer = +alternativeApi :: Proxy AlternativeApi +alternativeApi = Proxy + +alternativeServer :: Server AlternativeApi +alternativeServer = return alice :<|> return jerry :<|> return "a string" @@ -464,10 +400,10 @@ unionServer = :<|> return jerry :<|> return () -unionSpec :: Spec -unionSpec = do +alternativeSpec :: Spec +alternativeSpec = do describe "Servant.API.Alternative" $ do - with (return $ serve unionApi unionServer) $ do + with (return $ serve alternativeApi alternativeServer) $ do it "unions endpoints" $ do response <- get "/foo" @@ -484,7 +420,10 @@ unionSpec = do it "returns 404 if the path does not exist" $ do get "/nonexistent" `shouldRespondWith` 404 - +-- }}} +------------------------------------------------------------------------------ +-- * responseHeaderSpec {{{ +------------------------------------------------------------------------------ type ResponseHeadersApi = Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) :<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) @@ -501,26 +440,29 @@ responseHeadersSpec :: Spec responseHeadersSpec = describe "ResponseHeaders" $ do with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do - let methods = [(methodGet, 200), (methodPost, 200), (methodPut, 200), (methodPatch, 200)] + let methods = [methodGet, methodPost, methodPut, methodPatch] it "includes the headers in the response" $ - forM_ methods $ \(method, expected) -> + forM_ methods $ \method -> Test.Hspec.Wai.request method "/" [] "" `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"] - , matchStatus = expected + , matchStatus = 200 } it "responds with not found for non-existent endpoints" $ - forM_ methods $ \(method,_) -> + forM_ methods $ \method -> Test.Hspec.Wai.request method "blahblah" [] "" `shouldRespondWith` 404 it "returns 406 if the Accept header is not supported" $ - forM_ methods $ \(method,_) -> + forM_ methods $ \method -> Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" `shouldRespondWith` 406 - +-- }}} +------------------------------------------------------------------------------ +-- * routerSpec {{{ +------------------------------------------------------------------------------ routerSpec :: Spec routerSpec = do describe "Servant.Server.Internal.Router" $ do @@ -539,6 +481,10 @@ routerSpec = do it "calls f on route result" $ do get "" `shouldRespondWith` 202 +-- }}} +------------------------------------------------------------------------------ +-- * miscCombinatorSpec {{{ +------------------------------------------------------------------------------ type MiscCombinatorsAPI = "version" :> HttpVersion :> Get '[JSON] String :<|> "secure" :> IsSecure :> Get '[JSON] String @@ -557,8 +503,8 @@ miscServ = versionHandler secureHandler NotSecure = return "not secure" hostHandler = return . show -miscReqCombinatorsSpec :: Spec -miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $ +miscCombinatorSpec :: Spec +miscCombinatorSpec = with (return $ serve miscApi miscServ) $ describe "Misc. combinators for request inspection" $ do it "Successfully gets the HTTP version specified in the request" $ go "/version" "\"HTTP/1.0\"" @@ -570,3 +516,35 @@ miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $ go "/host" "\"0.0.0.0:0\"" where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res +-- }}} +------------------------------------------------------------------------------ +-- * Test data types {{{ +------------------------------------------------------------------------------ + +data Person = Person { + name :: String, + age :: Integer + } + deriving (Eq, Show, Generic) + +instance ToJSON Person +instance FromJSON Person + +alice :: Person +alice = Person "Alice" 42 + +data Animal = Animal { + species :: String, + numberOfLegs :: Integer + } + deriving (Eq, Show, Generic) + +instance ToJSON Animal +instance FromJSON Animal + +jerry :: Animal +jerry = Animal "Mouse" 4 + +tweety :: Animal +tweety = Animal "Bird" 2 +-- }}} diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 2afae7af..03051533 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -70,7 +70,7 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader), getHeadersHList, getResponse) import Servant.API.Sub ((:>)) import Servant.API.Vault (Vault) -import Servant.API.Verbs (Created, Delete, DeleteAccepted, +import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted, DeleteNoContent, DeleteNonAuthoritative, Get, GetAccepted, GetNoContent, @@ -87,7 +87,7 @@ import Servant.API.Verbs (Created, Delete, DeleteAccepted, PutAccepted, PutNoContent, PutNoContent, PutNonAuthoritative, ReflectMethod (reflectMethod), - Verb) + Verb, StdMethod(..)) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', URI (..), safeLink) import Web.HttpApiData (FromHttpApiData (..), diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index 365381f7..c7776aa9 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -304,7 +304,7 @@ instance MimeRender OctetStream ByteString where instance MimeRender OctetStream BS.ByteString where mimeRender _ = fromStrict --- | A type for responses with content-body. +-- | A type for responses without content-body. data NoContent = NoContent deriving (Show, Eq, Read) diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs index c1462503..4915fdaf 100644 --- a/servant/src/Servant/API/Verbs.hs +++ b/servant/src/Servant/API/Verbs.hs @@ -3,17 +3,20 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} -module Servant.API.Verbs where +module Servant.API.Verbs + ( module Servant.API.Verbs + , StdMethod(GET, POST, HEAD, PUT, DELETE, TRACE, CONNECT, OPTIONS, PATCH) + ) where import Data.Typeable (Typeable) +import Data.Proxy (Proxy) import GHC.Generics (Generic) import GHC.TypeLits (Nat) import Network.HTTP.Types.Method (Method, StdMethod (..), methodDelete, methodGet, methodHead, methodPatch, methodPost, methodPut) -import Servant.API.ContentTypes (NoContent(..)) --- | @Verb@ is a general type for representing HTTP verbs/methods. For +-- | @Verb@ is a general type for representing HTTP verbs (a.k.a. methods). For -- convenience, type synonyms for each verb with a 200 response code are -- provided, but you are free to define your own: -- @@ -55,7 +58,7 @@ type Patch contentTypes a = Verb 'PATCH 200 contentTypes a -- | 'POST' with 201 status code. -- -type Created contentTypes a = Verb 'POST 201 contentTypes a +type PostCreated contentTypes a = Verb 'POST 201 contentTypes a -- ** 202 Accepted @@ -141,11 +144,11 @@ type PutResetContent contentTypes noContent = Verb 'PUT 205 contentTypes noConte -- RFC7233 Section 4.1> -- | 'GET' with 206 status code. -type GetPartialContent contentTypes noContent = Verb 'GET 205 contentTypes noContent +type GetPartialContent contentTypes noContent = Verb 'GET 206 contentTypes noContent class ReflectMethod a where - reflectMethod :: proxy a -> Method + reflectMethod :: Proxy a -> Method instance ReflectMethod 'GET where reflectMethod _ = methodGet diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 38f791ec..d83ffc7e 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -74,9 +74,7 @@ -- >>> safeLink api bad_link -- ... -- Could not deduce (Or --- (IsElem' --- (Verb 'Network.HTTP.Types.Method.DELETE 200 '[JSON] ()) --- (Verb 'Network.HTTP.Types.Method.GET 200 '[JSON] Int)) +-- (IsElem' (Verb 'DELETE 200 '[JSON] ()) (Verb 'GET 200 '[JSON] Int)) -- (IsElem' -- ("hello" :> Delete '[JSON] ()) -- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ())))) From f9c61379c04d436fc9e1353f61c46740c6eac272 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 8 Jan 2016 19:33:36 +0100 Subject: [PATCH 023/180] Refactor NoContent logic. Now MimeRender and MimeUnrender instances are not needed. --- servant/src/Servant/API/ContentTypes.hs | 36 +++++++++++-------------- 1 file changed, 16 insertions(+), 20 deletions(-) diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index c7776aa9..61bf1ce9 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -238,11 +238,12 @@ class (AllMime list) => AllMimeRender (list :: [*]) a where -> a -- value to serialize -> [(M.MediaType, ByteString)] -- content-types/response pairs -instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where +instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)] where pctyp = Proxy :: Proxy ctyp -instance ( MimeRender ctyp a +instance OVERLAPPABLE_ + ( MimeRender ctyp a , AllMimeRender (ctyp' ': ctyps) a ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where allMimeRender _ a = (contentType pctyp, mimeRender pctyp a) @@ -250,6 +251,19 @@ instance ( MimeRender ctyp a where pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy (ctyp' ': ctyps) + +-- Ideally we would like to declare a 'MimeRender a NoContent' instance, and +-- then this would be taken care of. However there is no more specific instance +-- between that and 'MimeRender JSON a', so we do this instead +instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where + allMimeRender _ _ = [(contentType pctyp, "")] + where pctyp = Proxy :: Proxy ctyp + +instance OVERLAPPING_ + ( AllMime (ctyp ': ctyp' ': ctyps) + ) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where + allMimeRender p _ = zip (allMime p) (repeat "") + -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeUnrender -------------------------------------------------------------------------- @@ -308,24 +322,6 @@ instance MimeRender OctetStream BS.ByteString where data NoContent = NoContent deriving (Show, Eq, Read) -instance FromJSON NoContent where - parseJSON _ = return NoContent - -instance ToJSON NoContent where - toJSON _ = "" - - -instance OVERLAPPING_ - MimeRender JSON NoContent where - mimeRender _ _ = "" - -instance OVERLAPPING_ - MimeRender PlainText NoContent where - mimeRender _ _ = "" - -instance OVERLAPPING_ - MimeRender OctetStream NoContent where - mimeRender _ _ = "" -------------------------------------------------------------------------- -- * MimeUnrender Instances From 37afddf3a2a231e424dda74b063babf4d1bdccbf Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 11 Jan 2016 13:37:20 +0100 Subject: [PATCH 024/180] Re-add missing Header instance for docs. --- servant-docs/src/Servant/Docs/Internal.hs | 9 +++++++++ servant-docs/test/Servant/DocsSpec.hs | 6 ++++++ 2 files changed, 15 insertions(+) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 0c3e30ac..8167d667 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -707,6 +707,15 @@ instance OVERLAPPING_ status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a +instance (KnownSymbol sym, HasDocs sublayout) + => HasDocs (Header sym a :> sublayout) where + docsFor Proxy (endpoint, action) = + docsFor sublayoutP (endpoint, action') + + where sublayoutP = Proxy :: Proxy sublayout + action' = over headers (|> headername) action + headername = T.pack $ symbolVal (Proxy :: Proxy sym) + instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) => HasDocs (QueryParam sym a :> sublayout) where diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index d37f78c9..703ea795 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -63,6 +63,7 @@ spec = describe "Servant.Docs" $ do , ("zwei, kaks, kaks",(TT2,UT2,UT2)) ] + where tests md = do it "mentions supported content-types" $ do @@ -76,11 +77,15 @@ spec = describe "Servant.Docs" $ do md `shouldContain` "POST" md `shouldContain` "GET" + it "mentions headers" $ do + md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header." + it "contains response samples" $ md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}" it "contains request body samples" $ md `shouldContain` "17" + -- * APIs data Datatype1 = Datatype1 { dt1field1 :: String @@ -103,6 +108,7 @@ instance MimeRender PlainText Int where type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int) :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1 + :<|> Header "X-Test" Int :> Put '[JSON] Int data TT = TT1 | TT2 deriving (Show, Eq) data UT = UT1 | UT2 deriving (Show, Eq) From 7f9758314e0c4316c43e450b84435668d65d2485 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 13 Jan 2016 17:06:20 +0100 Subject: [PATCH 025/180] Build mock example by default. So that CI reports errors. --- servant-mock/servant-mock.cabal | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 7d8589d0..af444527 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -18,8 +18,7 @@ cabal-version: >=1.10 flag example description: Build the example too - manual: True - default: False + default: True library exposed-modules: From 5a7fe7662911ebe0bfa2bfcd0c2fc27d0e8c7f3f Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 13 Jan 2016 17:32:57 +0100 Subject: [PATCH 026/180] Add polykinds to servant-mock --- servant-mock/src/Servant/Mock.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index e4437fba..7d17dca5 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} From c6e0ccbc2fe133cca35d5098351fd00a653cb313 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 14 Jan 2016 23:58:48 +0100 Subject: [PATCH 027/180] server/docs: fix formatting inconsistency --- servant-server/src/Servant/Server.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index a26941ea..b847ede3 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -63,7 +63,7 @@ module Servant.Server , err415 , err416 , err417 - -- * 5XX + -- ** 5XX , err500 , err501 , err502 From cd101e6b23f099e720416711eec11c0907776e64 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 15 Jan 2016 11:40:56 +0100 Subject: [PATCH 028/180] Fix maintainer's @ --- CONTRIBUTING.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 335f6094..4fa60c27 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -44,7 +44,7 @@ to reopen when the issues have been fixed). We require two +1 from the maintainers of the repo. If you feel like there has not been a timely response to a PR, you can ping the Maintainers group (with -`@Maintainers`). +`@haskell-servant/maintainers`). ## New combinators From 3bc4e17309ab2eab47e20db3869a1264755c4fc0 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 15 Jan 2016 11:50:00 +0100 Subject: [PATCH 029/180] How to report security issues. --- CONTRIBUTING.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 335f6094..f0cdd2eb 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -77,3 +77,10 @@ the `news` label if you make a new package so we can know about it! We are currently moving to a more aggresive release policy, so that you can get what you contribute from Hackage fairly soon. However, note that prior to major releases it may take some time in between releases. + +## Reporting security issues + +Please email haskell-servant-maintainers AT googlegroups DOT com. This group is +private, and accessible only to known maintainers. We will then discuss how to +proceed. Please do not make the issue public before we inform you that we have +a patch ready. From 641431d5b2da713d515e5024a8b4a9c9a7df54d6 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 15 Jan 2016 12:17:48 +0100 Subject: [PATCH 030/180] Fix extra quotes in Verb headers for docs. Fixes #325. --- servant-docs/src/Servant/Docs/Internal.hs | 3 ++- servant-docs/test/Servant/DocsSpec.hs | 6 +++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 8167d667..2b4db3eb 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -27,6 +27,7 @@ import Control.Lens (makeLenses, over, traversed, (%~), import qualified Control.Monad.Omega as Omega import Data.ByteString.Conversion (ToByteString, toByteString) import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BSC import qualified Data.CaseInsensitive as CI import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) @@ -522,7 +523,7 @@ markdown api = unlines $ responseStr (action ^. response) ++ [] - where str = "## " ++ show (endpoint^.method) + where str = "## " ++ BSC.unpack (endpoint^.method) ++ " " ++ showPath (endpoint^.path) introsStr :: [DocIntro] -> [String] diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 703ea795..2c7e87b0 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -73,9 +73,9 @@ spec = describe "Servant.Docs" $ do it "mentions status codes" $ do md `shouldContain` "Status code 200" - it "mentions methods" $ do - md `shouldContain` "POST" - md `shouldContain` "GET" + it "has methods as section headers" $ do + md `shouldContain` "## POST" + md `shouldContain` "## GET" it "mentions headers" $ do md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header." From e5974ec94d33bd6fce3a993a00ea2500eb67177b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sat, 16 Jan 2016 19:17:46 +0100 Subject: [PATCH 031/180] add ComprehensiveAPI to test whether we're missing instances Some of the combinators are commented atm, because we *are* missing combinators. --- servant-client/test/Servant/ClientSpec.hs | 3 ++ servant-docs/test/Servant/DocsSpec.hs | 18 ++++++++++- servant-js/test/Servant/JSSpec.hs | 7 ++++ servant-mock/servant-mock.cabal | 15 +++++++++ servant-mock/test/Servant/MockSpec.hs | 12 +++++++ servant-mock/test/Spec.hs | 1 + servant-server/test/Servant/ServerSpec.hs | 4 +++ servant/servant.cabal | 1 + .../API/Internal/Test/ComprehensiveAPI.hs | 32 +++++++++++++++++++ 9 files changed, 92 insertions(+), 1 deletion(-) create mode 100644 servant-mock/test/Servant/MockSpec.hs create mode 100644 servant-mock/test/Spec.hs create mode 100644 servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 245a7216..06cf7caa 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -49,9 +49,12 @@ import Test.HUnit import Test.QuickCheck import Servant.API +import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client import Servant.Server +_ = client comprehensiveAPI + spec :: Spec spec = describe "Servant.Client" $ do sucessSpec diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 2c7e87b0..e49aeaa1 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} @@ -18,8 +18,24 @@ import GHC.Generics import Test.Hspec import Servant.API +import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Docs.Internal +-- * comprehensive api + +_ = docs comprehensiveAPI + +instance ToParam (QueryParam "foo" Int) where + toParam = error "unused" +instance ToParam (QueryParams "foo" Int) where + toParam = error "unused" +instance ToParam (QueryFlag "foo") where + toParam = error "unused" +instance ToCapture (Capture "foo" Int) where + toCapture = error "unused" + +-- * specs + spec :: Spec spec = describe "Servant.Docs" $ do diff --git a/servant-js/test/Servant/JSSpec.hs b/servant-js/test/Servant/JSSpec.hs index 23fe4326..4249e930 100644 --- a/servant-js/test/Servant/JSSpec.hs +++ b/servant-js/test/Servant/JSSpec.hs @@ -21,6 +21,7 @@ import qualified Data.Text as T import Language.ECMAScript3.Parser (program, parse) import Test.Hspec hiding (shouldContain, shouldNotContain) +import Servant.API.Internal.Test.ComprehensiveAPI import Servant.JS import Servant.JS.Internal import qualified Servant.JS.Angular as NG @@ -29,6 +30,12 @@ import qualified Servant.JS.JQuery as JQ import qualified Servant.JS.Vanilla as JS import Servant.JSSpec.CustomHeaders +-- * comprehensive api + +_ = (jsForAPI comprehensiveAPI vanillaJS :: Text) + +-- * specs + type TestAPI = "simple" :> ReqBody '[JSON,FormUrlEncoded] Text :> Post '[JSON] Bool :<|> "has.extension" :> Get '[FormUrlEncoded,JSON] Bool diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index af444527..5c2470a3 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -45,3 +45,18 @@ executable mock-app buildable: True else buildable: False + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: + -Wall -fno-warn-name-shadowing + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Servant.MockSpec + build-depends: + base, + hspec, + servant, + servant-mock diff --git a/servant-mock/test/Servant/MockSpec.hs b/servant-mock/test/Servant/MockSpec.hs new file mode 100644 index 00000000..c7d08307 --- /dev/null +++ b/servant-mock/test/Servant/MockSpec.hs @@ -0,0 +1,12 @@ + +module Servant.MockSpec where + +import Test.Hspec + +import Servant.API.Internal.Test.ComprehensiveAPI +import Servant.Mock + +_ = mock comprehensiveAPI + +spec :: Spec +spec = return () diff --git a/servant-mock/test/Spec.hs b/servant-mock/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-mock/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index e4069b0f..aee31d19 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -46,6 +46,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, StdMethod (..), Verb, addHeader) +import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Server (ServantErr (..), Server, err404, serve) import Test.Hspec (Spec, context, describe, it, @@ -60,6 +61,9 @@ import Servant.Server.Internal.Router (tweakResponse, runRouter, Router, Router'(LeafRouter)) +-- * comprehensive api test + +_ = serve comprehensiveAPI (error "unused") (error "unused") -- * Specs diff --git a/servant/servant.cabal b/servant/servant.cabal index 451eb166..527d5b00 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -31,6 +31,7 @@ library Servant.API.ContentTypes Servant.API.Header Servant.API.HttpVersion + Servant.API.Internal.Test.ComprehensiveAPI Servant.API.IsSecure Servant.API.QueryParam Servant.API.Raw diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs new file mode 100644 index 00000000..1e5d9748 --- /dev/null +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.API.Internal.Test.ComprehensiveAPI where + +import Data.Proxy + +import Servant.API + +type GET = Get '[JSON] () + +type ComprehensiveAPI = + GET :<|> + Get '[JSON] Int :<|> + Capture "foo" Int :> GET :<|> + Header "foo" Int :> GET :<|> +-- HttpVersion :> GET :<|> + IsSecure :> GET :<|> + QueryParam "foo" Int :> GET :<|> + QueryParams "foo" Int :> GET :<|> + QueryFlag "foo" :> GET :<|> +-- Raw :<|> +-- RemoteHost :<|> + ReqBody '[JSON] Int :> GET :<|> +-- Get '[JSON] (Headers '[Header "foo" Int] ()) :<|> + "foo" :> GET :<|> + Vault :> GET :<|> + Verb 'POST 204 '[JSON] () :<|> + Verb 'POST 204 '[JSON] Int + +comprehensiveAPI :: Proxy ComprehensiveAPI +comprehensiveAPI = Proxy From b20b8d977046bfa3dad669dbf623488a5b4f6024 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sat, 16 Jan 2016 19:34:44 +0100 Subject: [PATCH 032/180] add HasClient instance for HttpVersion --- servant-client/src/Servant/Client.hs | 11 +++++++++++ .../src/Servant/API/Internal/Test/ComprehensiveAPI.hs | 2 +- 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index e9bab748..bab4f4a2 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -203,6 +203,17 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) where hname = symbolVal (Proxy :: Proxy sym) +-- | Using a 'HttpVersion' combinator in your API doesn't affect the client +-- functions. +instance HasClient sublayout + => HasClient (HttpVersion :> sublayout) where + + type Client (HttpVersion :> sublayout) = + Client sublayout + + clientWithRoute Proxy = + clientWithRoute (Proxy :: Proxy sublayout) + -- | If you use a 'QueryParam' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'QueryParam', diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index 1e5d9748..465d2885 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -14,7 +14,7 @@ type ComprehensiveAPI = Get '[JSON] Int :<|> Capture "foo" Int :> GET :<|> Header "foo" Int :> GET :<|> --- HttpVersion :> GET :<|> + HttpVersion :> GET :<|> IsSecure :> GET :<|> QueryParam "foo" Int :> GET :<|> QueryParams "foo" Int :> GET :<|> From efd12053afe9bda0ecb3a6da586ca5d4f944db5a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 18 Jan 2016 10:47:10 +0100 Subject: [PATCH 033/180] servant-docs: add .ghci --- servant-docs/.ghci | 1 + 1 file changed, 1 insertion(+) create mode 100644 servant-docs/.ghci diff --git a/servant-docs/.ghci b/servant-docs/.ghci new file mode 100644 index 00000000..0ba46fd4 --- /dev/null +++ b/servant-docs/.ghci @@ -0,0 +1 @@ +:set -itest -isrc -Iinclude From 290e4ef1ba675ae8ea6452fe86c3946fc71a6491 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 18 Jan 2016 11:01:30 +0100 Subject: [PATCH 034/180] add RemoteHost to ComprehensiveAPI --- servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index 465d2885..68c5fbc1 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -20,7 +20,7 @@ type ComprehensiveAPI = QueryParams "foo" Int :> GET :<|> QueryFlag "foo" :> GET :<|> -- Raw :<|> --- RemoteHost :<|> + RemoteHost :> GET :<|> ReqBody '[JSON] Int :> GET :<|> -- Get '[JSON] (Headers '[Header "foo" Int] ()) :<|> "foo" :> GET :<|> From 39b0507098ab8a54a4295c4a3d609b56e1a2ab14 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 18 Jan 2016 11:12:31 +0100 Subject: [PATCH 035/180] servant-mock: add .ghci --- servant-mock/.ghci | 1 + 1 file changed, 1 insertion(+) create mode 100644 servant-mock/.ghci diff --git a/servant-mock/.ghci b/servant-mock/.ghci new file mode 100644 index 00000000..0215492d --- /dev/null +++ b/servant-mock/.ghci @@ -0,0 +1 @@ +:set -Wall -itest -isrc -optP-include -optPdist/build/autogen/cabal_macros.h -Iinclude From 3fdaffa08dea2e2806c044b7b21d86823fe2a73b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 18 Jan 2016 12:29:33 +0100 Subject: [PATCH 036/180] servant-mock: add simple test case --- servant-mock/servant-mock.cabal | 6 ++++- servant-mock/test/Servant/MockSpec.hs | 34 +++++++++++++++++++++++++-- 2 files changed, 37 insertions(+), 3 deletions(-) diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 5c2470a3..285927dc 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -58,5 +58,9 @@ test-suite spec build-depends: base, hspec, + hspec-wai, + QuickCheck, servant, - servant-mock + servant-server, + servant-mock, + aeson diff --git a/servant-mock/test/Servant/MockSpec.hs b/servant-mock/test/Servant/MockSpec.hs index c7d08307..34c94304 100644 --- a/servant-mock/test/Servant/MockSpec.hs +++ b/servant-mock/test/Servant/MockSpec.hs @@ -1,12 +1,42 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} module Servant.MockSpec where -import Test.Hspec +import Data.Aeson as Aeson +import Data.Proxy +import GHC.Generics +import Servant.API +import Test.Hspec hiding (pending) +import Test.Hspec.Wai +import Test.QuickCheck +import Servant import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Mock _ = mock comprehensiveAPI +data Body + = Body + | ArbitraryBody + deriving (Generic, ToJSON) + +instance Arbitrary Body where + arbitrary = return ArbitraryBody + spec :: Spec -spec = return () +spec = do + describe "mock" $ do + context "Get" $ do + let api :: Proxy (Get '[JSON] Body) + api = Proxy + app = serve api (mock api) + with (return app) $ do + it "serves arbitrary response bodies" $ do + get "/" `shouldRespondWith` 200{ + matchBody = Just $ Aeson.encode ArbitraryBody + } From 14aac5fc9f9623ca466fb706e15b8d03579581a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 18 Jan 2016 13:22:58 +0100 Subject: [PATCH 037/180] servant-mock: support for response headers --- servant-mock/servant-mock.cabal | 4 +- servant-mock/src/Servant/Mock.hs | 11 ++++- servant-mock/test/Servant/MockSpec.hs | 44 ++++++++++++++++++- .../API/Internal/Test/ComprehensiveAPI.hs | 2 +- 4 files changed, 55 insertions(+), 6 deletions(-) diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 285927dc..54bc2fe2 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -63,4 +63,6 @@ test-suite spec servant, servant-server, servant-mock, - aeson + aeson, + bytestring-conversion, + wai diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index 7d17dca5..d2808be2 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -7,6 +7,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + +#include "overlapping-compat.h" + -- | -- Module : Servant.Mock -- Copyright : 2015 Alp Mestanogullari @@ -144,6 +147,12 @@ instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes => HasMock (Verb method status ctypes a) where mock _ = mockArbitrary +instance OVERLAPPING_ + (GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes), + Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) + => HasMock (Verb method status ctypes (Headers headerTypes a)) where + mock _ = mockArbitrary + instance HasMock Raw where mock _ = \_req respond -> do bdy <- genBody @@ -165,5 +174,3 @@ instance Arbitrary (HList '[]) where instance (Arbitrary a, Arbitrary (HList hs)) => Arbitrary (HList (Header h a ': hs)) where arbitrary = HCons <$> fmap Header arbitrary <*> arbitrary - - diff --git a/servant-mock/test/Servant/MockSpec.hs b/servant-mock/test/Servant/MockSpec.hs index 34c94304..ff7d9694 100644 --- a/servant-mock/test/Servant/MockSpec.hs +++ b/servant-mock/test/Servant/MockSpec.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} @@ -7,8 +6,11 @@ module Servant.MockSpec where import Data.Aeson as Aeson +import Data.ByteString.Conversion.To import Data.Proxy +import Data.String import GHC.Generics +import Network.Wai import Servant.API import Test.Hspec hiding (pending) import Test.Hspec.Wai @@ -23,11 +25,24 @@ _ = mock comprehensiveAPI data Body = Body | ArbitraryBody - deriving (Generic, ToJSON) + deriving (Generic) + +instance ToJSON Body instance Arbitrary Body where arbitrary = return ArbitraryBody +data TestHeader + = TestHeader + | ArbitraryHeader + deriving (Show) + +instance ToByteString TestHeader where + builder = fromString . show + +instance Arbitrary TestHeader where + arbitrary = return ArbitraryHeader + spec :: Spec spec = do describe "mock" $ do @@ -40,3 +55,28 @@ spec = do get "/" `shouldRespondWith` 200{ matchBody = Just $ Aeson.encode ArbitraryBody } + + context "response headers" $ do + let withHeader :: Proxy (Get '[JSON] (Headers '[Header "foo" TestHeader] Body)) + withHeader = Proxy + withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body)) + withoutHeader = Proxy + toApp :: HasMock api => Proxy api -> IO Application + toApp api = return $ serve api (mock api) + with (toApp withHeader) $ do + it "serves arbitrary response bodies" $ do + get "/" `shouldRespondWith` 200{ + matchHeaders = return $ MatchHeader $ \ h -> + if h == [("Content-Type", "application/json"), ("foo", "ArbitraryHeader")] + then Nothing + else Just ("headers not correct\n") + } + + with (toApp withoutHeader) $ do + it "works for no additional headers" $ do + get "/" `shouldRespondWith` 200{ + matchHeaders = return $ MatchHeader $ \ h -> + if h == [("Content-Type", "application/json")] + then Nothing + else Just ("headers not correct\n") + } diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index 68c5fbc1..2eade8e0 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -22,7 +22,7 @@ type ComprehensiveAPI = -- Raw :<|> RemoteHost :> GET :<|> ReqBody '[JSON] Int :> GET :<|> --- Get '[JSON] (Headers '[Header "foo" Int] ()) :<|> + Get '[JSON] (Headers '[Header "foo" Int] ()) :<|> "foo" :> GET :<|> Vault :> GET :<|> Verb 'POST 204 '[JSON] () :<|> From ac930ef198ee00a257e32c85839b6691817e5aa9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 18 Jan 2016 19:55:14 +0100 Subject: [PATCH 038/180] ComprehensiveAPI: add some comments (and minor tweaks) --- servant-client/test/Servant/ClientSpec.hs | 1 + servant-docs/test/Servant/DocsSpec.hs | 1 + servant-js/test/Servant/JSSpec.hs | 3 ++- servant-mock/test/Servant/MockSpec.hs | 1 + servant-server/test/Servant/ServerSpec.hs | 3 ++- servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs | 3 +++ 6 files changed, 10 insertions(+), 2 deletions(-) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 06cf7caa..c8726cf3 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -53,6 +53,7 @@ import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client import Servant.Server +-- This declaration simply checks that all instances are in place. _ = client comprehensiveAPI spec :: Spec diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index e49aeaa1..018fd46b 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -23,6 +23,7 @@ import Servant.Docs.Internal -- * comprehensive api +-- This declaration simply checks that all instances are in place. _ = docs comprehensiveAPI instance ToParam (QueryParam "foo" Int) where diff --git a/servant-js/test/Servant/JSSpec.hs b/servant-js/test/Servant/JSSpec.hs index 4249e930..371d39db 100644 --- a/servant-js/test/Servant/JSSpec.hs +++ b/servant-js/test/Servant/JSSpec.hs @@ -32,7 +32,8 @@ import Servant.JSSpec.CustomHeaders -- * comprehensive api -_ = (jsForAPI comprehensiveAPI vanillaJS :: Text) +-- This declaration simply checks that all instances are in place. +_ = jsForAPI comprehensiveAPI vanillaJS :: Text -- * specs diff --git a/servant-mock/test/Servant/MockSpec.hs b/servant-mock/test/Servant/MockSpec.hs index ff7d9694..24cad324 100644 --- a/servant-mock/test/Servant/MockSpec.hs +++ b/servant-mock/test/Servant/MockSpec.hs @@ -20,6 +20,7 @@ import Servant import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Mock +-- This declaration simply checks that all instances are in place. _ = mock comprehensiveAPI data Body diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index aee31d19..e583523d 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -63,7 +63,8 @@ import Servant.Server.Internal.Router -- * comprehensive api test -_ = serve comprehensiveAPI (error "unused") (error "unused") +-- This declaration simply checks that all instances are in place. +_ = serve comprehensiveAPI -- * Specs diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index 2eade8e0..1914df8e 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -1,6 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} +-- | This is a module containing an API with all `Servant.API` combinators. It +-- is used for testing only (in particular, checking that instances exist for +-- the core servant classes for each combinator), and should not be imported. module Servant.API.Internal.Test.ComprehensiveAPI where import Data.Proxy From 9c67267071221d7dbc3f4f49982a745368715d38 Mon Sep 17 00:00:00 2001 From: Christian Marie Date: Tue, 19 Jan 2016 11:06:38 +1100 Subject: [PATCH 039/180] servant-server: fix comment typo --- .../src/Servant/Server/Internal/RoutingApplication.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 4b27c688..bcb563df 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -77,7 +77,7 @@ toApplication ra request respond = do -- now, and therefore get 415 before 405, which is wrong. -- -- If we delay Captures, but perform method checks eagerly, we --- end up potentially preferring 405 over 404, whcih is also bad. +-- end up potentially preferring 405 over 404, which is also bad. -- -- So in principle, we'd like: -- From be36e5b31380586f3ecea282630f94a60f6bae82 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 20 Jan 2016 16:58:29 +0100 Subject: [PATCH 040/180] Change copyright to servant contributors --- servant-blaze/LICENSE | 2 +- servant-blaze/servant-blaze.cabal | 6 +++--- servant-cassava/LICENSE | 2 +- servant-cassava/servant-cassava.cabal | 6 +++--- servant-client/LICENSE | 2 +- servant-client/servant-client.cabal | 6 +++--- servant-docs/LICENSE | 2 +- servant-docs/servant-docs.cabal | 6 +++--- servant-examples/LICENSE | 2 +- servant-examples/servant-examples.cabal | 6 +++--- servant-foreign/LICENSE | 2 +- servant-foreign/servant-foreign.cabal | 6 +++--- servant-js/LICENSE | 2 +- servant-js/servant-js.cabal | 6 +++--- servant-lucid/LICENSE | 2 +- servant-lucid/servant-lucid.cabal | 6 +++--- servant-mock/LICENSE | 2 +- servant-mock/servant-mock.cabal | 6 +++--- servant-server/LICENSE | 2 +- servant-server/servant-server.cabal | 6 +++--- servant/LICENSE | 2 +- servant/servant.cabal | 6 +++--- 22 files changed, 44 insertions(+), 44 deletions(-) diff --git a/servant-blaze/LICENSE b/servant-blaze/LICENSE index 0b0a2174..1d0ce8da 100644 --- a/servant-blaze/LICENSE +++ b/servant-blaze/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Julian K. Arni +Copyright (c) 2015-2016, Servant Contributors All rights reserved. diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal index cc4ea34d..cc36a2de 100644 --- a/servant-blaze/servant-blaze.cabal +++ b/servant-blaze/servant-blaze.cabal @@ -8,9 +8,9 @@ synopsis: Blaze-html support for servant homepage: http://haskell-servant.github.io/ license: BSD3 license-file: LICENSE -author: Julian K. Arni -maintainer: jkarni@gmail.com --- copyright: +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2016 Servant Contributors category: Web build-type: Simple extra-source-files: include/*.h diff --git a/servant-cassava/LICENSE b/servant-cassava/LICENSE index 0b0a2174..1d0ce8da 100644 --- a/servant-cassava/LICENSE +++ b/servant-cassava/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Julian K. Arni +Copyright (c) 2015-2016, Servant Contributors All rights reserved. diff --git a/servant-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal index e2e7c964..8aaaa306 100644 --- a/servant-cassava/servant-cassava.cabal +++ b/servant-cassava/servant-cassava.cabal @@ -8,9 +8,9 @@ synopsis: Servant CSV content-type for cassava homepage: http://haskell-servant.github.io/ license: BSD3 license-file: LICENSE -author: Julian K. Arni -maintainer: jkarni@gmail.com --- copyright: +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2016 Servant Contributors -- category: build-type: Simple extra-source-files: include/*.h diff --git a/servant-client/LICENSE b/servant-client/LICENSE index bfee8018..9717a9ce 100644 --- a/servant-client/LICENSE +++ b/servant-client/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved. diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 087920dc..71cb2ee6 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -10,9 +10,9 @@ description: license: BSD3 license-file: LICENSE -author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni -maintainer: alpmestan@gmail.com -copyright: 2014 Zalora South East Asia Pte Ltd +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple extra-source-files: include/*.h diff --git a/servant-docs/LICENSE b/servant-docs/LICENSE index bfee8018..9717a9ce 100644 --- a/servant-docs/LICENSE +++ b/servant-docs/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved. diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index b1be264d..c95624f2 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -9,9 +9,9 @@ description: license: BSD3 license-file: LICENSE -author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni -maintainer: alpmestan@gmail.com -copyright: 2014-2015 Zalora South East Asia Pte Ltd +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple cabal-version: >=1.10 diff --git a/servant-examples/LICENSE b/servant-examples/LICENSE index f2e47b91..68d30586 100644 --- a/servant-examples/LICENSE +++ b/servant-examples/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Alp Mestanogullari +Copyright (c) 2015-2016, Servant Contributors All rights reserved. diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal index bd187106..d62c01c7 100644 --- a/servant-examples/servant-examples.cabal +++ b/servant-examples/servant-examples.cabal @@ -6,9 +6,9 @@ description: Example programs for servant, homepage: http://haskell-servant.github.io/ license: BSD3 license-file: LICENSE -author: Alp Mestanogullari -maintainer: alpmestan@gmail.com --- copyright: +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2016 Servant Contributors category: Web build-type: Simple cabal-version: >=1.10 diff --git a/servant-foreign/LICENSE b/servant-foreign/LICENSE index bfee8018..9717a9ce 100644 --- a/servant-foreign/LICENSE +++ b/servant-foreign/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved. diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index ca92b43a..1efda5c3 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -11,9 +11,9 @@ description: license: BSD3 license-file: LICENSE -author: Denis Redozubov, Maksymilian Owsianny -maintainer: denis.redozubov@gmail.com -copyright: 2015 Denis Redozubov, Alp Mestanogullari +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2016 Servant Contributors category: Web build-type: Simple cabal-version: >=1.10 diff --git a/servant-js/LICENSE b/servant-js/LICENSE index bfee8018..9717a9ce 100644 --- a/servant-js/LICENSE +++ b/servant-js/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved. diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index 28005e60..b8a52d64 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -13,9 +13,9 @@ description: license: BSD3 license-file: LICENSE -author: Alp Mestanogullari, Maksymilian Owsianny -maintainer: alpmestan@gmail.com -copyright: 2014 Alp Mestanogullari +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2016 Servant Contributors category: Web build-type: Simple cabal-version: >=1.10 diff --git a/servant-lucid/LICENSE b/servant-lucid/LICENSE index 0b0a2174..1d0ce8da 100644 --- a/servant-lucid/LICENSE +++ b/servant-lucid/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Julian K. Arni +Copyright (c) 2015-2016, Servant Contributors All rights reserved. diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal index f2be1eb5..008650bb 100644 --- a/servant-lucid/servant-lucid.cabal +++ b/servant-lucid/servant-lucid.cabal @@ -8,9 +8,9 @@ synopsis: Servant support for lucid homepage: http://haskell-servant.github.io/ license: BSD3 license-file: LICENSE -author: Julian K. Arni -maintainer: jkarni@gmail.com --- copyright: +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2016 Servant Contributors category: Web build-type: Simple extra-source-files: include/*.h diff --git a/servant-mock/LICENSE b/servant-mock/LICENSE index f2e47b91..68d30586 100644 --- a/servant-mock/LICENSE +++ b/servant-mock/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Alp Mestanogullari +Copyright (c) 2015-2016, Servant Contributors All rights reserved. diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 54bc2fe2..aa9b2bef 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -8,9 +8,9 @@ description: homepage: http://github.com/haskell-servant/servant license: BSD3 license-file: LICENSE -author: Alp Mestanogullari -maintainer: alpmestan@gmail.com -copyright: 2015 Alp Mestanogullari +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2016 Servant Contributors category: Web build-type: Simple extra-source-files: include/*.h diff --git a/servant-server/LICENSE b/servant-server/LICENSE index bfee8018..9717a9ce 100644 --- a/servant-server/LICENSE +++ b/servant-server/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved. diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index c4ec6edc..03c5cb31 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -15,9 +15,9 @@ homepage: http://haskell-servant.github.io/ Bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE -author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni -maintainer: alpmestan@gmail.com -copyright: 2014 Zalora South East Asia Pte Ltd +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple cabal-version: >=1.10 diff --git a/servant/LICENSE b/servant/LICENSE index bfee8018..9717a9ce 100644 --- a/servant/LICENSE +++ b/servant/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved. diff --git a/servant/servant.cabal b/servant/servant.cabal index 527d5b00..e0efb428 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -11,9 +11,9 @@ homepage: http://haskell-servant.github.io/ Bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE -author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni -maintainer: alpmestan@gmail.com -copyright: 2014 Zalora South East Asia Pte Ltd +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple extra-source-files: include/*.h From 67315c44870735d19f89668565aa0f10693c03c0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 14 Jan 2016 23:43:48 +0100 Subject: [PATCH 041/180] server: added Config machinery --- .travis.yml | 2 +- servant-client/test/Servant/ClientSpec.hs | 12 +- .../auth-combinator/auth-combinator.hs | 25 +++- .../socket-io-chat/socket-io-chat.hs | 2 +- servant-examples/tutorial/T1.hs | 2 +- servant-examples/tutorial/T10.hs | 2 +- servant-examples/tutorial/T2.hs | 2 +- servant-examples/tutorial/T3.hs | 2 +- servant-examples/tutorial/T4.hs | 2 +- servant-examples/tutorial/T5.hs | 2 +- servant-examples/tutorial/T6.hs | 2 +- servant-examples/tutorial/T7.hs | 2 +- servant-examples/tutorial/T9.hs | 2 +- .../wai-middleware/wai-middleware.hs | 4 +- servant-mock/example/main.hs | 2 +- servant-server/example/greet.hs | 2 +- servant-server/servant-server.cabal | 7 +- servant-server/src/Servant/Server.hs | 15 ++- servant-server/src/Servant/Server/Internal.hs | 95 +++++++++---- .../src/Servant/Server/Internal/Config.hs | 57 ++++++++ .../test/Servant/Server/ErrorSpec.hs | 8 +- .../Servant/Server/Internal/ConfigSpec.hs | 61 +++++++++ .../test/Servant/Server/Internal/EnterSpec.hs | 4 +- .../test/Servant/Server/UsingConfigSpec.hs | 125 ++++++++++++++++++ .../Server/UsingConfigSpec/TestCombinators.hs | 78 +++++++++++ servant-server/test/Servant/ServerSpec.hs | 35 ++--- .../test/Servant/Utils/StaticFilesSpec.hs | 4 +- servant/servant.cabal | 1 + servant/src/Servant/API.hs | 3 + servant/src/Servant/API/WithNamedConfig.hs | 8 ++ stack.yaml | 1 + 31 files changed, 486 insertions(+), 83 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/Config.hs create mode 100644 servant-server/test/Servant/Server/Internal/ConfigSpec.hs create mode 100644 servant-server/test/Servant/Server/UsingConfigSpec.hs create mode 100644 servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs create mode 100644 servant/src/Servant/API/WithNamedConfig.hs diff --git a/.travis.yml b/.travis.yml index 62501f7a..9cddf7ab 100644 --- a/.travis.yml +++ b/.travis.yml @@ -25,7 +25,7 @@ install: - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config script: - - for package in $(cat sources.txt); do (cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done + - for package in $(cat sources.txt); do (echo testing $package && cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done cache: directories: diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index c8726cf3..fb9e835a 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -114,7 +115,7 @@ api :: Proxy Api api = Proxy server :: Application -server = serve api ( +server = serve api EmptyConfig ( return alice :<|> return NoContent :<|> (\ name -> return $ Person name 0) @@ -141,7 +142,7 @@ failApi :: Proxy FailApi failApi = Proxy failServer :: Application -failServer = serve failApi ( +failServer = serve failApi EmptyConfig ( (\ _request respond -> respond $ responseLBS ok200 [] "") :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "") :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") @@ -231,7 +232,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do wrappedApiSpec :: Spec wrappedApiSpec = describe "error status codes" $ do - let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" [] + let serveW api = serve api EmptyConfig $ throwE $ ServantErr 500 "error message" "" [] context "are correctly handled by the client" $ let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = @@ -287,8 +288,9 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where - WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a, - HasClient api, Client api ~ ExceptT ServantError IO ()) => + WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a + , HasConfig api '[], HasClient api + , Client api ~ ExceptT ServantError IO ()) => Proxy api -> WrappedApi diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index ec152782..87f1fcc7 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -8,6 +8,7 @@ import Data.Aeson import Data.ByteString (ByteString) +import Data.IORef import Data.Text (Text) import GHC.Generics import Network.Wai @@ -18,23 +19,32 @@ import Servant.Server.Internal -- Pretty much stolen/adapted from -- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs -type DBLookup = ByteString -> IO Bool +type DBConnection = IORef [ByteString] +type DBLookup = DBConnection -> ByteString -> IO Bool + +initDB :: IO DBConnection +initDB = newIORef ["good password"] isGoodCookie :: DBLookup -isGoodCookie = return . (== "good password") +isGoodCookie ref password = do + allowed <- readIORef ref + return (password `elem` allowed) data AuthProtected instance HasServer rest => HasServer (AuthProtected :> rest) where type ServerT (AuthProtected :> rest) m = ServerT rest m + type HasConfig (AuthProtected :> rest) config = + (HasConfigEntry config DBConnection, HasConfig rest config) - route Proxy subserver = WithRequest $ \ request -> - route (Proxy :: Proxy rest) $ addAcceptCheck subserver $ cookieCheck request + route Proxy config subserver = WithRequest $ \ request -> + route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request where cookieCheck req = case lookup "Cookie" (requestHeaders req) of Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" } Just v -> do - authGranted <- isGoodCookie v + let dbConnection = getConfigEntry config + authGranted <- isGoodCookie dbConnection v if authGranted then return $ Route () else return $ FailFatal err403 { errBody = "Invalid cookie" } @@ -66,7 +76,10 @@ server = return prvdata :<|> return pubdata pubdata = [PublicData "this is a public piece of data"] main :: IO () -main = run 8080 (serve api server) +main = do + dbConnection <- initDB + let config = dbConnection :. EmptyConfig + run 8080 (serve api config server) {- Sample session: $ curl http://localhost:8080/ diff --git a/servant-examples/socket-io-chat/socket-io-chat.hs b/servant-examples/socket-io-chat/socket-io-chat.hs index 1250d8fe..4f5e649a 100644 --- a/servant-examples/socket-io-chat/socket-io-chat.hs +++ b/servant-examples/socket-io-chat/socket-io-chat.hs @@ -38,7 +38,7 @@ server sHandler = socketIOHandler app :: WaiMonad () -> Application -app sHandler = serve api $ server sHandler +app sHandler = serve api EmptyConfig $ server sHandler port :: Int port = 3001 diff --git a/servant-examples/tutorial/T1.hs b/servant-examples/tutorial/T1.hs index 97bbecb8..2473e7c8 100644 --- a/servant-examples/tutorial/T1.hs +++ b/servant-examples/tutorial/T1.hs @@ -42,4 +42,4 @@ server :: Server UserAPI server = return users app :: Application -app = serve userAPI server +app = serve userAPI EmptyConfig server diff --git a/servant-examples/tutorial/T10.hs b/servant-examples/tutorial/T10.hs index be5da4cf..859ff2cb 100644 --- a/servant-examples/tutorial/T10.hs +++ b/servant-examples/tutorial/T10.hs @@ -68,4 +68,4 @@ server = T3.server :<|> serveDocs plain = ("Content-Type", "text/plain") app :: Application -app = serve api server +app = serve api EmptyConfig server diff --git a/servant-examples/tutorial/T2.hs b/servant-examples/tutorial/T2.hs index fc49d256..bd311330 100644 --- a/servant-examples/tutorial/T2.hs +++ b/servant-examples/tutorial/T2.hs @@ -49,4 +49,4 @@ server = return users :<|> return isaac app :: Application -app = serve userAPI server +app = serve userAPI EmptyConfig server diff --git a/servant-examples/tutorial/T3.hs b/servant-examples/tutorial/T3.hs index 7b5bdeb3..4a56b946 100644 --- a/servant-examples/tutorial/T3.hs +++ b/servant-examples/tutorial/T3.hs @@ -81,4 +81,4 @@ server = position marketing clientinfo = return (emailForClient clientinfo) app :: Application -app = serve api server +app = serve api EmptyConfig server diff --git a/servant-examples/tutorial/T4.hs b/servant-examples/tutorial/T4.hs index 69cbf951..b86c8cb2 100644 --- a/servant-examples/tutorial/T4.hs +++ b/servant-examples/tutorial/T4.hs @@ -60,4 +60,4 @@ server :: Server PersonAPI server = return persons app :: Application -app = serve personAPI server +app = serve personAPI EmptyConfig server diff --git a/servant-examples/tutorial/T5.hs b/servant-examples/tutorial/T5.hs index 3b18aedb..81812d90 100644 --- a/servant-examples/tutorial/T5.hs +++ b/servant-examples/tutorial/T5.hs @@ -34,4 +34,4 @@ server = do where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." } app :: Application -app = serve ioAPI server +app = serve ioAPI EmptyConfig server diff --git a/servant-examples/tutorial/T6.hs b/servant-examples/tutorial/T6.hs index 781bf703..3e24647d 100644 --- a/servant-examples/tutorial/T6.hs +++ b/servant-examples/tutorial/T6.hs @@ -15,4 +15,4 @@ server :: Server API server = serveDirectory "tutorial" app :: Application -app = serve api server +app = serve api EmptyConfig server diff --git a/servant-examples/tutorial/T7.hs b/servant-examples/tutorial/T7.hs index e0145caf..010b66dd 100644 --- a/servant-examples/tutorial/T7.hs +++ b/servant-examples/tutorial/T7.hs @@ -30,4 +30,4 @@ readerServer = enter readerToEither readerServerT readerToEither = Nat $ \r -> return (runReader r "hi") app :: Application -app = serve readerAPI readerServer +app = serve readerAPI EmptyConfig readerServer diff --git a/servant-examples/tutorial/T9.hs b/servant-examples/tutorial/T9.hs index 75dd0630..a9fd575b 100644 --- a/servant-examples/tutorial/T9.hs +++ b/servant-examples/tutorial/T9.hs @@ -102,4 +102,4 @@ writeJSFiles = do TIO.writeFile "tutorial/t9/jq.js" jq app :: Application -app = serve api' server' +app = serve api' EmptyConfig server' diff --git a/servant-examples/wai-middleware/wai-middleware.hs b/servant-examples/wai-middleware/wai-middleware.hs index d625d092..52368c00 100644 --- a/servant-examples/wai-middleware/wai-middleware.hs +++ b/servant-examples/wai-middleware/wai-middleware.hs @@ -41,11 +41,11 @@ server = return products -- logStdout :: Middleware -- i.e, logStdout :: Application -> Application --- serve :: Proxy api -> Server api -> Application +-- serve :: Proxy api -> Config a -> Server api -> Application -- so applying a middleware is really as simple as -- applying a function to the result of 'serve' app :: Application -app = logStdout (serve simpleAPI server) +app = logStdout (serve simpleAPI EmptyConfig server) main :: IO () main = run 8080 app diff --git a/servant-mock/example/main.hs b/servant-mock/example/main.hs index 51ba7329..6c63c0e4 100644 --- a/servant-mock/example/main.hs +++ b/servant-mock/example/main.hs @@ -20,4 +20,4 @@ api :: Proxy API api = Proxy main :: IO () -main = run 8080 (serve api $ mock api) +main = run 8080 (serve api EmptyConfig $ mock api) diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index 3fda367d..37c3f674 100644 --- a/servant-server/example/greet.hs +++ b/servant-server/example/greet.hs @@ -59,7 +59,7 @@ server = helloH :<|> postGreetH :<|> deleteGreetH -- Turn the server into a WAI app. 'serve' is provided by servant, -- more precisely by the Servant.Server module. test :: Application -test = serve testApi server +test = serve testApi EmptyConfig server -- Run the server. -- diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 03c5cb31..f6ed6319 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -37,6 +37,7 @@ library Servant Servant.Server Servant.Server.Internal + Servant.Server.Internal.Config Servant.Server.Internal.Enter Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication @@ -94,10 +95,13 @@ test-suite spec hs-source-dirs: test main-is: Spec.hs other-modules: + Servant.Server.ErrorSpec + Servant.Server.Internal.ConfigSpec Servant.Server.Internal.EnterSpec Servant.ServerSpec + Servant.Server.UsingConfigSpec + Servant.Server.UsingConfigSpec.TestCombinators Servant.Utils.StaticFilesSpec - Servant.Server.ErrorSpec build-depends: base == 4.* , aeson @@ -115,6 +119,7 @@ test-suite spec , servant , servant-server , string-conversions + , should-not-typecheck == 2.* , temporary , text , transformers diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index b847ede3..5ef8498d 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -35,6 +36,10 @@ module Servant.Server , generalizeNat , tweakResponse + -- * Config + , Config(..) + , NamedConfig(..) + -- * Default error type , ServantErr(..) -- ** 3XX @@ -96,14 +101,18 @@ import Servant.Server.Internal.Enter -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > +-- > config :: Config '[] +-- > config = EmptyConfig +-- > -- > app :: Application --- > app = serve myApi server +-- > app = serve myApi config server -- > -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app -- -serve :: HasServer layout => Proxy layout -> Server layout -> Application -serve p server = toApplication (runRouter (route p d)) +serve :: (HasConfig layout a, HasServer layout) + => Proxy layout -> Config a -> Server layout -> Application +serve p config server = toApplication (runRouter (route p config d)) where d = Delayed r r r (\ _ _ -> Route server) r = return (Route ()) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 730e96d5..f502ea9a 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -13,6 +14,7 @@ module Servant.Server.Internal ( module Servant.Server.Internal + , module Servant.Server.Internal.Config , module Servant.Server.Internal.Router , module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.ServantErr @@ -30,6 +32,7 @@ import Data.String (fromString) import Data.String.Conversions (cs, (<>)) import Data.Text (Text) import Data.Typeable +import GHC.Exts (Constraint) import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) import Network.HTTP.Types hiding (Header, ResponseHeaders) @@ -49,7 +52,8 @@ import Servant.API ((:<|>) (..), (:>), Capture, Verb, ReflectMethod(reflectMethod), IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, Vault) + Raw, RemoteHost, ReqBody, Vault, + WithNamedConfig) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), @@ -58,6 +62,7 @@ import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) +import Servant.Server.Internal.Config import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr @@ -65,8 +70,9 @@ import Servant.Server.Internal.ServantErr class HasServer layout where type ServerT layout (m :: * -> *) :: * + type HasConfig layout (c :: [*]) :: Constraint - route :: Proxy layout -> Delayed (Server layout) -> Router + route :: HasConfig layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router type Server layout = ServerT layout (ExceptT ServantErr IO) @@ -86,9 +92,10 @@ type Server layout = ServerT layout (ExceptT ServantErr IO) instance (HasServer a, HasServer b) => HasServer (a :<|> b) where type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m + type HasConfig (a :<|> b) c = (HasConfig a c, HasConfig b c) - route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server)) - (route pb ((\ (_ :<|> b) -> b) <$> server)) + route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server)) + (route pb config ((\ (_ :<|> b) -> b) <$> server)) where pa = Proxy :: Proxy a pb = Proxy :: Proxy b @@ -117,10 +124,12 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout) type ServerT (Capture capture a :> sublayout) m = a -> ServerT sublayout m + type HasConfig (Capture capture a :> sublayout) c = (HasConfig sublayout c) - route Proxy d = + route Proxy config d = DynamicRouter $ \ first -> route (Proxy :: Proxy sublayout) + config (addCapture d $ case captured captureProxy first of Nothing -> return $ Fail err404 Just v -> return $ Route v @@ -192,8 +201,9 @@ instance OVERLAPPABLE_ ) => HasServer (Verb method status ctypes a) where type ServerT (Verb method status ctypes a) m = m a + type HasConfig (Verb method status ctypes a) c = () - route Proxy = methodRouter method (Proxy :: Proxy ctypes) status + route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) @@ -203,8 +213,9 @@ instance OVERLAPPING_ ) => HasServer (Verb method status ctypes (Headers h a)) where type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) + type HasConfig (Verb method status ctypes (Headers h a)) c = () - route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status + route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) @@ -233,10 +244,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) type ServerT (Header sym a :> sublayout) m = Maybe a -> ServerT sublayout m + type HasConfig (Header sym a :> sublayout) c = HasConfig sublayout c - route Proxy subserver = WithRequest $ \ request -> + route Proxy config subserver = WithRequest $ \ request -> let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request) - in route (Proxy :: Proxy sublayout) (passToServer subserver mheader) + in route (Proxy :: Proxy sublayout) config (passToServer subserver mheader) where str = fromString $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, @@ -265,8 +277,9 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) type ServerT (QueryParam sym a :> sublayout) m = Maybe a -> ServerT sublayout m + type HasConfig (QueryParam sym a :> sublayout) c = HasConfig sublayout c - route Proxy subserver = WithRequest $ \ request -> + route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of @@ -274,7 +287,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) Just Nothing -> Nothing -- param present with no value -> Nothing Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to -- the right type - in route (Proxy :: Proxy sublayout) (passToServer subserver param) + in route (Proxy :: Proxy sublayout) config (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, @@ -301,15 +314,16 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) type ServerT (QueryParams sym a :> sublayout) m = [a] -> ServerT sublayout m + type HasConfig (QueryParams sym a :> sublayout) c = HasConfig sublayout c - route Proxy subserver = WithRequest $ \ request -> + route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request -- if sym is "foo", we look for query string parameters -- named "foo" or "foo[]" and call parseQueryParam on the -- corresponding values parameters = filter looksLikeParam querytext values = mapMaybe (convert . snd) parameters - in route (Proxy :: Proxy sublayout) (passToServer subserver values) + in route (Proxy :: Proxy sublayout) config (passToServer subserver values) where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") convert Nothing = Nothing @@ -332,14 +346,15 @@ instance (KnownSymbol sym, HasServer sublayout) type ServerT (QueryFlag sym :> sublayout) m = Bool -> ServerT sublayout m + type HasConfig (QueryFlag sym :> sublayout) c = HasConfig sublayout c - route Proxy subserver = WithRequest $ \ request -> + route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of Just Nothing -> True -- param is there, with no value Just (Just v) -> examine v -- param with a value Nothing -> False -- param not in the query string - in route (Proxy :: Proxy sublayout) (passToServer subserver param) + in route (Proxy :: Proxy sublayout) config (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False @@ -355,8 +370,9 @@ instance (KnownSymbol sym, HasServer sublayout) instance HasServer Raw where type ServerT Raw m = Application + type HasConfig Raw c = () - route Proxy rawApplication = LeafRouter $ \ request respond -> do + route Proxy _ rawApplication = LeafRouter $ \ request respond -> do r <- runDelayed rawApplication case r of Route app -> app request (respond . Route) @@ -389,9 +405,10 @@ instance ( AllCTUnrender list a, HasServer sublayout type ServerT (ReqBody list a :> sublayout) m = a -> ServerT sublayout m + type HasConfig (ReqBody list a :> sublayout) c = HasConfig sublayout c - route Proxy subserver = WithRequest $ \ request -> - route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request)) + route Proxy config subserver = WithRequest $ \ request -> + route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request)) where bodyCheck request = do -- See HTTP RFC 2616, section 7.2.1 @@ -412,37 +429,42 @@ instance ( AllCTUnrender list a, HasServer sublayout instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where type ServerT (path :> sublayout) m = ServerT sublayout m + type HasConfig (path :> sublayout) c = HasConfig sublayout c - route Proxy subserver = StaticRouter $ + route Proxy config subserver = StaticRouter $ M.singleton (cs (symbolVal proxyPath)) - (route (Proxy :: Proxy sublayout) subserver) + (route (Proxy :: Proxy sublayout) config subserver) where proxyPath = Proxy :: Proxy path instance HasServer api => HasServer (RemoteHost :> api) where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m + type HasConfig (RemoteHost :> api) c = HasConfig api c - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ remoteHost req) + route Proxy config subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req) instance HasServer api => HasServer (IsSecure :> api) where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m + type HasConfig (IsSecure :> api) c = HasConfig api c - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ secure req) + route Proxy config subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) config (passToServer subserver $ secure req) where secure req = if isSecure req then Secure else NotSecure instance HasServer api => HasServer (Vault :> api) where type ServerT (Vault :> api) m = Vault -> ServerT api m + type HasConfig (Vault :> api) c = HasConfig api c - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ vault req) + route Proxy config subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) config (passToServer subserver $ vault req) instance HasServer api => HasServer (HttpVersion :> api) where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m + type HasConfig (HttpVersion :> api) c = HasConfig api c - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ httpVersion req) + route Proxy config subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req) pathIsEmpty :: Request -> Bool pathIsEmpty = go . pathInfo @@ -452,3 +474,20 @@ pathIsEmpty = go . pathInfo ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP + +-- * configs + +instance HasServer subApi => HasServer (WithNamedConfig name subConfig subApi) where + type ServerT (WithNamedConfig name subConfig subApi) m = + ServerT subApi m + type HasConfig (WithNamedConfig name subConfig subApi) config = + (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig) + + route Proxy config delayed = + route subProxy subConfig delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + subConfig :: Config subConfig + subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config diff --git a/servant-server/src/Servant/Server/Internal/Config.hs b/servant-server/src/Servant/Server/Internal/Config.hs new file mode 100644 index 00000000..e710de4b --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Config.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +#include "overlapping-compat.h" + +module Servant.Server.Internal.Config where + +import Data.Proxy +import GHC.TypeLits + +-- | The entire configuration. +data Config a where + EmptyConfig :: Config '[] + (:.) :: x -> Config xs -> Config (x ': xs) +infixr 5 :. + +instance Show (Config '[]) where + show EmptyConfig = "EmptyConfig" +instance (Show a, Show (Config as)) => Show (Config (a ': as)) where + showsPrec outerPrecedence (a :. as) = + showParen (outerPrecedence > 5) $ + shows a . showString " :. " . shows as + +instance Eq (Config '[]) where + _ == _ = True +instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where + x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 + +class HasConfigEntry (config :: [*]) (val :: *) where + getConfigEntry :: Config config -> val + +instance OVERLAPPABLE_ + HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where + getConfigEntry (_ :. xs) = getConfigEntry xs + +instance OVERLAPPING_ + HasConfigEntry (val ': xs) val where + getConfigEntry (x :. _) = x + +-- * support for named subconfigs + +data NamedConfig (name :: Symbol) (subConfig :: [*]) + = NamedConfig (Config subConfig) + +descendIntoNamedConfig :: forall config name subConfig . + HasConfigEntry config (NamedConfig name subConfig) => + Proxy (name :: Symbol) -> Config config -> Config subConfig +descendIntoNamedConfig Proxy config = + let NamedConfig subConfig = getConfigEntry config :: NamedConfig name subConfig + in subConfig diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 500a0069..745b47d9 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -42,7 +42,7 @@ errorOrderServer = \_ _ -> throwE err402 errorOrderSpec :: Spec errorOrderSpec = describe "HTTP error order" - $ with (return $ serve errorOrderApi errorOrderServer) $ do + $ with (return $ serve errorOrderApi EmptyConfig errorOrderServer) $ do let badContentType = (hContentType, "text/plain") badAccept = (hAccept, "text/plain") badMethod = methodGet @@ -89,7 +89,7 @@ prioErrorsApi = Proxy prioErrorsSpec :: Spec prioErrorsSpec = describe "PrioErrors" $ do let server = return - with (return $ serve prioErrorsApi server) $ do + with (return $ serve prioErrorsApi EmptyConfig server) $ do let check (mdescr, method) path (cdescr, ctype, body) resp = it fulldescr $ Test.Hspec.Wai.request method path [(hContentType, ctype)] body @@ -154,7 +154,7 @@ errorRetryServer errorRetrySpec :: Spec errorRetrySpec = describe "Handler search" - $ with (return $ serve errorRetryApi errorRetryServer) $ do + $ with (return $ serve errorRetryApi EmptyConfig errorRetryServer) $ do let jsonCT = (hContentType, "application/json") jsonAccept = (hAccept, "application/json") @@ -194,7 +194,7 @@ errorChoiceServer = return 0 errorChoiceSpec :: Spec errorChoiceSpec = describe "Multiple handlers return errors" - $ with (return $ serve errorChoiceApi errorChoiceServer) $ do + $ with (return $ serve errorChoiceApi EmptyConfig errorChoiceServer) $ do it "should respond with 404 if no path matches" $ do request methodGet "" [] "" `shouldRespondWith` 404 diff --git a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs new file mode 100644 index 00000000..182d91a8 --- /dev/null +++ b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fdefer-type-errors #-} +module Servant.Server.Internal.ConfigSpec (spec) where + +import Data.Proxy (Proxy (..)) +import Test.Hspec (Spec, describe, it, shouldBe, pending, context) +import Test.ShouldNotTypecheck (shouldNotTypecheck) + +import Servant.API +import Servant.Server.Internal.Config + +spec :: Spec +spec = do + describe "getConfigEntry" $ do + it "gets the config if a matching one exists" $ do + let config = 'a' :. EmptyConfig + getConfigEntry config `shouldBe` 'a' + + it "gets the first matching config" $ do + let config = 'a' :. 'b' :. EmptyConfig + getConfigEntry config `shouldBe` 'a' + + it "does not typecheck if type does not exist" $ do + let config = 'a' :. EmptyConfig + x = getConfigEntry config :: Bool + shouldNotTypecheck x + + context "Show instance" $ do + let config = 'a' :. True :. EmptyConfig + it "has a Show instance" $ do + show config `shouldBe` "'a' :. True :. EmptyConfig" + + context "bracketing" $ do + it "works" $ do + show (Just config) `shouldBe` "Just ('a' :. True :. EmptyConfig)" + + it "works with operators" $ do + let config = (1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig) + show config `shouldBe` "(1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)" + + describe "descendIntoNamedConfig" $ do + let config :: Config [Char, NamedConfig "sub" '[Char]] + config = + 'a' :. + (NamedConfig subConfig :: NamedConfig "sub" '[Char]) + :. EmptyConfig + subConfig = 'b' :. EmptyConfig + it "allows extracting subconfigs" $ do + descendIntoNamedConfig (Proxy :: Proxy "sub") config `shouldBe` subConfig + + it "allows extracting entries from subconfigs" $ do + getConfigEntry (descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Char]) + `shouldBe` 'b' + + it "does not typecheck if subConfig has the wrong type" $ do + let x = descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Int] + shouldNotTypecheck (show x) + + it "does not typecheck if subConfig with that name doesn't exist" $ do + let x = descendIntoNamedConfig (Proxy :: Proxy "foo") config :: Config '[Char] + shouldNotTypecheck (show x) diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs index 8b450377..06e8af9b 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -48,12 +48,12 @@ combinedReaderServer = enter fReader combinedReaderServer' enterSpec :: Spec enterSpec = describe "Enter" $ do - with (return (serve readerAPI readerServer)) $ do + with (return (serve readerAPI EmptyConfig readerServer)) $ do it "allows running arbitrary monads" $ do get "int" `shouldRespondWith` "1797" post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 } - with (return (serve combinedAPI combinedReaderServer)) $ do + with (return (serve combinedAPI EmptyConfig combinedReaderServer)) $ do it "allows combnation of enters" $ do get "bool" `shouldRespondWith` "true" diff --git a/servant-server/test/Servant/Server/UsingConfigSpec.hs b/servant-server/test/Servant/Server/UsingConfigSpec.hs new file mode 100644 index 00000000..a6c7ae43 --- /dev/null +++ b/servant-server/test/Servant/Server/UsingConfigSpec.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Server.UsingConfigSpec where + +import Control.Monad.Trans.Except +import Network.Wai +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Wai + +import Servant +import Servant.Server.UsingConfigSpec.TestCombinators + +spec :: Spec +spec = do + spec1 + spec2 + spec3 + spec4 + +-- * API + +type OneEntryAPI = + ExtractFromConfig :> Get '[JSON] String + +testServer :: String -> ExceptT ServantErr IO String +testServer s = return s + +oneEntryApp :: Application +oneEntryApp = + serve (Proxy :: Proxy OneEntryAPI) config testServer + where + config :: Config '[String] + config = "configEntry" :. EmptyConfig + +type OneEntryTwiceAPI = + "foo" :> ExtractFromConfig :> Get '[JSON] String :<|> + "bar" :> ExtractFromConfig :> Get '[JSON] String + +oneEntryTwiceApp :: Application +oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $ + testServer :<|> + testServer + where + config :: Config '[String] + config = "configEntryTwice" :. EmptyConfig + +-- * tests + +spec1 :: Spec +spec1 = do + describe "accessing config entries from custom combinators" $ do + with (return oneEntryApp) $ do + it "allows retrieving a ConfigEntry" $ do + get "/" `shouldRespondWith` "\"configEntry\"" + + with (return oneEntryTwiceApp) $ do + it "allows retrieving the same ConfigEntry twice" $ do + get "/foo" `shouldRespondWith` "\"configEntryTwice\"" + get "/bar" `shouldRespondWith` "\"configEntryTwice\"" + +type InjectAPI = + InjectIntoConfig :> "untagged" :> ExtractFromConfig :> + Get '[JSON] String :<|> + InjectIntoConfig :> "tagged" :> ExtractFromConfig :> + Get '[JSON] String + +injectApp :: Application +injectApp = serve (Proxy :: Proxy InjectAPI) config $ + (\ s -> return s) :<|> + (\ s -> return ("tagged: " ++ s)) + where + config = EmptyConfig + +spec2 :: Spec +spec2 = do + with (return injectApp) $ do + describe "inserting config entries with custom combinators" $ do + it "allows to inject config entries" $ do + get "/untagged" `shouldRespondWith` "\"injected\"" + + it "allows to inject tagged config entries" $ do + get "/tagged" `shouldRespondWith` "\"tagged: injected\"" + +type WithBirdfaceAPI = + "foo" :> ExtractFromConfig :> Get '[JSON] String :<|> + NamedConfigWithBirdface "sub" '[String] :> + "bar" :> ExtractFromConfig :> Get '[JSON] String + +withBirdfaceApp :: Application +withBirdfaceApp = serve (Proxy :: Proxy WithBirdfaceAPI) config $ + testServer :<|> + testServer + where + config :: Config '[String, (NamedConfig "sub" '[String])] + config = + "firstEntry" :. + (NamedConfig ("secondEntry" :. EmptyConfig)) :. + EmptyConfig + +spec3 :: Spec +spec3 = do + with (return withBirdfaceApp) $ do + it "allows retrieving different ConfigEntries for the same combinator" $ do + get "/foo" `shouldRespondWith` "\"firstEntry\"" + get "/bar" `shouldRespondWith` "\"secondEntry\"" + +type NamedConfigAPI = + WithNamedConfig "sub" '[String] ( + ExtractFromConfig :> Get '[JSON] String) + +namedConfigApp :: Application +namedConfigApp = serve (Proxy :: Proxy NamedConfigAPI) config return + where + config :: Config '[NamedConfig "sub" '[String]] + config = NamedConfig ("descend" :. EmptyConfig) :. EmptyConfig + +spec4 :: Spec +spec4 = do + with (return namedConfigApp) $ do + describe "WithNamedConfig" $ do + it "allows descending into a subconfig for a given api" $ do + get "/" `shouldRespondWith` "\"descend\"" diff --git a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs new file mode 100644 index 00000000..53f00f21 --- /dev/null +++ b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | These are custom combinators for Servant.Server.UsingConfigSpec. +-- +-- (For writing your own combinators you need to import Internal modules, for +-- just *using* combinators that require a Config, you don't. This module is +-- separate from Servant.Server.UsingConfigSpec to test that the module imports +-- work out this way.) +module Servant.Server.UsingConfigSpec.TestCombinators where + +import GHC.TypeLits + +import Servant +import Servant.Server.Internal.Config +import Servant.Server.Internal.RoutingApplication + +data ExtractFromConfig + +instance (HasServer subApi) => + HasServer (ExtractFromConfig :> subApi) where + + type ServerT (ExtractFromConfig :> subApi) m = + String -> ServerT subApi m + type HasConfig (ExtractFromConfig :> subApi) (c :: [*]) = + (HasConfigEntry c String, HasConfig subApi c) + + route Proxy config delayed = + route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi)) + where + subProxy :: Proxy subApi + subProxy = Proxy + + inject config f = f (getConfigEntry config) + +data InjectIntoConfig + +instance (HasServer subApi) => + HasServer (InjectIntoConfig :> subApi) where + + type ServerT (InjectIntoConfig :> subApi) m = + ServerT subApi m + type HasConfig (InjectIntoConfig :> subApi) c = + (HasConfig subApi (String ': c)) + + route Proxy config delayed = + route subProxy newConfig delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + newConfig = ("injected" :: String) :. config + +data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*]) + +instance (HasServer subApi) => + HasServer (NamedConfigWithBirdface name subConfig :> subApi) where + + type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m = + ServerT subApi m + type HasConfig (NamedConfigWithBirdface name subConfig :> subApi) config = + (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig) + + route Proxy config delayed = + route subProxy subConfig delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + subConfig :: Config subConfig + subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index e583523d..0955e332 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -48,7 +48,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Server (ServantErr (..), Server, err404, - serve) + serve, Config(EmptyConfig)) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import Test.Hspec.Wai (get, liftIO, matchHeaders, @@ -106,7 +106,7 @@ verbSpec = describe "Servant.API.Verb" $ do wrongMethod m = if m == methodPatch then methodPost else methodPatch test desc api method (status :: Int) = context desc $ - with (return $ serve api server) $ do + with (return $ serve api EmptyConfig server) $ do -- HEAD and 214/215 need not return bodies unless (status `elem` [214, 215] || method == methodHead) $ @@ -181,7 +181,7 @@ captureServer legs = case legs of captureSpec :: Spec captureSpec = do describe "Servant.API.Capture" $ do - with (return (serve captureApi captureServer)) $ do + with (return (serve captureApi EmptyConfig captureServer)) $ do it "can capture parts of the 'pathInfo'" $ do response <- get "/2" @@ -192,6 +192,7 @@ captureSpec = do with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) + EmptyConfig (\ "captured" request_ respond -> respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do @@ -224,8 +225,8 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize queryParamSpec :: Spec queryParamSpec = do describe "Servant.API.QueryParam" $ do - it "allows to retrieve simple GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do + it "allows retrieving simple GET parameters" $ + (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do let params1 = "?name=bob" response1 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params1, @@ -236,8 +237,8 @@ queryParamSpec = do name = "bob" } - it "allows to retrieve lists in GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do + it "allows retrieving lists in GET parameters" $ + (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do let params2 = "?names[]=bob&names[]=john" response2 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params2, @@ -250,8 +251,8 @@ queryParamSpec = do } - it "allows to retrieve value-less GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do + it "allows retrieving value-less GET parameters" $ + (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do let params3 = "?capitalize" response3 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params3, @@ -303,7 +304,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do mkReq method x = Test.Hspec.Wai.request method x [(hContentType, "application/json;charset=utf-8")] - with (return $ serve reqBodyApi server) $ do + with (return $ serve reqBodyApi EmptyConfig server) $ do it "passes the argument to the handler" $ do response <- mkReq methodPost "" (encode alice) @@ -336,13 +337,13 @@ headerSpec = describe "Servant.API.Header" $ do expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you" expectsString Nothing = error "Expected a string" - with (return (serve headerApi expectsInt)) $ do + with (return (serve headerApi EmptyConfig expectsInt)) $ do let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")] it "passes the header to the handler (Int)" $ delete' "/" "" `shouldRespondWith` 200 - with (return (serve headerApi expectsString)) $ do + with (return (serve headerApi EmptyConfig expectsString)) $ do let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")] it "passes the header to the handler (String)" $ @@ -366,7 +367,7 @@ rawSpec :: Spec rawSpec = do describe "Servant.API.Raw" $ do it "runs applications" $ do - (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do + (flip runSession) (serve rawApi EmptyConfig (rawApplication (const (42 :: Integer)))) $ do response <- Network.Wai.Test.request defaultRequest{ pathInfo = ["foo"] } @@ -374,7 +375,7 @@ rawSpec = do simpleBody response `shouldBe` "42" it "gets the pathInfo modified" $ do - (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do + (flip runSession) (serve rawApi EmptyConfig (rawApplication pathInfo)) $ do response <- Network.Wai.Test.request defaultRequest{ pathInfo = ["foo", "bar"] } @@ -408,7 +409,7 @@ alternativeServer = alternativeSpec :: Spec alternativeSpec = do describe "Servant.API.Alternative" $ do - with (return $ serve alternativeApi alternativeServer) $ do + with (return $ serve alternativeApi EmptyConfig alternativeServer) $ do it "unions endpoints" $ do response <- get "/foo" @@ -443,7 +444,7 @@ responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi" responseHeadersSpec :: Spec responseHeadersSpec = describe "ResponseHeaders" $ do - with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do + with (return $ serve (Proxy :: Proxy ResponseHeadersApi) EmptyConfig responseHeadersServer) $ do let methods = [methodGet, methodPost, methodPut, methodPatch] @@ -509,7 +510,7 @@ miscServ = versionHandler hostHandler = return . show miscCombinatorSpec :: Spec -miscCombinatorSpec = with (return $ serve miscApi miscServ) $ +miscCombinatorSpec = with (return $ serve miscApi EmptyConfig miscServ) $ describe "Misc. combinators for request inspection" $ do it "Successfully gets the HTTP version specified in the request" $ go "/version" "\"HTTP/1.0\"" diff --git a/servant-server/test/Servant/Utils/StaticFilesSpec.hs b/servant-server/test/Servant/Utils/StaticFilesSpec.hs index 94c63f18..e6430b5c 100644 --- a/servant-server/test/Servant/Utils/StaticFilesSpec.hs +++ b/servant-server/test/Servant/Utils/StaticFilesSpec.hs @@ -16,7 +16,7 @@ import Test.Hspec (Spec, around_, describe, it) import Test.Hspec.Wai (get, shouldRespondWith, with) import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON) -import Servant.Server (Server, serve) +import Servant.Server (Server, serve, Config(EmptyConfig)) import Servant.ServerSpec (Person (Person)) import Servant.Utils.StaticFiles (serveDirectory) @@ -29,7 +29,7 @@ api :: Proxy Api api = Proxy app :: Application -app = serve api server +app = serve api EmptyConfig server server :: Server Api server = diff --git a/servant/servant.cabal b/servant/servant.cabal index e0efb428..437c9843 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -41,6 +41,7 @@ library Servant.API.Sub Servant.API.Vault Servant.API.Verbs + Servant.API.WithNamedConfig Servant.Utils.Links build-depends: base >=4.7 && <5 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 03051533..2da0d4cf 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -23,6 +23,8 @@ module Servant.API ( -- | Is the request made through HTTPS? module Servant.API.Vault, -- | Access the location for arbitrary data to be shared by applications and middleware + module Servant.API.WithNamedConfig, + -- | Access config entries in combinators in servant-server -- * Actual endpoints, distinguished by HTTP method module Servant.API.Verbs, @@ -88,6 +90,7 @@ import Servant.API.Verbs (PostCreated, Delete, DeleteAccepte PutNoContent, PutNonAuthoritative, ReflectMethod (reflectMethod), Verb, StdMethod(..)) +import Servant.API.WithNamedConfig (WithNamedConfig) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', URI (..), safeLink) import Web.HttpApiData (FromHttpApiData (..), diff --git a/servant/src/Servant/API/WithNamedConfig.hs b/servant/src/Servant/API/WithNamedConfig.hs new file mode 100644 index 00000000..3f234292 --- /dev/null +++ b/servant/src/Servant/API/WithNamedConfig.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} + +module Servant.API.WithNamedConfig where + +import GHC.TypeLits + +data WithNamedConfig (name :: Symbol) (subConfig :: [*]) subApi diff --git a/stack.yaml b/stack.yaml index f370da09..c1aea0a2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -16,4 +16,5 @@ packages: extra-deps: - engine-io-wai-1.0.2 - control-monad-omega-0.3.1 +- should-not-typecheck-2.0.1 resolver: nightly-2015-10-08 From 2176fecfda33e4d200fef3b4c920cf0f2321ca74 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 18 Jan 2016 21:27:19 +0100 Subject: [PATCH 042/180] config: added instances for all interpretations --- servant-client/src/Servant/Client.hs | 6 ++++++ servant-docs/src/Servant/Docs/Internal.hs | 3 +++ servant-foreign/src/Servant/Foreign/Internal.hs | 7 +++++++ servant-mock/src/Servant/Mock.hs | 3 +++ servant-server/test/Servant/ServerSpec.hs | 7 ++++++- servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs | 3 ++- 6 files changed, 27 insertions(+), 2 deletions(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index bab4f4a2..82779651 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -417,6 +417,12 @@ instance HasClient api => HasClient (IsSecure :> api) where clientWithRoute Proxy req baseurl manager = clientWithRoute (Proxy :: Proxy api) req baseurl manager +instance HasClient subapi => + HasClient (WithNamedConfig name config subapi) where + + type Client (WithNamedConfig name config subapi) = Client subapi + clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi) + {- Note [Non-Empty Content Types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 2b4db3eb..70f8954c 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -794,6 +794,9 @@ instance HasDocs sublayout => HasDocs (Vault :> sublayout) where docsFor Proxy ep = docsFor (Proxy :: Proxy sublayout) ep +instance HasDocs sublayout => HasDocs (WithNamedConfig name config sublayout) where + docsFor Proxy = docsFor (Proxy :: Proxy sublayout) + -- ToSample instances for simple types instance ToSample () instance ToSample Bool diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index ae199202..bb2e4b1e 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -295,6 +295,13 @@ instance HasForeign lang sublayout => HasForeign lang (Vault :> sublayout) where foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) req +instance HasForeign lang sublayout => + HasForeign lang (WithNamedConfig name config sublayout) where + + type Foreign (WithNamedConfig name config sublayout) = Foreign sublayout + + foreignFor lang Proxy = foreignFor lang (Proxy :: Proxy sublayout) + instance HasForeign lang sublayout => HasForeign lang (HttpVersion :> sublayout) where type Foreign (HttpVersion :> sublayout) = Foreign sublayout diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index d2808be2..ae6afd55 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -160,6 +160,9 @@ instance HasMock Raw where where genBody = pack <$> generate (vector 100 :: Gen [Char]) +instance HasMock rest => HasMock (WithNamedConfig name config rest) where + mock _ = mock (Proxy :: Proxy rest) + mockArbitrary :: (MonadIO m, Arbitrary a) => m a mockArbitrary = liftIO (generate arbitrary) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 0955e332..21fabd38 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -60,11 +60,16 @@ import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.Router (tweakResponse, runRouter, Router, Router'(LeafRouter)) +import Servant.Server.Internal.Config + (Config(..), NamedConfig(..)) -- * comprehensive api test -- This declaration simply checks that all instances are in place. -_ = serve comprehensiveAPI +_ = serve comprehensiveAPI comprehensiveApiConfig + +comprehensiveApiConfig :: Config '[NamedConfig "foo" '[]] +comprehensiveApiConfig = NamedConfig EmptyConfig :. EmptyConfig -- * Specs diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index 1914df8e..733968b2 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -29,7 +29,8 @@ type ComprehensiveAPI = "foo" :> GET :<|> Vault :> GET :<|> Verb 'POST 204 '[JSON] () :<|> - Verb 'POST 204 '[JSON] Int + Verb 'POST 204 '[JSON] Int :<|> + WithNamedConfig "foo" '[] GET comprehensiveAPI :: Proxy ComprehensiveAPI comprehensiveAPI = Proxy From e726db9fe7c86c5e804291c161fda8e21ecb58c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 18 Jan 2016 21:40:59 +0100 Subject: [PATCH 043/180] updated stack-ghc-7.8.4.yaml --- stack-ghc-7.8.4.yaml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index 9632e808..8aa461d7 100644 --- a/stack-ghc-7.8.4.yaml +++ b/stack-ghc-7.8.4.yaml @@ -1,14 +1,15 @@ flags: {} packages: -- servant-examples/ -- servant-docs/ +- servant/ - servant-blaze/ +- servant-cassava/ - servant-client/ -- servant-lucid/ -- servant-mock/ +- servant-docs/ +- servant-examples/ - servant-foreign/ - servant-js/ -- servant/ +- servant-lucid/ +- servant-mock/ - servant-server/ extra-deps: - hspec-2.2.0 @@ -22,4 +23,5 @@ extra-deps: - stm-delay-0.1.1.1 - control-monad-omega-0.3.1 - http-api-data-0.1.1.1 +- should-not-typecheck-2.0.1 resolver: lts-2.22 From 2445855203b9ffcd67b574ec5d9c7e58bbf2b15f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 18 Jan 2016 22:14:11 +0100 Subject: [PATCH 044/180] servant-server: renaming of type variable --- servant-server/src/Servant/Server/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index f502ea9a..a5ab7200 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -72,7 +72,7 @@ class HasServer layout where type ServerT layout (m :: * -> *) :: * type HasConfig layout (c :: [*]) :: Constraint - route :: HasConfig layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router + route :: HasConfig layout config => Proxy layout -> Config config -> Delayed (Server layout) -> Router type Server layout = ServerT layout (ExceptT ServantErr IO) From b8f453127b1dcebc74c9bd998d2b06398e1ad279 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 18 Jan 2016 22:26:23 +0100 Subject: [PATCH 045/180] Documentation for config. --- servant/src/Servant/API/WithNamedConfig.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/servant/src/Servant/API/WithNamedConfig.hs b/servant/src/Servant/API/WithNamedConfig.hs index 3f234292..1beb3b8d 100644 --- a/servant/src/Servant/API/WithNamedConfig.hs +++ b/servant/src/Servant/API/WithNamedConfig.hs @@ -5,4 +5,21 @@ module Servant.API.WithNamedConfig where import GHC.TypeLits +-- | 'WithNamedConfig' names a specific tagged configuration to use for the +-- combinators in the API. For example: +-- +-- > type UseNamedConfigAPI1 = WithNamedConfig "myConfig" '[String] ( +-- > ReqBody '[JSON] Int :> Get '[JSON] Int) +-- +-- Both the 'ReqBody' and 'Get' combinators will use the 'NamedConfig' with +-- type tag "myConfig" as their configuration. In constrast, in (notice +-- parentesizing): +-- +-- > type UseNamedConfigAPI2 = WithNamedConfig "myConfig" '[String] ( +-- > ReqBody '[JSON] Int) :> Get '[JSON] Int +-- +-- Only the 'ReqBody' combinator will use this configuration, and 'Get' will +-- maintain the default configuration. +-- +-- For more information, see the tutorial. data WithNamedConfig (name :: Symbol) (subConfig :: [*]) subApi From 35bdc54dee6b8bac99c16496de375442018c617b Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 18 Jan 2016 22:34:56 +0100 Subject: [PATCH 046/180] Update changelogs --- servant-server/CHANGELOG.md | 3 +++ servant/CHANGELOG.md | 1 + 2 files changed, 4 insertions(+) diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 5ba871ee..0f3b9a8a 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,6 +1,9 @@ HEAD ---- +* Add `Config` machinery (https://github.com/haskell-servant/servant/pull/327). + This is a breaking change, as the signatures of both `route` and `serve` now + take an extra parameter. * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Drop `EitherT` in favor of `ExceptT` * Use `http-api-data` instead of `Servant.Common.Text` diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index 7890e0f1..ef344650 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,6 +1,7 @@ HEAD ---- +* Add `WithNamedConfig` combinator. * Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Fix safeLink, so Header is not in fact required. * Add more instances for (:<|>) From df09f8616e453c638422b5e3067b69120ed35088 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Tue, 19 Jan 2016 00:19:51 +0100 Subject: [PATCH 047/180] config: remove HasConfig and make HasServer take `config` as a parameter --- servant-client/test/Servant/ClientSpec.hs | 5 +- .../auth-combinator/auth-combinator.hs | 9 ++- servant-mock/example/main.hs | 2 +- servant-mock/src/Servant/Mock.hs | 76 ++++++++++--------- servant-mock/test/Servant/MockSpec.hs | 10 ++- servant-server/src/Servant/Server.hs | 4 +- servant-server/src/Servant/Server/Internal.hs | 69 +++++++---------- .../Server/UsingConfigSpec/TestCombinators.hs | 19 ++--- servant-server/test/Servant/ServerSpec.hs | 5 +- 9 files changed, 94 insertions(+), 105 deletions(-) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index fb9e835a..4cb1ef4c 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -288,9 +288,8 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where - WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a - , HasConfig api '[], HasClient api - , Client api ~ ExceptT ServantError IO ()) => + WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a, + HasClient api, Client api ~ ExceptT ServantError IO ()) => Proxy api -> WrappedApi diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index 87f1fcc7..f2cebb4f 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -1,10 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} import Data.Aeson import Data.ByteString (ByteString) @@ -32,10 +35,10 @@ isGoodCookie ref password = do data AuthProtected -instance HasServer rest => HasServer (AuthProtected :> rest) where +instance (HasConfigEntry config DBConnection, HasServer rest config) + => HasServer (AuthProtected :> rest) config where + type ServerT (AuthProtected :> rest) m = ServerT rest m - type HasConfig (AuthProtected :> rest) config = - (HasConfigEntry config DBConnection, HasConfig rest config) route Proxy config subserver = WithRequest $ \ request -> route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request diff --git a/servant-mock/example/main.hs b/servant-mock/example/main.hs index 6c63c0e4..7f08f352 100644 --- a/servant-mock/example/main.hs +++ b/servant-mock/example/main.hs @@ -20,4 +20,4 @@ api :: Proxy API api = Proxy main :: IO () -main = run 8080 (serve api EmptyConfig $ mock api) +main = run 8080 (serve api EmptyConfig $ mock api Proxy) diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index ae6afd55..2c447ca0 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -2,8 +2,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -66,6 +67,7 @@ import Network.HTTP.Types.Status import Network.Wai import Servant import Servant.API.ContentTypes +import Servant.Server.Internal.Config import Test.QuickCheck.Arbitrary (Arbitrary (..), vector) import Test.QuickCheck.Gen (Gen, generate) @@ -73,7 +75,7 @@ import Test.QuickCheck.Gen (Gen, generate) -- than turns them into random-response-generating -- request handlers, hence providing an instance for -- all the combinators of the core /servant/ library. -class HasServer api => HasMock api where +class HasServer api config => HasMock api config where -- | Calling this method creates request handlers of -- the right type to implement the API described by -- @api@ that just generate random response values of @@ -103,65 +105,67 @@ class HasServer api => HasMock api where -- So under the hood, 'mock' uses the 'IO' bit to generate -- random values of type 'User' and 'Book' every time these -- endpoints are requested. - mock :: Proxy api -> Server api + mock :: Proxy api -> Proxy config -> Server api -instance (HasMock a, HasMock b) => HasMock (a :<|> b) where - mock _ = mock (Proxy :: Proxy a) :<|> mock (Proxy :: Proxy b) +instance (HasMock a config, HasMock b config) => HasMock (a :<|> b) config where + mock _ config = mock (Proxy :: Proxy a) config :<|> mock (Proxy :: Proxy b) config -instance (KnownSymbol path, HasMock rest) => HasMock (path :> rest) where +instance (KnownSymbol path, HasMock rest config) => HasMock (path :> rest) config where mock _ = mock (Proxy :: Proxy rest) -instance (KnownSymbol s, FromHttpApiData a, HasMock rest) => HasMock (Capture s a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (KnownSymbol s, FromHttpApiData a, HasMock rest config) => HasMock (Capture s a :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance (AllCTUnrender ctypes a, HasMock rest) => HasMock (ReqBody ctypes a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (AllCTUnrender ctypes a, HasMock rest config) => HasMock (ReqBody ctypes a :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance HasMock rest => HasMock (RemoteHost :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest config => HasMock (RemoteHost :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance HasMock rest => HasMock (IsSecure :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest config => HasMock (IsSecure :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance HasMock rest => HasMock (Vault :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest config => HasMock (Vault :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance HasMock rest => HasMock (HttpVersion :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest config => HasMock (HttpVersion :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance (KnownSymbol s, FromHttpApiData a, HasMock rest) - => HasMock (QueryParam s a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (KnownSymbol s, FromHttpApiData a, HasMock rest config) + => HasMock (QueryParam s a :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance (KnownSymbol s, FromHttpApiData a, HasMock rest) - => HasMock (QueryParams s a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (KnownSymbol s, FromHttpApiData a, HasMock rest config) + => HasMock (QueryParams s a :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance (KnownSymbol s, HasMock rest) => HasMock (QueryFlag s :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (KnownSymbol s, HasMock rest config) => HasMock (QueryFlag s :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config -instance (KnownSymbol h, FromHttpApiData a, HasMock rest) => HasMock (Header h a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (KnownSymbol h, FromHttpApiData a, HasMock rest config) => HasMock (Header h a :> rest) config where + mock _ config = \_ -> mock (Proxy :: Proxy rest) config instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) - => HasMock (Verb method status ctypes a) where - mock _ = mockArbitrary + => HasMock (Verb method status ctypes a) config where + mock _ _ = mockArbitrary instance OVERLAPPING_ (GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes), Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) - => HasMock (Verb method status ctypes (Headers headerTypes a)) where - mock _ = mockArbitrary + => HasMock (Verb method status ctypes (Headers headerTypes a)) config where + mock _ _ = mockArbitrary -instance HasMock Raw where - mock _ = \_req respond -> do +instance HasMock Raw config where + mock _ _ = \_req respond -> do bdy <- genBody respond $ responseLBS status200 [] bdy where genBody = pack <$> generate (vector 100 :: Gen [Char]) -instance HasMock rest => HasMock (WithNamedConfig name config rest) where - mock _ = mock (Proxy :: Proxy rest) +instance (HasConfigEntry config (NamedConfig name subConfig), HasMock rest subConfig) => + HasMock (WithNamedConfig name subConfig rest) config where + + mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subConfig) mockArbitrary :: (MonadIO m, Arbitrary a) => m a mockArbitrary = liftIO (generate arbitrary) diff --git a/servant-mock/test/Servant/MockSpec.hs b/servant-mock/test/Servant/MockSpec.hs index 24cad324..cd369ee6 100644 --- a/servant-mock/test/Servant/MockSpec.hs +++ b/servant-mock/test/Servant/MockSpec.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} @@ -21,7 +23,7 @@ import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Mock -- This declaration simply checks that all instances are in place. -_ = mock comprehensiveAPI +_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedConfig "foo" '[]]) data Body = Body @@ -50,7 +52,7 @@ spec = do context "Get" $ do let api :: Proxy (Get '[JSON] Body) api = Proxy - app = serve api (mock api) + app = serve api EmptyConfig (mock api Proxy) with (return app) $ do it "serves arbitrary response bodies" $ do get "/" `shouldRespondWith` 200{ @@ -62,8 +64,8 @@ spec = do withHeader = Proxy withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body)) withoutHeader = Proxy - toApp :: HasMock api => Proxy api -> IO Application - toApp api = return $ serve api (mock api) + toApp :: (HasMock api '[]) => Proxy api -> IO Application + toApp api = return $ serve api EmptyConfig (mock api (Proxy :: Proxy '[])) with (toApp withHeader) $ do it "serves arbitrary response bodies" $ do get "/" `shouldRespondWith` 200{ diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 5ef8498d..b8de9cf5 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -110,8 +110,8 @@ import Servant.Server.Internal.Enter -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app -- -serve :: (HasConfig layout a, HasServer layout) - => Proxy layout -> Config a -> Server layout -> Application +serve :: (HasServer layout config) + => Proxy layout -> Config config -> Server layout -> Application serve p config server = toApplication (runRouter (route p config d)) where d = Delayed r r r (\ _ _ -> Route server) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index a5ab7200..17ecbbac 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -68,11 +69,10 @@ import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr -class HasServer layout where +class HasServer layout config where type ServerT layout (m :: * -> *) :: * - type HasConfig layout (c :: [*]) :: Constraint - route :: HasConfig layout config => Proxy layout -> Config config -> Delayed (Server layout) -> Router + route :: Proxy layout -> Config config -> Delayed (Server layout) -> Router type Server layout = ServerT layout (ExceptT ServantErr IO) @@ -89,10 +89,9 @@ type Server layout = ServerT layout (ExceptT ServantErr IO) -- > server = listAllBooks :<|> postBook -- > where listAllBooks = ... -- > postBook book = ... -instance (HasServer a, HasServer b) => HasServer (a :<|> b) where +instance (HasServer a config, HasServer b config) => HasServer (a :<|> b) config where type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m - type HasConfig (a :<|> b) c = (HasConfig a c, HasConfig b c) route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server)) (route pb config ((\ (_ :<|> b) -> b) <$> server)) @@ -119,12 +118,11 @@ captured _ = parseUrlPieceMaybe -- > server = getBook -- > where getBook :: Text -> ExceptT ServantErr IO Book -- > getBook isbn = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout) - => HasServer (Capture capture a :> sublayout) where +instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout config) + => HasServer (Capture capture a :> sublayout) config where type ServerT (Capture capture a :> sublayout) m = a -> ServerT sublayout m - type HasConfig (Capture capture a :> sublayout) c = (HasConfig sublayout c) route Proxy config d = DynamicRouter $ \ first -> @@ -198,10 +196,9 @@ methodRouterHeaders method proxy status action = LeafRouter route' instance OVERLAPPABLE_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status - ) => HasServer (Verb method status ctypes a) where + ) => HasServer (Verb method status ctypes a) config where type ServerT (Verb method status ctypes a) m = m a - type HasConfig (Verb method status ctypes a) c = () route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) @@ -210,10 +207,9 @@ instance OVERLAPPABLE_ instance OVERLAPPING_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status , GetHeaders (Headers h a) - ) => HasServer (Verb method status ctypes (Headers h a)) where + ) => HasServer (Verb method status ctypes (Headers h a)) config where type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) - type HasConfig (Verb method status ctypes (Headers h a)) c = () route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) @@ -239,12 +235,11 @@ instance OVERLAPPING_ -- > server = viewReferer -- > where viewReferer :: Referer -> ExceptT ServantErr IO referer -- > viewReferer referer = return referer -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) - => HasServer (Header sym a :> sublayout) where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) + => HasServer (Header sym a :> sublayout) config where type ServerT (Header sym a :> sublayout) m = Maybe a -> ServerT sublayout m - type HasConfig (Header sym a :> sublayout) c = HasConfig sublayout c route Proxy config subserver = WithRequest $ \ request -> let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request) @@ -272,12 +267,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) -- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book] -- > getBooksBy Nothing = ...return all books... -- > getBooksBy (Just author) = ...return books by the given author... -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) - => HasServer (QueryParam sym a :> sublayout) where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) + => HasServer (QueryParam sym a :> sublayout) config where type ServerT (QueryParam sym a :> sublayout) m = Maybe a -> ServerT sublayout m - type HasConfig (QueryParam sym a :> sublayout) c = HasConfig sublayout c route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request @@ -309,12 +303,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) -- > server = getBooksBy -- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book] -- > getBooksBy authors = ...return all books by these authors... -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) - => HasServer (QueryParams sym a :> sublayout) where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) + => HasServer (QueryParams sym a :> sublayout) config where type ServerT (QueryParams sym a :> sublayout) m = [a] -> ServerT sublayout m - type HasConfig (QueryParams sym a :> sublayout) c = HasConfig sublayout c route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request @@ -341,12 +334,11 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) -- > server = getBooks -- > where getBooks :: Bool -> ExceptT ServantErr IO [Book] -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... -instance (KnownSymbol sym, HasServer sublayout) - => HasServer (QueryFlag sym :> sublayout) where +instance (KnownSymbol sym, HasServer sublayout config) + => HasServer (QueryFlag sym :> sublayout) config where type ServerT (QueryFlag sym :> sublayout) m = Bool -> ServerT sublayout m - type HasConfig (QueryFlag sym :> sublayout) c = HasConfig sublayout c route Proxy config subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request @@ -367,10 +359,9 @@ instance (KnownSymbol sym, HasServer sublayout) -- > -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" -instance HasServer Raw where +instance HasServer Raw config where type ServerT Raw m = Application - type HasConfig Raw c = () route Proxy _ rawApplication = LeafRouter $ \ request respond -> do r <- runDelayed rawApplication @@ -400,12 +391,11 @@ instance HasServer Raw where -- > server = postBook -- > where postBook :: Book -> ExceptT ServantErr IO Book -- > postBook book = ...insert into your db... -instance ( AllCTUnrender list a, HasServer sublayout - ) => HasServer (ReqBody list a :> sublayout) where +instance ( AllCTUnrender list a, HasServer sublayout config + ) => HasServer (ReqBody list a :> sublayout) config where type ServerT (ReqBody list a :> sublayout) m = a -> ServerT sublayout m - type HasConfig (ReqBody list a :> sublayout) c = HasConfig sublayout c route Proxy config subserver = WithRequest $ \ request -> route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request)) @@ -426,42 +416,37 @@ instance ( AllCTUnrender list a, HasServer sublayout -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @sublayout@. -instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where +instance (KnownSymbol path, HasServer sublayout config) => HasServer (path :> sublayout) config where type ServerT (path :> sublayout) m = ServerT sublayout m - type HasConfig (path :> sublayout) c = HasConfig sublayout c route Proxy config subserver = StaticRouter $ M.singleton (cs (symbolVal proxyPath)) (route (Proxy :: Proxy sublayout) config subserver) where proxyPath = Proxy :: Proxy path -instance HasServer api => HasServer (RemoteHost :> api) where +instance HasServer api config => HasServer (RemoteHost :> api) config where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m - type HasConfig (RemoteHost :> api) c = HasConfig api c route Proxy config subserver = WithRequest $ \req -> route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req) -instance HasServer api => HasServer (IsSecure :> api) where +instance HasServer api config => HasServer (IsSecure :> api) config where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m - type HasConfig (IsSecure :> api) c = HasConfig api c route Proxy config subserver = WithRequest $ \req -> route (Proxy :: Proxy api) config (passToServer subserver $ secure req) where secure req = if isSecure req then Secure else NotSecure -instance HasServer api => HasServer (Vault :> api) where +instance HasServer api config => HasServer (Vault :> api) config where type ServerT (Vault :> api) m = Vault -> ServerT api m - type HasConfig (Vault :> api) c = HasConfig api c route Proxy config subserver = WithRequest $ \req -> route (Proxy :: Proxy api) config (passToServer subserver $ vault req) -instance HasServer api => HasServer (HttpVersion :> api) where +instance HasServer api config => HasServer (HttpVersion :> api) config where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m - type HasConfig (HttpVersion :> api) c = HasConfig api c route Proxy config subserver = WithRequest $ \req -> route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req) @@ -477,11 +462,11 @@ ct_wildcard = "*" <> "/" <> "*" -- Because CPP -- * configs -instance HasServer subApi => HasServer (WithNamedConfig name subConfig subApi) where +instance (HasConfigEntry config (NamedConfig name subConfig), HasServer subApi subConfig) + => HasServer (WithNamedConfig name subConfig subApi) config where + type ServerT (WithNamedConfig name subConfig subApi) m = ServerT subApi m - type HasConfig (WithNamedConfig name subConfig subApi) config = - (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig) route Proxy config delayed = route subProxy subConfig delayed diff --git a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs index 53f00f21..1da892e8 100644 --- a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs +++ b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -24,13 +25,11 @@ import Servant.Server.Internal.RoutingApplication data ExtractFromConfig -instance (HasServer subApi) => - HasServer (ExtractFromConfig :> subApi) where +instance (HasConfigEntry config String, HasServer subApi config) => + HasServer (ExtractFromConfig :> subApi) config where type ServerT (ExtractFromConfig :> subApi) m = String -> ServerT subApi m - type HasConfig (ExtractFromConfig :> subApi) (c :: [*]) = - (HasConfigEntry c String, HasConfig subApi c) route Proxy config delayed = route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi)) @@ -42,13 +41,11 @@ instance (HasServer subApi) => data InjectIntoConfig -instance (HasServer subApi) => - HasServer (InjectIntoConfig :> subApi) where +instance (HasServer subApi (String ': config)) => + HasServer (InjectIntoConfig :> subApi) config where type ServerT (InjectIntoConfig :> subApi) m = ServerT subApi m - type HasConfig (InjectIntoConfig :> subApi) c = - (HasConfig subApi (String ': c)) route Proxy config delayed = route subProxy newConfig delayed @@ -60,13 +57,11 @@ instance (HasServer subApi) => data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*]) -instance (HasServer subApi) => - HasServer (NamedConfigWithBirdface name subConfig :> subApi) where +instance (HasConfigEntry config (NamedConfig name subConfig), HasServer subApi subConfig) => + HasServer (NamedConfigWithBirdface name subConfig :> subApi) config where type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m = ServerT subApi m - type HasConfig (NamedConfigWithBirdface name subConfig :> subApi) config = - (HasConfigEntry config (NamedConfig name subConfig), HasConfig subApi subConfig) route Proxy config delayed = route subProxy subConfig delayed diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 21fabd38..04461566 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -1,14 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} module Servant.ServerSpec where From 09b22452aa62ed1d562bb8fceec953d0b3bac16d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 21 Jan 2016 17:51:40 +0100 Subject: [PATCH 048/180] server/config: added more documentation --- .../wai-middleware/wai-middleware.hs | 2 +- servant-server/src/Servant/Server.hs | 3 ++ servant-server/src/Servant/Server/Internal.hs | 1 - .../src/Servant/Server/Internal/Config.hs | 46 ++++++++++++++++++- servant/src/Servant/API/WithNamedConfig.hs | 14 ++---- 5 files changed, 53 insertions(+), 13 deletions(-) diff --git a/servant-examples/wai-middleware/wai-middleware.hs b/servant-examples/wai-middleware/wai-middleware.hs index 52368c00..7ad34c3f 100644 --- a/servant-examples/wai-middleware/wai-middleware.hs +++ b/servant-examples/wai-middleware/wai-middleware.hs @@ -41,7 +41,7 @@ server = return products -- logStdout :: Middleware -- i.e, logStdout :: Application -> Application --- serve :: Proxy api -> Config a -> Server api -> Application +-- serve :: Proxy api -> Config config -> Server api -> Application -- so applying a middleware is really as simple as -- applying a function to the result of 'serve' app :: Application diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index b8de9cf5..ea78a969 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -38,7 +38,10 @@ module Servant.Server -- * Config , Config(..) + , HasConfigEntry(getConfigEntry) + -- ** NamedConfig , NamedConfig(..) + , descendIntoNamedConfig -- * Default error type , ServantErr(..) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 17ecbbac..1b2c19a2 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -33,7 +33,6 @@ import Data.String (fromString) import Data.String.Conversions (cs, (<>)) import Data.Text (Text) import Data.Typeable -import GHC.Exts (Constraint) import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) import Network.HTTP.Types hiding (Header, ResponseHeaders) diff --git a/servant-server/src/Servant/Server/Internal/Config.hs b/servant-server/src/Servant/Server/Internal/Config.hs index e710de4b..c162494b 100644 --- a/servant-server/src/Servant/Server/Internal/Config.hs +++ b/servant-server/src/Servant/Server/Internal/Config.hs @@ -15,8 +15,18 @@ module Servant.Server.Internal.Config where import Data.Proxy import GHC.TypeLits --- | The entire configuration. -data Config a where +-- | When calling 'Servant.Server.serve' you have to supply a configuration +-- value of type @'Config' configTypes@. This parameter is used to pass values +-- to combinators. (It shouldn't be confused with general configuration +-- parameters for your web app, like the port, etc.). If you don't use +-- combinators that require any config entries, you can just pass 'EmptyConfig'. +-- To create a config with entries, use the operator @(':.')@. The parameter of +-- the type 'Config' is a type-level list reflecting the types of the contained +-- config entries: +-- +-- >>> :type True :. () :. EmptyConfig +-- True :. () :. EmptyConfig :: Config '[Bool, ()] +data Config configTypes where EmptyConfig :: Config '[] (:.) :: x -> Config xs -> Config (x ': xs) infixr 5 :. @@ -33,6 +43,19 @@ instance Eq (Config '[]) where instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 +-- | This class is used to access config entries in 'Config's. 'getConfigEntry' +-- returns the first value where the type matches: +-- +-- >>> getConfigEntry (True :. False :. EmptyConfig) :: Bool +-- True +-- +-- If the 'Config' does not contain an entry of the requested type, you'll get +-- an error: +-- +-- >>> getConfigEntry (True :. False :. EmptyConfig) :: String +-- ... +-- No instance for (HasConfigEntry '[] [Char]) +-- ... class HasConfigEntry (config :: [*]) (val :: *) where getConfigEntry :: Config config -> val @@ -46,9 +69,28 @@ instance OVERLAPPING_ -- * support for named subconfigs +-- | Normally config entries are accessed by their types. In case you need +-- to have multiple values of the same type in your 'Config' and need to access +-- them, we provide 'NamedConfig'. You can think of it as sub-namespaces for +-- 'Config's. data NamedConfig (name :: Symbol) (subConfig :: [*]) = NamedConfig (Config subConfig) +-- | 'descendIntoNamedConfig' allows you to access `NamedConfig's. Usually you +-- won't have to use it yourself but instead use a combinator like +-- 'Servant.API.WithNamedConfig.WithNamedConfig'. +-- +-- This is how 'descendIntoNamedConfig' works: +-- +-- >>> :set -XFlexibleContexts +-- >>> let subConfig = True :. EmptyConfig +-- >>> :type subConfig +-- subConfig :: Config '[Bool] +-- >>> let parentConfig = False :. (NamedConfig subConfig :: NamedConfig "subConfig" '[Bool]) :. EmptyConfig +-- >>> :type parentConfig +-- parentConfig :: Config '[Bool, NamedConfig "subConfig" '[Bool]] +-- >>> descendIntoNamedConfig (Proxy :: Proxy "subConfig") parentConfig :: Config '[Bool] +-- True :. EmptyConfig descendIntoNamedConfig :: forall config name subConfig . HasConfigEntry config (NamedConfig name subConfig) => Proxy (name :: Symbol) -> Config config -> Config subConfig diff --git a/servant/src/Servant/API/WithNamedConfig.hs b/servant/src/Servant/API/WithNamedConfig.hs index 1beb3b8d..72b59e2f 100644 --- a/servant/src/Servant/API/WithNamedConfig.hs +++ b/servant/src/Servant/API/WithNamedConfig.hs @@ -6,20 +6,16 @@ module Servant.API.WithNamedConfig where import GHC.TypeLits -- | 'WithNamedConfig' names a specific tagged configuration to use for the --- combinators in the API. For example: +-- combinators in the API. (See also in @servant-server@, +-- @Servant.Server.Config@.) For example: -- --- > type UseNamedConfigAPI1 = WithNamedConfig "myConfig" '[String] ( +-- > type UseNamedConfigAPI = WithNamedConfig "myConfig" '[String] ( -- > ReqBody '[JSON] Int :> Get '[JSON] Int) -- -- Both the 'ReqBody' and 'Get' combinators will use the 'NamedConfig' with --- type tag "myConfig" as their configuration. In constrast, in (notice --- parentesizing): +-- type tag "myConfig" as their configuration. -- --- > type UseNamedConfigAPI2 = WithNamedConfig "myConfig" '[String] ( --- > ReqBody '[JSON] Int) :> Get '[JSON] Int --- --- Only the 'ReqBody' combinator will use this configuration, and 'Get' will --- maintain the default configuration. +-- 'Config's are only relevant for @servant-server@. -- -- For more information, see the tutorial. data WithNamedConfig (name :: Symbol) (subConfig :: [*]) subApi From b9fb80ac5e246bde071bb05ecbbb9b2ad5f0a02c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 21 Jan 2016 18:04:00 +0100 Subject: [PATCH 049/180] server/config: tweak changelog --- servant-server/CHANGELOG.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 0f3b9a8a..bfdbe421 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -2,8 +2,8 @@ HEAD ---- * Add `Config` machinery (https://github.com/haskell-servant/servant/pull/327). - This is a breaking change, as the signatures of both `route` and `serve` now - take an extra parameter. + This is a breaking change, as the signatures of both `route`, `serve` and the + typeclass `HasServer` now take an additional parameter. * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Drop `EitherT` in favor of `ExceptT` * Use `http-api-data` instead of `Servant.Common.Text` From 1aeee3ef9403251fbc500ee3e3df91f699ed54b3 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 26 Jan 2016 14:43:15 +0100 Subject: [PATCH 050/180] Remove memoReqBody. --- servant-server/src/Servant/Server/Internal.hs | 2 +- .../Server/Internal/RoutingApplication.hs | 28 +------------------ 2 files changed, 2 insertions(+), 28 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 1b2c19a2..daf44640 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -158,7 +158,7 @@ methodCheck method request acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ()) acceptCheck proxy accH | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route () - | otherwise = return $ Fail err406 + | otherwise = return $ FailFatal err406 methodRouter :: (AllCTRender ctypes a) => Method -> Proxy ctypes -> Status diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index bcb563df..05814fe6 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -33,34 +33,8 @@ data RouteResult a = | Route !a deriving (Eq, Show, Read, Functor) -data ReqBodyState = Uncalled - | Called !B.ByteString - | Done !B.ByteString - toApplication :: RoutingApplication -> Application -toApplication ra request respond = do - reqBodyRef <- newIORef Uncalled - -- We may need to consume the requestBody more than once. In order to - -- maintain the illusion that 'requestBody' works as expected, - -- 'ReqBodyState' is introduced, and the complete body is memoized and - -- returned as many times as requested with empty "Done" marker chunks in - -- between. - -- See https://github.com/haskell-servant/servant/issues/3 - let memoReqBody = do - ior <- readIORef reqBodyRef - case ior of - Uncalled -> do - r <- BL.toStrict <$> strictRequestBody request - writeIORef reqBodyRef $ Done r - return r - Called bs -> do - writeIORef reqBodyRef $ Done bs - return bs - Done bs -> do - writeIORef reqBodyRef $ Called bs - return B.empty - - ra request{ requestBody = memoReqBody } routingRespond +toApplication ra request respond = ra request routingRespond where routingRespond :: RouteResult Response -> IO ResponseReceived routingRespond (Fail err) = respond $ responseServantErr err From 3bd3eff488a382ece37a481cc28547c5721ab187 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 26 Jan 2016 18:47:34 +0100 Subject: [PATCH 051/180] Add test for failing 400 --- servant-server/test/Servant/Server/ErrorSpec.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 745b47d9..5314f37e 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -168,6 +168,10 @@ errorRetrySpec = describe "Handler search" request methodGet "a" [jsonCT, jsonAccept] jsonBody `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) } + it "should not continue when body cannot be decoded" $ do + request methodPost "a" [jsonCT, jsonAccept] "a string" + `shouldRespondWith` 400 + -- }}} ------------------------------------------------------------------------------ -- * Error Choice {{{ From c532ecffd5ceb932486673edb2db3e644d904b65 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Thu, 28 Jan 2016 11:07:36 +0100 Subject: [PATCH 052/180] Small doc fix. --- .../src/Servant/Server/Internal/RoutingApplication.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index bcb563df..e0fb5246 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -98,10 +98,10 @@ toApplication ra request respond = do -- -- There are two reasons: -- --- 1. Currently, the order in which we perform checks coincides --- with the error we will generate. This is because during checks, --- once an error occurs, we do not perform any subsequent checks, --- but rather return this error. +-- 1. In a straight-forward implementation, the order in which we +-- perform checks will determine the error we generate. This is +-- because once an error occurs, we would abort and not perform +-- any subsequent checks, but rather return the current error. -- -- This is not a necessity: we could continue doing other checks, -- and choose the preferred error. However, that would in general From 2934bac40c5d2b54c59f3531732e039c9c9393ee Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Thu, 28 Jan 2016 11:07:59 +0100 Subject: [PATCH 053/180] Small whitespace fix. --- .../src/Servant/Server/Internal/RoutingApplication.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index e0fb5246..72f51bf7 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -159,7 +159,7 @@ data Delayed :: * -> * where -> Delayed c instance Functor Delayed where - fmap f (Delayed a b c g) = Delayed a b c ((fmap.fmap.fmap) f g) + fmap f (Delayed a b c g) = Delayed a b c ((fmap . fmap . fmap) f g) -- | Add a capture to the end of the capture block. addCapture :: Delayed (a -> b) From 927009408bbda1bfb6756f59e220cd6cfb5ed833 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Thu, 28 Jan 2016 11:08:22 +0100 Subject: [PATCH 054/180] Small whitespace fix. --- .../src/Servant/Server/Internal/RoutingApplication.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 72f51bf7..3112c640 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -240,9 +240,9 @@ runAction :: Delayed (ExceptT ServantErr IO a) -> IO r runAction action respond k = runDelayed action >>= go >>= respond where - go (Fail e) = return $ Fail e + go (Fail e) = return $ Fail e go (FailFatal e) = return $ FailFatal e - go (Route a) = do + go (Route a) = do e <- runExceptT a case e of Left err -> return . Route $ responseServantErr err From 23a31a89355f4cd3d7b0bb6f12eb85a721b9645f Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Thu, 28 Jan 2016 11:46:16 +0100 Subject: [PATCH 055/180] Eta-reduce the verb-synonyms. --- servant/src/Servant/API/Verbs.hs | 54 ++++++++++++++++---------------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs index 4915fdaf..1369d9f3 100644 --- a/servant/src/Servant/API/Verbs.hs +++ b/servant/src/Servant/API/Verbs.hs @@ -34,15 +34,15 @@ data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) a -- the relevant information is summarily presented here. -- | 'GET' with 200 status code. -type Get contentTypes a = Verb 'GET 200 contentTypes a +type Get = Verb 'GET 200 -- | 'POST' with 200 status code. -type Post contentTypes a = Verb 'POST 200 contentTypes a +type Post = Verb 'POST 200 -- | 'PUT' with 200 status code. -type Put contentTypes a = Verb 'PUT 200 contentTypes a +type Put = Verb 'PUT 200 -- | 'DELETE' with 200 status code. -type Delete contentTypes a = Verb 'DELETE 200 contentTypes a +type Delete = Verb 'DELETE 200 -- | 'PATCH' with 200 status code. -type Patch contentTypes a = Verb 'PATCH 200 contentTypes a +type Patch = Verb 'PATCH 200 -- * Other responses @@ -58,7 +58,7 @@ type Patch contentTypes a = Verb 'PATCH 200 contentTypes a -- | 'POST' with 201 status code. -- -type PostCreated contentTypes a = Verb 'POST 201 contentTypes a +type PostCreated = Verb 'POST 201 -- ** 202 Accepted @@ -69,15 +69,15 @@ type PostCreated contentTypes a = Verb 'POST 201 contentTypes a -- estimate of when the processing will be finished. -- | 'GET' with 202 status code. -type GetAccepted contentTypes a = Verb 'GET 202 contentTypes a +type GetAccepted = Verb 'GET 202 -- | 'POST' with 202 status code. -type PostAccepted contentTypes a = Verb 'POST 202 contentTypes a +type PostAccepted = Verb 'POST 202 -- | 'DELETE' with 202 status code. -type DeleteAccepted contentTypes a = Verb 'DELETE 202 contentTypes a +type DeleteAccepted = Verb 'DELETE 202 -- | 'PATCH' with 202 status code. -type PatchAccepted contentTypes a = Verb 'PATCH 202 contentTypes a +type PatchAccepted = Verb 'PATCH 202 -- | 'PUT' with 202 status code. -type PutAccepted contentTypes a = Verb 'PUT 202 contentTypes a +type PutAccepted = Verb 'PUT 202 -- ** 203 Non-Authoritative Information @@ -86,15 +86,15 @@ type PutAccepted contentTypes a = Verb 'PUT 202 contentTypes a -- information may come from a third-party. -- | 'GET' with 203 status code. -type GetNonAuthoritative contentTypes a = Verb 'GET 203 contentTypes a +type GetNonAuthoritative = Verb 'GET 203 -- | 'POST' with 203 status code. -type PostNonAuthoritative contentTypes a = Verb 'POST 203 contentTypes a +type PostNonAuthoritative = Verb 'POST 203 -- | 'DELETE' with 203 status code. -type DeleteNonAuthoritative contentTypes a = Verb 'DELETE 203 contentTypes a +type DeleteNonAuthoritative = Verb 'DELETE 203 -- | 'PATCH' with 203 status code. -type PatchNonAuthoritative contentTypes a = Verb 'PATCH 203 contentTypes a +type PatchNonAuthoritative = Verb 'PATCH 203 -- | 'PUT' with 203 status code. -type PutNonAuthoritative contentTypes a = Verb 'PUT 203 contentTypes a +type PutNonAuthoritative = Verb 'PUT 203 -- ** 204 No Content @@ -105,15 +105,15 @@ type PutNonAuthoritative contentTypes a = Verb 'PUT 203 contentTypes a -- If the document view should be reset, use @205 Reset Content@. -- | 'GET' with 204 status code. -type GetNoContent contentTypes noContent = Verb 'GET 204 contentTypes noContent +type GetNoContent = Verb 'GET 204 -- | 'POST' with 204 status code. -type PostNoContent contentTypes noContent = Verb 'POST 204 contentTypes noContent +type PostNoContent = Verb 'POST 204 -- | 'DELETE' with 204 status code. -type DeleteNoContent contentTypes noContent = Verb 'DELETE 204 contentTypes noContent +type DeleteNoContent = Verb 'DELETE 204 -- | 'PATCH' with 204 status code. -type PatchNoContent contentTypes noContent = Verb 'PATCH 204 contentTypes noContent +type PatchNoContent = Verb 'PATCH 204 -- | 'PUT' with 204 status code. -type PutNoContent contentTypes noContent = Verb 'PUT 204 contentTypes noContent +type PutNoContent = Verb 'PUT 204 -- ** 205 Reset Content @@ -124,15 +124,15 @@ type PutNoContent contentTypes noContent = Verb 'PUT 204 contentTypes noContent -- If the document view should not be reset, use @204 No Content@. -- | 'GET' with 205 status code. -type GetResetContent contentTypes noContent = Verb 'GET 205 contentTypes noContent +type GetResetContent = Verb 'GET 205 -- | 'POST' with 205 status code. -type PostResetContent contentTypes noContent = Verb 'POST 205 contentTypes noContent +type PostResetContent = Verb 'POST 205 -- | 'DELETE' with 205 status code. -type DeleteResetContent contentTypes noContent = Verb 'DELETE 205 contentTypes noContent +type DeleteResetContent = Verb 'DELETE 205 -- | 'PATCH' with 205 status code. -type PatchResetContent contentTypes noContent = Verb 'PATCH 205 contentTypes noContent +type PatchResetContent = Verb 'PATCH 205 -- | 'PUT' with 205 status code. -type PutResetContent contentTypes noContent = Verb 'PUT 205 contentTypes noContent +type PutResetContent = Verb 'PUT 205 -- ** 206 Partial Content @@ -144,7 +144,7 @@ type PutResetContent contentTypes noContent = Verb 'PUT 205 contentTypes noConte -- RFC7233 Section 4.1> -- | 'GET' with 206 status code. -type GetPartialContent contentTypes noContent = Verb 'GET 206 contentTypes noContent +type GetPartialContent = Verb 'GET 206 class ReflectMethod a where From e6e13fde8452dac7651033d52d99001ad627b9ab Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Thu, 11 Feb 2016 13:41:34 +0300 Subject: [PATCH 056/180] Make servant-foreign code nicer * non-messy imports * got rid of most long lines (>80 chars) * prisms for sum types and newtypes(we use lens anyway, so why not) * consistent indentation --- servant-foreign/src/Servant/Foreign.hs | 58 ++++--- .../src/Servant/Foreign/Internal.hs | 154 ++++++++++-------- servant-foreign/test/Servant/ForeignSpec.hs | 114 ++++++------- servant-js/src/Servant/JS/Angular.hs | 2 +- servant-js/src/Servant/JS/Axios.hs | 2 +- servant-js/src/Servant/JS/Internal.hs | 19 ++- servant-js/src/Servant/JS/JQuery.hs | 2 +- servant-js/src/Servant/JS/Vanilla.hs | 2 +- 8 files changed, 198 insertions(+), 155 deletions(-) diff --git a/servant-foreign/src/Servant/Foreign.hs b/servant-foreign/src/Servant/Foreign.hs index 5054e69f..33ac2732 100644 --- a/servant-foreign/src/Servant/Foreign.hs +++ b/servant-foreign/src/Servant/Foreign.hs @@ -1,36 +1,50 @@ -- | Generalizes all the data needed to make code generation work with -- arbitrary programming languages. module Servant.Foreign - ( HasForeign(..) - , HasForeignType(..) + ( ArgType(..) + , HeaderArg(..) + , QueryArg(..) + , Req(..) , Segment(..) , SegmentType(..) + , Url(..) + -- aliases + , Path + , ForeignType + , Arg , FunctionName - , QueryArg(..) - , HeaderArg(..) - , ArgType(..) - , Req + -- lenses + , reqUrl + , reqMethod + , reqHeaders + , reqBody + , reqReturnType + , reqFuncName + , path + , queryStr + , argName + , argType + -- prisms + , _HeaderArg + , _ReplaceHeaderArg + , _Static + , _Cap + , _Normal + , _Flag + , _List + -- rest of it + , HasForeign(..) + , HasForeignType(..) + , HasNoForeignType + , GenerateList(..) + , NoTypes , captureArg - , defReq + , isCapture , concatCase , snakeCase , camelCase - -- lenses - , argType - , argName - , isCapture - , funcName - , path - , reqUrl - , reqBody - , reqHeaders - , reqMethod - , reqReturnType - , segment - , queryStr + , defReq , listFromAPI - , GenerateList(..) - , NoTypes -- re-exports , module Servant.API ) where diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index bb2e4b1e..369d5b76 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -19,17 +19,19 @@ -- arbitrary programming languages. module Servant.Foreign.Internal where -import Control.Lens (makeLenses, (%~), (&), (.~), (<>~)) -import qualified Data.Char as C +import Control.Lens (makeLenses, makePrisms, (%~), (&), (.~), (<>~)) +import qualified Data.Char as C import Data.Proxy import Data.Text -import Data.Text.Encoding (decodeUtf8) -import GHC.Exts (Constraint) +import Data.Text.Encoding (decodeUtf8) +import GHC.Exts (Constraint) import GHC.TypeLits -import qualified Network.HTTP.Types as HTTP -import Prelude hiding (concat) +import qualified Network.HTTP.Types as HTTP +import Prelude hiding (concat) import Servant.API +type FunctionName = [Text] + -- | Function name builder that simply concat each part together concatCase :: FunctionName -> Text concatCase = concat @@ -49,36 +51,50 @@ camelCase = camelCase' . Prelude.map (replace "-" "") capitalize name = C.toUpper (Data.Text.head name) `cons` Data.Text.tail name type ForeignType = Text + type Arg = (Text, ForeignType) -newtype Segment = Segment { _segment :: SegmentType } +data SegmentType + = Static Text + -- ^ a static path segment. like "/foo" + | Cap Arg + -- ^ a capture. like "/:userid" deriving (Eq, Show) -data SegmentType = Static Text -- ^ a static path segment. like "/foo" - | Cap Arg -- ^ a capture. like "/:userid" +makePrisms ''SegmentType + +newtype Segment = Segment { unSegment :: SegmentType } deriving (Eq, Show) +makePrisms ''Segment + type Path = [Segment] -data ArgType = - Normal +data ArgType + = Normal | Flag | List deriving (Eq, Show) +makePrisms ''ArgType + data QueryArg = QueryArg { _argName :: Arg , _argType :: ArgType } deriving (Eq, Show) -data HeaderArg = HeaderArg - { headerArg :: Arg - } - | ReplaceHeaderArg - { headerArg :: Arg - , headerPattern :: Text - } deriving (Eq, Show) +makeLenses ''QueryArg +data HeaderArg = HeaderArg + { headerArg :: Arg } + | ReplaceHeaderArg + { headerArg :: Arg + , headerPattern :: Text + } deriving (Eq, Show) + +makeLenses ''HeaderArg + +makePrisms ''HeaderArg data Url = Url { _path :: Path @@ -88,7 +104,7 @@ data Url = Url defUrl :: Url defUrl = Url [] [] -type FunctionName = [Text] +makeLenses ''Url data Req = Req { _reqUrl :: Url @@ -96,12 +112,9 @@ data Req = Req , _reqHeaders :: [HeaderArg] , _reqBody :: Maybe ForeignType , _reqReturnType :: ForeignType - , _funcName :: FunctionName + , _reqFuncName :: FunctionName } deriving (Eq, Show) -makeLenses ''QueryArg -makeLenses ''Segment -makeLenses ''Url makeLenses ''Req isCapture :: Segment -> Bool @@ -155,66 +168,66 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where -- > -- class HasForeignType lang a where - typeFor :: Proxy lang -> Proxy a -> ForeignType + typeFor :: Proxy lang -> Proxy a -> ForeignType data NoTypes -instance HasForeignType NoTypes a where - typeFor _ _ = empty +instance HasForeignType NoTypes ftype where + typeFor _ _ = empty + +type HasNoForeignType = HasForeignType NoTypes class HasForeign lang (layout :: *) where type Foreign layout :: * foreignFor :: Proxy lang -> Proxy layout -> Req -> Foreign layout instance (HasForeign lang a, HasForeign lang b) - => HasForeign lang (a :<|> b) where + => HasForeign lang (a :<|> b) where type Foreign (a :<|> b) = Foreign a :<|> Foreign b foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy a) req :<|> foreignFor lang (Proxy :: Proxy b) req -instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) - => HasForeign lang (Capture sym a :> sublayout) where +instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout) + => HasForeign lang (Capture sym ftype :> sublayout) where type Foreign (Capture sym a :> sublayout) = Foreign sublayout foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ req & reqUrl.path <>~ [Segment (Cap arg)] - & funcName %~ (++ ["by", str]) - + & reqFuncName %~ (++ ["by", str]) where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy a)) + str = pack . symbolVal $ (Proxy :: Proxy sym) + arg = (str, typeFor lang (Proxy :: Proxy ftype)) instance (Elem JSON list, HasForeignType lang a, ReflectMethod method) - => HasForeign lang (Verb method status list a) where + => HasForeign lang (Verb method status list a) where type Foreign (Verb method status list a) = Req foreignFor lang Proxy req = - req & funcName %~ (methodLC :) + req & reqFuncName %~ (methodLC :) & reqMethod .~ method & reqReturnType .~ retType where - retType = typeFor lang (Proxy :: Proxy a) - method = reflectMethod (Proxy :: Proxy method) - methodLC = toLower $ decodeUtf8 method + 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 + => HasForeign lang (Header sym a :> sublayout) where type Foreign (Header sym a :> sublayout) = Foreign sublayout foreignFor lang Proxy req = foreignFor lang subP $ req & reqHeaders <>~ [HeaderArg arg] - where - hname = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (hname, typeFor lang (Proxy :: Proxy a)) - subP = Proxy :: Proxy sublayout + hname = pack . symbolVal $ (Proxy :: Proxy sym) + arg = (hname, typeFor lang (Proxy :: Proxy a)) + subP = Proxy :: Proxy sublayout instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) - => HasForeign lang (QueryParam sym a :> sublayout) where + => HasForeign lang (QueryParam sym a :> sublayout) where type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout foreignFor lang Proxy req = @@ -222,38 +235,37 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) req & reqUrl.queryStr <>~ [QueryArg arg Normal] where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy a)) + str = pack . symbolVal $ (Proxy :: Proxy sym) + arg = (str, typeFor lang (Proxy :: Proxy a)) -instance (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout) - => HasForeign lang (QueryParams sym a :> sublayout) where +instance + (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout) + => HasForeign lang (QueryParams sym a :> sublayout) where type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout - foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ req & reqUrl.queryStr <>~ [QueryArg arg List] - where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy [a])) + str = pack . symbolVal $ (Proxy :: Proxy sym) + arg = (str, typeFor lang (Proxy :: Proxy [a])) -instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang sublayout) - => HasForeign lang (QueryFlag sym :> sublayout) where +instance + (KnownSymbol sym, HasForeignType lang Bool, HasForeign lang sublayout) + => HasForeign lang (QueryFlag sym :> sublayout) where type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ req & reqUrl.queryStr <>~ [QueryArg arg Flag] - where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy a)) + str = pack . symbolVal $ (Proxy :: Proxy sym) + arg = (str, typeFor lang (Proxy :: Proxy Bool)) instance HasForeign lang Raw where type Foreign Raw = HTTP.Method -> Req foreignFor _ Proxy req method = - req & funcName %~ ((toLower $ decodeUtf8 method) :) + req & reqFuncName %~ ((toLower $ decodeUtf8 method) :) & reqMethod .~ method instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout) @@ -271,19 +283,21 @@ instance (KnownSymbol path, HasForeign lang sublayout) foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ req & reqUrl.path <>~ [Segment (Static str)] - & funcName %~ (++ [str]) - + & reqFuncName %~ (++ [str]) where - str = Data.Text.map (\c -> if c == '.' then '_' else c) - . pack . symbolVal $ (Proxy :: Proxy path) + str = + Data.Text.map (\c -> if c == '.' then '_' else c) + . pack . symbolVal $ (Proxy :: Proxy path) -instance HasForeign lang sublayout => HasForeign lang (RemoteHost :> sublayout) where +instance HasForeign lang sublayout + => HasForeign lang (RemoteHost :> sublayout) where type Foreign (RemoteHost :> sublayout) = Foreign sublayout foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) req -instance HasForeign lang sublayout => HasForeign lang (IsSecure :> sublayout) where +instance HasForeign lang sublayout + => HasForeign lang (IsSecure :> sublayout) where type Foreign (IsSecure :> sublayout) = Foreign sublayout foreignFor lang Proxy req = @@ -302,7 +316,8 @@ instance HasForeign lang sublayout => foreignFor lang Proxy = foreignFor lang (Proxy :: Proxy sublayout) -instance HasForeign lang sublayout => HasForeign lang (HttpVersion :> sublayout) where +instance HasForeign lang sublayout + => HasForeign lang (HttpVersion :> sublayout) where type Foreign (HttpVersion :> sublayout) = Foreign sublayout foreignFor lang Proxy req = @@ -317,10 +332,15 @@ class GenerateList reqs where instance GenerateList Req where generateList r = [r] -instance (GenerateList start, GenerateList rest) => GenerateList (start :<|> rest) where +instance (GenerateList start, GenerateList rest) + => GenerateList (start :<|> rest) where generateList (start :<|> rest) = (generateList start) ++ (generateList rest) -- | Generate the necessary data for codegen as a list, each 'Req' -- describing one endpoint from your API type. -listFromAPI :: (HasForeign lang api, GenerateList (Foreign api)) => Proxy lang -> Proxy api -> [Req] +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 06e722cc..0e279994 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -15,7 +15,6 @@ module Servant.ForeignSpec where import Data.Monoid ((<>)) import Data.Proxy import Servant.Foreign -import Servant.Foreign.Internal import Test.Hspec @@ -35,15 +34,19 @@ camelCaseSpec = describe "camelCase" $ do data LangX instance HasForeignType LangX () where - typeFor _ _ = "voidX" + typeFor _ _ = "voidX" + instance HasForeignType LangX Int where - typeFor _ _ = "intX" + typeFor _ _ = "intX" + instance HasForeignType LangX Bool where - typeFor _ _ = "boolX" + typeFor _ _ = "boolX" + instance OVERLAPPING_ HasForeignType LangX String where - typeFor _ _ = "stringX" + typeFor _ _ = "stringX" + instance OVERLAPPABLE_ HasForeignType LangX a => HasForeignType LangX [a] where - typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a) + typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a) type TestApi = "test" :> Header "header" [String] :> QueryFlag "flag" :> Get '[JSON] Int @@ -56,58 +59,57 @@ testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy TestApi) listFromAPISpec :: Spec listFromAPISpec = describe "listFromAPI" $ do - it "generates 4 endpoints for TestApi" $ do - length testApi `shouldBe` 4 + it "generates 4 endpoints for TestApi" $ do + length testApi `shouldBe` 4 - let [getReq, postReq, putReq, deleteReq] = testApi + let [getReq, postReq, putReq, deleteReq] = testApi - it "collects all info for get request" $ do - shouldBe getReq $ defReq - { _reqUrl = Url - [ Segment $ Static "test" ] - [ QueryArg ("flag", "boolX") Flag ] - , _reqMethod = "GET" - , _reqHeaders = [HeaderArg ("header", "listX of stringX")] - , _reqBody = Nothing - , _reqReturnType = "intX" - , _funcName = ["get", "test"] - } + it "collects all info for get request" $ do + shouldBe getReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" ] + [ QueryArg ("flag", "boolX") Flag ] + , _reqMethod = "GET" + , _reqHeaders = [HeaderArg ("header", "listX of stringX")] + , _reqBody = Nothing + , _reqReturnType = "intX" + , _reqFuncName = ["get", "test"] + } - it "collects all info for post request" $ do - shouldBe postReq $ defReq - { _reqUrl = Url - [ Segment $ Static "test" ] - [ QueryArg ("param", "intX") Normal ] - , _reqMethod = "POST" - , _reqHeaders = [] - , _reqBody = Just "listX of stringX" - , _reqReturnType = "voidX" - , _funcName = ["post", "test"] - } + it "collects all info for post request" $ do + shouldBe postReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" ] + [ QueryArg ("param", "intX") Normal ] + , _reqMethod = "POST" + , _reqHeaders = [] + , _reqBody = Just "listX of stringX" + , _reqReturnType = "voidX" + , _reqFuncName = ["post", "test"] + } - it "collects all info for put request" $ do - shouldBe putReq $ defReq - { _reqUrl = Url - [ Segment $ Static "test" ] - -- Shoud this be |intX| or |listX of intX| ? - [ QueryArg ("params", "listX of intX") List ] - , _reqMethod = "PUT" - , _reqHeaders = [] - , _reqBody = Just "stringX" - , _reqReturnType = "voidX" - , _funcName = ["put", "test"] - } - - it "collects all info for delete request" $ do - shouldBe deleteReq $ defReq - { _reqUrl = Url - [ Segment $ Static "test" - , Segment $ Cap ("id", "intX") ] - [] - , _reqMethod = "DELETE" - , _reqHeaders = [] - , _reqBody = Nothing - , _reqReturnType = "voidX" - , _funcName = ["delete", "test", "by", "id"] - } + it "collects all info for put request" $ do + shouldBe putReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" ] + -- Shoud this be |intX| or |listX of intX| ? + [ QueryArg ("params", "listX of intX") List ] + , _reqMethod = "PUT" + , _reqHeaders = [] + , _reqBody = Just "stringX" + , _reqReturnType = "voidX" + , _reqFuncName = ["put", "test"] + } + it "collects all info for delete request" $ do + shouldBe deleteReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" + , Segment $ Cap ("id", "intX") ] + [] + , _reqMethod = "DELETE" + , _reqHeaders = [] + , _reqBody = Nothing + , _reqReturnType = "voidX" + , _reqFuncName = ["delete", "test", "by", "id"] + } diff --git a/servant-js/src/Servant/JS/Angular.hs b/servant-js/src/Servant/JS/Angular.hs index 8530b03f..4d647225 100644 --- a/servant-js/src/Servant/JS/Angular.hs +++ b/servant-js/src/Servant/JS/Angular.hs @@ -128,7 +128,7 @@ generateAngularJSWith ngOptions opts req = "\n" <> fsep = if hasService then ":" else " =" - fname = namespace <> (functionNameBuilder opts $ req ^. funcName) + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) method = req ^. reqMethod url = if url' == "'" then "'/'" else url' diff --git a/servant-js/src/Servant/JS/Axios.hs b/servant-js/src/Servant/JS/Axios.hs index 25e92df3..c8540efe 100644 --- a/servant-js/src/Servant/JS/Axios.hs +++ b/servant-js/src/Servant/JS/Axios.hs @@ -116,7 +116,7 @@ generateAxiosJSWith aopts opts req = "\n" <> where hasNoModule = moduleName opts == "" - fname = namespace <> (functionNameBuilder opts $ req ^. funcName) + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) method = T.toLower . decodeUtf8 $ req ^. reqMethod url = if url' == "'" then "'/'" else url' diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs index 481536ad..61c33e0f 100644 --- a/servant-js/src/Servant/JS/Internal.hs +++ b/servant-js/src/Servant/JS/Internal.hs @@ -51,12 +51,19 @@ type JavaScriptGenerator = [Req] -> Text -- customize the output data CommonGeneratorOptions = CommonGeneratorOptions { - functionNameBuilder :: FunctionName -> Text -- ^ function generating function names - , requestBody :: Text -- ^ name used when a user want to send the request body (to let you redefine it) - , successCallback :: Text -- ^ name of the callback parameter when the request was successful - , errorCallback :: Text -- ^ name of the callback parameter when the request reported an error - , moduleName :: Text -- ^ namespace on which we define the foreign function (empty mean local var) - , urlPrefix :: Text -- ^ a prefix we should add to the Url in the codegen + functionNameBuilder :: FunctionName -> Text + -- ^ function generating function names + , requestBody :: Text + -- ^ name used when a user want to send the request body + -- (to let you redefine it) + , successCallback :: Text + -- ^ name of the callback parameter when the request was successful + , errorCallback :: Text + -- ^ name of the callback parameter when the request reported an error + , moduleName :: Text + -- ^ namespace on which we define the foreign function (empty mean local var) + , urlPrefix :: Text + -- ^ a prefix we should add to the Url in the codegen } -- | Default options. diff --git a/servant-js/src/Servant/JS/JQuery.hs b/servant-js/src/Servant/JS/JQuery.hs index 71147006..dfd3ddc0 100644 --- a/servant-js/src/Servant/JS/JQuery.hs +++ b/servant-js/src/Servant/JS/JQuery.hs @@ -81,7 +81,7 @@ generateJQueryJSWith opts req = "\n" <> namespace = if (moduleName opts) == "" then "var " else (moduleName opts) <> "." - fname = namespace <> (functionNameBuilder opts $ req ^. funcName) + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) method = req ^. reqMethod url = if url' == "'" then "'/'" else url' diff --git a/servant-js/src/Servant/JS/Vanilla.hs b/servant-js/src/Servant/JS/Vanilla.hs index f623e2a6..386a0d2e 100644 --- a/servant-js/src/Servant/JS/Vanilla.hs +++ b/servant-js/src/Servant/JS/Vanilla.hs @@ -93,7 +93,7 @@ generateVanillaJSWith opts req = "\n" <> namespace = if moduleName opts == "" then "var " else (moduleName opts) <> "." - fname = namespace <> (functionNameBuilder opts $ req ^. funcName) + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) method = req ^. reqMethod url = if url' == "'" then "'/'" else url' From e1947b9b4050f8079416ec137f1b51758e1ae1ae Mon Sep 17 00:00:00 2001 From: Daniel Gasienica Date: Wed, 17 Feb 2016 21:13:31 -0800 Subject: [PATCH 057/180] Fix minor typo: succesful --> successful --- servant-client/CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index 2c9f5279..d6ffc14b 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -6,7 +6,7 @@ HEAD * Added support for `path` on `BaseUrl`. * `client` now takes an explicit `Manager` argument. * Use `http-api-data` instead of `Servant.Common.Text` -* Client functions now consider any 2xx succesful. +* Client functions now consider any 2xx successful. * Remove matrix params. 0.4.1 From e35b4211c4eb98a2c0eb950acff5109f02245901 Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Thu, 18 Feb 2016 09:34:42 +0300 Subject: [PATCH 058/180] update servant-foreign changelog --- servant-foreign/CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/servant-foreign/CHANGELOG.md b/servant-foreign/CHANGELOG.md index 5d242065..2fcd5fb7 100644 --- a/servant-foreign/CHANGELOG.md +++ b/servant-foreign/CHANGELOG.md @@ -2,3 +2,4 @@ HEAD ----- * Use the `text` package instead of `String`. * Extract javascript-oblivious types and helpers to *servant-foreign* +* Typed-languages support From 1e5bdd6545541a995b162db2214e1b158473e830 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Thu, 18 Feb 2016 15:49:26 +0100 Subject: [PATCH 059/180] Delete .ghci file. --- .ghci | 1 - 1 file changed, 1 deletion(-) delete mode 100644 .ghci diff --git a/.ghci b/.ghci deleted file mode 100644 index 93d9b991..00000000 --- a/.ghci +++ /dev/null @@ -1 +0,0 @@ -:set -itest -isrc -packagehspec2 From f137972e5d397fe20b57b73a4fb67e8ff9101422 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 18 Feb 2016 16:36:24 +0100 Subject: [PATCH 060/180] Add 'serveWithConfig'. And keep the old signature for 'serve' --- servant-client/test/Servant/ClientSpec.hs | 6 ++-- .../auth-combinator/auth-combinator.hs | 2 +- .../socket-io-chat/socket-io-chat.hs | 2 +- servant-examples/tutorial/T1.hs | 2 +- servant-examples/tutorial/T10.hs | 2 +- servant-examples/tutorial/T2.hs | 2 +- servant-examples/tutorial/T3.hs | 2 +- servant-examples/tutorial/T4.hs | 2 +- servant-examples/tutorial/T5.hs | 2 +- servant-examples/tutorial/T6.hs | 2 +- servant-examples/tutorial/T7.hs | 2 +- servant-examples/tutorial/T9.hs | 2 +- .../wai-middleware/wai-middleware.hs | 2 +- servant-mock/example/main.hs | 2 +- servant-mock/src/Servant/Mock.hs | 17 +++++----- servant-mock/test/Servant/MockSpec.hs | 4 +-- servant-server/example/greet.hs | 2 +- servant-server/src/Servant/Server.hs | 14 +++++---- .../Server/Internal/RoutingApplication.hs | 8 +---- .../test/Servant/Server/ErrorSpec.hs | 8 ++--- .../test/Servant/Server/Internal/EnterSpec.hs | 4 +-- .../test/Servant/Server/UsingConfigSpec.hs | 10 +++--- servant-server/test/Servant/ServerSpec.hs | 31 +++++++++---------- .../test/Servant/Utils/StaticFilesSpec.hs | 4 +-- 24 files changed, 64 insertions(+), 70 deletions(-) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 4cb1ef4c..2bca7c13 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -115,7 +115,7 @@ api :: Proxy Api api = Proxy server :: Application -server = serve api EmptyConfig ( +server = serve api ( return alice :<|> return NoContent :<|> (\ name -> return $ Person name 0) @@ -142,7 +142,7 @@ failApi :: Proxy FailApi failApi = Proxy failServer :: Application -failServer = serve failApi EmptyConfig ( +failServer = serve failApi ( (\ _request respond -> respond $ responseLBS ok200 [] "") :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "") :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") @@ -232,7 +232,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do wrappedApiSpec :: Spec wrappedApiSpec = describe "error status codes" $ do - let serveW api = serve api EmptyConfig $ throwE $ ServantErr 500 "error message" "" [] + let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" [] context "are correctly handled by the client" $ let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index f2cebb4f..635c39b0 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -82,7 +82,7 @@ main :: IO () main = do dbConnection <- initDB let config = dbConnection :. EmptyConfig - run 8080 (serve api config server) + run 8080 (serveWithConfig api config server) {- Sample session: $ curl http://localhost:8080/ diff --git a/servant-examples/socket-io-chat/socket-io-chat.hs b/servant-examples/socket-io-chat/socket-io-chat.hs index 4f5e649a..1250d8fe 100644 --- a/servant-examples/socket-io-chat/socket-io-chat.hs +++ b/servant-examples/socket-io-chat/socket-io-chat.hs @@ -38,7 +38,7 @@ server sHandler = socketIOHandler app :: WaiMonad () -> Application -app sHandler = serve api EmptyConfig $ server sHandler +app sHandler = serve api $ server sHandler port :: Int port = 3001 diff --git a/servant-examples/tutorial/T1.hs b/servant-examples/tutorial/T1.hs index 2473e7c8..97bbecb8 100644 --- a/servant-examples/tutorial/T1.hs +++ b/servant-examples/tutorial/T1.hs @@ -42,4 +42,4 @@ server :: Server UserAPI server = return users app :: Application -app = serve userAPI EmptyConfig server +app = serve userAPI server diff --git a/servant-examples/tutorial/T10.hs b/servant-examples/tutorial/T10.hs index 859ff2cb..be5da4cf 100644 --- a/servant-examples/tutorial/T10.hs +++ b/servant-examples/tutorial/T10.hs @@ -68,4 +68,4 @@ server = T3.server :<|> serveDocs plain = ("Content-Type", "text/plain") app :: Application -app = serve api EmptyConfig server +app = serve api server diff --git a/servant-examples/tutorial/T2.hs b/servant-examples/tutorial/T2.hs index bd311330..fc49d256 100644 --- a/servant-examples/tutorial/T2.hs +++ b/servant-examples/tutorial/T2.hs @@ -49,4 +49,4 @@ server = return users :<|> return isaac app :: Application -app = serve userAPI EmptyConfig server +app = serve userAPI server diff --git a/servant-examples/tutorial/T3.hs b/servant-examples/tutorial/T3.hs index 4a56b946..7b5bdeb3 100644 --- a/servant-examples/tutorial/T3.hs +++ b/servant-examples/tutorial/T3.hs @@ -81,4 +81,4 @@ server = position marketing clientinfo = return (emailForClient clientinfo) app :: Application -app = serve api EmptyConfig server +app = serve api server diff --git a/servant-examples/tutorial/T4.hs b/servant-examples/tutorial/T4.hs index b86c8cb2..69cbf951 100644 --- a/servant-examples/tutorial/T4.hs +++ b/servant-examples/tutorial/T4.hs @@ -60,4 +60,4 @@ server :: Server PersonAPI server = return persons app :: Application -app = serve personAPI EmptyConfig server +app = serve personAPI server diff --git a/servant-examples/tutorial/T5.hs b/servant-examples/tutorial/T5.hs index 81812d90..3b18aedb 100644 --- a/servant-examples/tutorial/T5.hs +++ b/servant-examples/tutorial/T5.hs @@ -34,4 +34,4 @@ server = do where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." } app :: Application -app = serve ioAPI EmptyConfig server +app = serve ioAPI server diff --git a/servant-examples/tutorial/T6.hs b/servant-examples/tutorial/T6.hs index 3e24647d..781bf703 100644 --- a/servant-examples/tutorial/T6.hs +++ b/servant-examples/tutorial/T6.hs @@ -15,4 +15,4 @@ server :: Server API server = serveDirectory "tutorial" app :: Application -app = serve api EmptyConfig server +app = serve api server diff --git a/servant-examples/tutorial/T7.hs b/servant-examples/tutorial/T7.hs index 010b66dd..e0145caf 100644 --- a/servant-examples/tutorial/T7.hs +++ b/servant-examples/tutorial/T7.hs @@ -30,4 +30,4 @@ readerServer = enter readerToEither readerServerT readerToEither = Nat $ \r -> return (runReader r "hi") app :: Application -app = serve readerAPI EmptyConfig readerServer +app = serve readerAPI readerServer diff --git a/servant-examples/tutorial/T9.hs b/servant-examples/tutorial/T9.hs index a9fd575b..75dd0630 100644 --- a/servant-examples/tutorial/T9.hs +++ b/servant-examples/tutorial/T9.hs @@ -102,4 +102,4 @@ writeJSFiles = do TIO.writeFile "tutorial/t9/jq.js" jq app :: Application -app = serve api' EmptyConfig server' +app = serve api' server' diff --git a/servant-examples/wai-middleware/wai-middleware.hs b/servant-examples/wai-middleware/wai-middleware.hs index 7ad34c3f..1d26da1a 100644 --- a/servant-examples/wai-middleware/wai-middleware.hs +++ b/servant-examples/wai-middleware/wai-middleware.hs @@ -45,7 +45,7 @@ server = return products -- so applying a middleware is really as simple as -- applying a function to the result of 'serve' app :: Application -app = logStdout (serve simpleAPI EmptyConfig server) +app = logStdout (serve simpleAPI server) main :: IO () main = run 8080 app diff --git a/servant-mock/example/main.hs b/servant-mock/example/main.hs index 7f08f352..4a457467 100644 --- a/servant-mock/example/main.hs +++ b/servant-mock/example/main.hs @@ -20,4 +20,4 @@ api :: Proxy API api = Proxy main :: IO () -main = run 8080 (serve api EmptyConfig $ mock api Proxy) +main = run 8080 (serve api $ mock api Proxy) diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index 2c447ca0..7e2261e5 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #include "overlapping-compat.h" @@ -67,7 +67,6 @@ import Network.HTTP.Types.Status import Network.Wai import Servant import Servant.API.ContentTypes -import Servant.Server.Internal.Config import Test.QuickCheck.Arbitrary (Arbitrary (..), vector) import Test.QuickCheck.Gen (Gen, generate) diff --git a/servant-mock/test/Servant/MockSpec.hs b/servant-mock/test/Servant/MockSpec.hs index cd369ee6..320a60ac 100644 --- a/servant-mock/test/Servant/MockSpec.hs +++ b/servant-mock/test/Servant/MockSpec.hs @@ -52,7 +52,7 @@ spec = do context "Get" $ do let api :: Proxy (Get '[JSON] Body) api = Proxy - app = serve api EmptyConfig (mock api Proxy) + app = serve api (mock api Proxy) with (return app) $ do it "serves arbitrary response bodies" $ do get "/" `shouldRespondWith` 200{ @@ -65,7 +65,7 @@ spec = do withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body)) withoutHeader = Proxy toApp :: (HasMock api '[]) => Proxy api -> IO Application - toApp api = return $ serve api EmptyConfig (mock api (Proxy :: Proxy '[])) + toApp api = return $ serve api (mock api (Proxy :: Proxy '[])) with (toApp withHeader) $ do it "serves arbitrary response bodies" $ do get "/" `shouldRespondWith` 200{ diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index 37c3f674..3fda367d 100644 --- a/servant-server/example/greet.hs +++ b/servant-server/example/greet.hs @@ -59,7 +59,7 @@ server = helloH :<|> postGreetH :<|> deleteGreetH -- Turn the server into a WAI app. 'serve' is provided by servant, -- more precisely by the Servant.Server module. test :: Application -test = serve testApi EmptyConfig server +test = serve testApi server -- Run the server. -- diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index ea78a969..fd71efb5 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -8,6 +9,7 @@ module Servant.Server ( -- * Run a wai application from an API serve + , serveWithConfig , -- * Construct a wai Application from an API toApplication @@ -104,18 +106,18 @@ import Servant.Server.Internal.Enter -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > config :: Config '[] --- > config = EmptyConfig --- > -- > app :: Application --- > app = serve myApi config server +-- > app = serve myApi server -- > -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app -- -serve :: (HasServer layout config) +serve :: (HasServer layout '[]) => Proxy layout -> Server layout -> Application +serve p = serveWithConfig p EmptyConfig + +serveWithConfig :: (HasServer layout config) => Proxy layout -> Config config -> Server layout -> Application -serve p config server = toApplication (runRouter (route p config d)) +serveWithConfig p config server = toApplication (runRouter (route p config d)) where d = Delayed r r r (\ _ _ -> Route server) r = return (Route ()) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 4aa3bda7..3be47123 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -11,14 +11,8 @@ module Servant.Server.Internal.RoutingApplication where import Control.Applicative ((<$>)) #endif import Control.Monad.Trans.Except (ExceptT, runExceptT) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.IORef (newIORef, readIORef, - writeIORef) import Network.Wai (Application, Request, - Response, ResponseReceived, - requestBody, - strictRequestBody) + Response, ResponseReceived) import Servant.Server.Internal.ServantErr type RoutingApplication = diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 5314f37e..3575e2ac 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -42,7 +42,7 @@ errorOrderServer = \_ _ -> throwE err402 errorOrderSpec :: Spec errorOrderSpec = describe "HTTP error order" - $ with (return $ serve errorOrderApi EmptyConfig errorOrderServer) $ do + $ with (return $ serve errorOrderApi errorOrderServer) $ do let badContentType = (hContentType, "text/plain") badAccept = (hAccept, "text/plain") badMethod = methodGet @@ -89,7 +89,7 @@ prioErrorsApi = Proxy prioErrorsSpec :: Spec prioErrorsSpec = describe "PrioErrors" $ do let server = return - with (return $ serve prioErrorsApi EmptyConfig server) $ do + with (return $ serve prioErrorsApi server) $ do let check (mdescr, method) path (cdescr, ctype, body) resp = it fulldescr $ Test.Hspec.Wai.request method path [(hContentType, ctype)] body @@ -154,7 +154,7 @@ errorRetryServer errorRetrySpec :: Spec errorRetrySpec = describe "Handler search" - $ with (return $ serve errorRetryApi EmptyConfig errorRetryServer) $ do + $ with (return $ serve errorRetryApi errorRetryServer) $ do let jsonCT = (hContentType, "application/json") jsonAccept = (hAccept, "application/json") @@ -198,7 +198,7 @@ errorChoiceServer = return 0 errorChoiceSpec :: Spec errorChoiceSpec = describe "Multiple handlers return errors" - $ with (return $ serve errorChoiceApi EmptyConfig errorChoiceServer) $ do + $ with (return $ serve errorChoiceApi errorChoiceServer) $ do it "should respond with 404 if no path matches" $ do request methodGet "" [] "" `shouldRespondWith` 404 diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs index 06e8af9b..8b450377 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -48,12 +48,12 @@ combinedReaderServer = enter fReader combinedReaderServer' enterSpec :: Spec enterSpec = describe "Enter" $ do - with (return (serve readerAPI EmptyConfig readerServer)) $ do + with (return (serve readerAPI readerServer)) $ do it "allows running arbitrary monads" $ do get "int" `shouldRespondWith` "1797" post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 } - with (return (serve combinedAPI EmptyConfig combinedReaderServer)) $ do + with (return (serve combinedAPI combinedReaderServer)) $ do it "allows combnation of enters" $ do get "bool" `shouldRespondWith` "true" diff --git a/servant-server/test/Servant/Server/UsingConfigSpec.hs b/servant-server/test/Servant/Server/UsingConfigSpec.hs index a6c7ae43..64d6f2cf 100644 --- a/servant-server/test/Servant/Server/UsingConfigSpec.hs +++ b/servant-server/test/Servant/Server/UsingConfigSpec.hs @@ -30,7 +30,7 @@ testServer s = return s oneEntryApp :: Application oneEntryApp = - serve (Proxy :: Proxy OneEntryAPI) config testServer + serveWithConfig (Proxy :: Proxy OneEntryAPI) config testServer where config :: Config '[String] config = "configEntry" :. EmptyConfig @@ -40,7 +40,7 @@ type OneEntryTwiceAPI = "bar" :> ExtractFromConfig :> Get '[JSON] String oneEntryTwiceApp :: Application -oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $ +oneEntryTwiceApp = serveWithConfig (Proxy :: Proxy OneEntryTwiceAPI) config $ testServer :<|> testServer where @@ -68,7 +68,7 @@ type InjectAPI = Get '[JSON] String injectApp :: Application -injectApp = serve (Proxy :: Proxy InjectAPI) config $ +injectApp = serveWithConfig (Proxy :: Proxy InjectAPI) config $ (\ s -> return s) :<|> (\ s -> return ("tagged: " ++ s)) where @@ -90,7 +90,7 @@ type WithBirdfaceAPI = "bar" :> ExtractFromConfig :> Get '[JSON] String withBirdfaceApp :: Application -withBirdfaceApp = serve (Proxy :: Proxy WithBirdfaceAPI) config $ +withBirdfaceApp = serveWithConfig (Proxy :: Proxy WithBirdfaceAPI) config $ testServer :<|> testServer where @@ -112,7 +112,7 @@ type NamedConfigAPI = ExtractFromConfig :> Get '[JSON] String) namedConfigApp :: Application -namedConfigApp = serve (Proxy :: Proxy NamedConfigAPI) config return +namedConfigApp = serveWithConfig (Proxy :: Proxy NamedConfigAPI) config return where config :: Config '[NamedConfig "sub" '[String]] config = NamedConfig ("descend" :. EmptyConfig) :. EmptyConfig diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 04461566..efda259f 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -49,7 +49,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Server (ServantErr (..), Server, err404, - serve, Config(EmptyConfig)) + serve, serveWithConfig, Config(EmptyConfig)) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import Test.Hspec.Wai (get, liftIO, matchHeaders, @@ -67,7 +67,7 @@ import Servant.Server.Internal.Config -- * comprehensive api test -- This declaration simply checks that all instances are in place. -_ = serve comprehensiveAPI comprehensiveApiConfig +_ = serveWithConfig comprehensiveAPI comprehensiveApiConfig comprehensiveApiConfig :: Config '[NamedConfig "foo" '[]] comprehensiveApiConfig = NamedConfig EmptyConfig :. EmptyConfig @@ -112,7 +112,7 @@ verbSpec = describe "Servant.API.Verb" $ do wrongMethod m = if m == methodPatch then methodPost else methodPatch test desc api method (status :: Int) = context desc $ - with (return $ serve api EmptyConfig server) $ do + with (return $ serve api server) $ do -- HEAD and 214/215 need not return bodies unless (status `elem` [214, 215] || method == methodHead) $ @@ -187,7 +187,7 @@ captureServer legs = case legs of captureSpec :: Spec captureSpec = do describe "Servant.API.Capture" $ do - with (return (serve captureApi EmptyConfig captureServer)) $ do + with (return (serve captureApi captureServer)) $ do it "can capture parts of the 'pathInfo'" $ do response <- get "/2" @@ -198,7 +198,6 @@ captureSpec = do with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) - EmptyConfig (\ "captured" request_ respond -> respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do @@ -232,7 +231,7 @@ queryParamSpec :: Spec queryParamSpec = do describe "Servant.API.QueryParam" $ do it "allows retrieving simple GET parameters" $ - (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do + (flip runSession) (serve queryParamApi qpServer) $ do let params1 = "?name=bob" response1 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params1, @@ -244,7 +243,7 @@ queryParamSpec = do } it "allows retrieving lists in GET parameters" $ - (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do + (flip runSession) (serve queryParamApi qpServer) $ do let params2 = "?names[]=bob&names[]=john" response2 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params2, @@ -258,7 +257,7 @@ queryParamSpec = do it "allows retrieving value-less GET parameters" $ - (flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do + (flip runSession) (serve queryParamApi qpServer) $ do let params3 = "?capitalize" response3 <- Network.Wai.Test.request defaultRequest{ rawQueryString = params3, @@ -310,7 +309,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do mkReq method x = Test.Hspec.Wai.request method x [(hContentType, "application/json;charset=utf-8")] - with (return $ serve reqBodyApi EmptyConfig server) $ do + with (return $ serve reqBodyApi server) $ do it "passes the argument to the handler" $ do response <- mkReq methodPost "" (encode alice) @@ -343,13 +342,13 @@ headerSpec = describe "Servant.API.Header" $ do expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you" expectsString Nothing = error "Expected a string" - with (return (serve headerApi EmptyConfig expectsInt)) $ do + with (return (serve headerApi expectsInt)) $ do let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")] it "passes the header to the handler (Int)" $ delete' "/" "" `shouldRespondWith` 200 - with (return (serve headerApi EmptyConfig expectsString)) $ do + with (return (serve headerApi expectsString)) $ do let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")] it "passes the header to the handler (String)" $ @@ -373,7 +372,7 @@ rawSpec :: Spec rawSpec = do describe "Servant.API.Raw" $ do it "runs applications" $ do - (flip runSession) (serve rawApi EmptyConfig (rawApplication (const (42 :: Integer)))) $ do + (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do response <- Network.Wai.Test.request defaultRequest{ pathInfo = ["foo"] } @@ -381,7 +380,7 @@ rawSpec = do simpleBody response `shouldBe` "42" it "gets the pathInfo modified" $ do - (flip runSession) (serve rawApi EmptyConfig (rawApplication pathInfo)) $ do + (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do response <- Network.Wai.Test.request defaultRequest{ pathInfo = ["foo", "bar"] } @@ -415,7 +414,7 @@ alternativeServer = alternativeSpec :: Spec alternativeSpec = do describe "Servant.API.Alternative" $ do - with (return $ serve alternativeApi EmptyConfig alternativeServer) $ do + with (return $ serve alternativeApi alternativeServer) $ do it "unions endpoints" $ do response <- get "/foo" @@ -450,7 +449,7 @@ responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi" responseHeadersSpec :: Spec responseHeadersSpec = describe "ResponseHeaders" $ do - with (return $ serve (Proxy :: Proxy ResponseHeadersApi) EmptyConfig responseHeadersServer) $ do + with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do let methods = [methodGet, methodPost, methodPut, methodPatch] @@ -516,7 +515,7 @@ miscServ = versionHandler hostHandler = return . show miscCombinatorSpec :: Spec -miscCombinatorSpec = with (return $ serve miscApi EmptyConfig miscServ) $ +miscCombinatorSpec = with (return $ serve miscApi miscServ) $ describe "Misc. combinators for request inspection" $ do it "Successfully gets the HTTP version specified in the request" $ go "/version" "\"HTTP/1.0\"" diff --git a/servant-server/test/Servant/Utils/StaticFilesSpec.hs b/servant-server/test/Servant/Utils/StaticFilesSpec.hs index e6430b5c..94c63f18 100644 --- a/servant-server/test/Servant/Utils/StaticFilesSpec.hs +++ b/servant-server/test/Servant/Utils/StaticFilesSpec.hs @@ -16,7 +16,7 @@ import Test.Hspec (Spec, around_, describe, it) import Test.Hspec.Wai (get, shouldRespondWith, with) import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON) -import Servant.Server (Server, serve, Config(EmptyConfig)) +import Servant.Server (Server, serve) import Servant.ServerSpec (Person (Person)) import Servant.Utils.StaticFiles (serveDirectory) @@ -29,7 +29,7 @@ api :: Proxy Api api = Proxy app :: Application -app = serve api EmptyConfig server +app = serve api server server :: Server Api server = From 2cdd6a5fea338d6c5eb2659701562bf1030c1112 Mon Sep 17 00:00:00 2001 From: Ondrej Palkovsky Date: Thu, 18 Feb 2016 22:45:05 +0100 Subject: [PATCH 061/180] Bump aeson version. --- servant-js/servant-js.cabal | 2 +- servant-server/servant-server.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index b8a52d64..792fda22 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -63,7 +63,7 @@ executable counter buildable: False build-depends: base >= 4.7 && < 5 - , aeson >= 0.7 && < 0.11 + , aeson >= 0.7 && < 0.12 , filepath >= 1 , lens >= 4 , servant == 0.5.* diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index f6ed6319..79f3c934 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -45,7 +45,7 @@ library Servant.Utils.StaticFiles build-depends: base >= 4.7 && < 5 - , aeson >= 0.7 && < 0.11 + , aeson >= 0.7 && < 0.12 , attoparsec >= 0.12 && < 0.14 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6 From b1ff2beb8a5754dd7a260f5829953ba9bca9d9c0 Mon Sep 17 00:00:00 2001 From: Robert Klotzner Date: Fri, 26 Feb 2016 12:27:19 +0100 Subject: [PATCH 062/180] Make ServantErr throwable --- servant-server/src/Servant/Server/Internal/ServantErr.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs index 6cfa3e90..4bf3fe56 100644 --- a/servant-server/src/Servant/Server/Internal/ServantErr.hs +++ b/servant-server/src/Servant/Server/Internal/ServantErr.hs @@ -2,8 +2,10 @@ {-# LANGUAGE RecordWildCards #-} module Servant.Server.Internal.ServantErr where +import Control.Exception (Exception) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS +import Data.Typeable (Typeable) import qualified Network.HTTP.Types as HTTP import Network.Wai (Response, responseLBS) @@ -11,7 +13,10 @@ data ServantErr = ServantErr { errHTTPCode :: Int , errReasonPhrase :: String , errBody :: LBS.ByteString , errHeaders :: [HTTP.Header] - } deriving (Show, Eq, Read) + } deriving (Show, Eq, Read, Typeable) + +-- Make ServantErr throwable: +instance Exception ServantErr responseServantErr :: ServantErr -> Response responseServantErr ServantErr{..} = responseLBS status errHeaders errBody From c311f1a90b0744a0136e81401713b92a2eb247ec Mon Sep 17 00:00:00 2001 From: Robert Klotzner Date: Fri, 26 Feb 2016 13:01:54 +0100 Subject: [PATCH 063/180] Added DeriveDataTypeable ghc-7.8.4 needs that. --- servant-server/src/Servant/Server/Internal/ServantErr.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs index 4bf3fe56..0b58b6be 100644 --- a/servant-server/src/Servant/Server/Internal/ServantErr.hs +++ b/servant-server/src/Servant/Server/Internal/ServantErr.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} module Servant.Server.Internal.ServantErr where import Control.Exception (Exception) From deb2ccaab0e436fafdb5f736f0d90bfbfe334ed8 Mon Sep 17 00:00:00 2001 From: Robert Klotzner Date: Fri, 4 Mar 2016 12:11:44 +0100 Subject: [PATCH 064/180] Removed comment as suggested by @soenkehahn --- servant-server/src/Servant/Server/Internal/ServantErr.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs index 0b58b6be..1b05638c 100644 --- a/servant-server/src/Servant/Server/Internal/ServantErr.hs +++ b/servant-server/src/Servant/Server/Internal/ServantErr.hs @@ -16,7 +16,6 @@ data ServantErr = ServantErr { errHTTPCode :: Int , errHeaders :: [HTTP.Header] } deriving (Show, Eq, Read, Typeable) --- Make ServantErr throwable: instance Exception ServantErr responseServantErr :: ServantErr -> Response From 8ef4d4543b572d32abdd79c0cd7bc6ff9d2af43e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sun, 28 Feb 2016 23:23:32 +0100 Subject: [PATCH 065/180] renaming: Config -> Context --- servant-client/src/Servant/Client.hs | 4 +- servant-docs/src/Servant/Docs/Internal.hs | 2 +- .../auth-combinator/auth-combinator.hs | 14 +- .../wai-middleware/wai-middleware.hs | 2 +- .../src/Servant/Foreign/Internal.hs | 4 +- servant-mock/src/Servant/Mock.hs | 66 ++++----- servant-mock/test/Servant/MockSpec.hs | 2 +- servant-server/servant-server.cabal | 8 +- servant-server/src/Servant/Server.hs | 22 +-- servant-server/src/Servant/Server/Internal.hs | 116 ++++++++-------- .../src/Servant/Server/Internal/Config.hs | 99 -------------- .../src/Servant/Server/Internal/Context.hs | 99 ++++++++++++++ .../Servant/Server/Internal/ConfigSpec.hs | 61 --------- .../Servant/Server/Internal/ContextSpec.hs | 61 +++++++++ .../test/Servant/Server/UsingConfigSpec.hs | 125 ------------------ .../Server/UsingConfigSpec/TestCombinators.hs | 73 ---------- .../test/Servant/Server/UsingContextSpec.hs | 125 ++++++++++++++++++ .../UsingContextSpec/TestCombinators.hs | 72 ++++++++++ servant-server/test/Servant/ServerSpec.hs | 12 +- servant/servant.cabal | 2 +- servant/src/Servant/API.hs | 6 +- .../API/Internal/Test/ComprehensiveAPI.hs | 2 +- servant/src/Servant/API/WithNamedConfig.hs | 21 --- servant/src/Servant/API/WithNamedContext.hs | 21 +++ 24 files changed, 509 insertions(+), 510 deletions(-) delete mode 100644 servant-server/src/Servant/Server/Internal/Config.hs create mode 100644 servant-server/src/Servant/Server/Internal/Context.hs delete mode 100644 servant-server/test/Servant/Server/Internal/ConfigSpec.hs create mode 100644 servant-server/test/Servant/Server/Internal/ContextSpec.hs delete mode 100644 servant-server/test/Servant/Server/UsingConfigSpec.hs delete mode 100644 servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs create mode 100644 servant-server/test/Servant/Server/UsingContextSpec.hs create mode 100644 servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs delete mode 100644 servant/src/Servant/API/WithNamedConfig.hs create mode 100644 servant/src/Servant/API/WithNamedContext.hs diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 82779651..ed27b3c7 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -418,9 +418,9 @@ instance HasClient api => HasClient (IsSecure :> api) where clientWithRoute (Proxy :: Proxy api) req baseurl manager instance HasClient subapi => - HasClient (WithNamedConfig name config subapi) where + HasClient (WithNamedContext name context subapi) where - type Client (WithNamedConfig name config subapi) = Client subapi + type Client (WithNamedContext name context subapi) = Client subapi clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 70f8954c..666cad4c 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -794,7 +794,7 @@ instance HasDocs sublayout => HasDocs (Vault :> sublayout) where docsFor Proxy ep = docsFor (Proxy :: Proxy sublayout) ep -instance HasDocs sublayout => HasDocs (WithNamedConfig name config sublayout) where +instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where docsFor Proxy = docsFor (Proxy :: Proxy sublayout) -- ToSample instances for simple types diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index 635c39b0..94bb8931 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -35,18 +35,18 @@ isGoodCookie ref password = do data AuthProtected -instance (HasConfigEntry config DBConnection, HasServer rest config) - => HasServer (AuthProtected :> rest) config where +instance (HasContextEntry context DBConnection, HasServer rest context) + => HasServer (AuthProtected :> rest) context where type ServerT (AuthProtected :> rest) m = ServerT rest m - route Proxy config subserver = WithRequest $ \ request -> - route (Proxy :: Proxy rest) config $ addAcceptCheck subserver $ cookieCheck request + route Proxy context subserver = WithRequest $ \ request -> + route (Proxy :: Proxy rest) context $ addAcceptCheck subserver $ cookieCheck request where cookieCheck req = case lookup "Cookie" (requestHeaders req) of Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" } Just v -> do - let dbConnection = getConfigEntry config + let dbConnection = getContextEntry context authGranted <- isGoodCookie dbConnection v if authGranted then return $ Route () @@ -81,8 +81,8 @@ server = return prvdata :<|> return pubdata main :: IO () main = do dbConnection <- initDB - let config = dbConnection :. EmptyConfig - run 8080 (serveWithConfig api config server) + let context = dbConnection :. EmptyContext + run 8080 (serveWithContext api context server) {- Sample session: $ curl http://localhost:8080/ diff --git a/servant-examples/wai-middleware/wai-middleware.hs b/servant-examples/wai-middleware/wai-middleware.hs index 1d26da1a..a2e95860 100644 --- a/servant-examples/wai-middleware/wai-middleware.hs +++ b/servant-examples/wai-middleware/wai-middleware.hs @@ -41,7 +41,7 @@ server = return products -- logStdout :: Middleware -- i.e, logStdout :: Application -> Application --- serve :: Proxy api -> Config config -> Server api -> Application +-- serve :: Proxy api -> Context context -> Server api -> Application -- so applying a middleware is really as simple as -- applying a function to the result of 'serve' app :: Application diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 369d5b76..cb37f6b7 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -310,9 +310,9 @@ instance HasForeign lang sublayout => HasForeign lang (Vault :> sublayout) where foreignFor lang (Proxy :: Proxy sublayout) req instance HasForeign lang sublayout => - HasForeign lang (WithNamedConfig name config sublayout) where + HasForeign lang (WithNamedContext name context sublayout) where - type Foreign (WithNamedConfig name config sublayout) = Foreign sublayout + type Foreign (WithNamedContext name context sublayout) = Foreign sublayout foreignFor lang Proxy = foreignFor lang (Proxy :: Proxy sublayout) diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index 7e2261e5..9e9fed8a 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -74,7 +74,7 @@ import Test.QuickCheck.Gen (Gen, generate) -- than turns them into random-response-generating -- request handlers, hence providing an instance for -- all the combinators of the core /servant/ library. -class HasServer api config => HasMock api config where +class HasServer api context => HasMock api context where -- | Calling this method creates request handlers of -- the right type to implement the API described by -- @api@ that just generate random response values of @@ -104,67 +104,67 @@ class HasServer api config => HasMock api config where -- So under the hood, 'mock' uses the 'IO' bit to generate -- random values of type 'User' and 'Book' every time these -- endpoints are requested. - mock :: Proxy api -> Proxy config -> Server api + mock :: Proxy api -> Proxy context -> Server api -instance (HasMock a config, HasMock b config) => HasMock (a :<|> b) config where - mock _ config = mock (Proxy :: Proxy a) config :<|> mock (Proxy :: Proxy b) config +instance (HasMock a context, HasMock b context) => HasMock (a :<|> b) context where + mock _ context = mock (Proxy :: Proxy a) context :<|> mock (Proxy :: Proxy b) context -instance (KnownSymbol path, HasMock rest config) => HasMock (path :> rest) config where +instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) context where mock _ = mock (Proxy :: Proxy rest) -instance (KnownSymbol s, FromHttpApiData a, HasMock rest config) => HasMock (Capture s a :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (Capture s a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (AllCTUnrender ctypes a, HasMock rest config) => HasMock (ReqBody ctypes a :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance (AllCTUnrender ctypes a, HasMock rest context) => HasMock (ReqBody ctypes a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest config => HasMock (RemoteHost :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance HasMock rest context => HasMock (RemoteHost :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest config => HasMock (IsSecure :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance HasMock rest context => HasMock (IsSecure :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest config => HasMock (Vault :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance HasMock rest context => HasMock (Vault :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest config => HasMock (HttpVersion :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance HasMock rest context => HasMock (HttpVersion :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol s, FromHttpApiData a, HasMock rest config) - => HasMock (QueryParam s a :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) + => HasMock (QueryParam s a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol s, FromHttpApiData a, HasMock rest config) - => HasMock (QueryParams s a :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) + => HasMock (QueryParams s a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol s, HasMock rest config) => HasMock (QueryFlag s :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance (KnownSymbol s, HasMock rest context) => HasMock (QueryFlag s :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol h, FromHttpApiData a, HasMock rest config) => HasMock (Header h a :> rest) config where - mock _ config = \_ -> mock (Proxy :: Proxy rest) config +instance (KnownSymbol h, FromHttpApiData a, HasMock rest context) => HasMock (Header h a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) - => HasMock (Verb method status ctypes a) config where + => HasMock (Verb method status ctypes a) context where mock _ _ = mockArbitrary instance OVERLAPPING_ (GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes), Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) - => HasMock (Verb method status ctypes (Headers headerTypes a)) config where + => HasMock (Verb method status ctypes (Headers headerTypes a)) context where mock _ _ = mockArbitrary -instance HasMock Raw config where +instance HasMock Raw context where mock _ _ = \_req respond -> do bdy <- genBody respond $ responseLBS status200 [] bdy where genBody = pack <$> generate (vector 100 :: Gen [Char]) -instance (HasConfigEntry config (NamedConfig name subConfig), HasMock rest subConfig) => - HasMock (WithNamedConfig name subConfig rest) config where +instance (HasContextEntry context (NamedContext name subContext), HasMock rest subContext) => + HasMock (WithNamedContext name subContext rest) context where - mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subConfig) + mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subContext) mockArbitrary :: (MonadIO m, Arbitrary a) => m a mockArbitrary = liftIO (generate arbitrary) diff --git a/servant-mock/test/Servant/MockSpec.hs b/servant-mock/test/Servant/MockSpec.hs index 320a60ac..7d7b32ac 100644 --- a/servant-mock/test/Servant/MockSpec.hs +++ b/servant-mock/test/Servant/MockSpec.hs @@ -23,7 +23,7 @@ import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Mock -- This declaration simply checks that all instances are in place. -_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedConfig "foo" '[]]) +_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedContext "foo" '[]]) data Body = Body diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 79f3c934..9a23a4d7 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -37,7 +37,7 @@ library Servant Servant.Server Servant.Server.Internal - Servant.Server.Internal.Config + Servant.Server.Internal.Context Servant.Server.Internal.Enter Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication @@ -96,11 +96,11 @@ test-suite spec main-is: Spec.hs other-modules: Servant.Server.ErrorSpec - Servant.Server.Internal.ConfigSpec + Servant.Server.Internal.ContextSpec Servant.Server.Internal.EnterSpec Servant.ServerSpec - Servant.Server.UsingConfigSpec - Servant.Server.UsingConfigSpec.TestCombinators + Servant.Server.UsingContextSpec + Servant.Server.UsingContextSpec.TestCombinators Servant.Utils.StaticFilesSpec build-depends: base == 4.* diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index fd71efb5..70fae733 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -9,7 +9,7 @@ module Servant.Server ( -- * Run a wai application from an API serve - , serveWithConfig + , serveWithContext , -- * Construct a wai Application from an API toApplication @@ -38,12 +38,12 @@ module Servant.Server , generalizeNat , tweakResponse - -- * Config - , Config(..) - , HasConfigEntry(getConfigEntry) - -- ** NamedConfig - , NamedConfig(..) - , descendIntoNamedConfig + -- * Context + , Context(..) + , HasContextEntry(getContextEntry) + -- ** NamedContext + , NamedContext(..) + , descendIntoNamedContext -- * Default error type , ServantErr(..) @@ -113,11 +113,11 @@ import Servant.Server.Internal.Enter -- > main = Network.Wai.Handler.Warp.run 8080 app -- serve :: (HasServer layout '[]) => Proxy layout -> Server layout -> Application -serve p = serveWithConfig p EmptyConfig +serve p = serveWithContext p EmptyContext -serveWithConfig :: (HasServer layout config) - => Proxy layout -> Config config -> Server layout -> Application -serveWithConfig p config server = toApplication (runRouter (route p config d)) +serveWithContext :: (HasServer layout context) + => Proxy layout -> Context context -> Server layout -> Application +serveWithContext p context server = toApplication (runRouter (route p context d)) where d = Delayed r r r (\ _ _ -> Route server) r = return (Route ()) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index daf44640..05450649 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -15,7 +15,7 @@ module Servant.Server.Internal ( module Servant.Server.Internal - , module Servant.Server.Internal.Config + , module Servant.Server.Internal.Context , module Servant.Server.Internal.Router , module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.ServantErr @@ -53,7 +53,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, Vault, - WithNamedConfig) + WithNamedContext) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), @@ -62,16 +62,16 @@ import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) -import Servant.Server.Internal.Config +import Servant.Server.Internal.Context import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr -class HasServer layout config where +class HasServer layout context where type ServerT layout (m :: * -> *) :: * - route :: Proxy layout -> Config config -> Delayed (Server layout) -> Router + route :: Proxy layout -> Context context -> Delayed (Server layout) -> Router type Server layout = ServerT layout (ExceptT ServantErr IO) @@ -88,12 +88,12 @@ type Server layout = ServerT layout (ExceptT ServantErr IO) -- > server = listAllBooks :<|> postBook -- > where listAllBooks = ... -- > postBook book = ... -instance (HasServer a config, HasServer b config) => HasServer (a :<|> b) config where +instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) context where type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m - route Proxy config server = choice (route pa config ((\ (a :<|> _) -> a) <$> server)) - (route pb config ((\ (_ :<|> b) -> b) <$> server)) + route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server)) + (route pb context ((\ (_ :<|> b) -> b) <$> server)) where pa = Proxy :: Proxy a pb = Proxy :: Proxy b @@ -117,16 +117,16 @@ captured _ = parseUrlPieceMaybe -- > server = getBook -- > where getBook :: Text -> ExceptT ServantErr IO Book -- > getBook isbn = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout config) - => HasServer (Capture capture a :> sublayout) config where +instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) + => HasServer (Capture capture a :> sublayout) context where type ServerT (Capture capture a :> sublayout) m = a -> ServerT sublayout m - route Proxy config d = + route Proxy context d = DynamicRouter $ \ first -> route (Proxy :: Proxy sublayout) - config + context (addCapture d $ case captured captureProxy first of Nothing -> return $ Fail err404 Just v -> return $ Route v @@ -195,7 +195,7 @@ methodRouterHeaders method proxy status action = LeafRouter route' instance OVERLAPPABLE_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status - ) => HasServer (Verb method status ctypes a) config where + ) => HasServer (Verb method status ctypes a) context where type ServerT (Verb method status ctypes a) m = m a @@ -206,7 +206,7 @@ instance OVERLAPPABLE_ instance OVERLAPPING_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status , GetHeaders (Headers h a) - ) => HasServer (Verb method status ctypes (Headers h a)) config where + ) => HasServer (Verb method status ctypes (Headers h a)) context where type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) @@ -234,15 +234,15 @@ instance OVERLAPPING_ -- > server = viewReferer -- > where viewReferer :: Referer -> ExceptT ServantErr IO referer -- > viewReferer referer = return referer -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) - => HasServer (Header sym a :> sublayout) config where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) + => HasServer (Header sym a :> sublayout) context where type ServerT (Header sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy config subserver = WithRequest $ \ request -> + route Proxy context subserver = WithRequest $ \ request -> let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request) - in route (Proxy :: Proxy sublayout) config (passToServer subserver mheader) + in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader) where str = fromString $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, @@ -266,13 +266,13 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) -- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book] -- > getBooksBy Nothing = ...return all books... -- > getBooksBy (Just author) = ...return books by the given author... -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) - => HasServer (QueryParam sym a :> sublayout) config where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) + => HasServer (QueryParam sym a :> sublayout) context where type ServerT (QueryParam sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy config subserver = WithRequest $ \ request -> + route Proxy context subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of @@ -280,7 +280,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) Just Nothing -> Nothing -- param present with no value -> Nothing Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to -- the right type - in route (Proxy :: Proxy sublayout) config (passToServer subserver param) + in route (Proxy :: Proxy sublayout) context (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, @@ -302,20 +302,20 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) -- > server = getBooksBy -- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book] -- > getBooksBy authors = ...return all books by these authors... -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) - => HasServer (QueryParams sym a :> sublayout) config where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) + => HasServer (QueryParams sym a :> sublayout) context where type ServerT (QueryParams sym a :> sublayout) m = [a] -> ServerT sublayout m - route Proxy config subserver = WithRequest $ \ request -> + route Proxy context subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request -- if sym is "foo", we look for query string parameters -- named "foo" or "foo[]" and call parseQueryParam on the -- corresponding values parameters = filter looksLikeParam querytext values = mapMaybe (convert . snd) parameters - in route (Proxy :: Proxy sublayout) config (passToServer subserver values) + in route (Proxy :: Proxy sublayout) context (passToServer subserver values) where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") convert Nothing = Nothing @@ -333,19 +333,19 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout config) -- > server = getBooks -- > where getBooks :: Bool -> ExceptT ServantErr IO [Book] -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... -instance (KnownSymbol sym, HasServer sublayout config) - => HasServer (QueryFlag sym :> sublayout) config where +instance (KnownSymbol sym, HasServer sublayout context) + => HasServer (QueryFlag sym :> sublayout) context where type ServerT (QueryFlag sym :> sublayout) m = Bool -> ServerT sublayout m - route Proxy config subserver = WithRequest $ \ request -> + route Proxy context subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of Just Nothing -> True -- param is there, with no value Just (Just v) -> examine v -- param with a value Nothing -> False -- param not in the query string - in route (Proxy :: Proxy sublayout) config (passToServer subserver param) + in route (Proxy :: Proxy sublayout) context (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False @@ -358,7 +358,7 @@ instance (KnownSymbol sym, HasServer sublayout config) -- > -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" -instance HasServer Raw config where +instance HasServer Raw context where type ServerT Raw m = Application @@ -390,14 +390,14 @@ instance HasServer Raw config where -- > server = postBook -- > where postBook :: Book -> ExceptT ServantErr IO Book -- > postBook book = ...insert into your db... -instance ( AllCTUnrender list a, HasServer sublayout config - ) => HasServer (ReqBody list a :> sublayout) config where +instance ( AllCTUnrender list a, HasServer sublayout context + ) => HasServer (ReqBody list a :> sublayout) context where type ServerT (ReqBody list a :> sublayout) m = a -> ServerT sublayout m - route Proxy config subserver = WithRequest $ \ request -> - route (Proxy :: Proxy sublayout) config (addBodyCheck subserver (bodyCheck request)) + route Proxy context subserver = WithRequest $ \ request -> + route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request)) where bodyCheck request = do -- See HTTP RFC 2616, section 7.2.1 @@ -415,40 +415,40 @@ instance ( AllCTUnrender list a, HasServer sublayout config -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @sublayout@. -instance (KnownSymbol path, HasServer sublayout config) => HasServer (path :> sublayout) config where +instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> sublayout) context where type ServerT (path :> sublayout) m = ServerT sublayout m - route Proxy config subserver = StaticRouter $ + route Proxy context subserver = StaticRouter $ M.singleton (cs (symbolVal proxyPath)) - (route (Proxy :: Proxy sublayout) config subserver) + (route (Proxy :: Proxy sublayout) context subserver) where proxyPath = Proxy :: Proxy path -instance HasServer api config => HasServer (RemoteHost :> api) config where +instance HasServer api context => HasServer (RemoteHost :> api) context where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m - route Proxy config subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) config (passToServer subserver $ remoteHost req) + route Proxy context subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req) -instance HasServer api config => HasServer (IsSecure :> api) config where +instance HasServer api context => HasServer (IsSecure :> api) context where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m - route Proxy config subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) config (passToServer subserver $ secure req) + route Proxy context subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) context (passToServer subserver $ secure req) where secure req = if isSecure req then Secure else NotSecure -instance HasServer api config => HasServer (Vault :> api) config where +instance HasServer api context => HasServer (Vault :> api) context where type ServerT (Vault :> api) m = Vault -> ServerT api m - route Proxy config subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) config (passToServer subserver $ vault req) + route Proxy context subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) context (passToServer subserver $ vault req) -instance HasServer api config => HasServer (HttpVersion :> api) config where +instance HasServer api context => HasServer (HttpVersion :> api) context where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m - route Proxy config subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req) + route Proxy context subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req) pathIsEmpty :: Request -> Bool pathIsEmpty = go . pathInfo @@ -459,19 +459,19 @@ pathIsEmpty = go . pathInfo ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP --- * configs +-- * contexts -instance (HasConfigEntry config (NamedConfig name subConfig), HasServer subApi subConfig) - => HasServer (WithNamedConfig name subConfig subApi) config where +instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) + => HasServer (WithNamedContext name subContext subApi) context where - type ServerT (WithNamedConfig name subConfig subApi) m = + type ServerT (WithNamedContext name subContext subApi) m = ServerT subApi m - route Proxy config delayed = - route subProxy subConfig delayed + route Proxy context delayed = + route subProxy subContext delayed where subProxy :: Proxy subApi subProxy = Proxy - subConfig :: Config subConfig - subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config + subContext :: Context subContext + subContext = descendIntoNamedContext (Proxy :: Proxy name) context diff --git a/servant-server/src/Servant/Server/Internal/Config.hs b/servant-server/src/Servant/Server/Internal/Config.hs deleted file mode 100644 index c162494b..00000000 --- a/servant-server/src/Servant/Server/Internal/Config.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -#include "overlapping-compat.h" - -module Servant.Server.Internal.Config where - -import Data.Proxy -import GHC.TypeLits - --- | When calling 'Servant.Server.serve' you have to supply a configuration --- value of type @'Config' configTypes@. This parameter is used to pass values --- to combinators. (It shouldn't be confused with general configuration --- parameters for your web app, like the port, etc.). If you don't use --- combinators that require any config entries, you can just pass 'EmptyConfig'. --- To create a config with entries, use the operator @(':.')@. The parameter of --- the type 'Config' is a type-level list reflecting the types of the contained --- config entries: --- --- >>> :type True :. () :. EmptyConfig --- True :. () :. EmptyConfig :: Config '[Bool, ()] -data Config configTypes where - EmptyConfig :: Config '[] - (:.) :: x -> Config xs -> Config (x ': xs) -infixr 5 :. - -instance Show (Config '[]) where - show EmptyConfig = "EmptyConfig" -instance (Show a, Show (Config as)) => Show (Config (a ': as)) where - showsPrec outerPrecedence (a :. as) = - showParen (outerPrecedence > 5) $ - shows a . showString " :. " . shows as - -instance Eq (Config '[]) where - _ == _ = True -instance (Eq a, Eq (Config as)) => Eq (Config (a ': as)) where - x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 - --- | This class is used to access config entries in 'Config's. 'getConfigEntry' --- returns the first value where the type matches: --- --- >>> getConfigEntry (True :. False :. EmptyConfig) :: Bool --- True --- --- If the 'Config' does not contain an entry of the requested type, you'll get --- an error: --- --- >>> getConfigEntry (True :. False :. EmptyConfig) :: String --- ... --- No instance for (HasConfigEntry '[] [Char]) --- ... -class HasConfigEntry (config :: [*]) (val :: *) where - getConfigEntry :: Config config -> val - -instance OVERLAPPABLE_ - HasConfigEntry xs val => HasConfigEntry (notIt ': xs) val where - getConfigEntry (_ :. xs) = getConfigEntry xs - -instance OVERLAPPING_ - HasConfigEntry (val ': xs) val where - getConfigEntry (x :. _) = x - --- * support for named subconfigs - --- | Normally config entries are accessed by their types. In case you need --- to have multiple values of the same type in your 'Config' and need to access --- them, we provide 'NamedConfig'. You can think of it as sub-namespaces for --- 'Config's. -data NamedConfig (name :: Symbol) (subConfig :: [*]) - = NamedConfig (Config subConfig) - --- | 'descendIntoNamedConfig' allows you to access `NamedConfig's. Usually you --- won't have to use it yourself but instead use a combinator like --- 'Servant.API.WithNamedConfig.WithNamedConfig'. --- --- This is how 'descendIntoNamedConfig' works: --- --- >>> :set -XFlexibleContexts --- >>> let subConfig = True :. EmptyConfig --- >>> :type subConfig --- subConfig :: Config '[Bool] --- >>> let parentConfig = False :. (NamedConfig subConfig :: NamedConfig "subConfig" '[Bool]) :. EmptyConfig --- >>> :type parentConfig --- parentConfig :: Config '[Bool, NamedConfig "subConfig" '[Bool]] --- >>> descendIntoNamedConfig (Proxy :: Proxy "subConfig") parentConfig :: Config '[Bool] --- True :. EmptyConfig -descendIntoNamedConfig :: forall config name subConfig . - HasConfigEntry config (NamedConfig name subConfig) => - Proxy (name :: Symbol) -> Config config -> Config subConfig -descendIntoNamedConfig Proxy config = - let NamedConfig subConfig = getConfigEntry config :: NamedConfig name subConfig - in subConfig diff --git a/servant-server/src/Servant/Server/Internal/Context.hs b/servant-server/src/Servant/Server/Internal/Context.hs new file mode 100644 index 00000000..3b116c9d --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Context.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +#include "overlapping-compat.h" + +module Servant.Server.Internal.Context where + +import Data.Proxy +import GHC.TypeLits + +-- | When calling 'Servant.Server.serve' you have to supply a context +-- value of type @'Context' contextTypes@. This parameter is used to pass values +-- to combinators. (It shouldn't be confused with general configuration +-- parameters for your web app, like the port, etc.). If you don't use +-- combinators that require any context entries, you can just use `serve` (or +-- pass 'EmptyContext'). To create a context with entries, use the operator +-- @(':.')@. The parameter of the type 'Context' is a type-level list reflecting +-- the types of the contained context entries: +-- +-- >>> :type True :. () :. EmptyContext +-- True :. () :. EmptyContext :: Context '[Bool, ()] +data Context contextTypes where + EmptyContext :: Context '[] + (:.) :: x -> Context xs -> Context (x ': xs) +infixr 5 :. + +instance Show (Context '[]) where + show EmptyContext = "EmptyContext" +instance (Show a, Show (Context as)) => Show (Context (a ': as)) where + showsPrec outerPrecedence (a :. as) = + showParen (outerPrecedence > 5) $ + shows a . showString " :. " . shows as + +instance Eq (Context '[]) where + _ == _ = True +instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where + x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 + +-- | This class is used to access context entries in 'Context's. 'getContextEntry' +-- returns the first value where the type matches: +-- +-- >>> getContextEntry (True :. False :. EmptyContext) :: Bool +-- True +-- +-- If the 'Context' does not contain an entry of the requested type, you'll get +-- an error: +-- +-- >>> getContextEntry (True :. False :. EmptyContext) :: String +-- ... +-- No instance for (HasContextEntry '[] [Char]) +-- ... +class HasContextEntry (context :: [*]) (val :: *) where + getContextEntry :: Context context -> val + +instance OVERLAPPABLE_ + HasContextEntry xs val => HasContextEntry (notIt ': xs) val where + getContextEntry (_ :. xs) = getContextEntry xs + +instance OVERLAPPING_ + HasContextEntry (val ': xs) val where + getContextEntry (x :. _) = x + +-- * support for named subcontexts + +-- | Normally context entries are accessed by their types. In case you need +-- to have multiple values of the same type in your 'Context' and need to access +-- them, we provide 'NamedContext'. You can think of it as sub-namespaces for +-- 'Context's. +data NamedContext (name :: Symbol) (subContext :: [*]) + = NamedContext (Context subContext) + +-- | 'descendIntoNamedContext' allows you to access `NamedContext's. Usually you +-- won't have to use it yourself but instead use a combinator like +-- 'Servant.API.WithNamedContext.WithNamedContext'. +-- +-- This is how 'descendIntoNamedContext' works: +-- +-- >>> :set -XFlexibleContexts +-- >>> let subContext = True :. EmptyContext +-- >>> :type subContext +-- subContext :: Context '[Bool] +-- >>> let parentContext = False :. (NamedContext subContext :: NamedContext "subContext" '[Bool]) :. EmptyContext +-- >>> :type parentContext +-- parentContext :: Context '[Bool, NamedContext "subContext" '[Bool]] +-- >>> descendIntoNamedContext (Proxy :: Proxy "subContext") parentContext :: Context '[Bool] +-- True :. EmptyContext +descendIntoNamedContext :: forall context name subContext . + HasContextEntry context (NamedContext name subContext) => + Proxy (name :: Symbol) -> Context context -> Context subContext +descendIntoNamedContext Proxy context = + let NamedContext subContext = getContextEntry context :: NamedContext name subContext + in subContext diff --git a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs b/servant-server/test/Servant/Server/Internal/ConfigSpec.hs deleted file mode 100644 index 182d91a8..00000000 --- a/servant-server/test/Servant/Server/Internal/ConfigSpec.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# OPTIONS_GHC -fdefer-type-errors #-} -module Servant.Server.Internal.ConfigSpec (spec) where - -import Data.Proxy (Proxy (..)) -import Test.Hspec (Spec, describe, it, shouldBe, pending, context) -import Test.ShouldNotTypecheck (shouldNotTypecheck) - -import Servant.API -import Servant.Server.Internal.Config - -spec :: Spec -spec = do - describe "getConfigEntry" $ do - it "gets the config if a matching one exists" $ do - let config = 'a' :. EmptyConfig - getConfigEntry config `shouldBe` 'a' - - it "gets the first matching config" $ do - let config = 'a' :. 'b' :. EmptyConfig - getConfigEntry config `shouldBe` 'a' - - it "does not typecheck if type does not exist" $ do - let config = 'a' :. EmptyConfig - x = getConfigEntry config :: Bool - shouldNotTypecheck x - - context "Show instance" $ do - let config = 'a' :. True :. EmptyConfig - it "has a Show instance" $ do - show config `shouldBe` "'a' :. True :. EmptyConfig" - - context "bracketing" $ do - it "works" $ do - show (Just config) `shouldBe` "Just ('a' :. True :. EmptyConfig)" - - it "works with operators" $ do - let config = (1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig) - show config `shouldBe` "(1 :. 'a' :. EmptyConfig) :<|> ('b' :. True :. EmptyConfig)" - - describe "descendIntoNamedConfig" $ do - let config :: Config [Char, NamedConfig "sub" '[Char]] - config = - 'a' :. - (NamedConfig subConfig :: NamedConfig "sub" '[Char]) - :. EmptyConfig - subConfig = 'b' :. EmptyConfig - it "allows extracting subconfigs" $ do - descendIntoNamedConfig (Proxy :: Proxy "sub") config `shouldBe` subConfig - - it "allows extracting entries from subconfigs" $ do - getConfigEntry (descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Char]) - `shouldBe` 'b' - - it "does not typecheck if subConfig has the wrong type" $ do - let x = descendIntoNamedConfig (Proxy :: Proxy "sub") config :: Config '[Int] - shouldNotTypecheck (show x) - - it "does not typecheck if subConfig with that name doesn't exist" $ do - let x = descendIntoNamedConfig (Proxy :: Proxy "foo") config :: Config '[Char] - shouldNotTypecheck (show x) diff --git a/servant-server/test/Servant/Server/Internal/ContextSpec.hs b/servant-server/test/Servant/Server/Internal/ContextSpec.hs new file mode 100644 index 00000000..dfac1e2e --- /dev/null +++ b/servant-server/test/Servant/Server/Internal/ContextSpec.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fdefer-type-errors #-} +module Servant.Server.Internal.ContextSpec (spec) where + +import Data.Proxy (Proxy (..)) +import Test.Hspec (Spec, describe, it, shouldBe, pending, context) +import Test.ShouldNotTypecheck (shouldNotTypecheck) + +import Servant.API +import Servant.Server.Internal.Context + +spec :: Spec +spec = do + describe "getContextEntry" $ do + it "gets the context if a matching one exists" $ do + let cxt = 'a' :. EmptyContext + getContextEntry cxt `shouldBe` 'a' + + it "gets the first matching context" $ do + let cxt = 'a' :. 'b' :. EmptyContext + getContextEntry cxt `shouldBe` 'a' + + it "does not typecheck if type does not exist" $ do + let cxt = 'a' :. EmptyContext + x = getContextEntry cxt :: Bool + shouldNotTypecheck x + + context "Show instance" $ do + let cxt = 'a' :. True :. EmptyContext + it "has a Show instance" $ do + show cxt `shouldBe` "'a' :. True :. EmptyContext" + + context "bracketing" $ do + it "works" $ do + show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)" + + it "works with operators" $ do + let cxt = (1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext) + show cxt `shouldBe` "(1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)" + + describe "descendIntoNamedContext" $ do + let cxt :: Context [Char, NamedContext "sub" '[Char]] + cxt = + 'a' :. + (NamedContext subContext :: NamedContext "sub" '[Char]) + :. EmptyContext + subContext = 'b' :. EmptyContext + it "allows extracting subcontexts" $ do + descendIntoNamedContext (Proxy :: Proxy "sub") cxt `shouldBe` subContext + + it "allows extracting entries from subcontexts" $ do + getContextEntry (descendIntoNamedContext (Proxy :: Proxy "sub") cxt :: Context '[Char]) + `shouldBe` 'b' + + it "does not typecheck if subContext has the wrong type" $ do + let x = descendIntoNamedContext (Proxy :: Proxy "sub") cxt :: Context '[Int] + shouldNotTypecheck (show x) + + it "does not typecheck if subContext with that name doesn't exist" $ do + let x = descendIntoNamedContext (Proxy :: Proxy "foo") cxt :: Context '[Char] + shouldNotTypecheck (show x) diff --git a/servant-server/test/Servant/Server/UsingConfigSpec.hs b/servant-server/test/Servant/Server/UsingConfigSpec.hs deleted file mode 100644 index 64d6f2cf..00000000 --- a/servant-server/test/Servant/Server/UsingConfigSpec.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} - -module Servant.Server.UsingConfigSpec where - -import Control.Monad.Trans.Except -import Network.Wai -import Test.Hspec (Spec, describe, it) -import Test.Hspec.Wai - -import Servant -import Servant.Server.UsingConfigSpec.TestCombinators - -spec :: Spec -spec = do - spec1 - spec2 - spec3 - spec4 - --- * API - -type OneEntryAPI = - ExtractFromConfig :> Get '[JSON] String - -testServer :: String -> ExceptT ServantErr IO String -testServer s = return s - -oneEntryApp :: Application -oneEntryApp = - serveWithConfig (Proxy :: Proxy OneEntryAPI) config testServer - where - config :: Config '[String] - config = "configEntry" :. EmptyConfig - -type OneEntryTwiceAPI = - "foo" :> ExtractFromConfig :> Get '[JSON] String :<|> - "bar" :> ExtractFromConfig :> Get '[JSON] String - -oneEntryTwiceApp :: Application -oneEntryTwiceApp = serveWithConfig (Proxy :: Proxy OneEntryTwiceAPI) config $ - testServer :<|> - testServer - where - config :: Config '[String] - config = "configEntryTwice" :. EmptyConfig - --- * tests - -spec1 :: Spec -spec1 = do - describe "accessing config entries from custom combinators" $ do - with (return oneEntryApp) $ do - it "allows retrieving a ConfigEntry" $ do - get "/" `shouldRespondWith` "\"configEntry\"" - - with (return oneEntryTwiceApp) $ do - it "allows retrieving the same ConfigEntry twice" $ do - get "/foo" `shouldRespondWith` "\"configEntryTwice\"" - get "/bar" `shouldRespondWith` "\"configEntryTwice\"" - -type InjectAPI = - InjectIntoConfig :> "untagged" :> ExtractFromConfig :> - Get '[JSON] String :<|> - InjectIntoConfig :> "tagged" :> ExtractFromConfig :> - Get '[JSON] String - -injectApp :: Application -injectApp = serveWithConfig (Proxy :: Proxy InjectAPI) config $ - (\ s -> return s) :<|> - (\ s -> return ("tagged: " ++ s)) - where - config = EmptyConfig - -spec2 :: Spec -spec2 = do - with (return injectApp) $ do - describe "inserting config entries with custom combinators" $ do - it "allows to inject config entries" $ do - get "/untagged" `shouldRespondWith` "\"injected\"" - - it "allows to inject tagged config entries" $ do - get "/tagged" `shouldRespondWith` "\"tagged: injected\"" - -type WithBirdfaceAPI = - "foo" :> ExtractFromConfig :> Get '[JSON] String :<|> - NamedConfigWithBirdface "sub" '[String] :> - "bar" :> ExtractFromConfig :> Get '[JSON] String - -withBirdfaceApp :: Application -withBirdfaceApp = serveWithConfig (Proxy :: Proxy WithBirdfaceAPI) config $ - testServer :<|> - testServer - where - config :: Config '[String, (NamedConfig "sub" '[String])] - config = - "firstEntry" :. - (NamedConfig ("secondEntry" :. EmptyConfig)) :. - EmptyConfig - -spec3 :: Spec -spec3 = do - with (return withBirdfaceApp) $ do - it "allows retrieving different ConfigEntries for the same combinator" $ do - get "/foo" `shouldRespondWith` "\"firstEntry\"" - get "/bar" `shouldRespondWith` "\"secondEntry\"" - -type NamedConfigAPI = - WithNamedConfig "sub" '[String] ( - ExtractFromConfig :> Get '[JSON] String) - -namedConfigApp :: Application -namedConfigApp = serveWithConfig (Proxy :: Proxy NamedConfigAPI) config return - where - config :: Config '[NamedConfig "sub" '[String]] - config = NamedConfig ("descend" :. EmptyConfig) :. EmptyConfig - -spec4 :: Spec -spec4 = do - with (return namedConfigApp) $ do - describe "WithNamedConfig" $ do - it "allows descending into a subconfig for a given api" $ do - get "/" `shouldRespondWith` "\"descend\"" diff --git a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs deleted file mode 100644 index 1da892e8..00000000 --- a/servant-server/test/Servant/Server/UsingConfigSpec/TestCombinators.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | These are custom combinators for Servant.Server.UsingConfigSpec. --- --- (For writing your own combinators you need to import Internal modules, for --- just *using* combinators that require a Config, you don't. This module is --- separate from Servant.Server.UsingConfigSpec to test that the module imports --- work out this way.) -module Servant.Server.UsingConfigSpec.TestCombinators where - -import GHC.TypeLits - -import Servant -import Servant.Server.Internal.Config -import Servant.Server.Internal.RoutingApplication - -data ExtractFromConfig - -instance (HasConfigEntry config String, HasServer subApi config) => - HasServer (ExtractFromConfig :> subApi) config where - - type ServerT (ExtractFromConfig :> subApi) m = - String -> ServerT subApi m - - route Proxy config delayed = - route subProxy config (fmap (inject config) delayed :: Delayed (Server subApi)) - where - subProxy :: Proxy subApi - subProxy = Proxy - - inject config f = f (getConfigEntry config) - -data InjectIntoConfig - -instance (HasServer subApi (String ': config)) => - HasServer (InjectIntoConfig :> subApi) config where - - type ServerT (InjectIntoConfig :> subApi) m = - ServerT subApi m - - route Proxy config delayed = - route subProxy newConfig delayed - where - subProxy :: Proxy subApi - subProxy = Proxy - - newConfig = ("injected" :: String) :. config - -data NamedConfigWithBirdface (name :: Symbol) (subConfig :: [*]) - -instance (HasConfigEntry config (NamedConfig name subConfig), HasServer subApi subConfig) => - HasServer (NamedConfigWithBirdface name subConfig :> subApi) config where - - type ServerT (NamedConfigWithBirdface name subConfig :> subApi) m = - ServerT subApi m - - route Proxy config delayed = - route subProxy subConfig delayed - where - subProxy :: Proxy subApi - subProxy = Proxy - - subConfig :: Config subConfig - subConfig = descendIntoNamedConfig (Proxy :: Proxy name) config diff --git a/servant-server/test/Servant/Server/UsingContextSpec.hs b/servant-server/test/Servant/Server/UsingContextSpec.hs new file mode 100644 index 00000000..33b04125 --- /dev/null +++ b/servant-server/test/Servant/Server/UsingContextSpec.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Server.UsingContextSpec where + +import Control.Monad.Trans.Except +import Network.Wai +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Wai + +import Servant +import Servant.Server.UsingContextSpec.TestCombinators + +spec :: Spec +spec = do + spec1 + spec2 + spec3 + spec4 + +-- * API + +type OneEntryAPI = + ExtractFromContext :> Get '[JSON] String + +testServer :: String -> ExceptT ServantErr IO String +testServer s = return s + +oneEntryApp :: Application +oneEntryApp = + serveWithContext (Proxy :: Proxy OneEntryAPI) context testServer + where + context :: Context '[String] + context = "contextEntry" :. EmptyContext + +type OneEntryTwiceAPI = + "foo" :> ExtractFromContext :> Get '[JSON] String :<|> + "bar" :> ExtractFromContext :> Get '[JSON] String + +oneEntryTwiceApp :: Application +oneEntryTwiceApp = serveWithContext (Proxy :: Proxy OneEntryTwiceAPI) context $ + testServer :<|> + testServer + where + context :: Context '[String] + context = "contextEntryTwice" :. EmptyContext + +-- * tests + +spec1 :: Spec +spec1 = do + describe "accessing context entries from custom combinators" $ do + with (return oneEntryApp) $ do + it "allows retrieving a ContextEntry" $ do + get "/" `shouldRespondWith` "\"contextEntry\"" + + with (return oneEntryTwiceApp) $ do + it "allows retrieving the same ContextEntry twice" $ do + get "/foo" `shouldRespondWith` "\"contextEntryTwice\"" + get "/bar" `shouldRespondWith` "\"contextEntryTwice\"" + +type InjectAPI = + InjectIntoContext :> "untagged" :> ExtractFromContext :> + Get '[JSON] String :<|> + InjectIntoContext :> "tagged" :> ExtractFromContext :> + Get '[JSON] String + +injectApp :: Application +injectApp = serveWithContext (Proxy :: Proxy InjectAPI) context $ + (\ s -> return s) :<|> + (\ s -> return ("tagged: " ++ s)) + where + context = EmptyContext + +spec2 :: Spec +spec2 = do + with (return injectApp) $ do + describe "inserting context entries with custom combinators" $ do + it "allows to inject context entries" $ do + get "/untagged" `shouldRespondWith` "\"injected\"" + + it "allows to inject tagged context entries" $ do + get "/tagged" `shouldRespondWith` "\"tagged: injected\"" + +type WithBirdfaceAPI = + "foo" :> ExtractFromContext :> Get '[JSON] String :<|> + NamedContextWithBirdface "sub" '[String] :> + "bar" :> ExtractFromContext :> Get '[JSON] String + +withBirdfaceApp :: Application +withBirdfaceApp = serveWithContext (Proxy :: Proxy WithBirdfaceAPI) context $ + testServer :<|> + testServer + where + context :: Context '[String, (NamedContext "sub" '[String])] + context = + "firstEntry" :. + (NamedContext ("secondEntry" :. EmptyContext)) :. + EmptyContext + +spec3 :: Spec +spec3 = do + with (return withBirdfaceApp) $ do + it "allows retrieving different ContextEntries for the same combinator" $ do + get "/foo" `shouldRespondWith` "\"firstEntry\"" + get "/bar" `shouldRespondWith` "\"secondEntry\"" + +type NamedContextAPI = + WithNamedContext "sub" '[String] ( + ExtractFromContext :> Get '[JSON] String) + +namedContextApp :: Application +namedContextApp = serveWithContext (Proxy :: Proxy NamedContextAPI) context return + where + context :: Context '[NamedContext "sub" '[String]] + context = NamedContext ("descend" :. EmptyContext) :. EmptyContext + +spec4 :: Spec +spec4 = do + with (return namedContextApp) $ do + describe "WithNamedContext" $ do + it "allows descending into a subcontext for a given api" $ do + get "/" `shouldRespondWith` "\"descend\"" diff --git a/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs new file mode 100644 index 00000000..48595c9c --- /dev/null +++ b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | These are custom combinators for Servant.Server.UsingContextSpec. +-- +-- (For writing your own combinators you need to import Internal modules, for +-- just *using* combinators that require a Context, you don't. This module is +-- separate from Servant.Server.UsingContextSpec to test that the module imports +-- work out this way.) +module Servant.Server.UsingContextSpec.TestCombinators where + +import GHC.TypeLits + +import Servant +import Servant.Server.Internal.RoutingApplication + +data ExtractFromContext + +instance (HasContextEntry context String, HasServer subApi context) => + HasServer (ExtractFromContext :> subApi) context where + + type ServerT (ExtractFromContext :> subApi) m = + String -> ServerT subApi m + + route Proxy context delayed = + route subProxy context (fmap (inject context) delayed :: Delayed (Server subApi)) + where + subProxy :: Proxy subApi + subProxy = Proxy + + inject context f = f (getContextEntry context) + +data InjectIntoContext + +instance (HasServer subApi (String ': context)) => + HasServer (InjectIntoContext :> subApi) context where + + type ServerT (InjectIntoContext :> subApi) m = + ServerT subApi m + + route Proxy context delayed = + route subProxy newContext delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + newContext = ("injected" :: String) :. context + +data NamedContextWithBirdface (name :: Symbol) (subContext :: [*]) + +instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) => + HasServer (NamedContextWithBirdface name subContext :> subApi) context where + + type ServerT (NamedContextWithBirdface name subContext :> subApi) m = + ServerT subApi m + + route Proxy context delayed = + route subProxy subContext delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + subContext :: Context subContext + subContext = descendIntoNamedContext (Proxy :: Proxy name) context diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index efda259f..6bf9defc 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -49,7 +49,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Server (ServantErr (..), Server, err404, - serve, serveWithConfig, Config(EmptyConfig)) + serve, serveWithContext, Context(EmptyContext)) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import Test.Hspec.Wai (get, liftIO, matchHeaders, @@ -61,16 +61,16 @@ import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.Router (tweakResponse, runRouter, Router, Router'(LeafRouter)) -import Servant.Server.Internal.Config - (Config(..), NamedConfig(..)) +import Servant.Server.Internal.Context + (Context(..), NamedContext(..)) -- * comprehensive api test -- This declaration simply checks that all instances are in place. -_ = serveWithConfig comprehensiveAPI comprehensiveApiConfig +_ = serveWithContext comprehensiveAPI comprehensiveApiContext -comprehensiveApiConfig :: Config '[NamedConfig "foo" '[]] -comprehensiveApiConfig = NamedConfig EmptyConfig :. EmptyConfig +comprehensiveApiContext :: Context '[NamedContext "foo" '[]] +comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext -- * Specs diff --git a/servant/servant.cabal b/servant/servant.cabal index 437c9843..1b5e3c27 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -41,7 +41,7 @@ library Servant.API.Sub Servant.API.Vault Servant.API.Verbs - Servant.API.WithNamedConfig + Servant.API.WithNamedContext Servant.Utils.Links build-depends: base >=4.7 && <5 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 2da0d4cf..fcaf5e91 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -23,8 +23,8 @@ module Servant.API ( -- | Is the request made through HTTPS? module Servant.API.Vault, -- | Access the location for arbitrary data to be shared by applications and middleware - module Servant.API.WithNamedConfig, - -- | Access config entries in combinators in servant-server + module Servant.API.WithNamedContext, + -- | Access context entries in combinators in servant-server -- * Actual endpoints, distinguished by HTTP method module Servant.API.Verbs, @@ -90,7 +90,7 @@ import Servant.API.Verbs (PostCreated, Delete, DeleteAccepte PutNoContent, PutNonAuthoritative, ReflectMethod (reflectMethod), Verb, StdMethod(..)) -import Servant.API.WithNamedConfig (WithNamedConfig) +import Servant.API.WithNamedContext (WithNamedContext) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', URI (..), safeLink) import Web.HttpApiData (FromHttpApiData (..), diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index 733968b2..91d01727 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -30,7 +30,7 @@ type ComprehensiveAPI = Vault :> GET :<|> Verb 'POST 204 '[JSON] () :<|> Verb 'POST 204 '[JSON] Int :<|> - WithNamedConfig "foo" '[] GET + WithNamedContext "foo" '[] GET comprehensiveAPI :: Proxy ComprehensiveAPI comprehensiveAPI = Proxy diff --git a/servant/src/Servant/API/WithNamedConfig.hs b/servant/src/Servant/API/WithNamedConfig.hs deleted file mode 100644 index 72b59e2f..00000000 --- a/servant/src/Servant/API/WithNamedConfig.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} - -module Servant.API.WithNamedConfig where - -import GHC.TypeLits - --- | 'WithNamedConfig' names a specific tagged configuration to use for the --- combinators in the API. (See also in @servant-server@, --- @Servant.Server.Config@.) For example: --- --- > type UseNamedConfigAPI = WithNamedConfig "myConfig" '[String] ( --- > ReqBody '[JSON] Int :> Get '[JSON] Int) --- --- Both the 'ReqBody' and 'Get' combinators will use the 'NamedConfig' with --- type tag "myConfig" as their configuration. --- --- 'Config's are only relevant for @servant-server@. --- --- For more information, see the tutorial. -data WithNamedConfig (name :: Symbol) (subConfig :: [*]) subApi diff --git a/servant/src/Servant/API/WithNamedContext.hs b/servant/src/Servant/API/WithNamedContext.hs new file mode 100644 index 00000000..e467ea41 --- /dev/null +++ b/servant/src/Servant/API/WithNamedContext.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} + +module Servant.API.WithNamedContext where + +import GHC.TypeLits + +-- | 'WithNamedContext' names a specific tagged context to use for the +-- combinators in the API. (See also in @servant-server@, +-- @Servant.Server.Context@.) For example: +-- +-- > type UseNamedContextAPI = WithNamedContext "myContext" '[String] ( +-- > ReqBody '[JSON] Int :> Get '[JSON] Int) +-- +-- Both the 'ReqBody' and 'Get' combinators will use the 'WithNamedContext' with +-- type tag "myContext" as their context. +-- +-- 'Context's are only relevant for @servant-server@. +-- +-- For more information, see the tutorial. +data WithNamedContext (name :: Symbol) (subContext :: [*]) subApi From c6b6639453058d4ba89777109d3d7e417a6ca77c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Tue, 1 Mar 2016 09:53:49 +0800 Subject: [PATCH 066/180] reworded Context comment --- .../src/Servant/Server/Internal/Context.hs | 21 ++++++++++++------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/Context.hs b/servant-server/src/Servant/Server/Internal/Context.hs index 3b116c9d..580a7542 100644 --- a/servant-server/src/Servant/Server/Internal/Context.hs +++ b/servant-server/src/Servant/Server/Internal/Context.hs @@ -15,14 +15,19 @@ module Servant.Server.Internal.Context where import Data.Proxy import GHC.TypeLits --- | When calling 'Servant.Server.serve' you have to supply a context --- value of type @'Context' contextTypes@. This parameter is used to pass values --- to combinators. (It shouldn't be confused with general configuration --- parameters for your web app, like the port, etc.). If you don't use --- combinators that require any context entries, you can just use `serve` (or --- pass 'EmptyContext'). To create a context with entries, use the operator --- @(':.')@. The parameter of the type 'Context' is a type-level list reflecting --- the types of the contained context entries: +-- | 'Context's are used to pass values to combinators. (They are __not__ meant +-- to be used to pass parameters to your handlers, i.e. they should not replace +-- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using +-- with 'Servant.Server.Internal.Enter.enter'.) If you don't use combinators that +-- require any context entries, you can just use 'Servant.Server.serve' as always. +-- +-- If you are using combinators that require a non-empty 'Context' you have to +-- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all +-- the values your combinators need. A 'Context' is essentially a heterogenous +-- list and accessing the elements is being done by type (see 'getContextEntry'). +-- The parameter of the type 'Context' is a type-level list reflecting the types +-- of the contained context entries. To create a 'Context' with entries, use the +-- operator @(':.')@: -- -- >>> :type True :. () :. EmptyContext -- True :. () :. EmptyContext :: Context '[Bool, ()] From 6dc577c821b20778a74ff9d8070c86c0e4c2332a Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 18:49:01 +0100 Subject: [PATCH 067/180] Add basic-auth data types to servant core --- servant/src/Servant/API.hs | 4 ++++ servant/src/Servant/API/BasicAuth.hs | 29 ++++++++++++++++++++++++++++ 2 files changed, 33 insertions(+) create mode 100644 servant/src/Servant/API/BasicAuth.hs diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index fcaf5e91..5dda312c 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -29,6 +29,9 @@ module Servant.API ( -- * Actual endpoints, distinguished by HTTP method module Servant.API.Verbs, + -- * Authentication + module Servant.API.BasicAuth, + -- * Content Types module Servant.API.ContentTypes, -- | Serializing and deserializing types based on @Accept@ and @@ -51,6 +54,7 @@ module Servant.API ( ) where import Servant.API.Alternative ((:<|>) (..)) +import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..)) import Servant.API.Capture (Capture) import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, FromFormUrlEncoded (..), JSON, diff --git a/servant/src/Servant/API/BasicAuth.hs b/servant/src/Servant/API/BasicAuth.hs new file mode 100644 index 00000000..0a78bded --- /dev/null +++ b/servant/src/Servant/API/BasicAuth.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +module Servant.API.BasicAuth where + +import Data.ByteString (ByteString) +import Data.Typeable (Typeable) +import GHC.TypeLits (Symbol) + + +-- | Combinator for . +-- +-- *IMPORTANT*: Only use Basic Auth over HTTPS! Credentials are not hashed or +-- encrypted. Note also that because the same credentials are sent on every +-- request, Basic Auth is not as secure as some alternatives. Further, the +-- implementation in servant-server does not protect against some types of +-- timing attacks. +-- +-- In Basic Auth, username and password are base64-encoded and transmitted via +-- the @Authorization@ header. Handshakes are not required, making it +-- relatively efficient. +data BasicAuth (realm :: Symbol) + deriving (Typeable) + +-- | A simple datatype to hold data required to decorate a request +data BasicAuthData = BasicAuthData { basicAuthUsername :: !ByteString + , basicAuthPassword :: !ByteString + } From 84172c613554af58db1f9736c3e148d4d90d6179 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 19:00:31 +0100 Subject: [PATCH 068/180] Augment Delayed to handle authentication. --- .../Server/Internal/RoutingApplication.hs | 92 +++++++++++++++---- 1 file changed, 72 insertions(+), 20 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 3be47123..7e846504 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -52,6 +52,7 @@ toApplication ra request respond = ra request routingRespond -- static routes (can cause 404) -- delayed captures (can cause 404) -- methods (can cause 405) +-- authentication and authorization (can cause 401, 403) -- delayed body (can cause 415, 400) -- accept header (can cause 406) -- @@ -119,36 +120,71 @@ toApplication ra request respond = ra request routingRespond -- The accept header check can be performed as the final -- computation in this block. It can cause a 406. -- -data Delayed :: * -> * where - Delayed :: IO (RouteResult a) - -> IO (RouteResult ()) - -> IO (RouteResult b) - -> (a -> b -> RouteResult c) - -> Delayed c +data Delayed c where + Delayed :: { capturesD :: IO (RouteResult captures) + , methodD :: IO (RouteResult ()) + , authD :: IO (RouteResult auth) + , bodyD :: IO (RouteResult body) + , serverD :: (captures -> auth -> body -> RouteResult c) + } -> Delayed c instance Functor Delayed where - fmap f (Delayed a b c g) = Delayed a b c ((fmap . fmap . fmap) f g) + fmap f Delayed{..} + = Delayed { capturesD = capturesD + , methodD = methodD + , authD = authD + , bodyD = bodyD + , serverD = (fmap.fmap.fmap.fmap) f serverD + } -- Note [Existential Record Update] -- | Add a capture to the end of the capture block. addCapture :: Delayed (a -> b) -> IO (RouteResult a) -> Delayed b -addCapture (Delayed captures method body server) new = - Delayed (combineRouteResults (,) captures new) method body (\ (x, v) y -> ($ v) <$> server x y) +addCapture Delayed{..} new + = Delayed { capturesD = combineRouteResults (,) capturesD new + , methodD = methodD + , authD = authD + , bodyD = bodyD + , serverD = \ (x, v) y z -> ($ v) <$> serverD x y z + } -- Note [Existential Record Update] -- | Add a method check to the end of the method block. addMethodCheck :: Delayed a -> IO (RouteResult ()) -> Delayed a -addMethodCheck (Delayed captures method body server) new = - Delayed captures (combineRouteResults const method new) body server +addMethodCheck Delayed{..} new + = Delayed { capturesD = capturesD + , methodD = combineRouteResults const methodD new + , authD = authD + , bodyD = bodyD + , serverD = serverD + } -- Note [Existential Record Update] + +-- | Add an auth check to the end of the auth block. +addAuthCheck :: Delayed (a -> b) + -> IO (RouteResult a) + -> Delayed b +addAuthCheck Delayed{..} new + = Delayed { capturesD = capturesD + , methodD = methodD + , authD = combineRouteResults (,) authD new + , bodyD = bodyD + , serverD = \ x (y, v) z -> ($ v) <$> serverD x y z + } -- Note [Existential Record Update] -- | Add a body check to the end of the body block. addBodyCheck :: Delayed (a -> b) -> IO (RouteResult a) -> Delayed b -addBodyCheck (Delayed captures method body server) new = - Delayed captures method (combineRouteResults (,) body new) (\ x (y, v) -> ($ v) <$> server x y) +addBodyCheck Delayed{..} new + = Delayed { capturesD = capturesD + , methodD = methodD + , authD = authD + , bodyD = combineRouteResults (,) bodyD new + , serverD = \ x y (z, v) -> ($ v) <$> serverD x y z + } -- Note [Existential Record Update] + -- | Add an accept header check to the end of the body block. -- The accept header check should occur after the body check, @@ -157,8 +193,13 @@ addBodyCheck (Delayed captures method body server) new = addAcceptCheck :: Delayed a -> IO (RouteResult ()) -> Delayed a -addAcceptCheck (Delayed captures method body server) new = - Delayed captures method (combineRouteResults const body new) server +addAcceptCheck Delayed{..} new + = Delayed { capturesD = capturesD + , methodD = methodD + , authD = authD + , bodyD = combineRouteResults const bodyD new + , serverD = serverD + } -- Note [Existential Record Update] -- | Many combinators extract information that is passed to -- the handler without the possibility of failure. In such a @@ -190,13 +231,17 @@ combineRouteResults f m1 m2 = -- | Run a delayed server. Performs all scheduled operations -- in order, and passes the results from the capture and body -- blocks on to the actual handler. +-- +-- This should only be called once per request; otherwise the guarantees about +-- effect and HTTP error ordering break down. runDelayed :: Delayed a -> IO (RouteResult a) -runDelayed (Delayed captures method body server) = - captures `bindRouteResults` \ c -> - method `bindRouteResults` \ _ -> - body `bindRouteResults` \ b -> - return (server c b) +runDelayed Delayed{..} = + capturesD `bindRouteResults` \ c -> + methodD `bindRouteResults` \ _ -> + authD `bindRouteResults` \ a -> + bodyD `bindRouteResults` \ b -> + return (serverD c a b) -- | Runs a delayed server and the resulting action. -- Takes a continuation that lets us send a response. @@ -215,3 +260,10 @@ runAction action respond k = runDelayed action >>= go >>= respond case e of Left err -> return . Route $ responseServantErr err Right x -> return $! k x + +{- Note [Existential Record Update] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Due to GHC issue , we cannot +do the more succint thing - just update the records we actually change. +-} From 9966e5b3044078f18aece298cb80cc93f4cde4c1 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 19:23:05 +0100 Subject: [PATCH 069/180] Add userdata to BasicAuth API type --- servant/src/Servant/API/BasicAuth.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant/src/Servant/API/BasicAuth.hs b/servant/src/Servant/API/BasicAuth.hs index 0a78bded..cc38ddb3 100644 --- a/servant/src/Servant/API/BasicAuth.hs +++ b/servant/src/Servant/API/BasicAuth.hs @@ -20,7 +20,7 @@ import GHC.TypeLits (Symbol) -- In Basic Auth, username and password are base64-encoded and transmitted via -- the @Authorization@ header. Handshakes are not required, making it -- relatively efficient. -data BasicAuth (realm :: Symbol) +data BasicAuth (realm :: Symbol) (userData :: *) deriving (Typeable) -- | A simple datatype to hold data required to decorate a request From 104ac29bf8da2891cd4e4b875d279efeaa6807db Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 19:56:15 +0100 Subject: [PATCH 070/180] Add BasicAuth support to servant-server --- servant-server/servant-server.cabal | 3 + servant-server/src/Servant/Server.hs | 7 +- servant-server/src/Servant/Server/Internal.hs | 25 +++++- .../src/Servant/Server/Internal/BasicAuth.hs | 69 ++++++++++++++++ .../Server/Internal/RoutingApplication.hs | 1 + .../test/Servant/Server/ErrorSpec.hs | 78 +++++++++++++------ servant-server/test/Servant/ServerSpec.hs | 77 +++++++++++++----- servant/servant.cabal | 1 + 8 files changed, 214 insertions(+), 47 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/BasicAuth.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 9a23a4d7..2aa25cee 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -38,6 +38,7 @@ library Servant.Server Servant.Server.Internal Servant.Server.Internal.Context + Servant.Server.Internal.BasicAuth Servant.Server.Internal.Enter Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication @@ -47,6 +48,7 @@ library base >= 4.7 && < 5 , aeson >= 0.7 && < 0.12 , attoparsec >= 0.12 && < 0.14 + , base64-bytestring == 1.0.* , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6 , http-api-data >= 0.1 && < 0.3 @@ -67,6 +69,7 @@ library , wai >= 3.0 && < 3.3 , wai-app-static >= 3.0 && < 3.2 , warp >= 3.0 && < 3.3 + , word8 == 0.1.* hs-source-dirs: src default-language: Haskell2010 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 70fae733..6b37297e 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -45,6 +45,11 @@ module Servant.Server , NamedContext(..) , descendIntoNamedContext + + -- * Basic Authentication + , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck) + , BasicAuthResult(..) + -- * Default error type , ServantErr(..) -- ** 3XX @@ -119,7 +124,7 @@ serveWithContext :: (HasServer layout context) => Proxy layout -> Context context -> Server layout -> Application serveWithContext p context server = toApplication (runRouter (route p context d)) where - d = Delayed r r r (\ _ _ -> Route server) + d = Delayed r r r r (\ _ _ _ -> Route server) r = return (Route ()) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 05450649..bdf7451f 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -16,6 +16,7 @@ module Servant.Server.Internal ( module Servant.Server.Internal , module Servant.Server.Internal.Context + , module Servant.Server.Internal.BasicAuth , module Servant.Server.Internal.Router , module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.ServantErr @@ -26,6 +27,7 @@ import Control.Applicative ((<$>)) #endif import Control.Monad.Trans.Except (ExceptT) import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL import qualified Data.Map as M import Data.Maybe (fromMaybe, mapMaybe) @@ -48,7 +50,7 @@ import Web.HttpApiData.Internal (parseHeaderMaybe, parseQueryParamMaybe, parseUrlPieceMaybe) -import Servant.API ((:<|>) (..), (:>), Capture, +import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture, Verb, ReflectMethod(reflectMethod), IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, @@ -63,6 +65,7 @@ import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) import Servant.Server.Internal.Context +import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr @@ -450,6 +453,26 @@ instance HasServer api context => HasServer (HttpVersion :> api) context where route Proxy context subserver = WithRequest $ \req -> route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req) +-- * Basic Authentication + +-- | Basic Authentication +instance ( KnownSymbol realm + , HasServer api config + , HasConfigEntry config (BasicAuthCheck usr) + ) + => HasServer (BasicAuth realm usr :> api) config where + + type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m + + route Proxy config subserver = WithRequest $ \ request -> + route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request) + where + realm = BC8.pack $ symbolVal (Proxy :: Proxy realm) + basicAuthConfig = getConfigEntry config + authCheck req = runBasicAuth req realm basicAuthConfig + +-- * helpers + pathIsEmpty :: Request -> Bool pathIsEmpty = go . pathInfo where go [] = True diff --git a/servant-server/src/Servant/Server/Internal/BasicAuth.hs b/servant-server/src/Servant/Server/Internal/BasicAuth.hs new file mode 100644 index 00000000..f941f401 --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/BasicAuth.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Servant.Server.Internal.BasicAuth where + +import Control.Monad (guard) +import qualified Data.ByteString as BS +import Data.ByteString.Base64 (decodeLenient) +import Data.Monoid ((<>)) +import Data.Typeable (Typeable) +import Data.Word8 (isSpace, toLower, _colon) +import GHC.Generics +import Network.HTTP.Types (Header) +import Network.Wai (Request, requestHeaders) + +import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) +import Servant.Server.Internal.RoutingApplication +import Servant.Server.Internal.ServantErr + +-- * Basic Auth + +-- | servant-server's current implementation of basic authentication is not +-- immune to certian kinds of timing attacks. Decoding payloads does not take +-- a fixed amount of time. + +-- | The result of authentication/authorization +data BasicAuthResult usr + = Unauthorized + | BadPassword + | NoSuchUser + | Authorized usr + deriving (Eq, Show, Read, Generic, Typeable, Functor) + +-- | Datatype wrapping a function used to check authentication. +newtype BasicAuthCheck usr = BasicAuthCheck + { unBasicAuthCheck :: BasicAuthData + -> IO (BasicAuthResult usr) + } + deriving (Generic, Typeable, Functor) + +-- | Internal method to make a basic-auth challenge +mkBAChallengerHdr :: BS.ByteString -> Header +mkBAChallengerHdr realm = ("WWW-Authenticate", "Basic realm=\"" <> realm <> "\"") + +-- | Find and decode an 'Authorization' header from the request as Basic Auth +decodeBAHdr :: Request -> Maybe BasicAuthData +decodeBAHdr req = do + ah <- lookup "Authorization" $ requestHeaders req + let (b, rest) = BS.break isSpace ah + guard (BS.map toLower b == "basic") + let decoded = decodeLenient (BS.dropWhile isSpace rest) + let (username, passWithColonAtHead) = BS.break (== _colon) decoded + (_, password) <- BS.uncons passWithColonAtHead + return (BasicAuthData username password) + +-- | Run and check basic authentication, returning the appropriate http error per +-- the spec. +runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> IO (RouteResult usr) +runBasicAuth req realm (BasicAuthCheck ba) = + case decodeBAHdr req of + Nothing -> plzAuthenticate + Just e -> ba e >>= \res -> case res of + BadPassword -> plzAuthenticate + NoSuchUser -> plzAuthenticate + Unauthorized -> return $ Fail err403 + Authorized usr -> return $ Route usr + where plzAuthenticate = return $ Fail err401 { errHeaders = [mkBAChallengerHdr realm] } diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 7e846504..cd1ac019 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} module Servant.Server.Internal.RoutingApplication where diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 3575e2ac..5ae22361 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Server.ErrorSpec (spec) where @@ -10,7 +11,8 @@ import Data.Aeson (encode) import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BCL import Data.Proxy -import Network.HTTP.Types (hAccept, hContentType, methodGet, +import Network.HTTP.Types (hAccept, hAuthorization, + hContentType, methodGet, methodPost, methodPut) import Safe (readMay) import Test.Hspec @@ -25,57 +27,79 @@ spec = describe "HTTP Errors" $ do errorRetrySpec errorChoiceSpec +-- * Auth machinery (reused throughout) + +-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password. +errorOrderAuthCheck :: BasicAuthCheck () +errorOrderAuthCheck = + let check (BasicAuthData username password) = + if username == "servant" && password == "server" + then return (Authorized ()) + else return Unauthorized + in BasicAuthCheck check + ------------------------------------------------------------------------------ -- * Error Order {{{ type ErrorOrderApi = "home" + :> BasicAuth "error-realm" () :> ReqBody '[JSON] Int :> Capture "t" Int :> Post '[JSON] Int - errorOrderApi :: Proxy ErrorOrderApi errorOrderApi = Proxy errorOrderServer :: Server ErrorOrderApi -errorOrderServer = \_ _ -> throwE err402 +errorOrderServer = \_ _ _ -> throwE err402 errorOrderSpec :: Spec -errorOrderSpec = describe "HTTP error order" - $ with (return $ serve errorOrderApi errorOrderServer) $ do +errorOrderSpec = + describe "HTTP error order" $ + with (return $ serve errorOrderApi + (errorOrderAuthCheck :. EmptyConfig) + errorOrderServer + ) $ do let badContentType = (hContentType, "text/plain") badAccept = (hAccept, "text/plain") badMethod = methodGet badUrl = "home/nonexistent" badBody = "nonsense" + badAuth = (hAuthorization, "Basic foofoofoo") goodContentType = (hContentType, "application/json") goodAccept = (hAccept, "application/json") goodMethod = methodPost goodUrl = "home/2" goodBody = encode (5 :: Int) + -- username:password = servant:server + goodAuth = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=") it "has 404 as its highest priority error" $ do - request badMethod badUrl [badContentType, badAccept] badBody + request badMethod badUrl [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 404 it "has 405 as its second highest priority error" $ do - request badMethod goodUrl [badContentType, badAccept] badBody + request badMethod goodUrl [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 405 - it "has 415 as its third highest priority error" $ do - request goodMethod goodUrl [badContentType, badAccept] badBody + it "has 401 as its third highest priority error (auth)" $ do + request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody + `shouldRespondWith` 401 + + it "has 415 as its fourth highest priority error" $ do + request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody `shouldRespondWith` 415 - it "has 400 as its fourth highest priority error" $ do - request goodMethod goodUrl [goodContentType, badAccept] badBody + it "has 400 as its fifth highest priority error" $ do + request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody `shouldRespondWith` 400 - it "has 406 as its fifth highest priority error" $ do - request goodMethod goodUrl [goodContentType, badAccept] goodBody + it "has 406 as its sixth highest priority error" $ do + request goodMethod goodUrl [goodAuth, goodContentType, badAccept] goodBody `shouldRespondWith` 406 it "has handler-level errors as last priority" $ do - request goodMethod goodUrl [goodContentType, goodAccept] goodBody + request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody `shouldRespondWith` 402 type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer @@ -134,9 +158,12 @@ type ErrorRetryApi :<|> "a" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 2 :<|> "a" :> ReqBody '[JSON] String :> Post '[JSON] Int -- 3 :<|> "a" :> ReqBody '[JSON] Int :> Get '[JSON] Int -- 4 - :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5 - :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 6 - :<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 7 + :<|> "a" :> BasicAuth "bar-realm" () + :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5 + :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 6 + + :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 7 + :<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 8 errorRetryApi :: Proxy ErrorRetryApi errorRetryApi = Proxy @@ -148,13 +175,18 @@ errorRetryServer :<|> (\_ -> return 2) :<|> (\_ -> return 3) :<|> (\_ -> return 4) - :<|> (\_ -> return 5) + :<|> (\_ _ -> return 5) :<|> (\_ -> return 6) :<|> (\_ -> return 7) + :<|> (\_ -> return 8) errorRetrySpec :: Spec -errorRetrySpec = describe "Handler search" - $ with (return $ serve errorRetryApi errorRetryServer) $ do +errorRetrySpec = + describe "Handler search" $ + with (return $ serve errorRetryApi + (errorOrderAuthCheck :. EmptyConfig) + errorRetryServer + ) $ do let jsonCT = (hContentType, "application/json") jsonAccept = (hAccept, "application/json") @@ -162,16 +194,12 @@ errorRetrySpec = describe "Handler search" it "should continue when URLs don't match" $ do request methodPost "" [jsonCT, jsonAccept] jsonBody - `shouldRespondWith` 200 { matchBody = Just $ encode (7 :: Int) } + `shouldRespondWith` 200 { matchBody = Just $ encode (8 :: Int) } it "should continue when methods don't match" $ do request methodGet "a" [jsonCT, jsonAccept] jsonBody `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) } - it "should not continue when body cannot be decoded" $ do - request methodPost "a" [jsonCT, jsonAccept] "a string" - `shouldRespondWith` 400 - -- }}} ------------------------------------------------------------------------------ -- * Error Choice {{{ diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 6bf9defc..71f1bd9f 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -38,8 +38,8 @@ import Network.Wai.Internal (Response (ResponseBuilder)) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody, simpleHeaders, simpleStatus) -import Servant.API ((:<|>) (..), (:>), Capture, Delete, - Get, Header (..), +import Servant.API ((:<|>) (..), (:>), BasicAuth, BasicAuthData(BasicAuthData), + Capture, Delete, Get, Header (..), Headers, HttpVersion, IsSecure (..), JSON, NoContent (..), Patch, PlainText, @@ -49,13 +49,16 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Server (ServantErr (..), Server, err404, - serve, serveWithContext, Context(EmptyContext)) + serve, serveWithContext, Context((:.), EmptyContext)) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) +import qualified Test.Hspec.Wai as THW import Test.Hspec.Wai (get, liftIO, matchHeaders, - matchStatus, request, - shouldRespondWith, with, (<:>)) + matchStatus, shouldRespondWith, + with, (<:>)) +import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck), + BasicAuthResult(Authorized,Unauthorized)) import Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..)) import Servant.Server.Internal.Router @@ -86,6 +89,7 @@ spec = do responseHeadersSpec routerSpec miscCombinatorSpec + basicAuthSpec ------------------------------------------------------------------------------ -- * verbSpec {{{ @@ -117,49 +121,49 @@ verbSpec = describe "Servant.API.Verb" $ do -- HEAD and 214/215 need not return bodies unless (status `elem` [214, 215] || method == methodHead) $ it "returns the person" $ do - response <- Test.Hspec.Wai.request method "/" [] "" + response <- THW.request method "/" [] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status liftIO $ decode' (simpleBody response) `shouldBe` Just alice it "returns no content on NoContent" $ do - response <- Test.Hspec.Wai.request method "/noContent" [] "" + response <- THW.request method "/noContent" [] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status liftIO $ simpleBody response `shouldBe` "" -- HEAD should not return body when (method == methodHead) $ it "HEAD returns no content body" $ do - response <- Test.Hspec.Wai.request method "/" [] "" + response <- THW.request method "/" [] "" liftIO $ simpleBody response `shouldBe` "" it "throws 405 on wrong method " $ do - Test.Hspec.Wai.request (wrongMethod method) "/" [] "" + THW.request (wrongMethod method) "/" [] "" `shouldRespondWith` 405 it "returns headers" $ do - response1 <- Test.Hspec.Wai.request method "/header" [] "" + response1 <- THW.request method "/header" [] "" liftIO $ statusCode (simpleStatus response1) `shouldBe` status liftIO $ simpleHeaders response1 `shouldContain` [("H", "5")] - response2 <- Test.Hspec.Wai.request method "/header" [] "" + response2 <- THW.request method "/header" [] "" liftIO $ statusCode (simpleStatus response2) `shouldBe` status liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")] it "handles trailing '/' gracefully" $ do - response <- Test.Hspec.Wai.request method "/headerNC/" [] "" + response <- THW.request method "/headerNC/" [] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status it "returns 406 if the Accept header is not supported" $ do - Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" + THW.request method "" [(hAccept, "crazy/mime")] "" `shouldRespondWith` 406 it "responds if the Accept header is supported" $ do - response <- Test.Hspec.Wai.request method "" + response <- THW.request method "" [(hAccept, "application/json")] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status it "sets the Content-Type header" $ do - response <- Test.Hspec.Wai.request method "" [] "" + response <- THW.request method "" [] "" liftIO $ simpleHeaders response `shouldContain` [("Content-Type", "application/json")] @@ -306,7 +310,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do let server :: Server ReqBodyApi server = return :<|> return . age - mkReq method x = Test.Hspec.Wai.request method x + mkReq method x = THW.request method x [(hContentType, "application/json;charset=utf-8")] with (return $ serve reqBodyApi server) $ do @@ -319,7 +323,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400 it "responds with 415 if the request body media type is unsupported" $ do - Test.Hspec.Wai.request methodPost "/" + THW.request methodPost "/" [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415 -- }}} @@ -455,19 +459,19 @@ responseHeadersSpec = describe "ResponseHeaders" $ do it "includes the headers in the response" $ forM_ methods $ \method -> - Test.Hspec.Wai.request method "/" [] "" + THW.request method "/" [] "" `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"] , matchStatus = 200 } it "responds with not found for non-existent endpoints" $ forM_ methods $ \method -> - Test.Hspec.Wai.request method "blahblah" [] "" + THW.request method "blahblah" [] "" `shouldRespondWith` 404 it "returns 406 if the Accept header is not supported" $ forM_ methods $ \method -> - Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" + THW.request method "" [(hAccept, "crazy/mime")] "" `shouldRespondWith` 406 -- }}} @@ -527,6 +531,39 @@ miscCombinatorSpec = with (return $ serve miscApi miscServ) $ go "/host" "\"0.0.0.0:0\"" where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res + +-- }}} +------------------------------------------------------------------------------ +-- * Authentication {{{ +------------------------------------------------------------------------------ + +type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal + +basicAuthApi :: Proxy BasicAuthAPI +basicAuthApi = Proxy +basicAuthServer :: Server BasicAuthAPI +basicAuthServer = const (return jerry) + +basicAuthContext :: Context '[ BasicAuthCheck () ] +basicAuthContext = + let basicHandler = BasicAuthCheck $ (\(BasicAuthData usr pass) -> + if usr == "servant" && pass == "server" + then return (Authorized ()) + else return Unauthorized + ) + in basicHandler :. EmptyContext + +basicAuthSpec :: Spec +basicAuthSpec = do + describe "Servant.API.BasicAuth" $ do + with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ do + + context "Basic Authentication" $ do + it "returns with 401 with bad password" $ do + get "/basic" `shouldRespondWith` 401 + it "returns 200 with the right password" $ do + THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200 + -- }}} ------------------------------------------------------------------------------ -- * Test data types {{{ diff --git a/servant/servant.cabal b/servant/servant.cabal index 1b5e3c27..56e4580e 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -27,6 +27,7 @@ library exposed-modules: Servant.API Servant.API.Alternative + Servant.API.BasicAuth Servant.API.Capture Servant.API.ContentTypes Servant.API.Header From d989d15e4c6daa8aeeb97158f7183ca53c8a9f82 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 20:12:47 +0100 Subject: [PATCH 071/180] Add basic-auth support to servant-client --- servant-client/servant-client.cabal | 2 + servant-client/src/Servant/Client.hs | 10 +++++ .../src/Servant/Common/BasicAuth.hs | 21 ++++++++++ servant-client/test/Servant/ClientSpec.hs | 40 +++++++++++++++++++ 4 files changed, 73 insertions(+) create mode 100644 servant-client/src/Servant/Common/BasicAuth.hs diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 71cb2ee6..8e20f1a3 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -28,11 +28,13 @@ library exposed-modules: Servant.Client Servant.Common.BaseUrl + Servant.Common.BasicAuth Servant.Common.Req build-depends: base >=4.7 && <5 , aeson , attoparsec + , base64-bytestring , bytestring , exceptions , http-api-data >= 0.1 && < 0.3 diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index ed27b3c7..d3373708 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -37,6 +37,7 @@ import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as HTTP import Servant.API import Servant.Common.BaseUrl +import Servant.Common.BasicAuth import Servant.Common.Req -- * Accessing APIs as a Client @@ -424,6 +425,15 @@ instance HasClient subapi => clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi) +-- * Basic Authentication + +instance HasClient api => HasClient (BasicAuth realm usr :> api) where + type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api + + clientWithRoute Proxy req baseurl manager val = + clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) baseurl manager + + {- Note [Non-Empty Content Types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Rather than have diff --git a/servant-client/src/Servant/Common/BasicAuth.hs b/servant-client/src/Servant/Common/BasicAuth.hs new file mode 100644 index 00000000..e2802699 --- /dev/null +++ b/servant-client/src/Servant/Common/BasicAuth.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Basic Authentication for clients + +module Servant.Common.BasicAuth ( + basicAuthReq + ) where + +import Data.ByteString.Base64 (encode) +import Data.Monoid ((<>)) +import Data.Text.Encoding (decodeUtf8) +import Servant.Common.Req (addHeader, Req) +import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) + +-- | Authenticate a request using Basic Authentication +basicAuthReq :: BasicAuthData -> Req -> Req +basicAuthReq (BasicAuthData user pass) req = + let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass)) + in addHeader "Authorization" authText req diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 2bca7c13..291b9786 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -62,6 +62,7 @@ spec = describe "Servant.Client" $ do sucessSpec failSpec wrappedApiSpec + basicAuthSpec -- * test data types @@ -148,6 +149,29 @@ failServer = serve failApi ( :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") ) + +-- * auth stuff + +type BasicAuthAPI = + BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person + +basicAuthAPI :: Proxy BasicAuthAPI +basicAuthAPI = Proxy + +basicAuthHandler :: BasicAuthCheck () +basicAuthHandler = + let check (BasicAuthData username password) = + if username == "servant" && password == "server" + then return (Authorized ()) + else return Unauthorized + in BasicAuthCheck check + +serverConfig :: Config '[ BasicAuthCheck () ] +serverConfig = basicAuthHandler :. EmptyConfig + +basicAuthServer :: Application +basicAuthServer = serve basicAuthAPI serverConfig (const (return alice)) + {-# NOINLINE manager #-} manager :: C.Manager manager = unsafePerformIO $ C.newManager C.defaultManagerSettings @@ -292,6 +316,22 @@ data WrappedApi where HasClient api, Client api ~ ExceptT ServantError IO ()) => Proxy api -> WrappedApi +basicAuthSpec :: Spec +basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do + context "Authentication works when requests are properly authenticated" $ do + + it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do + let getBasic = client basicAuthAPI baseUrl manager + let basicAuthData = BasicAuthData "servant" "server" + (left show <$> runExceptT (getBasic basicAuthData)) `shouldReturn` Right alice + + context "Authentication is rejected when requests are not authenticated properly" $ do + + it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do + let getBasic = client basicAuthAPI baseUrl manager + let basicAuthData = BasicAuthData "not" "password" + Left FailureResponse{..} <- runExceptT (getBasic basicAuthData) + responseStatus `shouldBe` Status 403 "Forbidden" -- * utils From f13c61956ce67314298789779f4de023068a02c5 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 20:15:51 +0100 Subject: [PATCH 072/180] Add authentication support to servant-docs --- servant-docs/src/Servant/Docs/Internal.hs | 45 ++++++++++++++++++++--- 1 file changed, 40 insertions(+), 5 deletions(-) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 666cad4c..2d0cf673 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -22,7 +22,7 @@ module Servant.Docs.Internal where import Control.Applicative import Control.Arrow (second) -import Control.Lens (makeLenses, over, traversed, (%~), +import Control.Lens (makeLenses, mapped, over, traversed, view, (%~), (&), (.~), (<>~), (^.), (|>)) import qualified Control.Monad.Omega as Omega import Data.ByteString.Conversion (ToByteString, toByteString) @@ -140,6 +140,12 @@ data DocIntro = DocIntro , _introBody :: [String] -- ^ Each String is a paragraph. } deriving (Eq, Show) +-- | A type to represent Authentication information about an endpoint. +data DocAuthentication = DocAuthentication + { _authIntro :: String + , _authDataRequired :: String + } deriving (Eq, Ord, Show) + instance Ord DocIntro where compare = comparing _introTitle @@ -230,7 +236,8 @@ defResponse = Response -- You can tweak an 'Action' (like the default 'defAction') with these lenses -- to transform an action and add some information to it. data Action = Action - { _captures :: [DocCapture] -- type collected + user supplied info + { _authInfo :: [DocAuthentication] -- user supplied info + , _captures :: [DocCapture] -- type collected + user supplied info , _headers :: [Text] -- type collected , _params :: [DocQueryParam] -- type collected + user supplied info , _notes :: [DocNote] -- user supplied @@ -247,8 +254,8 @@ data Action = Action -- 'combineAction' to mush two together taking the response, body and content -- types from the very left. combineAction :: Action -> Action -> Action -Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ = - Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp +Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ = + Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp -- Default 'Action'. Has no 'captures', no GET 'params', expects -- no request body ('rqbody') and the typical response is 'defResponse'. @@ -268,6 +275,7 @@ defAction = [] [] [] + [] defResponse -- | Create an API that's comprised of a single endpoint. @@ -277,6 +285,7 @@ single :: Endpoint -> Action -> API single e a = API mempty (HM.singleton e a) -- gimme some lenses +makeLenses ''DocAuthentication makeLenses ''DocOptions makeLenses ''API makeLenses ''Endpoint @@ -454,7 +463,7 @@ instance AllHeaderSamples '[] where instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h) => AllHeaderSamples (Header h l ': ls) where - allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) : + allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) : allHeaderToSample (Proxy :: Proxy ls) where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h) mkHeader (Just x) = (headerName, cs $ toByteString x) @@ -504,6 +513,10 @@ class ToParam t where class ToCapture c where toCapture :: Proxy c -> DocCapture +-- | The class that helps us get documentation for authenticated endpoints +class ToAuthInfo a where + toAuthInfo :: Proxy a -> DocAuthentication + -- | Generate documentation in Markdown format for -- the given 'API'. markdown :: API -> String @@ -516,6 +529,7 @@ markdown api = unlines $ str : "" : notesStr (action ^. notes) ++ + authStr (action ^. authInfo) ++ capturesStr (action ^. captures) ++ headersStr (action ^. headers) ++ paramsStr (action ^. params) ++ @@ -548,6 +562,20 @@ markdown api = unlines $ "" : [] + + authStr :: [DocAuthentication] -> [String] + authStr auths = + let authIntros = mapped %~ view authIntro $ auths + clientInfos = mapped %~ view authDataRequired $ auths + in "#### Authentication": + "": + unlines authIntros : + "": + "Clients must supply the following data" : + unlines clientInfos : + "" : + [] + capturesStr :: [DocCapture] -> [String] capturesStr [] = [] capturesStr l = @@ -797,6 +825,13 @@ instance HasDocs sublayout => HasDocs (Vault :> sublayout) where instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where docsFor Proxy = docsFor (Proxy :: Proxy sublayout) +instance (ToAuthInfo (BasicAuth realm usr), HasDocs sublayout) => HasDocs (BasicAuth realm usr :> sublayout) where + docsFor Proxy (endpoint, action) = + docsFor (Proxy :: Proxy sublayout) (endpoint, action') + where + authProxy = Proxy :: Proxy (BasicAuth realm usr) + action' = over authInfo (|> toAuthInfo authProxy) action + -- ToSample instances for simple types instance ToSample () instance ToSample Bool From e13965ae34c09abeedf933df47ef0041f58765c9 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 20:23:32 +0100 Subject: [PATCH 073/180] Add a basic authentication example --- servant-examples/basic-auth/basic-auth.hs | 105 ++++++++++++++++++++++ servant-examples/servant-examples.cabal | 16 ++++ 2 files changed, 121 insertions(+) create mode 100644 servant-examples/basic-auth/basic-auth.hs diff --git a/servant-examples/basic-auth/basic-auth.hs b/servant-examples/basic-auth/basic-auth.hs new file mode 100644 index 00000000..1d538169 --- /dev/null +++ b/servant-examples/basic-auth/basic-auth.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Main where + +import Data.Aeson (ToJSON) +import Data.Proxy (Proxy (Proxy)) +import Data.Text (Text) +import GHC.Generics (Generic) +import Network.Wai.Handler.Warp (run) +import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth, + Get, JSON) +import Servant.API.BasicAuth (BasicAuthData (BasicAuthData)) +import Servant.Server (BasicAuthCheck (BasicAuthCheck), + BasicAuthResult( Authorized + , Unauthorized + ), + Config ((:.), EmptyConfig), Server, + serve) + +-- | let's define some types that our API returns. + +-- | private data that needs protection +newtype PrivateData = PrivateData { ssshhh :: Text } + deriving (Eq, Show, Generic) + +instance ToJSON PrivateData + +-- | public data that anyone can use. +newtype PublicData = PublicData { somedata :: Text } + deriving (Eq, Show, Generic) + +instance ToJSON PublicData + +-- | A user we'll grab from the database when we authenticate someone +newtype User = User { userName :: Text } + deriving (Eq, Show) + +-- | a type to wrap our public api +type PublicAPI = Get '[JSON] [PublicData] + +-- | a type to wrap our private api +type PrivateAPI = Get '[JSON] PrivateData + +-- | our API +type API = "public" :> PublicAPI + :<|> "private" :> BasicAuth "foo-realm" User :> PrivateAPI + +-- | a value holding a proxy of our API type +api :: Proxy API +api = Proxy + +-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password. +authCheck :: BasicAuthCheck User +authCheck = + let check (BasicAuthData username password) = + if username == "servant" && password == "server" + then return (Authorized (User "servant")) + else return Unauthorized + in BasicAuthCheck check + +-- | We need to supply our handlers with the right configuration. In this case, +-- Basic Authentication requires a Config Entry with the 'BasicAuthCheck' value +-- tagged with "foo-tag" This config is then supplied to 'server' and threaded +-- to the BasicAuth HasServer handlers. +serverConfig :: Config (BasicAuthCheck User ': '[]) +serverConfig = authCheck :. EmptyConfig + +-- | an implementation of our server. Here is where we pass all the handlers to our endpoints. +-- In particular, for the BasicAuth protected handler, we need to supply a function +-- that takes 'User' as an argument. +server :: Server API +server = + let publicAPIHandler = return [PublicData "foo", PublicData "bar"] + privateAPIHandler (user :: User) = return (PrivateData (userName user)) + in publicAPIHandler :<|> privateAPIHandler + +-- | hello, server! +main :: IO () +main = run 8080 (serve api serverConfig server) + +{- Sample session + +$ curl -XGET localhost:8080/public +[{"somedata":"foo"},{"somedata":"bar"} + +$ curl -iXGET localhost:8080/private +HTTP/1.1 401 Unauthorized +transfer-encoding: chunked +Date: Thu, 07 Jan 2016 22:36:38 GMT +Server: Warp/3.1.8 +WWW-Authenticate: Basic realm="foo-realm" + +$ curl -iXGET localhost:8080/private -H "Authorization: Basic c2VydmFudDpzZXJ2ZXI=" +HTTP/1.1 200 OK +transfer-encoding: chunked +Date: Thu, 07 Jan 2016 22:37:58 GMT +Server: Warp/3.1.8 +Content-Type: application/json + +{"ssshhh":"servant"} +-} diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal index d62c01c7..a36a5eba 100644 --- a/servant-examples/servant-examples.cabal +++ b/servant-examples/servant-examples.cabal @@ -89,6 +89,22 @@ executable wai-middleware hs-source-dirs: wai-middleware default-language: Haskell2010 +executable basic-auth + main-is: basic-auth.hs + ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing + build-depends: + aeson >= 0.8 + , base >= 4.7 && < 5 + , bytestring + , http-types + , servant == 0.5.* + , servant-server == 0.5.* + , text + , wai + , warp + hs-source-dirs: basic-auth + default-language: Haskell2010 + executable auth-combinator main-is: auth-combinator.hs ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing From 60a536382fd286627229284c62528e0d0948f457 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 20:25:34 +0100 Subject: [PATCH 074/180] Update CHANGELOG for basic authentication support --- servant-client/CHANGELOG.md | 1 + servant-docs/CHANGELOG.md | 1 + servant-server/CHANGELOG.md | 1 + servant/CHANGELOG.md | 1 + 4 files changed, 4 insertions(+) diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index d6ffc14b..055cfa17 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -8,6 +8,7 @@ HEAD * Use `http-api-data` instead of `Servant.Common.Text` * Client functions now consider any 2xx successful. * Remove matrix params. +* Added support for Basic authentication 0.4.1 ----- diff --git a/servant-docs/CHANGELOG.md b/servant-docs/CHANGELOG.md index a5be837a..7f6ed577 100644 --- a/servant-docs/CHANGELOG.md +++ b/servant-docs/CHANGELOG.md @@ -9,6 +9,7 @@ HEAD * Move `toSample` out of `ToSample` class * Add a few helper functions to define `toSamples` * Remove matrix params. +* Added support for Basic authentication 0.4 --- diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index bfdbe421..c5916153 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -11,6 +11,7 @@ HEAD * Remove `RouteMismatch`. * Redefined constructors of `RouteResult`. * Added `Delayed` and related functions (`addMethodCheck`, `addAcceptCheck`, `addBodyCheck`, `runDelayed`) +* Added support for Basic Authentication 0.4.1 ----- diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index ef344650..cf447968 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -10,6 +10,7 @@ HEAD * Add PlainText String MimeRender and MimeUnrender instances. * Add new `Verbs` combinator, and make all existing and new verb combinators type synonyms of it. +* Add `BasicAuth` combinator to support Basic authentication 0.4.2 ----- From 1e703be15fad97b18ec387c32033a19723121d7f Mon Sep 17 00:00:00 2001 From: aaron levin Date: Sun, 6 Mar 2016 21:16:28 +0100 Subject: [PATCH 075/180] replace serve with serveWithConfig --- servant-client/test/Servant/ClientSpec.hs | 2 +- servant-examples/basic-auth/basic-auth.hs | 4 ++-- servant-server/test/Servant/Server/ErrorSpec.hs | 4 ++-- servant-server/test/Servant/ServerSpec.hs | 4 ++-- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 291b9786..b6237b0e 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -170,7 +170,7 @@ serverConfig :: Config '[ BasicAuthCheck () ] serverConfig = basicAuthHandler :. EmptyConfig basicAuthServer :: Application -basicAuthServer = serve basicAuthAPI serverConfig (const (return alice)) +basicAuthServer = serveWithConfig basicAuthAPI serverConfig (const (return alice)) {-# NOINLINE manager #-} manager :: C.Manager diff --git a/servant-examples/basic-auth/basic-auth.hs b/servant-examples/basic-auth/basic-auth.hs index 1d538169..208edbb1 100644 --- a/servant-examples/basic-auth/basic-auth.hs +++ b/servant-examples/basic-auth/basic-auth.hs @@ -19,7 +19,7 @@ import Servant.Server (BasicAuthCheck (BasicAuthCheck), , Unauthorized ), Config ((:.), EmptyConfig), Server, - serve) + serveWithConfig) -- | let's define some types that our API returns. @@ -80,7 +80,7 @@ server = -- | hello, server! main :: IO () -main = run 8080 (serve api serverConfig server) +main = run 8080 (serveWithConfig api serverConfig server) {- Sample session diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 5ae22361..3dce641d 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -56,7 +56,7 @@ errorOrderServer = \_ _ _ -> throwE err402 errorOrderSpec :: Spec errorOrderSpec = describe "HTTP error order" $ - with (return $ serve errorOrderApi + with (return $ serveWithConfig errorOrderApi (errorOrderAuthCheck :. EmptyConfig) errorOrderServer ) $ do @@ -183,7 +183,7 @@ errorRetryServer errorRetrySpec :: Spec errorRetrySpec = describe "Handler search" $ - with (return $ serve errorRetryApi + with (return $ serveWithConfig errorRetryApi (errorOrderAuthCheck :. EmptyConfig) errorRetryServer ) $ do diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 71f1bd9f..763a16e2 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -347,13 +347,13 @@ headerSpec = describe "Servant.API.Header" $ do expectsString Nothing = error "Expected a string" with (return (serve headerApi expectsInt)) $ do - let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")] + let delete' x = THW.request methodDelete x [("MyHeader", "5")] it "passes the header to the handler (Int)" $ delete' "/" "" `shouldRespondWith` 200 with (return (serve headerApi expectsString)) $ do - let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")] + let delete' x = THW.request methodDelete x [("MyHeader", "more from you")] it "passes the header to the handler (String)" $ delete' "/" "" `shouldRespondWith` 200 From 546adc391a2699063d76f2e5f5b18498f1415e85 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Tue, 8 Mar 2016 23:28:27 +0100 Subject: [PATCH 076/180] basic-auth: config -> context --- servant-client/test/Servant/ClientSpec.hs | 6 +++--- servant-examples/basic-auth/basic-auth.hs | 16 ++++++++-------- servant-server/src/Servant/Server/Internal.hs | 14 +++++++------- servant-server/test/Servant/Server/ErrorSpec.hs | 8 ++++---- servant-server/test/Servant/ServerSpec.hs | 2 +- 5 files changed, 23 insertions(+), 23 deletions(-) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index b6237b0e..4b6ccbb9 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -166,11 +166,11 @@ basicAuthHandler = else return Unauthorized in BasicAuthCheck check -serverConfig :: Config '[ BasicAuthCheck () ] -serverConfig = basicAuthHandler :. EmptyConfig +serverContext :: Context '[ BasicAuthCheck () ] +serverContext = basicAuthHandler :. EmptyContext basicAuthServer :: Application -basicAuthServer = serveWithConfig basicAuthAPI serverConfig (const (return alice)) +basicAuthServer = serveWithContext basicAuthAPI serverContext (const (return alice)) {-# NOINLINE manager #-} manager :: C.Manager diff --git a/servant-examples/basic-auth/basic-auth.hs b/servant-examples/basic-auth/basic-auth.hs index 208edbb1..cedd4694 100644 --- a/servant-examples/basic-auth/basic-auth.hs +++ b/servant-examples/basic-auth/basic-auth.hs @@ -18,8 +18,8 @@ import Servant.Server (BasicAuthCheck (BasicAuthCheck), BasicAuthResult( Authorized , Unauthorized ), - Config ((:.), EmptyConfig), Server, - serveWithConfig) + Context ((:.), EmptyContext), Server, + serveWithContext) -- | let's define some types that our API returns. @@ -62,12 +62,12 @@ authCheck = else return Unauthorized in BasicAuthCheck check --- | We need to supply our handlers with the right configuration. In this case, --- Basic Authentication requires a Config Entry with the 'BasicAuthCheck' value --- tagged with "foo-tag" This config is then supplied to 'server' and threaded +-- | We need to supply our handlers with the right Context. In this case, +-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value +-- tagged with "foo-tag" This context is then supplied to 'server' and threaded -- to the BasicAuth HasServer handlers. -serverConfig :: Config (BasicAuthCheck User ': '[]) -serverConfig = authCheck :. EmptyConfig +serverContext :: Context (BasicAuthCheck User ': '[]) +serverContext = authCheck :. EmptyContext -- | an implementation of our server. Here is where we pass all the handlers to our endpoints. -- In particular, for the BasicAuth protected handler, we need to supply a function @@ -80,7 +80,7 @@ server = -- | hello, server! main :: IO () -main = run 8080 (serveWithConfig api serverConfig server) +main = run 8080 (serveWithContext api serverContext server) {- Sample session diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index bdf7451f..ea89b0a0 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -457,19 +457,19 @@ instance HasServer api context => HasServer (HttpVersion :> api) context where -- | Basic Authentication instance ( KnownSymbol realm - , HasServer api config - , HasConfigEntry config (BasicAuthCheck usr) + , HasServer api context + , HasContextEntry context (BasicAuthCheck usr) ) - => HasServer (BasicAuth realm usr :> api) config where + => HasServer (BasicAuth realm usr :> api) context where type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m - route Proxy config subserver = WithRequest $ \ request -> - route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request) + route Proxy context subserver = WithRequest $ \ request -> + route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request) where realm = BC8.pack $ symbolVal (Proxy :: Proxy realm) - basicAuthConfig = getConfigEntry config - authCheck req = runBasicAuth req realm basicAuthConfig + basicAuthContext = getContextEntry context + authCheck req = runBasicAuth req realm basicAuthContext -- * helpers diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 3dce641d..96d2df6f 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -56,8 +56,8 @@ errorOrderServer = \_ _ _ -> throwE err402 errorOrderSpec :: Spec errorOrderSpec = describe "HTTP error order" $ - with (return $ serveWithConfig errorOrderApi - (errorOrderAuthCheck :. EmptyConfig) + with (return $ serveWithContext errorOrderApi + (errorOrderAuthCheck :. EmptyContext) errorOrderServer ) $ do let badContentType = (hContentType, "text/plain") @@ -183,8 +183,8 @@ errorRetryServer errorRetrySpec :: Spec errorRetrySpec = describe "Handler search" $ - with (return $ serveWithConfig errorRetryApi - (errorOrderAuthCheck :. EmptyConfig) + with (return $ serveWithContext errorRetryApi + (errorOrderAuthCheck :. EmptyContext) errorRetryServer ) $ do diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 763a16e2..0524a11a 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -65,7 +65,7 @@ import Servant.Server.Internal.Router (tweakResponse, runRouter, Router, Router'(LeafRouter)) import Servant.Server.Internal.Context - (Context(..), NamedContext(..)) + (NamedContext(..)) -- * comprehensive api test From 038abb433d8621e80086f13c814ee849cebcaa82 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 20:59:58 +0100 Subject: [PATCH 077/180] Add general Authentication combinators --- servant/servant.cabal | 1 + servant/src/Servant/API.hs | 4 ++++ servant/src/Servant/API/Auth.hs | 12 ++++++++++++ 3 files changed, 17 insertions(+) create mode 100644 servant/src/Servant/API/Auth.hs diff --git a/servant/servant.cabal b/servant/servant.cabal index 56e4580e..a83d4830 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -26,6 +26,7 @@ source-repository head library exposed-modules: Servant.API + Servant.API.Auth Servant.API.Alternative Servant.API.BasicAuth Servant.API.Capture diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 5dda312c..fc70272f 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -40,6 +40,9 @@ module Servant.API ( -- * Response Headers module Servant.API.ResponseHeaders, + -- * General Authentication + module Servant.API.Auth, + -- * Untyped endpoints module Servant.API.Raw, -- | Plugging in a wai 'Network.Wai.Application', serving directories @@ -55,6 +58,7 @@ module Servant.API ( import Servant.API.Alternative ((:<|>) (..)) import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..)) +import Servant.API.Auth (AuthProtect) import Servant.API.Capture (Capture) import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, FromFormUrlEncoded (..), JSON, diff --git a/servant/src/Servant/API/Auth.hs b/servant/src/Servant/API/Auth.hs new file mode 100644 index 00000000..e1485b15 --- /dev/null +++ b/servant/src/Servant/API/Auth.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +module Servant.API.Auth where + +import Data.Typeable (Typeable) + +-- | A generalized Authentication combinator. Use this if you have a +-- non-standard authentication technique. +data AuthProtect (tag :: k) deriving (Typeable) + From 0461c4642d669b6f0478767cfd9512cdde21e710 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 21:21:57 +0100 Subject: [PATCH 078/180] Add gen. authentication support to servant-server --- servant-server/servant-server.cabal | 1 + servant-server/src/Servant/Server.hs | 6 ++- servant-server/src/Servant/Server/Internal.hs | 23 +++++++++- .../src/Servant/Server/Internal/Auth.hs | 27 ++++++++++++ servant-server/test/Servant/ServerSpec.hs | 44 +++++++++++++++++-- 5 files changed, 95 insertions(+), 6 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/Auth.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 2aa25cee..f15e7a45 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -38,6 +38,7 @@ library Servant.Server Servant.Server.Internal Servant.Server.Internal.Context + Servant.Server.Internal.Auth Servant.Server.Internal.BasicAuth Servant.Server.Internal.Enter Servant.Server.Internal.Router diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 6b37297e..c88b1375 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -45,11 +45,15 @@ module Servant.Server , NamedContext(..) , descendIntoNamedContext - -- * Basic Authentication , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck) , BasicAuthResult(..) + -- * General Authentication + , AuthHandler(unAuthHandler) + , AuthServerData + , mkAuthHandler + -- * Default error type , ServantErr(..) -- ** 3XX diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index ea89b0a0..37955122 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -10,11 +10,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} #include "overlapping-compat.h" module Servant.Server.Internal ( module Servant.Server.Internal + , module Servant.Server.Internal.Auth , module Servant.Server.Internal.Context , module Servant.Server.Internal.BasicAuth , module Servant.Server.Internal.Router @@ -25,7 +27,7 @@ module Servant.Server.Internal #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Except (ExceptT, runExceptT) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL @@ -50,7 +52,7 @@ import Web.HttpApiData.Internal (parseHeaderMaybe, parseQueryParamMaybe, parseUrlPieceMaybe) -import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture, +import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, Capture, Verb, ReflectMethod(reflectMethod), IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, @@ -64,6 +66,7 @@ import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) +import Servant.Server.Internal.Auth import Servant.Server.Internal.Context import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Router @@ -482,6 +485,22 @@ pathIsEmpty = go . pathInfo ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP +-- * General Authentication + +instance ( HasServer api context + , HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag))) + ) + => HasServer (AuthProtect tag :> api) context where + + type ServerT (AuthProtect tag :> api) m = + AuthServerData (AuthProtect tag) -> ServerT api m + + route Proxy context subserver = WithRequest $ \ request -> + route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request) + where + authHandler = unAuthHandler (getContextEntry context) + authCheck = fmap (either FailFatal Route) . runExceptT . authHandler + -- * contexts instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) diff --git a/servant-server/src/Servant/Server/Internal/Auth.hs b/servant-server/src/Servant/Server/Internal/Auth.hs new file mode 100644 index 00000000..e9c69db8 --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Auth.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Servant.Server.Internal.Auth where + +import Control.Monad.Trans.Except (ExceptT) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) + +import Servant.Server.Internal.ServantErr (ServantErr) + +-- * General Auth + +-- | Specify the type of data returned after we've authenticated a request. +-- quite often this is some `User` datatype. +type family AuthServerData a :: * + +-- | Handlers for AuthProtected resources +newtype AuthHandler r usr = AuthHandler + { unAuthHandler :: r -> ExceptT ServantErr IO usr } + deriving (Generic, Typeable) + +mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr +mkAuthHandler = AuthHandler diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 0524a11a..04e6f407 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -31,14 +31,15 @@ import Network.HTTP.Types (Status (..), hAccept, hContentType, methodHead, methodPatch, methodPost, methodPut, ok200, parseQuery) -import Network.Wai (Application, Request, pathInfo, +import Network.Wai (Application, Request, requestHeaders, pathInfo, queryString, rawQueryString, responseBuilder, responseLBS) import Network.Wai.Internal (Response (ResponseBuilder)) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody, simpleHeaders, simpleStatus) -import Servant.API ((:<|>) (..), (:>), BasicAuth, BasicAuthData(BasicAuthData), +import Servant.API ((:<|>) (..), (:>), AuthProtect, + BasicAuth, BasicAuthData(BasicAuthData), Capture, Delete, Get, Header (..), Headers, HttpVersion, IsSecure (..), JSON, @@ -59,6 +60,9 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders, import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck), BasicAuthResult(Authorized,Unauthorized)) +import Servant.Server.Internal.Auth + (AuthHandler, AuthServerData, + mkAuthHandler) import Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..)) import Servant.Server.Internal.Router @@ -90,6 +94,7 @@ spec = do routerSpec miscCombinatorSpec basicAuthSpec + genAuthSpec ------------------------------------------------------------------------------ -- * verbSpec {{{ @@ -534,7 +539,7 @@ miscCombinatorSpec = with (return $ serve miscApi miscServ) $ -- }}} ------------------------------------------------------------------------------ --- * Authentication {{{ +-- * Basic Authentication {{{ ------------------------------------------------------------------------------ type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal @@ -564,6 +569,39 @@ basicAuthSpec = do it "returns 200 with the right password" $ do THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200 +-- }}} +------------------------------------------------------------------------------ +-- * General Authentication {{{ +------------------------------------------------------------------------------ + +type GenAuthAPI = AuthProtect "auth" :> "auth" :> Get '[JSON] Animal +authApi :: Proxy GenAuthAPI +authApi = Proxy +authServer :: Server GenAuthAPI +authServer = const (return tweety) + +type instance AuthServerData (AuthProtect "auth") = () + +genAuthContext :: Context '[ AuthHandler Request () ] +genAuthContext = + let authHandler = (\req -> + if elem ("Auth", "secret") (requestHeaders req) + then return () + else throwE err401 + ) + in mkAuthHandler authHandler :. EmptyContext + +genAuthSpec :: Spec +genAuthSpec = do + describe "Servant.API.Auth" $ do + with (return (serveWithContext authApi genAuthContext authServer)) $ do + + context "Custom Auth Protection" $ do + it "returns 401 when missing headers" $ do + get "/auth" `shouldRespondWith` 401 + it "returns 200 with the right header" $ do + THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200 + -- }}} ------------------------------------------------------------------------------ -- * Test data types {{{ From 23da4879eff37dd2abf54009f954b7c42b714c0f Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 21:45:08 +0100 Subject: [PATCH 079/180] Add general auth support to servant-client --- servant-client/servant-client.cabal | 1 + servant-client/src/Servant/Client.hs | 13 +++++- servant-client/src/Servant/Common/Auth.hs | 30 ++++++++++++++ servant-client/test/Servant/ClientSpec.hs | 50 +++++++++++++++++++++-- 4 files changed, 90 insertions(+), 4 deletions(-) create mode 100644 servant-client/src/Servant/Common/Auth.hs diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 8e20f1a3..124d6307 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -27,6 +27,7 @@ source-repository head library exposed-modules: Servant.Client + Servant.Common.Auth Servant.Common.BaseUrl Servant.Common.BasicAuth Servant.Common.Req diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index d3373708..d62515dc 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -15,8 +15,11 @@ -- querying functions for each endpoint just from the type representing your -- API. module Servant.Client - ( client + ( AuthClientData + , AuthenticateReq(..) + , client , HasClient(..) + , mkAuthenticateReq , ServantError(..) , module Servant.Common.BaseUrl ) where @@ -36,6 +39,7 @@ import Network.HTTP.Media import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as HTTP import Servant.API +import Servant.Common.Auth import Servant.Common.BaseUrl import Servant.Common.BasicAuth import Servant.Common.Req @@ -424,6 +428,13 @@ instance HasClient subapi => type Client (WithNamedContext name context subapi) = Client subapi clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi) +instance ( HasClient api + ) => HasClient (AuthProtect tag :> api) where + type Client (AuthProtect tag :> api) + = AuthenticateReq (AuthProtect tag) -> Client api + + clientWithRoute Proxy req baseurl manager (AuthenticateReq (val,func)) = + clientWithRoute (Proxy :: Proxy api) (func val req) baseurl manager -- * Basic Authentication diff --git a/servant-client/src/Servant/Common/Auth.hs b/servant-client/src/Servant/Common/Auth.hs new file mode 100644 index 00000000..5e450bd8 --- /dev/null +++ b/servant-client/src/Servant/Common/Auth.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Authentication for clients + +module Servant.Common.Auth ( + AuthenticateReq(AuthenticateReq, unAuthReq) + , AuthClientData + , mkAuthenticateReq + ) where + +import Servant.Common.Req (Req) + +-- | For a resource protected by authentication (e.g. AuthProtect), we need +-- to provide the client with some data used to add authentication data +-- to a request +type family AuthClientData a :: * + +-- | For better type inference and to avoid usage of a data family, we newtype +-- wrap the combination of some 'AuthClientData' and a function to add authentication +-- data to a request +newtype AuthenticateReq a = + AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) } + +-- | Handy helper to avoid wrapping datatypes in tuples everywhere. +mkAuthenticateReq :: AuthClientData a + -> (AuthClientData a -> Req -> Req) + -> AuthenticateReq a +mkAuthenticateReq val func = AuthenticateReq (val, func) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 4b6ccbb9..0ee1ed01 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -12,6 +12,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fcontext-stack=100 #-} @@ -41,7 +42,8 @@ import Network.HTTP.Media import Network.HTTP.Types (Status (..), badRequest400, methodGet, ok200, status400) import Network.Socket -import Network.Wai (Application, responseLBS) +import Network.Wai (Application, Request, + requestHeaders, responseLBS) import Network.Wai.Handler.Warp import System.IO.Unsafe (unsafePerformIO) import Test.Hspec @@ -53,6 +55,7 @@ import Servant.API import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client import Servant.Server +import qualified Servant.Common.Req as SCR -- This declaration simply checks that all instances are in place. _ = client comprehensiveAPI @@ -63,6 +66,7 @@ spec = describe "Servant.Client" $ do failSpec wrappedApiSpec basicAuthSpec + genAuthSpec -- * test data types @@ -149,8 +153,7 @@ failServer = serve failApi ( :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") ) - --- * auth stuff +-- * basic auth stuff type BasicAuthAPI = BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person @@ -172,6 +175,30 @@ serverContext = basicAuthHandler :. EmptyContext basicAuthServer :: Application basicAuthServer = serveWithContext basicAuthAPI serverContext (const (return alice)) +-- * general auth stuff + +type GenAuthAPI = + AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person + +genAuthAPI :: Proxy GenAuthAPI +genAuthAPI = Proxy + +type instance AuthServerData (AuthProtect "auth-tag") = () +type instance AuthClientData (AuthProtect "auth-tag") = () + +genAuthHandler :: AuthHandler Request () +genAuthHandler = + let handler req = case lookup "AuthHeader" (requestHeaders req) of + Nothing -> throwE (err401 { errBody = "Missing auth header" }) + Just _ -> return () + in mkAuthHandler handler + +serverConfig :: Config '[ AuthHandler Request () ] +serverConfig = genAuthHandler :. EmptyConfig + +genAuthServer :: Application +genAuthServer = serve genAuthAPI serverConfig (const (return alice)) + {-# NOINLINE manager #-} manager :: C.Manager manager = unsafePerformIO $ C.newManager C.defaultManagerSettings @@ -333,6 +360,23 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d Left FailureResponse{..} <- runExceptT (getBasic basicAuthData) responseStatus `shouldBe` Status 403 "Forbidden" +genAuthSpec :: Spec +genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do + context "Authentication works when requests are properly authenticated" $ do + + it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do + let getProtected = client genAuthAPI baseUrl manager + let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req) + (left show <$> runExceptT (getProtected authRequest)) `shouldReturn` Right alice + + context "Authentication is rejected when requests are not authenticated properly" $ do + + it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do + let getProtected = client genAuthAPI baseUrl manager + let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req) + Left FailureResponse{..} <- runExceptT (getProtected authRequest) + responseStatus `shouldBe` (Status 401 "Unauthorized") + -- * utils startWaiApp :: Application -> IO (ThreadId, BaseUrl) From a09733a560453a86c3652036c5220a905be46ffd Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 21:49:54 +0100 Subject: [PATCH 080/180] modify auth-combinator example for gen auth --- .../auth-combinator/auth-combinator.hs | 137 +++++++++++------- servant-examples/servant-examples.cabal | 2 + 2 files changed, 84 insertions(+), 55 deletions(-) diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index 94bb8931..bfa4b6ee 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -9,56 +9,53 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -import Data.Aeson -import Data.ByteString (ByteString) -import Data.IORef -import Data.Text (Text) +import Control.Monad.Trans.Except (ExceptT, throwE) +import Data.Aeson hiding ((.:)) +import Data.ByteString (ByteString) +import Data.Monoid ((<>)) +import Data.Map (Map, fromList) +import qualified Data.Map as Map +import Data.Text (Text) import GHC.Generics import Network.Wai import Network.Wai.Handler.Warp import Servant -import Servant.Server.Internal --- Pretty much stolen/adapted from --- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs +-- | This file contains an authenticated server using servant's generalized +-- authentication support. Our basic authentication scheme is trivial: we +-- look for a cookie named "servant-auth-cookie" and its value will contain +-- a key, which we use to lookup a User. Obviously this is an absurd example, +-- but we pick something simple and non-standard to show you how to extend +-- servant's support for authentication. -type DBConnection = IORef [ByteString] -type DBLookup = DBConnection -> ByteString -> IO Bool +-- | A user type that we "fetch from the database" after +-- performing authentication +newtype User = User { unUser :: Text } -initDB :: IO DBConnection -initDB = newIORef ["good password"] +-- | A (pure) database mapping keys to users. +database :: Map ByteString User +database = fromList [ ("key1", User "Anne Briggs") + , ("key2", User "Bruce Cockburn") + , ("key3", User "Ghédalia Tazartès") + ] -isGoodCookie :: DBLookup -isGoodCookie ref password = do - allowed <- readIORef ref - return (password `elem` allowed) +-- | A method that, when given a password, will return a User. +-- This is our bespoke (and bad) authentication logic. +lookupUser :: ByteString -> ExceptT ServantErr IO User +lookupUser key = case Map.lookup key database of + Nothing -> throwE (err403 { errBody = "Invalid Cookie" }) + Just usr -> return usr -data AuthProtected - -instance (HasContextEntry context DBConnection, HasServer rest context) - => HasServer (AuthProtected :> rest) context where - - type ServerT (AuthProtected :> rest) m = ServerT rest m - - route Proxy context subserver = WithRequest $ \ request -> - route (Proxy :: Proxy rest) context $ addAcceptCheck subserver $ cookieCheck request - where - cookieCheck req = case lookup "Cookie" (requestHeaders req) of - Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" } - Just v -> do - let dbConnection = getContextEntry context - authGranted <- isGoodCookie dbConnection v - if authGranted - then return $ Route () - else return $ FailFatal err403 { errBody = "Invalid cookie" } - -type PrivateAPI = Get '[JSON] [PrivateData] - -type PublicAPI = Get '[JSON] [PublicData] - -type API = "private" :> AuthProtected :> PrivateAPI - :<|> PublicAPI +-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User +-- we look for a Cookie and pass the value of the cookie to `lookupUser`. +authHandler :: AuthHandler Request User +authHandler = + let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of + Nothing -> throwE (err401 { errBody = "Missing auth header" }) + Just authCookieKey -> lookupUser authCookieKey + in mkAuthHandler handler +-- | Data types that will be returned from various api endpoints newtype PrivateData = PrivateData { ssshhh :: Text } deriving (Eq, Show, Generic) @@ -69,28 +66,58 @@ newtype PublicData = PublicData { somedata :: Text } instance ToJSON PublicData +-- | Our private API that we want to be auth-protected. +type PrivateAPI = Get '[JSON] [PrivateData] + +-- | Our public API that doesn't have any protection +type PublicAPI = Get '[JSON] [PublicData] + +-- | Our API, with auth-protection +type API = "private" :> AuthProtect "cookie-auth" :> PrivateAPI + :<|> "public" :> PublicAPI + +-- | A value holding our type-level API api :: Proxy API api = Proxy +-- | We need to specify the data returned after authentication +type instance AuthServerData (AuthProtect "cookie-auth") = User + +-- | The context that will be made available to request handlers. We supply the +-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance +-- of 'AuthProtect' can extract the handler and run it on the request. +serverContext :: Context (AuthHandler Request User ': '[]) +serverContext = authHandler :. EmptyContext + +-- | Our API, where we provide all the author-supplied handlers for each end +-- point. Note that 'privateDataFunc' is a function that takes 'User' as an +-- argument. We dont' worry about the authentication instrumentation here, +-- that is taken care of by supplying context server :: Server API -server = return prvdata :<|> return pubdata +server = privateDataFunc :<|> return publicData - where prvdata = [PrivateData "this is a secret"] - pubdata = [PublicData "this is a public piece of data"] + where privateDataFunc (User name) = + return [PrivateData ("this is a secret: " <> name)] + publicData = [PublicData "this is a public piece of data"] +-- | run our server main :: IO () -main = do - dbConnection <- initDB - let context = dbConnection :. EmptyContext - run 8080 (serveWithContext api context server) +main = run 8080 (serveWithContext api serverContext server) -{- Sample session: -$ curl http://localhost:8080/ +{- Sample Session: + +$ curl -XGET localhost:8080/private +Missing auth header +>>>>>>> modify auth-combinator example for gen auth +>>>>>>> 8246c1f... modify auth-combinator example for gen auth + +$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3" +[{"ssshhh":"this is a secret: Ghédalia Tazartès"}] + +$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key" +Invalid Cookie + +$ curl -XGET localhost:8080/public [{"somedata":"this is a public piece of data"}] -$ curl http://localhost:8080/private -Missing auth header. -$ curl -H "Cookie: good password" http://localhost:8080/private -[{"ssshhh":"this is a secret"}] -$ curl -H "Cookie: bad password" http://localhost:8080/private -Invalid cookie. -} + diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal index a36a5eba..1f00349e 100644 --- a/servant-examples/servant-examples.cabal +++ b/servant-examples/servant-examples.cabal @@ -112,10 +112,12 @@ executable auth-combinator aeson >= 0.8 , base >= 4.7 && < 5 , bytestring + , containers , http-types , servant == 0.5.* , servant-server == 0.5.* , text + , transformers , wai , warp hs-source-dirs: auth-combinator From cd31b20cd887f015443ccc09e1157cfa32c34b96 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 21:57:04 +0100 Subject: [PATCH 081/180] Update CHANGELOG for generalized authentication support --- servant-client/CHANGELOG.md | 2 ++ servant-server/CHANGELOG.md | 1 + servant/CHANGELOG.md | 1 + 3 files changed, 4 insertions(+) diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index 055cfa17..be3453cc 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -9,6 +9,8 @@ HEAD * Client functions now consider any 2xx successful. * Remove matrix params. * Added support for Basic authentication +* Add generalized authentication support via the `AuthClientData` type family and + `AuthenticateReq` data type 0.4.1 ----- diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index c5916153..3c121ddd 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -12,6 +12,7 @@ HEAD * Redefined constructors of `RouteResult`. * Added `Delayed` and related functions (`addMethodCheck`, `addAcceptCheck`, `addBodyCheck`, `runDelayed`) * Added support for Basic Authentication +* Add generalized authentication support via the `AuthServerData` type family and `AuthHandler` handler 0.4.1 ----- diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index cf447968..3707dda4 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -11,6 +11,7 @@ HEAD * Add new `Verbs` combinator, and make all existing and new verb combinators type synonyms of it. * Add `BasicAuth` combinator to support Basic authentication +* Add generalized authentication support 0.4.2 ----- From 29f8e64e1c91cb2107be471fc9efc344de7f899e Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 22:01:54 +0100 Subject: [PATCH 082/180] Add Experimental warnings on combinators --- servant-client/src/Servant/Common/Auth.hs | 6 ++++++ servant-server/src/Servant/Server/Internal/Auth.hs | 5 +++++ servant/servant.cabal | 2 +- servant/src/Servant/{ => Experimental}/API/Auth.hs | 2 ++ 4 files changed, 14 insertions(+), 1 deletion(-) rename servant/src/Servant/{ => Experimental}/API/Auth.hs (86%) diff --git a/servant-client/src/Servant/Common/Auth.hs b/servant-client/src/Servant/Common/Auth.hs index 5e450bd8..9bcef932 100644 --- a/servant-client/src/Servant/Common/Auth.hs +++ b/servant-client/src/Servant/Common/Auth.hs @@ -15,15 +15,21 @@ import Servant.Common.Req (Req) -- | For a resource protected by authentication (e.g. AuthProtect), we need -- to provide the client with some data used to add authentication data -- to a request +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE type family AuthClientData a :: * -- | For better type inference and to avoid usage of a data family, we newtype -- wrap the combination of some 'AuthClientData' and a function to add authentication -- data to a request +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE newtype AuthenticateReq a = AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) } -- | Handy helper to avoid wrapping datatypes in tuples everywhere. +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE mkAuthenticateReq :: AuthClientData a -> (AuthClientData a -> Req -> Req) -> AuthenticateReq a diff --git a/servant-server/src/Servant/Server/Internal/Auth.hs b/servant-server/src/Servant/Server/Internal/Auth.hs index e9c69db8..f3428a93 100644 --- a/servant-server/src/Servant/Server/Internal/Auth.hs +++ b/servant-server/src/Servant/Server/Internal/Auth.hs @@ -16,12 +16,17 @@ import Servant.Server.Internal.ServantErr (ServantErr) -- | Specify the type of data returned after we've authenticated a request. -- quite often this is some `User` datatype. +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE type family AuthServerData a :: * -- | Handlers for AuthProtected resources +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE newtype AuthHandler r usr = AuthHandler { unAuthHandler :: r -> ExceptT ServantErr IO usr } deriving (Generic, Typeable) +-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr mkAuthHandler = AuthHandler diff --git a/servant/servant.cabal b/servant/servant.cabal index a83d4830..fc2dec36 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -26,7 +26,6 @@ source-repository head library exposed-modules: Servant.API - Servant.API.Auth Servant.API.Alternative Servant.API.BasicAuth Servant.API.Capture @@ -44,6 +43,7 @@ library Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext + Servant.API.Experimental.Auth Servant.Utils.Links build-depends: base >=4.7 && <5 diff --git a/servant/src/Servant/API/Auth.hs b/servant/src/Servant/Experimental/API/Auth.hs similarity index 86% rename from servant/src/Servant/API/Auth.hs rename to servant/src/Servant/Experimental/API/Auth.hs index e1485b15..0647b012 100644 --- a/servant/src/Servant/API/Auth.hs +++ b/servant/src/Servant/Experimental/API/Auth.hs @@ -8,5 +8,7 @@ import Data.Typeable (Typeable) -- | A generalized Authentication combinator. Use this if you have a -- non-standard authentication technique. +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE. data AuthProtect (tag :: k) deriving (Typeable) From b3af5a8d9592dab6b016f3d7f9ec18253db10bb4 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Sun, 6 Mar 2016 22:23:55 +0100 Subject: [PATCH 083/180] Move general authentication to Experimental module Removes the UndecidableInstances extension in the module containing the HasServer instances. --- servant-client/servant-client.cabal | 2 +- servant-client/src/Servant/Client.hs | 2 +- .../{Common => Client/Experimental}/Auth.hs | 2 +- servant-client/test/Servant/ClientSpec.hs | 13 ++-- .../auth-combinator/auth-combinator.hs | 1 + servant-server/servant-server.cabal | 4 +- servant-server/src/Servant/Server.hs | 6 +- .../src/Servant/Server/Experimental/Auth.hs | 66 +++++++++++++++++++ servant-server/src/Servant/Server/Internal.hs | 22 +------ .../src/Servant/Server/Internal/Auth.hs | 32 --------- servant-server/test/Servant/ServerSpec.hs | 4 +- servant/servant.cabal | 2 +- servant/src/Servant/API.hs | 10 +-- .../API => API/Experimental}/Auth.hs | 2 +- 14 files changed, 94 insertions(+), 74 deletions(-) rename servant-client/src/Servant/{Common => Client/Experimental}/Auth.hs (96%) create mode 100644 servant-server/src/Servant/Server/Experimental/Auth.hs delete mode 100644 servant-server/src/Servant/Server/Internal/Auth.hs rename servant/src/Servant/{Experimental/API => API/Experimental}/Auth.hs (90%) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 124d6307..6fbb6642 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -27,7 +27,7 @@ source-repository head library exposed-modules: Servant.Client - Servant.Common.Auth + Servant.Client.Experimental.Auth Servant.Common.BaseUrl Servant.Common.BasicAuth Servant.Common.Req diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index d62515dc..e73c05a4 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -39,7 +39,7 @@ import Network.HTTP.Media import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as HTTP import Servant.API -import Servant.Common.Auth +import Servant.Client.Experimental.Auth import Servant.Common.BaseUrl import Servant.Common.BasicAuth import Servant.Common.Req diff --git a/servant-client/src/Servant/Common/Auth.hs b/servant-client/src/Servant/Client/Experimental/Auth.hs similarity index 96% rename from servant-client/src/Servant/Common/Auth.hs rename to servant-client/src/Servant/Client/Experimental/Auth.hs index 9bcef932..a98d0b41 100644 --- a/servant-client/src/Servant/Common/Auth.hs +++ b/servant-client/src/Servant/Client/Experimental/Auth.hs @@ -4,7 +4,7 @@ -- | Authentication for clients -module Servant.Common.Auth ( +module Servant.Client.Experimental.Auth ( AuthenticateReq(AuthenticateReq, unAuthReq) , AuthClientData , mkAuthenticateReq diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 0ee1ed01..0ad3b70e 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -55,6 +55,7 @@ import Servant.API import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client import Servant.Server +import Servant.Server.Experimental.Auth import qualified Servant.Common.Req as SCR -- This declaration simply checks that all instances are in place. @@ -169,11 +170,11 @@ basicAuthHandler = else return Unauthorized in BasicAuthCheck check -serverContext :: Context '[ BasicAuthCheck () ] -serverContext = basicAuthHandler :. EmptyContext +basicServerContext :: Context '[ BasicAuthCheck () ] +basicServerContext = basicAuthHandler :. EmptyContext basicAuthServer :: Application -basicAuthServer = serveWithContext basicAuthAPI serverContext (const (return alice)) +basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice)) -- * general auth stuff @@ -193,11 +194,11 @@ genAuthHandler = Just _ -> return () in mkAuthHandler handler -serverConfig :: Config '[ AuthHandler Request () ] -serverConfig = genAuthHandler :. EmptyConfig +genAuthServerContext :: Context '[ AuthHandler Request () ] +genAuthServerContext = genAuthHandler :. EmptyContext genAuthServer :: Application -genAuthServer = serve genAuthAPI serverConfig (const (return alice)) +genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice)) {-# NOINLINE manager #-} manager :: C.Manager diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index bfa4b6ee..709efa0c 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -20,6 +20,7 @@ import GHC.Generics import Network.Wai import Network.Wai.Handler.Warp import Servant +import Servant.Server.Experimental.Auth -- | This file contains an authenticated server using servant's generalized -- authentication support. Our basic authentication scheme is trivial: we diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index f15e7a45..6167a2b4 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -36,10 +36,10 @@ library exposed-modules: Servant Servant.Server + Servant.Server.Experimental.Auth Servant.Server.Internal - Servant.Server.Internal.Context - Servant.Server.Internal.Auth Servant.Server.Internal.BasicAuth + Servant.Server.Internal.Context Servant.Server.Internal.Enter Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index c88b1375..8eff9c66 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -50,9 +50,9 @@ module Servant.Server , BasicAuthResult(..) -- * General Authentication - , AuthHandler(unAuthHandler) - , AuthServerData - , mkAuthHandler + -- , AuthHandler(unAuthHandler) + -- , AuthServerData + -- , mkAuthHandler -- * Default error type , ServantErr(..) diff --git a/servant-server/src/Servant/Server/Experimental/Auth.hs b/servant-server/src/Servant/Server/Experimental/Auth.hs new file mode 100644 index 00000000..1cc698fc --- /dev/null +++ b/servant-server/src/Servant/Server/Experimental/Auth.hs @@ -0,0 +1,66 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Servant.Server.Experimental.Auth where + +import Control.Monad.Trans.Except (ExceptT, + runExceptT) +import Data.Proxy (Proxy (Proxy)) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Network.Wai (Request) + +import Servant ((:>)) +import Servant.API.Experimental.Auth +import Servant.Server.Internal (HasContextEntry, + HasServer, ServerT, + getContextEntry, + route) +import Servant.Server.Internal.Router (Router' (WithRequest)) +import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route), + addAuthCheck) +import Servant.Server.Internal.ServantErr (ServantErr) + +-- * General Auth + +-- | Specify the type of data returned after we've authenticated a request. +-- quite often this is some `User` datatype. +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +type family AuthServerData a :: * + +-- | Handlers for AuthProtected resources +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +newtype AuthHandler r usr = AuthHandler + { unAuthHandler :: r -> ExceptT ServantErr IO usr } + deriving (Generic, Typeable) + +-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr +mkAuthHandler = AuthHandler + +-- | Known orphan instance. +instance ( HasServer api context + , HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag))) + ) + => HasServer (AuthProtect tag :> api) context where + + type ServerT (AuthProtect tag :> api) m = + AuthServerData (AuthProtect tag) -> ServerT api m + + route Proxy context subserver = WithRequest $ \ request -> + route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request) + where + authHandler = unAuthHandler (getContextEntry context) + authCheck = fmap (either FailFatal Route) . runExceptT . authHandler + diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 37955122..c170de9b 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -10,13 +10,11 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} #include "overlapping-compat.h" module Servant.Server.Internal ( module Servant.Server.Internal - , module Servant.Server.Internal.Auth , module Servant.Server.Internal.Context , module Servant.Server.Internal.BasicAuth , module Servant.Server.Internal.Router @@ -27,7 +25,7 @@ module Servant.Server.Internal #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Trans.Except (ExceptT) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL @@ -52,7 +50,7 @@ import Web.HttpApiData.Internal (parseHeaderMaybe, parseQueryParamMaybe, parseUrlPieceMaybe) -import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, Capture, +import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture, Verb, ReflectMethod(reflectMethod), IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, @@ -66,7 +64,6 @@ import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) -import Servant.Server.Internal.Auth import Servant.Server.Internal.Context import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Router @@ -456,8 +453,6 @@ instance HasServer api context => HasServer (HttpVersion :> api) context where route Proxy context subserver = WithRequest $ \req -> route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req) --- * Basic Authentication - -- | Basic Authentication instance ( KnownSymbol realm , HasServer api context @@ -487,19 +482,6 @@ ct_wildcard = "*" <> "/" <> "*" -- Because CPP -- * General Authentication -instance ( HasServer api context - , HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag))) - ) - => HasServer (AuthProtect tag :> api) context where - - type ServerT (AuthProtect tag :> api) m = - AuthServerData (AuthProtect tag) -> ServerT api m - - route Proxy context subserver = WithRequest $ \ request -> - route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request) - where - authHandler = unAuthHandler (getContextEntry context) - authCheck = fmap (either FailFatal Route) . runExceptT . authHandler -- * contexts diff --git a/servant-server/src/Servant/Server/Internal/Auth.hs b/servant-server/src/Servant/Server/Internal/Auth.hs deleted file mode 100644 index f3428a93..00000000 --- a/servant-server/src/Servant/Server/Internal/Auth.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - -module Servant.Server.Internal.Auth where - -import Control.Monad.Trans.Except (ExceptT) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) - -import Servant.Server.Internal.ServantErr (ServantErr) - --- * General Auth - --- | Specify the type of data returned after we've authenticated a request. --- quite often this is some `User` datatype. --- --- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -type family AuthServerData a :: * - --- | Handlers for AuthProtected resources --- --- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -newtype AuthHandler r usr = AuthHandler - { unAuthHandler :: r -> ExceptT ServantErr IO usr } - deriving (Generic, Typeable) - --- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr -mkAuthHandler = AuthHandler diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 04e6f407..0e17c022 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -49,7 +49,7 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect, Raw, RemoteHost, ReqBody, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI -import Servant.Server (ServantErr (..), Server, err404, +import Servant.Server (ServantErr (..), Server, err401, err404, serve, serveWithContext, Context((:.), EmptyContext)) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) @@ -60,7 +60,7 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders, import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck), BasicAuthResult(Authorized,Unauthorized)) -import Servant.Server.Internal.Auth +import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) import Servant.Server.Internal.RoutingApplication diff --git a/servant/servant.cabal b/servant/servant.cabal index fc2dec36..a66efbce 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -30,6 +30,7 @@ library Servant.API.BasicAuth Servant.API.Capture Servant.API.ContentTypes + Servant.API.Experimental.Auth Servant.API.Header Servant.API.HttpVersion Servant.API.Internal.Test.ComprehensiveAPI @@ -43,7 +44,6 @@ library Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext - Servant.API.Experimental.Auth Servant.Utils.Links build-depends: base >=4.7 && <5 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index fc70272f..5ea7b480 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -40,9 +40,6 @@ module Servant.API ( -- * Response Headers module Servant.API.ResponseHeaders, - -- * General Authentication - module Servant.API.Auth, - -- * Untyped endpoints module Servant.API.Raw, -- | Plugging in a wai 'Network.Wai.Application', serving directories @@ -51,6 +48,11 @@ module Servant.API ( module Web.HttpApiData, -- | Classes and instances for types that can be converted to and from HTTP API data. + + -- * Experimental modules + module Servant.API.Experimental.Auth, + -- | General Authentication + -- * Utilities module Servant.Utils.Links, -- | Type-safe internal URIs @@ -58,13 +60,13 @@ module Servant.API ( import Servant.API.Alternative ((:<|>) (..)) import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..)) -import Servant.API.Auth (AuthProtect) import Servant.API.Capture (Capture) import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, FromFormUrlEncoded (..), JSON, MimeRender (..), NoContent (NoContent), MimeUnrender (..), OctetStream, PlainText, ToFormUrlEncoded (..)) +import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.Header (Header (..)) import Servant.API.HttpVersion (HttpVersion (..)) import Servant.API.IsSecure (IsSecure (..)) diff --git a/servant/src/Servant/Experimental/API/Auth.hs b/servant/src/Servant/API/Experimental/Auth.hs similarity index 90% rename from servant/src/Servant/Experimental/API/Auth.hs rename to servant/src/Servant/API/Experimental/Auth.hs index 0647b012..ce330287 100644 --- a/servant/src/Servant/Experimental/API/Auth.hs +++ b/servant/src/Servant/API/Experimental/Auth.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} -module Servant.API.Auth where +module Servant.API.Experimental.Auth where import Data.Typeable (Typeable) From e5635a044eafa3f8d7ad514b8738ee134ef2f286 Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Thu, 18 Feb 2016 00:47:30 +0300 Subject: [PATCH 084/180] use newtypes in servant-foreign --- servant-foreign/servant-foreign.cabal | 33 ++++- servant-foreign/src/Servant/Foreign.hs | 20 ++- .../src/Servant/Foreign/Inflections.hs | 45 ++++++ .../src/Servant/Foreign/Internal.hs | 129 +++++++++--------- servant-foreign/test/Servant/ForeignSpec.hs | 37 ++--- servant-js/src/Servant/JS/Angular.hs | 20 +-- servant-js/src/Servant/JS/Axios.hs | 18 ++- servant-js/src/Servant/JS/Internal.hs | 35 +++-- servant-js/src/Servant/JS/JQuery.hs | 19 ++- servant-js/src/Servant/JS/Vanilla.hs | 18 ++- .../test/Servant/JSSpec/CustomHeaders.hs | 9 +- 11 files changed, 245 insertions(+), 138 deletions(-) create mode 100644 servant-foreign/src/Servant/Foreign/Inflections.hs diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 1efda5c3..4188a5a9 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -26,7 +26,9 @@ source-repository head location: http://github.com/haskell-servant/servant.git library - exposed-modules: Servant.Foreign, Servant.Foreign.Internal + exposed-modules: Servant.Foreign + , Servant.Foreign.Internal + , Servant.Foreign.Inflections build-depends: base == 4.* , lens == 4.* , servant == 0.5.* @@ -36,6 +38,20 @@ library default-language: Haskell2010 ghc-options: -Wall include-dirs: include + default-extensions: CPP + , ConstraintKinds + , DataKinds + , FlexibleContexts + , FlexibleInstances + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , ScopedTypeVariables + , TemplateHaskell + , TypeFamilies + , TypeOperators + , UndecidableInstances + , OverloadedStrings + , PolyKinds test-suite spec @@ -44,9 +60,20 @@ test-suite spec ghc-options: -Wall include-dirs: include main-is: Spec.hs - other-modules: - Servant.ForeignSpec + other-modules: Servant.ForeignSpec build-depends: base , hspec >= 2.1.8 , servant-foreign default-language: Haskell2010 + default-extensions: ConstraintKinds + , DataKinds + , FlexibleContexts + , FlexibleInstances + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , ScopedTypeVariables + , TypeFamilies + , TypeOperators + , UndecidableInstances + , OverloadedStrings + , PolyKinds diff --git a/servant-foreign/src/Servant/Foreign.hs b/servant-foreign/src/Servant/Foreign.hs index 33ac2732..3850ad37 100644 --- a/servant-foreign/src/Servant/Foreign.hs +++ b/servant-foreign/src/Servant/Foreign.hs @@ -10,10 +10,14 @@ module Servant.Foreign , Url(..) -- aliases , Path - , ForeignType - , Arg - , FunctionName + , ForeignType(..) + , Arg(..) + , FunctionName(..) + , PathSegment(..) -- lenses + , aName + , aType + , aPath , reqUrl , reqMethod , reqHeaders @@ -24,7 +28,10 @@ module Servant.Foreign , queryStr , argName , argType + , headerArg -- prisms + , _PathSegment + , _ForeignType , _HeaderArg , _ReplaceHeaderArg , _Static @@ -40,14 +47,13 @@ module Servant.Foreign , NoTypes , captureArg , isCapture - , concatCase - , snakeCase - , camelCase , defReq , listFromAPI - -- re-exports + -- re-exports , module Servant.API + , module Servant.Foreign.Inflections ) where import Servant.API import Servant.Foreign.Internal +import Servant.Foreign.Inflections diff --git a/servant-foreign/src/Servant/Foreign/Inflections.hs b/servant-foreign/src/Servant/Foreign/Inflections.hs new file mode 100644 index 00000000..759d04a0 --- /dev/null +++ b/servant-foreign/src/Servant/Foreign/Inflections.hs @@ -0,0 +1,45 @@ +module Servant.Foreign.Inflections + ( concatCase + , snakeCase + , camelCase + -- lenses + , concatCaseL + , snakeCaseL + , camelCaseL + ) where + + +import Control.Lens hiding (cons) +import qualified Data.Char as C +import Data.Monoid +import Data.Text hiding (map) +import Prelude hiding (head, tail) +import Servant.Foreign.Internal + +concatCaseL :: Getter FunctionName Text +concatCaseL = _FunctionName . to mconcat + +-- | Function name builder that simply concat each part together +concatCase :: FunctionName -> Text +concatCase = view concatCaseL + +snakeCaseL :: Getter FunctionName Text +snakeCaseL = _FunctionName . to (intercalate "_") + +-- | Function name builder using the snake_case convention. +-- each part is separated by a single underscore character. +snakeCase :: FunctionName -> Text +snakeCase = view snakeCaseL + +camelCaseL :: Getter FunctionName Text +camelCaseL = _FunctionName . to (convert . map (replace "-" "")) + where + convert [] = "" + convert (p:ps) = mconcat $ p : map capitalize ps + capitalize "" = "" + capitalize name = C.toUpper (head name) `cons` tail name + +-- | Function name builder using the CamelCase convention. +-- each part begins with an upper case character. +camelCase :: FunctionName -> Text +camelCase = view camelCaseL diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index cb37f6b7..d4130470 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -1,27 +1,15 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} #if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE NullaryTypeClasses #-} +{-# LANGUAGE NullaryTypeClasses #-} #endif -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# 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, makePrisms, (%~), (&), (.~), (<>~)) -import qualified Data.Char as C +import Control.Lens hiding (cons) import Data.Proxy +import Data.String import Data.Text import Data.Text.Encoding (decodeUtf8) import GHC.Exts (Constraint) @@ -30,36 +18,38 @@ import qualified Network.HTTP.Types as HTTP import Prelude hiding (concat) import Servant.API -type FunctionName = [Text] --- | Function name builder that simply concat each part together -concatCase :: FunctionName -> Text -concatCase = concat +newtype FunctionName = FunctionName { unFunctionName :: [Text] } + deriving (Show, Eq, Monoid) --- | Function name builder using the snake_case convention. --- each part is separated by a single underscore character. -snakeCase :: FunctionName -> Text -snakeCase = intercalate "_" +makePrisms ''FunctionName --- | Function name builder using the CamelCase convention. --- each part begins with an upper case character. -camelCase :: FunctionName -> Text -camelCase = camelCase' . Prelude.map (replace "-" "") - where camelCase' [] = "" - camelCase' (p:ps) = concat $ p : Prelude.map capitalize ps - capitalize "" = "" - capitalize name = C.toUpper (Data.Text.head name) `cons` Data.Text.tail name +newtype ForeignType = ForeignType { unForeignType :: Text } + deriving (Show, Eq, IsString, Monoid) -type ForeignType = Text +makePrisms ''ForeignType -type Arg = (Text, ForeignType) +newtype PathSegment = PathSegment { unPathSegment :: Text } + deriving (Show, Eq, IsString, Monoid) + +makePrisms ''PathSegment + +data Arg = Arg + { _aName :: PathSegment + , _aType :: ForeignType } + deriving (Show, Eq) + +makeLenses ''Arg + +aPath :: Getter Arg Text +aPath = aName . _PathSegment data SegmentType - = Static Text + = Static PathSegment -- ^ a static path segment. like "/foo" | Cap Arg -- ^ a capture. like "/:userid" - deriving (Eq, Show) + deriving (Show, Eq) makePrisms ''SegmentType @@ -68,6 +58,14 @@ newtype Segment = Segment { unSegment :: SegmentType } makePrisms ''Segment +isCapture :: Segment -> Bool +isCapture (Segment (Cap _)) = True +isCapture _ = False + +captureArg :: Segment -> Arg +captureArg (Segment (Cap s)) = s +captureArg _ = error "captureArg called on non capture" + type Path = [Segment] data ArgType @@ -86,10 +84,10 @@ data QueryArg = QueryArg makeLenses ''QueryArg data HeaderArg = HeaderArg - { headerArg :: Arg } + { _headerArg :: Arg } | ReplaceHeaderArg - { headerArg :: Arg - , headerPattern :: Text + { _headerArg :: Arg + , _headerPattern :: Text } deriving (Eq, Show) makeLenses ''HeaderArg @@ -117,16 +115,8 @@ data Req = Req 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" [] Nothing "" [] +defReq = Req defUrl "GET" [] Nothing (ForeignType "") (FunctionName []) -- | To be used exclusively as a "negative" return type/constraint -- by @'Elem`@ type family. @@ -173,7 +163,7 @@ class HasForeignType lang a where data NoTypes instance HasForeignType NoTypes ftype where - typeFor _ _ = empty + typeFor _ _ = ForeignType empty type HasNoForeignType = HasForeignType NoTypes @@ -195,18 +185,21 @@ instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout) foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqUrl.path <>~ [Segment (Cap arg)] - & reqFuncName %~ (++ ["by", str]) + req & reqUrl . path <>~ [Segment (Cap arg)] + & reqFuncName . _FunctionName %~ (++ ["by", str]) where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy ftype)) + str = pack . symbolVal $ (Proxy :: Proxy sym) + ftype = typeFor lang (Proxy :: Proxy ftype) + arg = Arg + { _aName = PathSegment str + , _aType = ftype } 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 & reqFuncName %~ (methodLC :) + req & reqFuncName . _FunctionName %~ (methodLC :) & reqMethod .~ method & reqReturnType .~ retType where @@ -219,12 +212,13 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) type Foreign (Header sym a :> sublayout) = Foreign sublayout foreignFor lang Proxy req = - foreignFor lang subP $ req - & reqHeaders <>~ [HeaderArg arg] + foreignFor lang subP $ req & reqHeaders <>~ [HeaderArg arg] where hname = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (hname, typeFor lang (Proxy :: Proxy a)) - subP = Proxy :: Proxy sublayout + arg = Arg + { _aName = PathSegment hname + , _aType = typeFor lang (Proxy :: Proxy a) } + subP = Proxy :: Proxy sublayout instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) => HasForeign lang (QueryParam sym a :> sublayout) where @@ -233,10 +227,11 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ req & reqUrl.queryStr <>~ [QueryArg arg Normal] - where str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy a)) + arg = Arg + { _aName = PathSegment str + , _aType = typeFor lang (Proxy :: Proxy a) } instance (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout) @@ -247,7 +242,9 @@ instance req & reqUrl.queryStr <>~ [QueryArg arg List] where str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy [a])) + arg = Arg + { _aName = PathSegment str + , _aType = typeFor lang (Proxy :: Proxy [a]) } instance (KnownSymbol sym, HasForeignType lang Bool, HasForeign lang sublayout) @@ -259,13 +256,15 @@ instance req & reqUrl.queryStr <>~ [QueryArg arg Flag] where str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy Bool)) + arg = Arg + { _aName = PathSegment str + , _aType = typeFor lang (Proxy :: Proxy Bool) } instance HasForeign lang Raw where type Foreign Raw = HTTP.Method -> Req foreignFor _ Proxy req method = - req & reqFuncName %~ ((toLower $ decodeUtf8 method) :) + req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :) & reqMethod .~ method instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout) @@ -282,8 +281,8 @@ instance (KnownSymbol path, HasForeign lang sublayout) foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqUrl.path <>~ [Segment (Static str)] - & reqFuncName %~ (++ [str]) + req & reqUrl . path <>~ [Segment (Static (PathSegment str))] + & reqFuncName . _FunctionName %~ (++ [str]) where str = Data.Text.map (\c -> if c == '.' then '_' else c) diff --git a/servant-foreign/test/Servant/ForeignSpec.hs b/servant-foreign/test/Servant/ForeignSpec.hs index 0e279994..c70a96af 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -1,13 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} - +{-# LANGUAGE CPP #-} #include "overlapping-compat.h" module Servant.ForeignSpec where @@ -26,15 +17,17 @@ spec = describe "Servant.Foreign" $ do camelCaseSpec :: Spec camelCaseSpec = describe "camelCase" $ do it "converts FunctionNames to camelCase" $ do - camelCase ["post", "counter", "inc"] `shouldBe` "postCounterInc" - camelCase ["get", "hyphen-ated", "counter"] `shouldBe` "getHyphenatedCounter" + camelCase (FunctionName ["post", "counter", "inc"]) + `shouldBe` "postCounterInc" + camelCase (FunctionName ["get", "hyphen-ated", "counter"]) + `shouldBe` "getHyphenatedCounter" ---------------------------------------------------------------------- data LangX instance HasForeignType LangX () where - typeFor _ _ = "voidX" + typeFor _ _ = ForeignType "voidX" instance HasForeignType LangX Int where typeFor _ _ = "intX" @@ -68,24 +61,24 @@ listFromAPISpec = describe "listFromAPI" $ do shouldBe getReq $ defReq { _reqUrl = Url [ Segment $ Static "test" ] - [ QueryArg ("flag", "boolX") Flag ] + [ QueryArg (Arg "flag" "boolX") Flag ] , _reqMethod = "GET" - , _reqHeaders = [HeaderArg ("header", "listX of stringX")] + , _reqHeaders = [HeaderArg $ Arg "header" "listX of stringX"] , _reqBody = Nothing , _reqReturnType = "intX" - , _reqFuncName = ["get", "test"] + , _reqFuncName = FunctionName ["get", "test"] } it "collects all info for post request" $ do shouldBe postReq $ defReq { _reqUrl = Url [ Segment $ Static "test" ] - [ QueryArg ("param", "intX") Normal ] + [ QueryArg (Arg "param" "intX") Normal ] , _reqMethod = "POST" , _reqHeaders = [] , _reqBody = Just "listX of stringX" , _reqReturnType = "voidX" - , _reqFuncName = ["post", "test"] + , _reqFuncName = FunctionName ["post", "test"] } it "collects all info for put request" $ do @@ -93,23 +86,23 @@ listFromAPISpec = describe "listFromAPI" $ do { _reqUrl = Url [ Segment $ Static "test" ] -- Shoud this be |intX| or |listX of intX| ? - [ QueryArg ("params", "listX of intX") List ] + [ QueryArg (Arg "params" "listX of intX") List ] , _reqMethod = "PUT" , _reqHeaders = [] , _reqBody = Just "stringX" , _reqReturnType = "voidX" - , _reqFuncName = ["put", "test"] + , _reqFuncName = FunctionName ["put", "test"] } it "collects all info for delete request" $ do shouldBe deleteReq $ defReq { _reqUrl = Url [ Segment $ Static "test" - , Segment $ Cap ("id", "intX") ] + , Segment $ Cap (Arg "id" "intX") ] [] , _reqMethod = "DELETE" , _reqHeaders = [] , _reqBody = Nothing , _reqReturnType = "voidX" - , _reqFuncName = ["delete", "test", "by", "id"] + , _reqFuncName = FunctionName ["delete", "test", "by", "id"] } diff --git a/servant-js/src/Servant/JS/Angular.hs b/servant-js/src/Servant/JS/Angular.hs index 4d647225..ea5a4764 100644 --- a/servant-js/src/Servant/JS/Angular.hs +++ b/servant-js/src/Servant/JS/Angular.hs @@ -76,9 +76,12 @@ generateAngularJSWith ngOptions opts req = "\n" <> where argsStr = T.intercalate ", " args args = http ++ captures - ++ map (view $ argName._1) queryparams + ++ map (view $ argName . aPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . aPath) + ) hs -- If we want to generate Top Level Function, they must depend on -- the $http service, if we generate a service, the functions will @@ -87,9 +90,9 @@ generateAngularJSWith ngOptions opts req = "\n" <> 0 -> ["$http"] _ -> [] - captures = map (fst . captureArg) + captures = map (view aPath . captureArg) . filter isCapture - $ req ^. reqUrl.path + $ req ^. reqUrl . path hs = req ^. reqHeaders @@ -110,10 +113,11 @@ generateAngularJSWith ngOptions opts req = "\n" <> then "" else " , headers: { " <> headersStr <> " }\n" - where headersStr = T.intercalate ", " $ map headerStr hs - headerStr header = "\"" <> - fst (headerArg header) <> - "\": " <> toJSHeader header + where + headersStr = T.intercalate ", " $ map headerStr hs + headerStr header = "\"" <> + header ^. headerArg . aPath <> + "\": " <> toJSHeader header namespace = if hasService diff --git a/servant-js/src/Servant/JS/Axios.hs b/servant-js/src/Servant/JS/Axios.hs index c8540efe..6047ccc8 100644 --- a/servant-js/src/Servant/JS/Axios.hs +++ b/servant-js/src/Servant/JS/Axios.hs @@ -62,11 +62,14 @@ generateAxiosJSWith aopts opts req = "\n" <> where argsStr = T.intercalate ", " args args = captures - ++ map (view $ argName._1) queryparams + ++ map (view $ argName . aPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . aPath) + ) hs - captures = map (fst . captureArg) + captures = map (view aPath . captureArg) . filter isCapture $ req ^. reqUrl.path @@ -104,10 +107,11 @@ generateAxiosJSWith aopts opts req = "\n" <> then "" else " , headers: { " <> headersStr <> " }\n" - where headersStr = T.intercalate ", " $ map headerStr hs - headerStr header = "\"" <> - fst (headerArg header) <> - "\": " <> toJSHeader header + where + headersStr = T.intercalate ", " $ map headerStr hs + headerStr header = "\"" <> + header ^. headerArg . aPath <> + "\": " <> toJSHeader header namespace = if hasNoModule diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs index 61c33e0f..9d9dff9d 100644 --- a/servant-js/src/Servant/JS/Internal.hs +++ b/servant-js/src/Servant/JS/Internal.hs @@ -1,4 +1,6 @@ -{-#LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + module Servant.JS.Internal ( JavaScriptGenerator , CommonGeneratorOptions(..) @@ -19,7 +21,22 @@ module Servant.JS.Internal , reqHeaders , HasForeign(..) , HasForeignType(..) + , HasNoForeignType + , GenerateList(..) + , NoTypes + , HeaderArg + , ArgType(..) , HeaderArg(..) + , QueryArg(..) + , Req(..) + , Segment(..) + , SegmentType(..) + , Url(..) + , Path + , ForeignType(..) + , Arg(..) + , FunctionName(..) + , PathSegment(..) , concatCase , snakeCase , camelCase @@ -32,7 +49,7 @@ module Servant.JS.Internal , Header ) where -import Control.Lens ((^.), _1) +import Control.Lens import qualified Data.CharSet as Set import qualified Data.CharSet.Unicode.Category as Set import Data.Monoid @@ -123,7 +140,8 @@ toValidFunctionName t = ] toJSHeader :: HeaderArg -> Text -toJSHeader (HeaderArg n) = toValidFunctionName ("header" <> fst n) +toJSHeader (HeaderArg n) + = toValidFunctionName ("header" <> n ^. aName . _PathSegment) toJSHeader (ReplaceHeaderArg n p) | pn `T.isPrefixOf` p = pv <> " + \"" <> rp <> "\"" | pn `T.isSuffixOf` p = "\"" <> rp <> "\" + " <> pv @@ -131,8 +149,8 @@ toJSHeader (ReplaceHeaderArg n p) <> "\"" | otherwise = p where - pv = toValidFunctionName ("header" <> fst n) - pn = "{" <> fst n <> "}" + pv = toValidFunctionName ("header" <> n ^. aName . _PathSegment) + pn = "{" <> n ^. aName . _PathSegment <> "}" rp = T.replace pn "" p jsSegments :: [Segment] -> Text @@ -145,8 +163,9 @@ segmentToStr (Segment st) notTheEnd = segmentTypeToStr st <> if notTheEnd then "" else "'" segmentTypeToStr :: SegmentType -> Text -segmentTypeToStr (Static s) = s -segmentTypeToStr (Cap s) = "' + encodeURIComponent(" <> fst s <> ") + '" +segmentTypeToStr (Static s) = s ^. _PathSegment +segmentTypeToStr (Cap s) = + "' + encodeURIComponent(" <> s ^. aName . _PathSegment <> ") + '" jsGParams :: Text -> [QueryArg] -> Text jsGParams _ [] = "" @@ -168,4 +187,4 @@ paramToStr qarg notTheEnd = <> "[]=' + encodeURIComponent(" <> name <> if notTheEnd then ") + '" else ")" - where name = qarg ^. argName . _1 + where name = qarg ^. argName . aName . _PathSegment diff --git a/servant-js/src/Servant/JS/JQuery.hs b/servant-js/src/Servant/JS/JQuery.hs index dfd3ddc0..d4471122 100644 --- a/servant-js/src/Servant/JS/JQuery.hs +++ b/servant-js/src/Servant/JS/JQuery.hs @@ -10,6 +10,7 @@ import Data.Text.Encoding (decodeUtf8) import Servant.Foreign import Servant.JS.Internal + -- | Generate javascript functions that use the /jQuery/ library -- to make the AJAX calls. Uses 'defCommonGeneratorOptions' -- for the generator options. @@ -42,12 +43,15 @@ generateJQueryJSWith opts req = "\n" <> where argsStr = T.intercalate ", " args args = captures - ++ map (view $ argName._1) queryparams + ++ map (view $ argName . aPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map (toValidFunctionName + . (<>) "header" + . view (headerArg . aPath) + ) hs ++ [onSuccess, onError] - captures = map (fst . captureArg) + captures = map (view aPath . captureArg) . filter isCapture $ req ^. reqUrl.path @@ -73,10 +77,11 @@ generateJQueryJSWith opts req = "\n" <> then "" else " , headers: { " <> headersStr <> " }\n" - where headersStr = T.intercalate ", " $ map headerStr hs - headerStr header = "\"" <> - fst (headerArg header) <> - "\": " <> toJSHeader header + where + headersStr = T.intercalate ", " $ map headerStr hs + headerStr header = "\"" <> + header ^. headerArg . aPath <> + "\": " <> toJSHeader header namespace = if (moduleName opts) == "" then "var " diff --git a/servant-js/src/Servant/JS/Vanilla.hs b/servant-js/src/Servant/JS/Vanilla.hs index 386a0d2e..41b4dc30 100644 --- a/servant-js/src/Servant/JS/Vanilla.hs +++ b/servant-js/src/Servant/JS/Vanilla.hs @@ -54,12 +54,15 @@ generateVanillaJSWith opts req = "\n" <> where argsStr = T.intercalate ", " args args = captures - ++ map (view $ argName._1) queryparams + ++ map (view $ argName . aPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . aPath) + ) hs ++ [onSuccess, onError] - captures = map (fst . captureArg) + captures = map (view aPath . captureArg) . filter isCapture $ req ^. reqUrl.path @@ -85,10 +88,11 @@ generateVanillaJSWith opts req = "\n" <> then "" else headersStr <> "\n" - where headersStr = T.intercalate "\n" $ map headerStr hs - headerStr header = " xhr.setRequestHeader(\"" <> - fst (headerArg header) <> - "\", " <> toJSHeader header <> ");" + where + headersStr = T.intercalate "\n" $ map headerStr hs + headerStr header = " xhr.setRequestHeader(\"" <> + header ^. headerArg . aPath <> + "\", " <> toJSHeader header <> ");" namespace = if moduleName opts == "" then "var " diff --git a/servant-js/test/Servant/JSSpec/CustomHeaders.hs b/servant-js/test/Servant/JSSpec/CustomHeaders.hs index 150436e3..4e4e3311 100644 --- a/servant-js/test/Servant/JSSpec/CustomHeaders.hs +++ b/servant-js/test/Servant/JSSpec/CustomHeaders.hs @@ -27,8 +27,9 @@ instance (KnownSymbol sym, HasForeign lang sublayout) type Foreign (Authorization sym a :> sublayout) = Foreign sublayout foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqHeaders <>~ [ ReplaceHeaderArg ("Authorization", "") $ - tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ] + req & reqHeaders <>~ + [ ReplaceHeaderArg (Arg "Authorization" "") + $ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ] where tokenType t = t <> " {Authorization}" @@ -40,7 +41,7 @@ instance (HasForeign lang sublayout) type Foreign (MyLovelyHorse a :> sublayout) = Foreign sublayout foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqHeaders <>~ [ ReplaceHeaderArg ("X-MyLovelyHorse", "") tpl ] + req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" "") tpl ] where tpl = "I am good friends with {X-MyLovelyHorse}" @@ -52,6 +53,6 @@ instance (HasForeign lang sublayout) type Foreign (WhatsForDinner a :> sublayout) = Foreign sublayout foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqHeaders <>~ [ ReplaceHeaderArg ("X-WhatsForDinner", "") tpl ] + req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" "") tpl ] where tpl = "I would like {X-WhatsForDinner} with a cherry on top." From 36ddf7663a9923034384f4e4087e65e27c5b140a Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Tue, 1 Mar 2016 11:59:00 +0300 Subject: [PATCH 085/180] fix 7.8.4 compilation --- servant-foreign/src/Servant/Foreign/Internal.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index d4130470..6851fd56 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -8,6 +8,9 @@ module Servant.Foreign.Internal where import Control.Lens hiding (cons) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif import Data.Proxy import Data.String import Data.Text From d8e98a1f16150192ba1bf5897d99c64d3d5030dd Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Sat, 12 Mar 2016 12:51:11 +0300 Subject: [PATCH 086/180] fix lens export mismatch --- servant-foreign/src/Servant/Foreign/Internal.hs | 2 +- servant-js/src/Servant/JS/Internal.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 6851fd56..b22a0716 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -7,7 +7,7 @@ -- arbitrary programming languages. module Servant.Foreign.Internal where -import Control.Lens hiding (cons) +import Control.Lens hiding (cons, List) #if !MIN_VERSION_base(4,8,0) import Data.Monoid #endif diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs index 9d9dff9d..b55819ba 100644 --- a/servant-js/src/Servant/JS/Internal.hs +++ b/servant-js/src/Servant/JS/Internal.hs @@ -49,7 +49,7 @@ module Servant.JS.Internal , Header ) where -import Control.Lens +import Control.Lens hiding (List) import qualified Data.CharSet as Set import qualified Data.CharSet.Unicode.Category as Set import Data.Monoid From bfe812f5d91f699d41bfdc5c66e3eb934db23971 Mon Sep 17 00:00:00 2001 From: Steve Purcell Date: Sun, 13 Mar 2016 17:02:00 +1300 Subject: [PATCH 087/180] [servant-foreign] Normalise names of arg field accessors --- servant-foreign/src/Servant/Foreign.hs | 10 +++--- .../src/Servant/Foreign/Internal.hs | 32 +++++++++---------- servant-js/src/Servant/JS/Angular.hs | 8 ++--- servant-js/src/Servant/JS/Axios.hs | 8 ++--- servant-js/src/Servant/JS/Internal.hs | 12 +++---- servant-js/src/Servant/JS/JQuery.hs | 8 ++--- servant-js/src/Servant/JS/Vanilla.hs | 8 ++--- 7 files changed, 43 insertions(+), 43 deletions(-) diff --git a/servant-foreign/src/Servant/Foreign.hs b/servant-foreign/src/Servant/Foreign.hs index 3850ad37..5df4a6c0 100644 --- a/servant-foreign/src/Servant/Foreign.hs +++ b/servant-foreign/src/Servant/Foreign.hs @@ -15,9 +15,9 @@ module Servant.Foreign , FunctionName(..) , PathSegment(..) -- lenses - , aName - , aType - , aPath + , argName + , argType + , argPath , reqUrl , reqMethod , reqHeaders @@ -26,8 +26,8 @@ module Servant.Foreign , reqFuncName , path , queryStr - , argName - , argType + , queryArgName + , queryArgType , headerArg -- prisms , _PathSegment diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index b22a0716..dc33124b 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -38,14 +38,14 @@ newtype PathSegment = PathSegment { unPathSegment :: Text } makePrisms ''PathSegment data Arg = Arg - { _aName :: PathSegment - , _aType :: ForeignType } + { _argName :: PathSegment + , _argType :: ForeignType } deriving (Show, Eq) makeLenses ''Arg -aPath :: Getter Arg Text -aPath = aName . _PathSegment +argPath :: Getter Arg Text +argPath = argName . _PathSegment data SegmentType = Static PathSegment @@ -80,8 +80,8 @@ data ArgType makePrisms ''ArgType data QueryArg = QueryArg - { _argName :: Arg - , _argType :: ArgType + { _queryArgName :: Arg + , _queryArgType :: ArgType } deriving (Eq, Show) makeLenses ''QueryArg @@ -194,8 +194,8 @@ instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout) str = pack . symbolVal $ (Proxy :: Proxy sym) ftype = typeFor lang (Proxy :: Proxy ftype) arg = Arg - { _aName = PathSegment str - , _aType = ftype } + { _argName = PathSegment str + , _argType = ftype } instance (Elem JSON list, HasForeignType lang a, ReflectMethod method) => HasForeign lang (Verb method status list a) where @@ -219,8 +219,8 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) where hname = pack . symbolVal $ (Proxy :: Proxy sym) arg = Arg - { _aName = PathSegment hname - , _aType = typeFor lang (Proxy :: Proxy a) } + { _argName = PathSegment hname + , _argType = typeFor lang (Proxy :: Proxy a) } subP = Proxy :: Proxy sublayout instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) @@ -233,8 +233,8 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) where str = pack . symbolVal $ (Proxy :: Proxy sym) arg = Arg - { _aName = PathSegment str - , _aType = typeFor lang (Proxy :: Proxy a) } + { _argName = PathSegment str + , _argType = typeFor lang (Proxy :: Proxy a) } instance (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout) @@ -246,8 +246,8 @@ instance where str = pack . symbolVal $ (Proxy :: Proxy sym) arg = Arg - { _aName = PathSegment str - , _aType = typeFor lang (Proxy :: Proxy [a]) } + { _argName = PathSegment str + , _argType = typeFor lang (Proxy :: Proxy [a]) } instance (KnownSymbol sym, HasForeignType lang Bool, HasForeign lang sublayout) @@ -260,8 +260,8 @@ instance where str = pack . symbolVal $ (Proxy :: Proxy sym) arg = Arg - { _aName = PathSegment str - , _aType = typeFor lang (Proxy :: Proxy Bool) } + { _argName = PathSegment str + , _argType = typeFor lang (Proxy :: Proxy Bool) } instance HasForeign lang Raw where type Foreign Raw = HTTP.Method -> Req diff --git a/servant-js/src/Servant/JS/Angular.hs b/servant-js/src/Servant/JS/Angular.hs index ea5a4764..5c93610d 100644 --- a/servant-js/src/Servant/JS/Angular.hs +++ b/servant-js/src/Servant/JS/Angular.hs @@ -76,11 +76,11 @@ generateAngularJSWith ngOptions opts req = "\n" <> where argsStr = T.intercalate ", " args args = http ++ captures - ++ map (view $ argName . aPath) queryparams + ++ map (view $ queryArgName . argPath) queryparams ++ body ++ map ( toValidFunctionName . (<>) "header" - . view (headerArg . aPath) + . view (headerArg . argPath) ) hs -- If we want to generate Top Level Function, they must depend on @@ -90,7 +90,7 @@ generateAngularJSWith ngOptions opts req = "\n" <> 0 -> ["$http"] _ -> [] - captures = map (view aPath . captureArg) + captures = map (view argPath . captureArg) . filter isCapture $ req ^. reqUrl . path @@ -116,7 +116,7 @@ generateAngularJSWith ngOptions opts req = "\n" <> where headersStr = T.intercalate ", " $ map headerStr hs headerStr header = "\"" <> - header ^. headerArg . aPath <> + header ^. headerArg . argPath <> "\": " <> toJSHeader header namespace = diff --git a/servant-js/src/Servant/JS/Axios.hs b/servant-js/src/Servant/JS/Axios.hs index 6047ccc8..3b299cd4 100644 --- a/servant-js/src/Servant/JS/Axios.hs +++ b/servant-js/src/Servant/JS/Axios.hs @@ -62,14 +62,14 @@ generateAxiosJSWith aopts opts req = "\n" <> where argsStr = T.intercalate ", " args args = captures - ++ map (view $ argName . aPath) queryparams + ++ map (view $ queryArgName . argPath) queryparams ++ body ++ map ( toValidFunctionName . (<>) "header" - . view (headerArg . aPath) + . view (headerArg . argPath) ) hs - captures = map (view aPath . captureArg) + captures = map (view argPath . captureArg) . filter isCapture $ req ^. reqUrl.path @@ -110,7 +110,7 @@ generateAxiosJSWith aopts opts req = "\n" <> where headersStr = T.intercalate ", " $ map headerStr hs headerStr header = "\"" <> - header ^. headerArg . aPath <> + header ^. headerArg . argPath <> "\": " <> toJSHeader header namespace = diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs index b55819ba..cc49bf88 100644 --- a/servant-js/src/Servant/JS/Internal.hs +++ b/servant-js/src/Servant/JS/Internal.hs @@ -141,7 +141,7 @@ toValidFunctionName t = toJSHeader :: HeaderArg -> Text toJSHeader (HeaderArg n) - = toValidFunctionName ("header" <> n ^. aName . _PathSegment) + = toValidFunctionName ("header" <> n ^. argName . _PathSegment) toJSHeader (ReplaceHeaderArg n p) | pn `T.isPrefixOf` p = pv <> " + \"" <> rp <> "\"" | pn `T.isSuffixOf` p = "\"" <> rp <> "\" + " <> pv @@ -149,8 +149,8 @@ toJSHeader (ReplaceHeaderArg n p) <> "\"" | otherwise = p where - pv = toValidFunctionName ("header" <> n ^. aName . _PathSegment) - pn = "{" <> n ^. aName . _PathSegment <> "}" + pv = toValidFunctionName ("header" <> n ^. argName . _PathSegment) + pn = "{" <> n ^. argName . _PathSegment <> "}" rp = T.replace pn "" p jsSegments :: [Segment] -> Text @@ -165,7 +165,7 @@ segmentToStr (Segment st) notTheEnd = segmentTypeToStr :: SegmentType -> Text segmentTypeToStr (Static s) = s ^. _PathSegment segmentTypeToStr (Cap s) = - "' + encodeURIComponent(" <> s ^. aName . _PathSegment <> ") + '" + "' + encodeURIComponent(" <> s ^. argName . _PathSegment <> ") + '" jsGParams :: Text -> [QueryArg] -> Text jsGParams _ [] = "" @@ -177,7 +177,7 @@ jsParams = jsGParams "&" paramToStr :: QueryArg -> Bool -> Text paramToStr qarg notTheEnd = - case qarg ^. argType of + case qarg ^. queryArgType of Normal -> name <> "=' + encodeURIComponent(" <> name @@ -187,4 +187,4 @@ paramToStr qarg notTheEnd = <> "[]=' + encodeURIComponent(" <> name <> if notTheEnd then ") + '" else ")" - where name = qarg ^. argName . aName . _PathSegment + where name = qarg ^. queryArgName . argName . _PathSegment diff --git a/servant-js/src/Servant/JS/JQuery.hs b/servant-js/src/Servant/JS/JQuery.hs index d4471122..98038f0c 100644 --- a/servant-js/src/Servant/JS/JQuery.hs +++ b/servant-js/src/Servant/JS/JQuery.hs @@ -43,15 +43,15 @@ generateJQueryJSWith opts req = "\n" <> where argsStr = T.intercalate ", " args args = captures - ++ map (view $ argName . aPath) queryparams + ++ map (view $ queryArgName . argPath) queryparams ++ body ++ map (toValidFunctionName . (<>) "header" - . view (headerArg . aPath) + . view (headerArg . argPath) ) hs ++ [onSuccess, onError] - captures = map (view aPath . captureArg) + captures = map (view argPath . captureArg) . filter isCapture $ req ^. reqUrl.path @@ -80,7 +80,7 @@ generateJQueryJSWith opts req = "\n" <> where headersStr = T.intercalate ", " $ map headerStr hs headerStr header = "\"" <> - header ^. headerArg . aPath <> + header ^. headerArg . argPath <> "\": " <> toJSHeader header namespace = if (moduleName opts) == "" diff --git a/servant-js/src/Servant/JS/Vanilla.hs b/servant-js/src/Servant/JS/Vanilla.hs index 41b4dc30..216fbc7f 100644 --- a/servant-js/src/Servant/JS/Vanilla.hs +++ b/servant-js/src/Servant/JS/Vanilla.hs @@ -54,15 +54,15 @@ generateVanillaJSWith opts req = "\n" <> where argsStr = T.intercalate ", " args args = captures - ++ map (view $ argName . aPath) queryparams + ++ map (view $ queryArgName . argPath) queryparams ++ body ++ map ( toValidFunctionName . (<>) "header" - . view (headerArg . aPath) + . view (headerArg . argPath) ) hs ++ [onSuccess, onError] - captures = map (view aPath . captureArg) + captures = map (view argPath . captureArg) . filter isCapture $ req ^. reqUrl.path @@ -91,7 +91,7 @@ generateVanillaJSWith opts req = "\n" <> where headersStr = T.intercalate "\n" $ map headerStr hs headerStr header = " xhr.setRequestHeader(\"" <> - header ^. headerArg . aPath <> + header ^. headerArg . argPath <> "\", " <> toJSHeader header <> ");" namespace = if moduleName opts == "" From 207f05e759468595a33f716d527af3dd4af09ebf Mon Sep 17 00:00:00 2001 From: Steve Purcell Date: Sun, 13 Mar 2016 18:35:49 +1300 Subject: [PATCH 088/180] [servant-foreign] Parameterise Req with a foreign type --- servant-foreign/servant-foreign.cabal | 2 + .../src/Servant/Foreign/Internal.hs | 102 +++++++++++------- servant-foreign/test/Servant/ForeignSpec.hs | 3 +- servant-js/src/Servant/JS/Internal.hs | 18 ++-- 4 files changed, 75 insertions(+), 50 deletions(-) diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 4188a5a9..b1404444 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -46,6 +46,7 @@ library , GeneralizedNewtypeDeriving , MultiParamTypeClasses , ScopedTypeVariables + , StandaloneDeriving , TemplateHaskell , TypeFamilies , TypeOperators @@ -64,6 +65,7 @@ test-suite spec build-depends: base , hspec >= 2.1.8 , servant-foreign + , text >= 1.2 && < 1.3 default-language: Haskell2010 default-extensions: ConstraintKinds , DataKinds diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index dc33124b..f4095add 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -27,8 +27,12 @@ newtype FunctionName = FunctionName { unFunctionName :: [Text] } makePrisms ''FunctionName -newtype ForeignType = ForeignType { unForeignType :: Text } - deriving (Show, Eq, IsString, Monoid) +newtype ForeignType f = ForeignType { unForeignType :: f } + +deriving instance Show f => Show (ForeignType f) +deriving instance Eq f => Eq (ForeignType f) +deriving instance IsString f => IsString (ForeignType f) +deriving instance Monoid f => Monoid (ForeignType f) makePrisms ''ForeignType @@ -37,39 +41,45 @@ newtype PathSegment = PathSegment { unPathSegment :: Text } makePrisms ''PathSegment -data Arg = Arg +data Arg f = Arg { _argName :: PathSegment - , _argType :: ForeignType } - deriving (Show, Eq) + , _argType :: ForeignType f } + +deriving instance Eq f => Eq (Arg f) +deriving instance Show f => Show (Arg f) makeLenses ''Arg -argPath :: Getter Arg Text +argPath :: Getter (Arg f) Text argPath = argName . _PathSegment -data SegmentType +data SegmentType f = Static PathSegment -- ^ a static path segment. like "/foo" - | Cap Arg + | Cap (Arg f) -- ^ a capture. like "/:userid" - deriving (Show, Eq) + +deriving instance Eq f => Eq (SegmentType f) +deriving instance Show f => Show (SegmentType f) makePrisms ''SegmentType -newtype Segment = Segment { unSegment :: SegmentType } - deriving (Eq, Show) +newtype Segment f = Segment { unSegment :: SegmentType f } + +deriving instance Eq f => Eq (Segment f) +deriving instance Show f => Show (Segment f) makePrisms ''Segment -isCapture :: Segment -> Bool +isCapture :: Segment f -> Bool isCapture (Segment (Cap _)) = True isCapture _ = False -captureArg :: Segment -> Arg +captureArg :: Segment f -> Arg f captureArg (Segment (Cap s)) = s captureArg _ = error "captureArg called on non capture" -type Path = [Segment] +type Path f = [Segment f] data ArgType = Normal @@ -79,46 +89,58 @@ data ArgType makePrisms ''ArgType -data QueryArg = QueryArg - { _queryArgName :: Arg +data QueryArg f = QueryArg + { _queryArgName :: Arg f , _queryArgType :: ArgType - } deriving (Eq, Show) + } + +deriving instance Eq f => Eq (QueryArg f) +deriving instance Show f => Show (QueryArg f) makeLenses ''QueryArg -data HeaderArg = HeaderArg - { _headerArg :: Arg } +data HeaderArg f = HeaderArg + { _headerArg :: Arg f } | ReplaceHeaderArg - { _headerArg :: Arg + { _headerArg :: Arg f , _headerPattern :: Text - } deriving (Eq, Show) + } + +deriving instance Eq f => Eq (HeaderArg f) +deriving instance Show f => Show (HeaderArg f) makeLenses ''HeaderArg makePrisms ''HeaderArg -data Url = Url - { _path :: Path - , _queryStr :: [QueryArg] - } deriving (Eq, Show) +data Url f = Url + { _path :: Path f + , _queryStr :: [QueryArg f] + } -defUrl :: Url +deriving instance Eq f => Eq (Url f) +deriving instance Show f => Show (Url f) + +defUrl :: Url f defUrl = Url [] [] makeLenses ''Url -data Req = Req - { _reqUrl :: Url +data Req f = Req + { _reqUrl :: Url f , _reqMethod :: HTTP.Method - , _reqHeaders :: [HeaderArg] - , _reqBody :: Maybe ForeignType - , _reqReturnType :: ForeignType + , _reqHeaders :: [HeaderArg f] + , _reqBody :: Maybe (ForeignType f) + , _reqReturnType :: ForeignType f , _reqFuncName :: FunctionName - } deriving (Eq, Show) + } + +deriving instance Eq f => Eq (Req f) +deriving instance Show f => Show (Req f) makeLenses ''Req -defReq :: Req +defReq :: Req Text defReq = Req defUrl "GET" [] Nothing (ForeignType "") (FunctionName []) -- | To be used exclusively as a "negative" return type/constraint @@ -161,7 +183,7 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where -- > -- class HasForeignType lang a where - typeFor :: Proxy lang -> Proxy a -> ForeignType + typeFor :: Proxy lang -> Proxy a -> ForeignType Text data NoTypes @@ -172,7 +194,7 @@ type HasNoForeignType = HasForeignType NoTypes class HasForeign lang (layout :: *) where type Foreign layout :: * - foreignFor :: Proxy lang -> Proxy layout -> Req -> Foreign layout + foreignFor :: Proxy lang -> Proxy layout -> Req Text -> Foreign layout instance (HasForeign lang a, HasForeign lang b) => HasForeign lang (a :<|> b) where @@ -199,7 +221,7 @@ instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout) 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 + type Foreign (Verb method status list a) = Req Text foreignFor lang Proxy req = req & reqFuncName . _FunctionName %~ (methodLC :) @@ -264,7 +286,7 @@ instance , _argType = typeFor lang (Proxy :: Proxy Bool) } instance HasForeign lang Raw where - type Foreign Raw = HTTP.Method -> Req + type Foreign Raw = HTTP.Method -> Req Text foreignFor _ Proxy req method = req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :) @@ -329,9 +351,9 @@ instance HasForeign lang sublayout -- the data needed to generate a function for each endpoint -- and hands it all back in a list. class GenerateList reqs where - generateList :: reqs -> [Req] + generateList :: reqs -> [Req Text] -instance GenerateList Req where +instance GenerateList (Req Text) where generateList r = [r] instance (GenerateList start, GenerateList rest) @@ -344,5 +366,5 @@ listFromAPI :: (HasForeign lang api, GenerateList (Foreign api)) => Proxy lang -> Proxy api - -> [Req] + -> [Req Text] 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 c70a96af..5c0c348b 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -6,6 +6,7 @@ module Servant.ForeignSpec where import Data.Monoid ((<>)) import Data.Proxy import Servant.Foreign +import Data.Text (Text(..)) import Test.Hspec @@ -47,7 +48,7 @@ type TestApi :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] () :<|> "test" :> Capture "id" Int :> Delete '[JSON] () -testApi :: [Req] +testApi :: [Req Text] testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy TestApi) listFromAPISpec :: Spec diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs index cc49bf88..360b8d13 100644 --- a/servant-js/src/Servant/JS/Internal.hs +++ b/servant-js/src/Servant/JS/Internal.hs @@ -57,12 +57,12 @@ import qualified Data.Text as T import Data.Text (Text) import Servant.Foreign -type AjaxReq = Req +type AjaxReq = Req Text -- A 'JavascriptGenerator' just takes the data found in the API type -- for each endpoint and generates Javascript code in a Text. Several -- generators are available in this package. -type JavaScriptGenerator = [Req] -> Text +type JavaScriptGenerator = [Req Text] -> Text -- | This structure is used by specific implementations to let you -- customize the output @@ -139,7 +139,7 @@ toValidFunctionName t = , Set.connectorPunctuation ] -toJSHeader :: HeaderArg -> Text +toJSHeader :: HeaderArg f -> Text toJSHeader (HeaderArg n) = toValidFunctionName ("header" <> n ^. argName . _PathSegment) toJSHeader (ReplaceHeaderArg n p) @@ -153,29 +153,29 @@ toJSHeader (ReplaceHeaderArg n p) pn = "{" <> n ^. argName . _PathSegment <> "}" rp = T.replace pn "" p -jsSegments :: [Segment] -> Text +jsSegments :: [Segment f] -> Text jsSegments [] = "" jsSegments [x] = "/" <> segmentToStr x False jsSegments (x:xs) = "/" <> segmentToStr x True <> jsSegments xs -segmentToStr :: Segment -> Bool -> Text +segmentToStr :: Segment f -> Bool -> Text segmentToStr (Segment st) notTheEnd = segmentTypeToStr st <> if notTheEnd then "" else "'" -segmentTypeToStr :: SegmentType -> Text +segmentTypeToStr :: SegmentType f -> Text segmentTypeToStr (Static s) = s ^. _PathSegment segmentTypeToStr (Cap s) = "' + encodeURIComponent(" <> s ^. argName . _PathSegment <> ") + '" -jsGParams :: Text -> [QueryArg] -> Text +jsGParams :: Text -> [QueryArg f] -> Text jsGParams _ [] = "" jsGParams _ [x] = paramToStr x False jsGParams s (x:xs) = paramToStr x True <> s <> jsGParams s xs -jsParams :: [QueryArg] -> Text +jsParams :: [QueryArg f] -> Text jsParams = jsGParams "&" -paramToStr :: QueryArg -> Bool -> Text +paramToStr :: QueryArg f -> Bool -> Text paramToStr qarg notTheEnd = case qarg ^. queryArgType of Normal -> name From c528eb24ca367ff5fee7835116630bc1f5aa893e Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Tue, 1 Mar 2016 14:21:21 +0300 Subject: [PATCH 089/180] use base-compat --- servant/servant.cabal | 1 + servant/src/Servant/API/Alternative.hs | 7 ++----- servant/src/Servant/API/ContentTypes.hs | 8 +++----- servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs | 1 - servant/src/Servant/API/ResponseHeaders.hs | 4 +--- servant/src/Servant/Utils/Links.hs | 6 +----- stack-ghc-7.8.4.yaml | 1 + 7 files changed, 9 insertions(+), 19 deletions(-) diff --git a/servant/servant.cabal b/servant/servant.cabal index a66efbce..689fc0fb 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -47,6 +47,7 @@ library Servant.Utils.Links build-depends: base >=4.7 && <5 + , base-compat >= 0.8 , aeson >= 0.7 , attoparsec >= 0.12 , bytestring == 0.10.* diff --git a/servant/src/Servant/API/Alternative.hs b/servant/src/Servant/API/Alternative.hs index 752dcef0..144f8b48 100644 --- a/servant/src/Servant/API/Alternative.hs +++ b/servant/src/Servant/API/Alternative.hs @@ -9,12 +9,9 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid (..)) -import Data.Traversable (Traversable) -import Data.Foldable (Foldable) -#endif import Data.Typeable (Typeable) +import Prelude.Compat (Monoid(..), Traversable, Foldable) + -- | Union of two APIs, first takes precedence in case of overlap. -- -- Example: diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index 61bf1ce9..1e0febdb 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -72,11 +72,8 @@ module Servant.API.ContentTypes , canHandleAcceptH ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((*>), (<*)) -#endif import Control.Arrow (left) -import Control.Monad +import Control.Monad.Compat hiding (mapM) import Data.Aeson (FromJSON(..), ToJSON(..), encode) import Data.Aeson.Parser (value) import Data.Aeson.Types (parseEither) @@ -88,7 +85,7 @@ import Data.ByteString.Lazy (ByteString, fromStrict, import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Char8 as BC import Data.Maybe (isJust) -import Data.Monoid +import Data.Monoid.Compat import Data.String.Conversions (cs) import qualified Data.Text as TextS import qualified Data.Text.Encoding as TextS @@ -99,6 +96,7 @@ import GHC.Generics (Generic) import qualified Network.HTTP.Media as M import Network.URI (escapeURIString, isUnreserved, unEscapeString) +import Prelude.Compat ((<*), (*>)) -- * Provided content types data JSON deriving Typeable diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index 91d01727..22d69263 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -7,7 +7,6 @@ module Servant.API.Internal.Test.ComprehensiveAPI where import Data.Proxy - import Servant.API type GET = Get '[JSON] () diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index dc73a8e0..09d567a7 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -30,9 +30,6 @@ module Servant.API.ResponseHeaders , HList(..) ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif import Data.ByteString.Char8 as BS (pack, unlines, init) import Data.ByteString.Conversion (ToByteString, toByteString', FromByteString, fromByteString) @@ -42,6 +39,7 @@ import GHC.TypeLits (KnownSymbol, symbolVal) import qualified Network.HTTP.Types.Header as HTTP import Servant.API.Header (Header (..)) +import Prelude.Compat -- | Response Header objects. You should never need to construct one directly. -- Instead, use 'addHeader'. diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index d83ffc7e..86085fa6 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -105,11 +105,7 @@ import Data.List import Data.Proxy ( Proxy(..) ) import qualified Data.Text as Text import qualified Data.ByteString.Char8 as BSC -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid ( Monoid(..), (<>) ) -#else -import Data.Monoid ( (<>) ) -#endif +import Data.Monoid.Compat ( Monoid(..), (<>) ) import Network.URI ( URI(..), escapeURIString, isUnreserved ) import GHC.TypeLits ( KnownSymbol, symbolVal ) import GHC.Exts(Constraint) diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index 8aa461d7..679b2b52 100644 --- a/stack-ghc-7.8.4.yaml +++ b/stack-ghc-7.8.4.yaml @@ -12,6 +12,7 @@ packages: - servant-mock/ - servant-server/ extra-deps: +- base-compat-0.9.0 - hspec-2.2.0 - hspec-core-2.2.0 - hspec-discover-2.2.0 From c755f478067ec7f8e1cee352e59e36d743e90a75 Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Tue, 1 Mar 2016 14:41:24 +0300 Subject: [PATCH 090/180] use base-compat in servant-server --- servant-server/servant-server.cabal | 1 + servant-server/src/Servant/Server/Internal.hs | 4 +--- servant-server/src/Servant/Server/Internal/Enter.hs | 5 ++--- .../src/Servant/Server/Internal/RoutingApplication.hs | 4 +--- servant/servant.cabal | 2 +- stack.yaml | 1 + 6 files changed, 7 insertions(+), 10 deletions(-) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 6167a2b4..a4609bd5 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -47,6 +47,7 @@ library Servant.Utils.StaticFiles build-depends: base >= 4.7 && < 5 + , base-compat >= 0.9 , aeson >= 0.7 && < 0.12 , attoparsec >= 0.12 && < 0.14 , base64-bytestring == 1.0.* diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index c170de9b..31c758b2 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -22,9 +22,6 @@ module Servant.Server.Internal , module Servant.Server.Internal.ServantErr ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif import Control.Monad.Trans.Except (ExceptT) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 @@ -45,6 +42,7 @@ import Network.Wai (Application, Request, Response, rawQueryString, remoteHost, requestHeaders, requestMethod, responseLBS, vault) +import Prelude.Compat import Web.HttpApiData (FromHttpApiData) import Web.HttpApiData.Internal (parseHeaderMaybe, parseQueryParamMaybe, diff --git a/servant-server/src/Servant/Server/Internal/Enter.hs b/servant-server/src/Servant/Server/Internal/Enter.hs index 5bcebe9d..169a05b6 100644 --- a/servant-server/src/Servant/Server/Internal/Enter.hs +++ b/servant-server/src/Servant/Server/Internal/Enter.hs @@ -10,9 +10,6 @@ {-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal.Enter where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif import qualified Control.Category as C #if MIN_VERSION_mtl(2,2,1) import Control.Monad.Except @@ -25,6 +22,8 @@ import qualified Control.Monad.State.Strict as SState import qualified Control.Monad.Writer.Lazy as LWriter import qualified Control.Monad.Writer.Strict as SWriter import Data.Typeable +import Prelude.Compat + import Servant.API class Enter typ arg ret | typ arg -> ret, typ ret -> arg where diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index cd1ac019..e7a53c3c 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -8,12 +8,10 @@ {-# LANGUAGE StandaloneDeriving #-} module Servant.Server.Internal.RoutingApplication where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif import Control.Monad.Trans.Except (ExceptT, runExceptT) import Network.Wai (Application, Request, Response, ResponseReceived) +import Prelude.Compat import Servant.Server.Internal.ServantErr type RoutingApplication = diff --git a/servant/servant.cabal b/servant/servant.cabal index 689fc0fb..849e3d05 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -47,7 +47,7 @@ library Servant.Utils.Links build-depends: base >=4.7 && <5 - , base-compat >= 0.8 + , base-compat >= 0.9 , aeson >= 0.7 , attoparsec >= 0.12 , bytestring == 0.10.* diff --git a/stack.yaml b/stack.yaml index c1aea0a2..adec1495 100644 --- a/stack.yaml +++ b/stack.yaml @@ -14,6 +14,7 @@ packages: - servant-mock/ - servant-server/ extra-deps: +- base-compat-0.9.0 - engine-io-wai-1.0.2 - control-monad-omega-0.3.1 - should-not-typecheck-2.0.1 From a22a9811903e5b8d0ff96bb1da9a91b2b912542a Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Tue, 1 Mar 2016 21:25:04 +0300 Subject: [PATCH 091/180] update base-compat imports --- servant-server/src/Servant/Server/Internal.hs | 1 + servant-server/src/Servant/Server/Internal/Enter.hs | 1 + .../src/Servant/Server/Internal/RoutingApplication.hs | 1 + servant/src/Servant/API/Alternative.hs | 3 ++- servant/src/Servant/API/ContentTypes.hs | 5 +++-- servant/src/Servant/API/ResponseHeaders.hs | 1 + 6 files changed, 9 insertions(+), 3 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 31c758b2..c9679d9e 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -42,6 +42,7 @@ import Network.Wai (Application, Request, Response, rawQueryString, remoteHost, requestHeaders, requestMethod, responseLBS, vault) +import Prelude () import Prelude.Compat import Web.HttpApiData (FromHttpApiData) import Web.HttpApiData.Internal (parseHeaderMaybe, diff --git a/servant-server/src/Servant/Server/Internal/Enter.hs b/servant-server/src/Servant/Server/Internal/Enter.hs index 169a05b6..f1c88b2e 100644 --- a/servant-server/src/Servant/Server/Internal/Enter.hs +++ b/servant-server/src/Servant/Server/Internal/Enter.hs @@ -22,6 +22,7 @@ import qualified Control.Monad.State.Strict as SState import qualified Control.Monad.Writer.Lazy as LWriter import qualified Control.Monad.Writer.Strict as SWriter import Data.Typeable +import Prelude () import Prelude.Compat import Servant.API diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index e7a53c3c..7d0c4341 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -11,6 +11,7 @@ module Servant.Server.Internal.RoutingApplication where import Control.Monad.Trans.Except (ExceptT, runExceptT) import Network.Wai (Application, Request, Response, ResponseReceived) +import Prelude () import Prelude.Compat import Servant.Server.Internal.ServantErr diff --git a/servant/src/Servant/API/Alternative.hs b/servant/src/Servant/API/Alternative.hs index 144f8b48..a7651d3c 100644 --- a/servant/src/Servant/API/Alternative.hs +++ b/servant/src/Servant/API/Alternative.hs @@ -10,7 +10,8 @@ module Servant.API.Alternative ((:<|>)(..)) where import Data.Typeable (Typeable) -import Prelude.Compat (Monoid(..), Traversable, Foldable) +import Prelude () +import Prelude.Compat -- | Union of two APIs, first takes precedence in case of overlap. -- diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index 1e0febdb..6ca29330 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -73,7 +73,7 @@ module Servant.API.ContentTypes ) where import Control.Arrow (left) -import Control.Monad.Compat hiding (mapM) +import Control.Monad.Compat import Data.Aeson (FromJSON(..), ToJSON(..), encode) import Data.Aeson.Parser (value) import Data.Aeson.Types (parseEither) @@ -96,7 +96,8 @@ import GHC.Generics (Generic) import qualified Network.HTTP.Media as M import Network.URI (escapeURIString, isUnreserved, unEscapeString) -import Prelude.Compat ((<*), (*>)) +import Prelude () +import Prelude.Compat -- * Provided content types data JSON deriving Typeable diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index 09d567a7..cde14938 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -39,6 +39,7 @@ import GHC.TypeLits (KnownSymbol, symbolVal) import qualified Network.HTTP.Types.Header as HTTP import Servant.API.Header (Header (..)) +import Prelude () import Prelude.Compat -- | Response Header objects. You should never need to construct one directly. From 7484780013cc1c57eb899f641392ff65dc51a96d Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Thu, 3 Mar 2016 12:45:08 +0300 Subject: [PATCH 092/180] import only (<>) from Data.Monoid --- servant/src/Servant/Utils/Links.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 86085fa6..1ada7c93 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -101,14 +101,16 @@ module Servant.Utils.Links ( , Or ) where -import Data.List -import Data.Proxy ( Proxy(..) ) -import qualified Data.Text as Text import qualified Data.ByteString.Char8 as BSC -import Data.Monoid.Compat ( Monoid(..), (<>) ) -import Network.URI ( URI(..), escapeURIString, isUnreserved ) -import GHC.TypeLits ( KnownSymbol, symbolVal ) -import GHC.Exts(Constraint) +import Data.List +import Data.Monoid.Compat ( (<>) ) +import Data.Proxy ( Proxy(..) ) +import qualified Data.Text as Text +import GHC.Exts (Constraint) +import GHC.TypeLits ( KnownSymbol, symbolVal ) +import Network.URI ( URI(..), escapeURIString, isUnreserved ) +import Prelude () +import Prelude.Compat import Web.HttpApiData import Servant.API.Capture ( Capture ) From 54273878b959a07f42f49b75b1d9c0ce3e37fbd4 Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Sat, 12 Mar 2016 12:21:41 +0300 Subject: [PATCH 093/180] little improvements --- servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index 22d69263..91d01727 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -7,6 +7,7 @@ module Servant.API.Internal.Test.ComprehensiveAPI where import Data.Proxy + import Servant.API type GET = Get '[JSON] () From 460a0c90b49294386b9b7ea6e7c80bff6b78e3de Mon Sep 17 00:00:00 2001 From: Denis Redozubov Date: Sat, 12 Mar 2016 12:45:04 +0300 Subject: [PATCH 094/180] more purging --- servant-js/servant-js.cabal | 2 ++ servant-js/test/Servant/JSSpec.hs | 11 +++++------ servant/src/Servant/Utils/Links.hs | 1 - 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index 792fda22..adbed88d 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -42,6 +42,7 @@ library Servant.JS.JQuery Servant.JS.Vanilla build-depends: base >= 4.5 && <5 + , base-compat >= 0.9 , charset >= 0.3 , lens >= 4 , servant-foreign == 0.5.* @@ -83,6 +84,7 @@ test-suite spec Servant.JSSpec Servant.JSSpec.CustomHeaders build-depends: base + , base-compat , hspec >= 2.1.8 , hspec-expectations , language-ecmascript >= 0.16 diff --git a/servant-js/test/Servant/JSSpec.hs b/servant-js/test/Servant/JSSpec.hs index 371d39db..ee3ff0a2 100644 --- a/servant-js/test/Servant/JSSpec.hs +++ b/servant-js/test/Servant/JSSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} @@ -7,18 +6,18 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module Servant.JSSpec where import Data.Either (isRight) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid ((<>),mconcat) -#else -import Data.Monoid ((<>)) -#endif +import Data.Monoid () +import Data.Monoid.Compat ((<>)) import Data.Proxy import Data.Text (Text) import qualified Data.Text as T import Language.ECMAScript3.Parser (program, parse) +import Prelude () +import Prelude.Compat import Test.Hspec hiding (shouldContain, shouldNotContain) import Servant.API.Internal.Test.ComprehensiveAPI diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 1ada7c93..2fb7d0a5 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} From 5188e842a9288ac3986b30b93cb1a5d58cb2933d Mon Sep 17 00:00:00 2001 From: Steve Purcell Date: Mon, 14 Mar 2016 10:21:36 +1300 Subject: [PATCH 095/180] [servant-foreign] Parameterise type classes with a foreign representation type We allow a user-specified type to represent the foreign type of haskell types encountered in the API. This lets users map Integer, Date etc. to representations other than Text, and have those representations available in the returned list of Req. For example, we might want to map a type which has an instance of Generic to both a foreign type name and a class declaration for that foreign type such that it can encode/decode itself to JSON. The previous limitation to a single Text output prevented this case. --- servant-foreign/servant-foreign.cabal | 1 - servant-foreign/src/Servant/Foreign.hs | 3 - .../src/Servant/Foreign/Internal.hs | 236 +++++++++--------- servant-foreign/test/Servant/ForeignSpec.hs | 33 ++- servant-js/src/Servant/JS.hs | 10 +- servant-js/src/Servant/JS/Internal.hs | 6 +- servant-js/test/Servant/JSSpec.hs | 4 +- .../test/Servant/JSSpec/CustomHeaders.hs | 31 +-- 8 files changed, 155 insertions(+), 169 deletions(-) diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index b1404444..9a101256 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -65,7 +65,6 @@ test-suite spec build-depends: base , hspec >= 2.1.8 , servant-foreign - , text >= 1.2 && < 1.3 default-language: Haskell2010 default-extensions: ConstraintKinds , DataKinds diff --git a/servant-foreign/src/Servant/Foreign.hs b/servant-foreign/src/Servant/Foreign.hs index 5df4a6c0..e2d212b6 100644 --- a/servant-foreign/src/Servant/Foreign.hs +++ b/servant-foreign/src/Servant/Foreign.hs @@ -10,7 +10,6 @@ module Servant.Foreign , Url(..) -- aliases , Path - , ForeignType(..) , Arg(..) , FunctionName(..) , PathSegment(..) @@ -31,7 +30,6 @@ module Servant.Foreign , headerArg -- prisms , _PathSegment - , _ForeignType , _HeaderArg , _ReplaceHeaderArg , _Static @@ -42,7 +40,6 @@ module Servant.Foreign -- rest of it , HasForeign(..) , HasForeignType(..) - , HasNoForeignType , GenerateList(..) , NoTypes , captureArg diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index f4095add..72f24116 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -27,15 +27,6 @@ newtype FunctionName = FunctionName { unFunctionName :: [Text] } makePrisms ''FunctionName -newtype ForeignType f = ForeignType { unForeignType :: f } - -deriving instance Show f => Show (ForeignType f) -deriving instance Eq f => Eq (ForeignType f) -deriving instance IsString f => IsString (ForeignType f) -deriving instance Monoid f => Monoid (ForeignType f) - -makePrisms ''ForeignType - newtype PathSegment = PathSegment { unPathSegment :: Text } deriving (Show, Eq, IsString, Monoid) @@ -43,7 +34,7 @@ makePrisms ''PathSegment data Arg f = Arg { _argName :: PathSegment - , _argType :: ForeignType f } + , _argType :: f } deriving instance Eq f => Eq (Arg f) deriving instance Show f => Show (Arg f) @@ -130,8 +121,8 @@ data Req f = Req { _reqUrl :: Url f , _reqMethod :: HTTP.Method , _reqHeaders :: [HeaderArg f] - , _reqBody :: Maybe (ForeignType f) - , _reqReturnType :: ForeignType f + , _reqBody :: Maybe f + , _reqReturnType :: Maybe f , _reqFuncName :: FunctionName } @@ -140,8 +131,8 @@ deriving instance Show f => Show (Req f) makeLenses ''Req -defReq :: Req Text -defReq = Req defUrl "GET" [] Nothing (ForeignType "") (FunctionName []) +defReq :: Req ftype +defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) -- | To be used exclusively as a "negative" return type/constraint -- by @'Elem`@ type family. @@ -154,158 +145,158 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where -- | 'HasForeignType' maps Haskell types with types in the target -- language of your backend. For example, let's say you're --- implementing a backend to some language __X__: +-- implementing a backend to some language __X__, and you want +-- a Text representation of each input/output type mentioned in the API: -- -- > -- First you need to create a dummy type to parametrize your -- > -- instances. -- > data LangX -- > -- > -- Otherwise you define instances for the types you need --- > instance HasForeignType LangX Int where --- > typeFor _ _ = "intX" +-- > instance HasForeignType LangX Text Int where +-- > typeFor _ _ _ = "intX" -- > -- > -- Or for example in case of lists --- > instance HasForeignType LangX a => HasForeignType LangX [a] where --- > typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a) +-- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where +-- > typeFor lang type _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a) -- -- Finally to generate list of information about all the endpoints for -- an API you create a function of a form: -- --- > getEndpoints :: (HasForeign LangX api, GenerateList (Foreign api)) --- > => Proxy api -> [Req] --- > getEndpoints api = listFromAPI (Proxy :: Proxy LangX) api +-- > getEndpoints :: (HasForeign LangX Text api, GenerateList Text (Foreign Text api)) +-- > => Proxy api -> [Req Text] +-- > getEndpoints api = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy Text) api -- -- > -- If language __X__ is dynamically typed then you can use --- > -- a predefined NoTypes parameter --- > getEndpoints :: (HasForeign NoTypes api, GenerateList (Foreign api)) --- > => Proxy api -> [Req] --- > getEndpoints api = listFromAPI (Proxy :: Proxy NoTypes) api +-- > -- a predefined NoTypes parameter with the () output type: +-- +-- > getEndpoints :: (HasForeign NoTypes () api, GenerateList Text (Foreign () api)) +-- > => Proxy api -> [Req ()] +-- > getEndpoints api = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) api -- > -- -class HasForeignType lang a where - typeFor :: Proxy lang -> Proxy a -> ForeignType Text +class HasForeignType lang ftype a where + typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype data NoTypes -instance HasForeignType NoTypes ftype where - typeFor _ _ = ForeignType empty +instance HasForeignType NoTypes () ftype where + typeFor _ _ _ = () -type HasNoForeignType = HasForeignType NoTypes +class HasForeign lang ftype (layout :: *) where + type Foreign ftype layout :: * + foreignFor :: Proxy lang -> Proxy ftype -> Proxy layout -> Req ftype -> Foreign ftype layout -class HasForeign lang (layout :: *) where - type Foreign layout :: * - foreignFor :: Proxy lang -> Proxy layout -> Req Text -> Foreign layout +instance (HasForeign lang ftype a, HasForeign lang ftype b) + => HasForeign lang ftype (a :<|> b) where + type Foreign ftype (a :<|> b) = Foreign ftype a :<|> Foreign ftype b -instance (HasForeign lang a, HasForeign lang b) - => HasForeign lang (a :<|> b) where - type Foreign (a :<|> b) = Foreign a :<|> Foreign b + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy a) req + :<|> foreignFor lang ftype (Proxy :: Proxy b) req - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy a) req - :<|> foreignFor lang (Proxy :: Proxy b) req +instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype sublayout) + => HasForeign lang ftype (Capture sym t :> sublayout) where + type Foreign ftype (Capture sym a :> sublayout) = Foreign ftype sublayout -instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout) - => HasForeign lang (Capture sym ftype :> sublayout) where - type Foreign (Capture sym a :> sublayout) = Foreign sublayout - - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ + foreignFor lang Proxy Proxy req = + foreignFor lang Proxy (Proxy :: Proxy sublayout) $ req & reqUrl . path <>~ [Segment (Cap arg)] & reqFuncName . _FunctionName %~ (++ ["by", str]) where str = pack . symbolVal $ (Proxy :: Proxy sym) - ftype = typeFor lang (Proxy :: Proxy ftype) + ftype = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy t) arg = Arg { _argName = PathSegment str , _argType = ftype } -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 Text +instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method) + => HasForeign lang ftype (Verb method status list a) where + type Foreign ftype (Verb method status list a) = Req ftype - foreignFor lang Proxy req = + foreignFor lang Proxy Proxy req = req & reqFuncName . _FunctionName %~ (methodLC :) & reqMethod .~ method - & reqReturnType .~ retType + & reqReturnType .~ Just retType where - retType = typeFor lang (Proxy :: Proxy a) + retType = typeFor lang (Proxy :: Proxy ftype) (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 - type Foreign (Header sym a :> sublayout) = Foreign sublayout +instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout) + => HasForeign lang ftype (Header sym a :> sublayout) where + type Foreign ftype (Header sym a :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang subP $ req & reqHeaders <>~ [HeaderArg arg] + foreignFor lang Proxy Proxy req = + foreignFor lang Proxy subP $ req & reqHeaders <>~ [HeaderArg arg] where hname = pack . symbolVal $ (Proxy :: Proxy sym) arg = Arg { _argName = PathSegment hname - , _argType = typeFor lang (Proxy :: Proxy a) } + , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) } subP = Proxy :: Proxy sublayout -instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) - => HasForeign lang (QueryParam sym a :> sublayout) where - type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout +instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout) + => HasForeign lang ftype (QueryParam sym a :> sublayout) where + type Foreign ftype (QueryParam sym a :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ + foreignFor lang Proxy Proxy req = + foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy sublayout) $ req & reqUrl.queryStr <>~ [QueryArg arg Normal] where str = pack . symbolVal $ (Proxy :: Proxy sym) arg = Arg { _argName = PathSegment str - , _argType = typeFor lang (Proxy :: Proxy a) } + , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) } instance - (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout) - => HasForeign lang (QueryParams sym a :> sublayout) where - type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ + (KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype sublayout) + => HasForeign lang ftype (QueryParams sym a :> sublayout) where + type Foreign ftype (QueryParams sym a :> sublayout) = Foreign ftype sublayout + foreignFor lang Proxy Proxy req = + foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy sublayout) $ req & reqUrl.queryStr <>~ [QueryArg arg List] where str = pack . symbolVal $ (Proxy :: Proxy sym) arg = Arg { _argName = PathSegment str - , _argType = typeFor lang (Proxy :: Proxy [a]) } + , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [a]) } instance - (KnownSymbol sym, HasForeignType lang Bool, HasForeign lang sublayout) - => HasForeign lang (QueryFlag sym :> sublayout) where - type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout + (KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype sublayout) + => HasForeign lang ftype (QueryFlag sym :> sublayout) where + type Foreign ftype (QueryFlag sym :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy sublayout) $ req & reqUrl.queryStr <>~ [QueryArg arg Flag] where str = pack . symbolVal $ (Proxy :: Proxy sym) arg = Arg { _argName = PathSegment str - , _argType = typeFor lang (Proxy :: Proxy Bool) } + , _argType = typeFor lang ftype (Proxy :: Proxy Bool) } -instance HasForeign lang Raw where - type Foreign Raw = HTTP.Method -> Req Text +instance HasForeign lang ftype Raw where + type Foreign ftype Raw = HTTP.Method -> Req ftype - foreignFor _ Proxy req method = + foreignFor _ Proxy Proxy req method = req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :) & reqMethod .~ method -instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout) - => HasForeign lang (ReqBody list a :> sublayout) where - type Foreign (ReqBody list a :> sublayout) = Foreign sublayout +instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype sublayout) + => HasForeign lang ftype (ReqBody list a :> sublayout) where + type Foreign ftype (ReqBody list a :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqBody .~ (Just $ typeFor lang (Proxy :: Proxy a)) + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy sublayout) $ + req & reqBody .~ (Just $ typeFor lang ftype (Proxy :: Proxy a)) -instance (KnownSymbol path, HasForeign lang sublayout) - => HasForeign lang (path :> sublayout) where - type Foreign (path :> sublayout) = Foreign sublayout +instance (KnownSymbol path, HasForeign lang ftype sublayout) + => HasForeign lang ftype (path :> sublayout) where + type Foreign ftype (path :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy sublayout) $ req & reqUrl . path <>~ [Segment (Static (PathSegment str))] & reqFuncName . _FunctionName %~ (++ [str]) where @@ -313,58 +304,59 @@ instance (KnownSymbol path, HasForeign lang sublayout) Data.Text.map (\c -> if c == '.' then '_' else c) . pack . symbolVal $ (Proxy :: Proxy path) -instance HasForeign lang sublayout - => HasForeign lang (RemoteHost :> sublayout) where - type Foreign (RemoteHost :> sublayout) = Foreign sublayout +instance HasForeign lang ftype sublayout + => HasForeign lang ftype (RemoteHost :> sublayout) where + type Foreign ftype (RemoteHost :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) req + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy sublayout) req -instance HasForeign lang sublayout - => HasForeign lang (IsSecure :> sublayout) where - type Foreign (IsSecure :> sublayout) = Foreign sublayout +instance HasForeign lang ftype sublayout + => HasForeign lang ftype (IsSecure :> sublayout) where + type Foreign ftype (IsSecure :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) req + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy sublayout) req -instance HasForeign lang sublayout => HasForeign lang (Vault :> sublayout) where - type Foreign (Vault :> sublayout) = Foreign sublayout +instance HasForeign lang ftype sublayout => HasForeign lang ftype (Vault :> sublayout) where + type Foreign ftype (Vault :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) req + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy sublayout) req -instance HasForeign lang sublayout => - HasForeign lang (WithNamedContext name context sublayout) where +instance HasForeign lang ftype sublayout => + HasForeign lang ftype (WithNamedContext name context sublayout) where - type Foreign (WithNamedContext name context sublayout) = Foreign sublayout + type Foreign ftype (WithNamedContext name context sublayout) = Foreign ftype sublayout - foreignFor lang Proxy = foreignFor lang (Proxy :: Proxy sublayout) + foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy sublayout) -instance HasForeign lang sublayout - => HasForeign lang (HttpVersion :> sublayout) where - type Foreign (HttpVersion :> sublayout) = Foreign sublayout +instance HasForeign lang ftype sublayout + => HasForeign lang ftype (HttpVersion :> sublayout) where + type Foreign ftype (HttpVersion :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) req + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy sublayout) req -- | Utility class used by 'listFromAPI' which computes -- the data needed to generate a function for each endpoint -- and hands it all back in a list. -class GenerateList reqs where - generateList :: reqs -> [Req Text] +class GenerateList ftype reqs where + generateList :: reqs -> [Req ftype] -instance GenerateList (Req Text) where +instance GenerateList ftype (Req ftype) where generateList r = [r] -instance (GenerateList start, GenerateList rest) - => GenerateList (start :<|> rest) where +instance (GenerateList ftype start, GenerateList ftype rest) + => GenerateList ftype (start :<|> rest) where generateList (start :<|> rest) = (generateList start) ++ (generateList rest) -- | Generate the necessary data for codegen as a list, each 'Req' -- describing one endpoint from your API type. listFromAPI - :: (HasForeign lang api, GenerateList (Foreign api)) + :: (HasForeign lang ftype api, GenerateList ftype (Foreign ftype api)) => Proxy lang + -> Proxy ftype -> Proxy api - -> [Req Text] -listFromAPI lang p = generateList (foreignFor lang p defReq) + -> [Req ftype] +listFromAPI lang ftype p = generateList (foreignFor lang ftype p defReq) diff --git a/servant-foreign/test/Servant/ForeignSpec.hs b/servant-foreign/test/Servant/ForeignSpec.hs index 5c0c348b..0a762e1c 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -6,7 +6,6 @@ module Servant.ForeignSpec where import Data.Monoid ((<>)) import Data.Proxy import Servant.Foreign -import Data.Text (Text(..)) import Test.Hspec @@ -27,20 +26,20 @@ camelCaseSpec = describe "camelCase" $ do data LangX -instance HasForeignType LangX () where - typeFor _ _ = ForeignType "voidX" +instance HasForeignType LangX String () where + typeFor _ _ _ = "voidX" -instance HasForeignType LangX Int where - typeFor _ _ = "intX" +instance HasForeignType LangX String Int where + typeFor _ _ _ = "intX" -instance HasForeignType LangX Bool where - typeFor _ _ = "boolX" +instance HasForeignType LangX String Bool where + typeFor _ _ _ = "boolX" -instance OVERLAPPING_ HasForeignType LangX String where - typeFor _ _ = "stringX" +instance OVERLAPPING_ HasForeignType LangX String String where + typeFor _ _ _ = "stringX" -instance OVERLAPPABLE_ HasForeignType LangX a => HasForeignType LangX [a] where - typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a) +instance OVERLAPPABLE_ HasForeignType LangX String a => HasForeignType LangX String [a] where + typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a) type TestApi = "test" :> Header "header" [String] :> QueryFlag "flag" :> Get '[JSON] Int @@ -48,8 +47,8 @@ type TestApi :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] () :<|> "test" :> Capture "id" Int :> Delete '[JSON] () -testApi :: [Req Text] -testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy TestApi) +testApi :: [Req String] +testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: Proxy TestApi) listFromAPISpec :: Spec listFromAPISpec = describe "listFromAPI" $ do @@ -66,7 +65,7 @@ listFromAPISpec = describe "listFromAPI" $ do , _reqMethod = "GET" , _reqHeaders = [HeaderArg $ Arg "header" "listX of stringX"] , _reqBody = Nothing - , _reqReturnType = "intX" + , _reqReturnType = Just "intX" , _reqFuncName = FunctionName ["get", "test"] } @@ -78,7 +77,7 @@ listFromAPISpec = describe "listFromAPI" $ do , _reqMethod = "POST" , _reqHeaders = [] , _reqBody = Just "listX of stringX" - , _reqReturnType = "voidX" + , _reqReturnType = Just "voidX" , _reqFuncName = FunctionName ["post", "test"] } @@ -91,7 +90,7 @@ listFromAPISpec = describe "listFromAPI" $ do , _reqMethod = "PUT" , _reqHeaders = [] , _reqBody = Just "stringX" - , _reqReturnType = "voidX" + , _reqReturnType = Just "voidX" , _reqFuncName = FunctionName ["put", "test"] } @@ -104,6 +103,6 @@ listFromAPISpec = describe "listFromAPI" $ do , _reqMethod = "DELETE" , _reqHeaders = [] , _reqBody = Nothing - , _reqReturnType = "voidX" + , _reqReturnType = Just "voidX" , _reqFuncName = FunctionName ["delete", "test", "by", "id"] } diff --git a/servant-js/src/Servant/JS.hs b/servant-js/src/Servant/JS.hs index 443b758b..4afb38db 100644 --- a/servant-js/src/Servant/JS.hs +++ b/servant-js/src/Servant/JS.hs @@ -128,22 +128,22 @@ import Servant.Foreign (GenerateList(..), listFromAPI, NoTypes) -- | Generate the data necessary to generate javascript code -- for all the endpoints of an API, as ':<|>'-separated values -- of type 'AjaxReq'. -javascript :: HasForeign NoTypes layout => Proxy layout -> Foreign layout -javascript p = foreignFor (Proxy :: Proxy NoTypes) p defReq +javascript :: HasForeign NoTypes () layout => Proxy layout -> Foreign () layout +javascript p = foreignFor (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) 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 :: (HasForeign NoTypes api, GenerateList (Foreign api)) +jsForAPI :: (HasForeign NoTypes () api, GenerateList () (Foreign () api)) => Proxy api -- ^ proxy for your API type -> JavaScriptGenerator -- ^ js code generator to use (angular, vanilla js, jquery, others) -> Text -- ^ a text that you can embed in your pages or write to a file -jsForAPI p gen = gen (listFromAPI (Proxy :: Proxy NoTypes) p) +jsForAPI p gen = gen (listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) 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 :: (HasForeign NoTypes api, GenerateList (Foreign api)) +writeJSForAPI :: (HasForeign NoTypes () 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 diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs index 360b8d13..3c817e1e 100644 --- a/servant-js/src/Servant/JS/Internal.hs +++ b/servant-js/src/Servant/JS/Internal.hs @@ -21,7 +21,6 @@ module Servant.JS.Internal , reqHeaders , HasForeign(..) , HasForeignType(..) - , HasNoForeignType , GenerateList(..) , NoTypes , HeaderArg @@ -33,7 +32,6 @@ module Servant.JS.Internal , SegmentType(..) , Url(..) , Path - , ForeignType(..) , Arg(..) , FunctionName(..) , PathSegment(..) @@ -57,12 +55,12 @@ import qualified Data.Text as T import Data.Text (Text) import Servant.Foreign -type AjaxReq = Req Text +type AjaxReq = Req () -- A 'JavascriptGenerator' just takes the data found in the API type -- for each endpoint and generates Javascript code in a Text. Several -- generators are available in this package. -type JavaScriptGenerator = [Req Text] -> Text +type JavaScriptGenerator = [Req ()] -> Text -- | This structure is used by specific implementations to let you -- customize the output diff --git a/servant-js/test/Servant/JSSpec.hs b/servant-js/test/Servant/JSSpec.hs index 371d39db..3eeaf2a9 100644 --- a/servant-js/test/Servant/JSSpec.hs +++ b/servant-js/test/Servant/JSSpec.hs @@ -106,7 +106,7 @@ a `shouldNotContain` b = shouldNotSatisfy a (T.isInfixOf b) axiosSpec :: Spec axiosSpec = describe specLabel $ do - let reqList = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy TestAPI) + let reqList = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) (Proxy :: Proxy TestAPI) it "should add withCredentials when needed" $ do let jsText = genJS withCredOpts $ reqList output jsText @@ -130,7 +130,7 @@ axiosSpec = describe specLabel $ do angularSpec :: TestNames -> Spec angularSpec test = describe specLabel $ do - let reqList = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy TestAPI) + let reqList = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) (Proxy :: Proxy TestAPI) it "should implement a service globally" $ do let jsText = genJS reqList output jsText diff --git a/servant-js/test/Servant/JSSpec/CustomHeaders.hs b/servant-js/test/Servant/JSSpec/CustomHeaders.hs index 4e4e3311..6d881aa4 100644 --- a/servant-js/test/Servant/JSSpec/CustomHeaders.hs +++ b/servant-js/test/Servant/JSSpec/CustomHeaders.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} @@ -22,13 +23,13 @@ import Servant.JS.Internal -- using -- Basic, Digest, whatever. data Authorization (sym :: Symbol) a -instance (KnownSymbol sym, HasForeign lang sublayout) - => HasForeign lang (Authorization sym a :> sublayout) where - type Foreign (Authorization sym a :> sublayout) = Foreign sublayout +instance (KnownSymbol sym, HasForeign lang () sublayout) + => HasForeign lang () (Authorization sym a :> sublayout) where + type Foreign () (Authorization sym a :> sublayout) = Foreign () sublayout - foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $ req & reqHeaders <>~ - [ ReplaceHeaderArg (Arg "Authorization" "") + [ ReplaceHeaderArg (Arg "Authorization" ()) $ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ] where tokenType t = t <> " {Authorization}" @@ -36,23 +37,23 @@ instance (KnownSymbol sym, HasForeign lang sublayout) -- | This is a combinator that fetches an X-MyLovelyHorse header. data MyLovelyHorse a -instance (HasForeign lang sublayout) - => HasForeign lang (MyLovelyHorse a :> sublayout) where - type Foreign (MyLovelyHorse a :> sublayout) = Foreign sublayout +instance (HasForeign lang () sublayout) + => HasForeign lang () (MyLovelyHorse a :> sublayout) where + type Foreign () (MyLovelyHorse a :> sublayout) = Foreign () sublayout - foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" "") tpl ] + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $ + req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" ()) tpl ] where tpl = "I am good friends with {X-MyLovelyHorse}" -- | This is a combinator that fetches an X-WhatsForDinner header. data WhatsForDinner a -instance (HasForeign lang sublayout) - => HasForeign lang (WhatsForDinner a :> sublayout) where - type Foreign (WhatsForDinner a :> sublayout) = Foreign sublayout +instance (HasForeign lang () sublayout) + => HasForeign lang () (WhatsForDinner a :> sublayout) where + type Foreign () (WhatsForDinner a :> sublayout) = Foreign () sublayout - foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" "") tpl ] + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $ + req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" ()) tpl ] where tpl = "I would like {X-WhatsForDinner} with a cherry on top." From d96a8a0f3adea51e4dbba1806e96c78ca6d7798b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 18 Mar 2016 09:35:48 +0800 Subject: [PATCH 096/180] add README for release process --- scripts/README.md | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 scripts/README.md diff --git a/scripts/README.md b/scripts/README.md new file mode 100644 index 00000000..fe006cd0 --- /dev/null +++ b/scripts/README.md @@ -0,0 +1,8 @@ +The release process works roughly like this: + +``` bash +./scripts/bump-versions.sh +git commit +./scripts/upload.sh +git tag && git push --tags +``` From 94e07f951916f28256ab64f05b75c2f12e53dabc Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Mon, 18 Jan 2016 14:45:25 +0300 Subject: [PATCH 097/180] Add basic configuration for Read The Docs (based on Stack's) --- doc/CONTRIBUTING.md | 1 + doc/README.md | 1 + doc/conf.py | 288 ++++++++++++++++++++++++++++++++++++++++++++ doc/index.rst | 11 ++ 4 files changed, 301 insertions(+) create mode 120000 doc/CONTRIBUTING.md create mode 120000 doc/README.md create mode 100644 doc/conf.py create mode 100644 doc/index.rst diff --git a/doc/CONTRIBUTING.md b/doc/CONTRIBUTING.md new file mode 120000 index 00000000..44fcc634 --- /dev/null +++ b/doc/CONTRIBUTING.md @@ -0,0 +1 @@ +../CONTRIBUTING.md \ No newline at end of file diff --git a/doc/README.md b/doc/README.md new file mode 120000 index 00000000..32d46ee8 --- /dev/null +++ b/doc/README.md @@ -0,0 +1 @@ +../README.md \ No newline at end of file diff --git a/doc/conf.py b/doc/conf.py new file mode 100644 index 00000000..c2761418 --- /dev/null +++ b/doc/conf.py @@ -0,0 +1,288 @@ +# -*- coding: utf-8 -*- +# +# servant documentation build configuration file, created by +# sphinx-quickstart on Mon Nov 23 13:24:36 2015. +# +# This file is execfile()d with the current directory set to its +# containing dir. +# +# Note that not all possible configuration values are present in this +# autogenerated file. +# +# All configuration values have a default; values that are commented out +# serve to show the default. + +import sys +import os +import shlex +from recommonmark.parser import CommonMarkParser + +# If extensions (or modules to document with autodoc) are in another directory, +# add these directories to sys.path here. If the directory is relative to the +# documentation root, use os.path.abspath to make it absolute, like shown here. +#sys.path.insert(0, os.path.abspath('.')) + +# -- General configuration ------------------------------------------------ + +# If your documentation needs a minimal Sphinx version, state it here. +#needs_sphinx = '1.0' + +# Add any Sphinx extension module names here, as strings. They can be +# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom +# ones. +extensions = [] + +# Add any paths that contain templates here, relative to this directory. +templates_path = ['_templates'] + +# The suffix(es) of source filenames. +# You can specify multiple suffix as a list of string: +source_suffix = ['.md', '.rst'] + +# The encoding of source files. +#source_encoding = 'utf-8-sig' + +# The master toctree document. +master_doc = 'index' + +# General information about the project. +project = u'servant' +copyright = u'2015-2016, Servant contributors' +author = u'Servant contributors' + +# The version info for the project you're documenting, acts as replacement for +# |version| and |release|, also used in various other places throughout the +# built documents. +# +# The short X.Y version. +# version = 'latest' +# The full version, including alpha/beta/rc tags. +# release = 'latest' + +# The language for content autogenerated by Sphinx. Refer to documentation +# for a list of supported languages. +# +# This is also used if you do content translation via gettext catalogs. +# Usually you set "language" from the command line for these cases. +language = None + +# There are two options for replacing |today|: either, you set today to some +# non-false value, then it is used: +#today = '' +# Else, today_fmt is used as the format for a strftime call. +#today_fmt = '%B %d, %Y' + +# List of patterns, relative to source directory, that match files and +# directories to ignore when looking for source files. +exclude_patterns = ['_build'] + +# The reST default role (used for this markup: `text`) to use for all +# documents. +#default_role = None + +# If true, '()' will be appended to :func: etc. cross-reference text. +#add_function_parentheses = True + +# If true, the current module name will be prepended to all description +# unit titles (such as .. function::). +#add_module_names = True + +# If true, sectionauthor and moduleauthor directives will be shown in the +# output. They are ignored by default. +#show_authors = False + +# The name of the Pygments (syntax highlighting) style to use. +pygments_style = 'sphinx' + +# A list of ignored prefixes for module index sorting. +#modindex_common_prefix = [] + +# If true, keep warnings as "system message" paragraphs in the built documents. +#keep_warnings = False + +# If true, `todo` and `todoList` produce output, else they produce nothing. +todo_include_todos = False + + +# -- Options for HTML output ---------------------------------------------- + +# The theme to use for HTML and HTML Help pages. See the documentation for +# a list of builtin themes. +# html_theme = 'alabaster' + +# Theme options are theme-specific and customize the look and feel of a theme +# further. For a list of options available for each theme, see the +# documentation. +#html_theme_options = {} + +# Add any paths that contain custom themes here, relative to this directory. +#html_theme_path = [] + +# The name for this set of Sphinx documents. If None, it defaults to +# " v documentation". +#html_title = None + +# A shorter title for the navigation bar. Default is the same as html_title. +#html_short_title = None + +# The name of an image file (relative to this directory) to place at the top +# of the sidebar. +#html_logo = None + +# The name of an image file (within the static path) to use as favicon of the +# docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32 +# pixels large. +#html_favicon = None + +# Add any paths that contain custom static files (such as style sheets) here, +# relative to this directory. They are copied after the builtin static files, +# so a file named "default.css" will overwrite the builtin "default.css". +html_static_path = ['_static'] + +# Add any extra paths that contain custom files (such as robots.txt or +# .htaccess) here, relative to this directory. These files are copied +# directly to the root of the documentation. +#html_extra_path = [] + +# If not '', a 'Last updated on:' timestamp is inserted at every page bottom, +# using the given strftime format. +#html_last_updated_fmt = '%b %d, %Y' + +# If true, SmartyPants will be used to convert quotes and dashes to +# typographically correct entities. +#html_use_smartypants = True + +# Custom sidebar templates, maps document names to template names. +#html_sidebars = {} + +# Additional templates that should be rendered to pages, maps page names to +# template names. +#html_additional_pages = {} + +# If false, no module index is generated. +#html_domain_indices = True + +# If false, no index is generated. +#html_use_index = True + +# If true, the index is split into individual pages for each letter. +#html_split_index = False + +# If true, links to the reST sources are added to the pages. +#html_show_sourcelink = True + +# If true, "Created using Sphinx" is shown in the HTML footer. Default is True. +#html_show_sphinx = True + +# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True. +#html_show_copyright = True + +# If true, an OpenSearch description file will be output, and all pages will +# contain a tag referring to it. The value of this option must be the +# base URL from which the finished HTML is served. +#html_use_opensearch = '' + +# This is the file name suffix for HTML files (e.g. ".xhtml"). +#html_file_suffix = None + +# Language to be used for generating the HTML full-text search index. +# Sphinx supports the following languages: +# 'da', 'de', 'en', 'es', 'fi', 'fr', 'hu', 'it', 'ja' +# 'nl', 'no', 'pt', 'ro', 'ru', 'sv', 'tr' +#html_search_language = 'en' + +# A dictionary with options for the search language support, empty by default. +# Now only 'ja' uses this config value +#html_search_options = {'type': 'default'} + +# The name of a javascript file (relative to the configuration directory) that +# implements a search results scorer. If empty, the default will be used. +#html_search_scorer = 'scorer.js' + +# Output file base name for HTML help builder. +htmlhelp_basename = 'servantdoc' + +# -- Options for LaTeX output --------------------------------------------- + +latex_elements = { +# The paper size ('letterpaper' or 'a4paper'). +#'papersize': 'letterpaper', + +# The font size ('10pt', '11pt' or '12pt'). +#'pointsize': '10pt', + +# Additional stuff for the LaTeX preamble. +#'preamble': '', + +# Latex figure (float) alignment +#'figure_align': 'htbp', +} + +# Grouping the document tree into LaTeX files. List of tuples +# (source start file, target name, title, +# author, documentclass [howto, manual, or own class]). +latex_documents = [ + (master_doc, 'servant.tex', u'servant Documentation', + u'Servant contributors', 'manual'), +] + +# The name of an image file (relative to this directory) to place at the top of +# the title page. +#latex_logo = None + +# For "manual" documents, if this is true, then toplevel headings are parts, +# not chapters. +#latex_use_parts = False + +# If true, show page references after internal links. +#latex_show_pagerefs = False + +# If true, show URL addresses after external links. +#latex_show_urls = False + +# Documents to append as an appendix to all manuals. +#latex_appendices = [] + +# If false, no module index is generated. +#latex_domain_indices = True + + +# -- Options for manual page output --------------------------------------- + +# One entry per manual page. List of tuples +# (source start file, name, description, authors, manual section). +man_pages = [ + (master_doc, 'servant', u'servant Documentation', + [author], 1) +] + +# If true, show URL addresses after external links. +#man_show_urls = False + + +# -- Options for Texinfo output ------------------------------------------- + +# Grouping the document tree into Texinfo files. List of tuples +# (source start file, target name, title, author, +# dir menu entry, description, category) +texinfo_documents = [ + (master_doc, 'servant', u'servant Documentation', + author, 'servant', 'One line description of project.', + 'Miscellaneous'), +] + +# Documents to append as an appendix to all manuals. +#texinfo_appendices = [] + +# If false, no module index is generated. +#texinfo_domain_indices = True + +# How to display URL addresses: 'footnote', 'no', or 'inline'. +#texinfo_show_urls = 'footnote' + +# If true, do not generate a @detailmenu in the "Top" node's menu. +#texinfo_no_detailmenu = False + +source_parsers = { + '.md': CommonMarkParser, +} diff --git a/doc/index.rst b/doc/index.rst new file mode 100644 index 00000000..41b48c52 --- /dev/null +++ b/doc/index.rst @@ -0,0 +1,11 @@ +servant – Type-Level Web DSL +============================ + +Documentation table of contents +------------------------------- + +.. toctree:: + + README.md + CONTRIBUTING.md + From 3b3c929b408a56e4cba4ca34d5a2dc9fa1486751 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 25 Jan 2016 14:11:40 +0100 Subject: [PATCH 098/180] Move tutorial files over --- .gitignore | 1 + tutorial/Makefile | 216 +++++++ tutorial/api-type.lhs | 309 ++++++++++ tutorial/client.lhs | 138 +++++ tutorial/conf.py | 287 +++++++++ tutorial/docs.lhs | 227 +++++++ tutorial/index.rst | 68 +++ tutorial/javascript.lhs | 175 ++++++ tutorial/requirements.txt | 25 + tutorial/server.lhs | 1176 +++++++++++++++++++++++++++++++++++++ 10 files changed, 2622 insertions(+) create mode 100644 tutorial/Makefile create mode 100644 tutorial/api-type.lhs create mode 100644 tutorial/client.lhs create mode 100644 tutorial/conf.py create mode 100644 tutorial/docs.lhs create mode 100644 tutorial/index.rst create mode 100644 tutorial/javascript.lhs create mode 100644 tutorial/requirements.txt create mode 100644 tutorial/server.lhs diff --git a/.gitignore b/.gitignore index 2b2f3487..ee3cbf51 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,4 @@ Setup .stack-work shell.nix default.nix +tutorial/_build diff --git a/tutorial/Makefile b/tutorial/Makefile new file mode 100644 index 00000000..95957c1a --- /dev/null +++ b/tutorial/Makefile @@ -0,0 +1,216 @@ +# Makefile for Sphinx documentation +# + +# You can set these variables from the command line. +SPHINXOPTS = +SPHINXBUILD = sphinx-build +PAPER = +BUILDDIR = _build + +# User-friendly check for sphinx-build +ifeq ($(shell which $(SPHINXBUILD) >/dev/null 2>&1; echo $$?), 1) +$(error The '$(SPHINXBUILD)' command was not found. Make sure you have Sphinx installed, then set the SPHINXBUILD environment variable to point to the full path of the '$(SPHINXBUILD)' executable. Alternatively you can add the directory with the executable to your PATH. If you don't have Sphinx installed, grab it from http://sphinx-doc.org/) +endif + +# Internal variables. +PAPEROPT_a4 = -D latex_paper_size=a4 +PAPEROPT_letter = -D latex_paper_size=letter +ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) . +# the i18n builder cannot share the environment and doctrees with the others +I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) . + +.PHONY: help +help: + @echo "Please use \`make ' where is one of" + @echo " html to make standalone HTML files" + @echo " dirhtml to make HTML files named index.html in directories" + @echo " singlehtml to make a single large HTML file" + @echo " pickle to make pickle files" + @echo " json to make JSON files" + @echo " htmlhelp to make HTML files and a HTML help project" + @echo " qthelp to make HTML files and a qthelp project" + @echo " applehelp to make an Apple Help Book" + @echo " devhelp to make HTML files and a Devhelp project" + @echo " epub to make an epub" + @echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter" + @echo " latexpdf to make LaTeX files and run them through pdflatex" + @echo " latexpdfja to make LaTeX files and run them through platex/dvipdfmx" + @echo " text to make text files" + @echo " man to make manual pages" + @echo " texinfo to make Texinfo files" + @echo " info to make Texinfo files and run them through makeinfo" + @echo " gettext to make PO message catalogs" + @echo " changes to make an overview of all changed/added/deprecated items" + @echo " xml to make Docutils-native XML files" + @echo " pseudoxml to make pseudoxml-XML files for display purposes" + @echo " linkcheck to check all external links for integrity" + @echo " doctest to run all doctests embedded in the documentation (if enabled)" + @echo " coverage to run coverage check of the documentation (if enabled)" + +.PHONY: clean +clean: + rm -rf $(BUILDDIR)/* + +.PHONY: html +html: + $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html + @echo + @echo "Build finished. The HTML pages are in $(BUILDDIR)/html." + +.PHONY: dirhtml +dirhtml: + $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml + @echo + @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml." + +.PHONY: singlehtml +singlehtml: + $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml + @echo + @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml." + +.PHONY: pickle +pickle: + $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle + @echo + @echo "Build finished; now you can process the pickle files." + +.PHONY: json +json: + $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json + @echo + @echo "Build finished; now you can process the JSON files." + +.PHONY: htmlhelp +htmlhelp: + $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp + @echo + @echo "Build finished; now you can run HTML Help Workshop with the" \ + ".hhp project file in $(BUILDDIR)/htmlhelp." + +.PHONY: qthelp +qthelp: + $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp + @echo + @echo "Build finished; now you can run "qcollectiongenerator" with the" \ + ".qhcp project file in $(BUILDDIR)/qthelp, like this:" + @echo "# qcollectiongenerator $(BUILDDIR)/qthelp/generics-eot.qhcp" + @echo "To view the help file:" + @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/generics-eot.qhc" + +.PHONY: applehelp +applehelp: + $(SPHINXBUILD) -b applehelp $(ALLSPHINXOPTS) $(BUILDDIR)/applehelp + @echo + @echo "Build finished. The help book is in $(BUILDDIR)/applehelp." + @echo "N.B. You won't be able to view it unless you put it in" \ + "~/Library/Documentation/Help or install it in your application" \ + "bundle." + +.PHONY: devhelp +devhelp: + $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp + @echo + @echo "Build finished." + @echo "To view the help file:" + @echo "# mkdir -p $$HOME/.local/share/devhelp/generics-eot" + @echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/generics-eot" + @echo "# devhelp" + +.PHONY: epub +epub: + $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub + @echo + @echo "Build finished. The epub file is in $(BUILDDIR)/epub." + +.PHONY: latex +latex: + $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex + @echo + @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex." + @echo "Run \`make' in that directory to run these through (pdf)latex" \ + "(use \`make latexpdf' here to do that automatically)." + +.PHONY: latexpdf +latexpdf: + $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex + @echo "Running LaTeX files through pdflatex..." + $(MAKE) -C $(BUILDDIR)/latex all-pdf + @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." + +.PHONY: latexpdfja +latexpdfja: + $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex + @echo "Running LaTeX files through platex and dvipdfmx..." + $(MAKE) -C $(BUILDDIR)/latex all-pdf-ja + @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." + +.PHONY: text +text: + $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text + @echo + @echo "Build finished. The text files are in $(BUILDDIR)/text." + +.PHONY: man +man: + $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man + @echo + @echo "Build finished. The manual pages are in $(BUILDDIR)/man." + +.PHONY: texinfo +texinfo: + $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo + @echo + @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo." + @echo "Run \`make' in that directory to run these through makeinfo" \ + "(use \`make info' here to do that automatically)." + +.PHONY: info +info: + $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo + @echo "Running Texinfo files through makeinfo..." + make -C $(BUILDDIR)/texinfo info + @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo." + +.PHONY: gettext +gettext: + $(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale + @echo + @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale." + +.PHONY: changes +changes: + $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes + @echo + @echo "The overview file is in $(BUILDDIR)/changes." + +.PHONY: linkcheck +linkcheck: + $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck + @echo + @echo "Link check complete; look for any errors in the above output " \ + "or in $(BUILDDIR)/linkcheck/output.txt." + +.PHONY: doctest +doctest: + $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest + @echo "Testing of doctests in the sources finished, look at the " \ + "results in $(BUILDDIR)/doctest/output.txt." + +.PHONY: coverage +coverage: + $(SPHINXBUILD) -b coverage $(ALLSPHINXOPTS) $(BUILDDIR)/coverage + @echo "Testing of coverage in the sources finished, look at the " \ + "results in $(BUILDDIR)/coverage/python.txt." + +.PHONY: xml +xml: + $(SPHINXBUILD) -b xml $(ALLSPHINXOPTS) $(BUILDDIR)/xml + @echo + @echo "Build finished. The XML files are in $(BUILDDIR)/xml." + +.PHONY: pseudoxml +pseudoxml: + $(SPHINXBUILD) -b pseudoxml $(ALLSPHINXOPTS) $(BUILDDIR)/pseudoxml + @echo + @echo "Build finished. The pseudo-XML files are in $(BUILDDIR)/pseudoxml." diff --git a/tutorial/api-type.lhs b/tutorial/api-type.lhs new file mode 100644 index 00000000..71c84631 --- /dev/null +++ b/tutorial/api-type.lhs @@ -0,0 +1,309 @@ +--- +title: A web API as a type +toc: true +--- + +The source for this tutorial section is a literate haskell file, so first we +need to have some language extensions and imports: + +> {-# LANGUAGE DataKinds #-} +> {-# LANGUAGE TypeOperators #-} +> +> module ApiType where +> +> import Data.Text +> import Servant.API + +Consider the following informal specification of an API: + + > The endpoint at `/users` expects a GET request with query string parameter + > `sortby` whose value can be one of `age` or `name` and returns a + > list/array of JSON objects describing users, with fields `age`, `name`, + > `email`, `registration_date`". + +You *should* be able to formalize that. And then use the formalized version to +get you much of the way towards writing a web app. And all the way towards +getting some client libraries, and documentation (and in the future, who knows +- tests, HATEOAS, ...). + +How would we describe it with servant? As mentioned earlier, an endpoint +description is a good old Haskell **type**: + +> type UserAPI = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User] +> +> data SortBy = Age | Name +> +> data User = User { +> name :: String, +> age :: Int +> } + +Let's break that down: + +- `"users"` says that our endpoint will be accessible under `/users`; +- `QueryParam "sortby" SortBy`, where `SortBy` is defined by `data SortBy = Age +| Name`, says that the endpoint has a query string parameter named `sortby` +whose value will be extracted as a value of type `SortBy`. +- `Get '[JSON] [User]` says that the endpoint will be accessible through HTTP +GET requests, returning a list of users encoded as JSON. You will see +later how you can make use of this to make your data available under different +formats, the choice being made depending on the [Accept +header](http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html) specified in +the client's request. +- the `:>` operator that separates the various "combinators" just lets you +sequence static path fragments, URL captures and other combinators. The +ordering only matters for static path fragments and URL captures. `"users" :> +"list-all" :> Get '[JSON] [User]`, equivalent to `/users/list-all`, is +obviously not the same as `"list-all" :> "users" :> Get '[JSON] [User]`, which +is equivalent to `/list-all/users`. This means that sometimes `:>` is somehow +equivalent to `/`, but sometimes it just lets you chain another combinator. + +We can also describe APIs with multiple endpoints by using the `:<|>` +combinators. Here's an example: + +> type UserAPI2 = "users" :> "list-all" :> Get '[JSON] [User] +> :<|> "list-all" :> "users" :> Get '[JSON] [User] + +*servant* provides a fair amount of combinators out-of-the-box, but you can +always write your own when you need it. Here's a quick overview of all the +combinators that servant comes with. + +Combinators +=========== + +Static strings +-------------- + +As you've already seen, you can use type-level strings (enabled with the +`DataKinds` language extension) for static path fragments. Chaining +them amounts to `/`-separating them in a URL. + +> type UserAPI3 = "users" :> "list-all" :> "now" :> Get '[JSON] [User] +> -- describes an endpoint reachable at: +> -- /users/list-all/now + +`Delete`, `Get`, `Patch`, `Post` and `Put` +------------------------------------------ + +These 5 combinators are very similar except that they each describe a +different HTTP method. This is how they're declared + +``` haskell +data Delete (contentTypes :: [*]) a +data Get (contentTypes :: [*]) a +data Patch (contentTypes :: [*]) a +data Post (contentTypes :: [*]) a +data Put (contentTypes :: [*]) a +``` + +An endpoint ends with one of the 5 combinators above (unless you write your +own). Examples: + +> type UserAPI4 = "users" :> Get '[JSON] [User] +> :<|> "admins" :> Get '[JSON] [User] + +`Capture` +--------- + +URL captures are parts of the URL that are variable and whose actual value is +captured and passed to the request handlers. In many web frameworks, you'll see +it written as in `/users/:userid`, with that leading `:` denoting that `userid` +is just some kind of variable name or placeholder. For instance, if `userid` is +supposed to range over all integers greater or equal to 1, our endpoint will +match requests made to `/users/1`, `/users/143` and so on. + +The `Capture` combinator in servant takes a (type-level) string representing +the "name of the variable" and a type, which indicates the type we want to +decode the "captured value" to. + +``` haskell +data Capture (s :: Symbol) a +-- s :: Symbol just says that 's' must be a type-level string. +``` + +In some web frameworks, you use regexes for captures. We use a +[`FromText`](https://hackage.haskell.org/package/servant/docs/Servant-Common-Text.html#t:FromText) +class, which the captured value must be an instance of. + +Examples: + +> type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User +> -- equivalent to 'GET /user/:userid' +> -- except that we explicitly say that "userid" +> -- must be an integer +> +> :<|> "user" :> Capture "userid" Integer :> Delete '[] () +> -- equivalent to 'DELETE /user/:userid' + +`QueryParam`, `QueryParams`, `QueryFlag`, `MatrixParam`, `MatrixParams` and `MatrixFlag` +---------------------------------------------------------------------------------------- + +`QueryParam`, `QueryParams` and `QueryFlag` are about query string +parameters, i.e., those parameters that come after the question mark +(`?`) in URLs, like `sortby` in `/users?sortby=age`, whose value is +set to `age`. `QueryParams` lets you specify that the query parameter +is actually a list of values, which can be specified using +`?param[]=value1¶m[]=value2`. This represents a list of values +composed of `value1` and `value2`. `QueryFlag` lets you specify a +boolean-like query parameter where a client isn't forced to specify a +value. The absence or presence of the parameter's name in the query +string determines whether the parameter is considered to have the +value `True` or `False`. For instance, `/users?active` would list only +active users whereas `/users` would list them all. + +Here are the corresponding data type declarations: + +``` haskell +data QueryParam (sym :: Symbol) a +data QueryParams (sym :: Symbol) a +data QueryFlag (sym :: Symbol) +``` + +[Matrix parameters](http://www.w3.org/DesignIssues/MatrixURIs.html) +are similar to query string parameters, but they can appear anywhere +in the paths (click the link for more details). A URL with matrix +parameters in it looks like `/users;sortby=age`, as opposed to +`/users?sortby=age` with query string parameters. The big advantage is +that they are not necessarily at the end of the URL. You could have +`/users;active=true;registered_after=2005-01-01/locations` to get +geolocation data about users whom are still active and registered +after *January 1st, 2005*. + +Corresponding data type declarations below. + +``` haskell +data MatrixParam (sym :: Symbol) a +data MatrixParams (sym :: Symbol) a +data MatrixFlag (sym :: Symbol) +``` + +Examples: + +> type UserAPI6 = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User] +> -- equivalent to 'GET /users?sortby={age, name}' +> +> :<|> "users" :> MatrixParam "sortby" SortBy :> Get '[JSON] [User] +> -- equivalent to 'GET /users;sortby={age, name}' + +Again, your handlers don't have to deserialize these things (into, for example, +a `SortBy`). *servant* takes care of it. + +`ReqBody` +--------- + +Each HTTP request can carry some additional data that the server can use in its +*body*, and this data can be encoded in any format -- as long as the server +understands it. This can be used for example for an endpoint for creating new +users: instead of passing each field of the user as a separate query string +parameter or something dirty like that, we can group all the data into a JSON +object. This has the advantage of supporting nested objects. + +*servant*'s `ReqBody` combinator takes a list of content types in which the +data encoded in the request body can be represented and the type of that data. +And, as you might have guessed, you don't have to check the content-type +header, and do the deserialization yourself. We do it for you. And return `Bad +Request` or `Unsupported Content Type` as appropriate. + +Here's the data type declaration for it: + +``` haskell +data ReqBody (contentTypes :: [*]) a +``` + +Examples: + +> type UserAPI7 = "users" :> ReqBody '[JSON] User :> Post '[JSON] User +> -- - equivalent to 'POST /users' with a JSON object +> -- describing a User in the request body +> -- - returns a User encoded in JSON +> +> :<|> "users" :> Capture "userid" Integer +> :> ReqBody '[JSON] User +> :> Put '[JSON] User +> -- - equivalent to 'PUT /users/:userid' with a JSON +> -- object describing a User in the request body +> -- - returns a User encoded in JSON + +Request `Header`s +----------------- + +Request headers are used for various purposes, from caching to carrying +auth-related data. They consist of a header name and an associated value. An +example would be `Accept: application/json`. + +The `Header` combinator in servant takes a type-level string for the header +name and the type to which we want to decode the header's value (from some +textual representation), as illustrated below: + +``` haskell +data Header (sym :: Symbol) a +``` + +Here's an example where we declare that an endpoint makes use of the +`User-Agent` header which specifies the name of the software/library used by +the client to send the request. + +> type UserAPI8 = "users" :> Header "User-Agent" Text :> Get '[JSON] [User] + +Content types +------------- + +So far, whenever we have used a combinator that carries a list of content +types, we've always specified `'[JSON]`. However, *servant* lets you use several +content types, and also lets you define your own content types. + +Four content-types are provided out-of-the-box by the core *servant* package: +`JSON`, `PlainText`, `FormUrlEncoded` and `OctetStream`. If for some obscure +reason you wanted one of your endpoints to make your user data available under +those 4 formats, you would write the API type as below: + +> type UserAPI9 = "users" :> Get '[JSON, PlainText, FormUrlEncoded, OctetStream] [User] + +We also provide an HTML content-type, but since there's no single library +that everyone uses, we decided to release 2 packages, *servant-lucid* and +*servant-blaze*, to provide HTML encoding of your data. + +We will further explain how these content types and your data types can play +together in the [section about serving an API](/tutorial/server.html). + +Response `Headers` +------------------ + +Just like an HTTP request, the response generated by a webserver can carry +headers too. *servant* provides a `Headers` combinator that carries a list of +`Header` and can be used by simply wrapping the "return type" of an endpoint +with it. + +``` haskell +data Headers (ls :: [*]) a +``` + +If you want to describe an endpoint that returns a "User-Count" header in each +response, you could write it as below: + +> type UserAPI10 = "users" :> Get '[JSON] (Headers '[Header "User-Count" Integer] [User]) + +Interoperability with other WAI `Application`s: `Raw` +----------------------------------------------------- + +Finally, we also include a combinator named `Raw` that can be used for two reasons: + +- You want to serve static files from a given directory. In that case you can just say: + +> type UserAPI11 = "users" :> Get '[JSON] [User] +> -- a /users endpoint +> +> :<|> Raw +> -- requests to anything else than /users +> -- go here, where the server will try to +> -- find a file with the right name +> -- at the right path + +- You more generally want to plug a [WAI `Application`](http://hackage.haskell.org/package/wai) +into your webservice. Static file serving is a specific example of that. The API type would look the +same as above though. (You can even combine *servant* with other web frameworks +this way!) + + diff --git a/tutorial/client.lhs b/tutorial/client.lhs new file mode 100644 index 00000000..21779f2b --- /dev/null +++ b/tutorial/client.lhs @@ -0,0 +1,138 @@ +--- +title: Deriving Haskell functions to query an API +toc: true +--- + +While defining handlers that serve an API has a lot to it, querying an API is simpler: we do not care about what happens inside the webserver, we just need to know how to talk to it and get a response back. Except that we usually have to write the querying functions by hand because the structure of the API isn't a first class citizen and can't be inspected to generate a bunch of client-side functions. + +*servant* however has a way to inspect API, because APIs are just Haskell types and (GHC) Haskell lets us do quite a few things with types. In the same way that we look at an API type to deduce the types the handlers should have, we can inspect the structure of the API to *derive* Haskell functions that take one argument for each occurence of `Capture`, `ReqBody`, `QueryParam` +and friends. By *derive*, we mean that there's no code generation involved, the functions are defined just by the structure of the API type. + +The source for this tutorial section is a literate haskell file, so first we +need to have some language extensions and imports: + +> {-# LANGUAGE DataKinds #-} +> {-# LANGUAGE DeriveGeneric #-} +> {-# LANGUAGE TypeOperators #-} +> +> module Client where +> +> import Control.Monad.Trans.Either +> import Data.Aeson +> import Data.Proxy +> import GHC.Generics +> import Servant.API +> import Servant.Client + +Also, we need examples for some domain specific data types: + +> data Position = Position +> { x :: Int +> , y :: Int +> } deriving (Show, Generic) +> +> instance FromJSON Position +> +> newtype HelloMessage = HelloMessage { msg :: String } +> deriving (Show, Generic) +> +> instance FromJSON HelloMessage +> +> data ClientInfo = ClientInfo +> { clientName :: String +> , clientEmail :: String +> , clientAge :: Int +> , clientInterestedIn :: [String] +> } deriving Generic +> +> instance ToJSON ClientInfo +> +> data Email = Email +> { from :: String +> , to :: String +> , subject :: String +> , body :: String +> } deriving (Show, Generic) +> +> instance FromJSON Email + +Enough chitchat, let's see an example. Consider the following API type from the previous section: + +> type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position +> :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage +> :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email + +What we are going to get with *servant-client* here is 3 functions, one to query each endpoint: + +> position :: Int -- ^ value for "x" +> -> Int -- ^ value for "y" +> -> EitherT ServantError IO Position +> +> hello :: Maybe String -- ^ an optional value for "name" +> -> EitherT ServantError IO HelloMessage +> +> marketing :: ClientInfo -- ^ value for the request body +> -> EitherT ServantError IO Email + +Each function makes available as an argument any value that the response may depend on, as evidenced in the API type. How do we get these functions? Just give a `Proxy` to your API and a host to make the requests to: + +> api :: Proxy API +> api = Proxy +> +> position :<|> hello :<|> marketing = client api (BaseUrl Http "localhost" 8081) + +As you can see in the code above, we just "pattern match our way" to these functions. If we try to derive less or more functions than there are endpoints in the API, we obviously get an error. The `BaseUrl` value there is just: + +``` haskell +-- | URI scheme to use +data Scheme = + Http -- ^ http:// + | Https -- ^ https:// + deriving + +-- | Simple data type to represent the target of HTTP requests +-- for servant's automatically-generated clients. +data BaseUrl = BaseUrl + { baseUrlScheme :: Scheme -- ^ URI scheme to use + , baseUrlHost :: String -- ^ host (eg "haskell.org") + , baseUrlPort :: Int -- ^ port (eg 80) + } +``` + +That's it. Let's now write some code that uses our client functions. + +> queries :: EitherT ServantError IO (Position, HelloMessage, Email) +> queries = do +> pos <- position 10 10 +> msg <- hello (Just "servant") +> em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) +> return (pos, msg, em) +> +> run :: IO () +> run = do +> res <- runEitherT queries +> case res of +> Left err -> putStrLn $ "Error: " ++ show err +> Right (pos, msg, em) -> do +> print pos +> print msg +> print em + +You can now run `dist/build/tutorial/tutorial 8` (the server) and +`dist/build/t8-main/t8-main` (the client) to see them both in action. + +``` bash + $ dist/build/tutorial/tutorial 8 + # and in another terminal: + $ dist/build/t8-main/t8-main + Position {x = 10, y = 10} + HelloMessage {msg = "Hello, servant"} + Email {from = "great@company.com", to = "alp@foo.com", subject = "Hey Alp, we miss you!", body = "Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!"} +``` + +The types of the arguments for the functions are the same as for (server-side) request handlers. You now know how to use *servant-client*! + + diff --git a/tutorial/conf.py b/tutorial/conf.py new file mode 100644 index 00000000..6d4f897d --- /dev/null +++ b/tutorial/conf.py @@ -0,0 +1,287 @@ +# -*- coding: utf-8 -*- +# +# generics-eot documentation build configuration file, created by +# sphinx-quickstart on Fri Jan 22 12:22:48 2016. +# +# This file is execfile()d with the current directory set to its +# containing dir. +# +# Note that not all possible configuration values are present in this +# autogenerated file. +# +# All configuration values have a default; values that are commented out +# serve to show the default. + +import sys +import os +from recommonmark.parser import CommonMarkParser + +# If extensions (or modules to document with autodoc) are in another directory, +# add these directories to sys.path here. If the directory is relative to the +# documentation root, use os.path.abspath to make it absolute, like shown here. +#sys.path.insert(0, os.path.abspath('.')) + +# -- General configuration ------------------------------------------------ + +# If your documentation needs a minimal Sphinx version, state it here. +#needs_sphinx = '1.0' + +# Add any Sphinx extension module names here, as strings. They can be +# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom +# ones. +extensions = [] + +# Add any paths that contain templates here, relative to this directory. +templates_path = ['_templates'] + +# The suffix(es) of source filenames. +# You can specify multiple suffix as a list of string: +source_suffix = ['.md', '.rst'] + +# The encoding of source files. +#source_encoding = 'utf-8-sig' + +# The master toctree document. +master_doc = 'index' + +# General information about the project. +project = u'generics-eot' +copyright = u'2016, Sönke Hahn' +author = u'Sönke Hahn' + +# The version info for the project you're documenting, acts as replacement for +# |version| and |release|, also used in various other places throughout the +# built documents. +# +# The short X.Y version. +version = u'0.1' +# The full version, including alpha/beta/rc tags. +release = u'0.1' + +# The language for content autogenerated by Sphinx. Refer to documentation +# for a list of supported languages. +# +# This is also used if you do content translation via gettext catalogs. +# Usually you set "language" from the command line for these cases. +language = None + +# There are two options for replacing |today|: either, you set today to some +# non-false value, then it is used: +#today = '' +# Else, today_fmt is used as the format for a strftime call. +#today_fmt = '%B %d, %Y' + +# List of patterns, relative to source directory, that match files and +# directories to ignore when looking for source files. +exclude_patterns = ['_build', 'venv'] + +# The reST default role (used for this markup: `text`) to use for all +# documents. +#default_role = None + +# If true, '()' will be appended to :func: etc. cross-reference text. +#add_function_parentheses = True + +# If true, the current module name will be prepended to all description +# unit titles (such as .. function::). +#add_module_names = True + +# If true, sectionauthor and moduleauthor directives will be shown in the +# output. They are ignored by default. +#show_authors = False + +# The name of the Pygments (syntax highlighting) style to use. +pygments_style = 'sphinx' + +# A list of ignored prefixes for module index sorting. +#modindex_common_prefix = [] + +# If true, keep warnings as "system message" paragraphs in the built documents. +#keep_warnings = False + +# If true, `todo` and `todoList` produce output, else they produce nothing. +todo_include_todos = False + + +# -- Options for HTML output ---------------------------------------------- + +# The theme to use for HTML and HTML Help pages. See the documentation for +# a list of builtin themes. +html_theme = 'alabaster' + +# Theme options are theme-specific and customize the look and feel of a theme +# further. For a list of options available for each theme, see the +# documentation. +#html_theme_options = {} + +# Add any paths that contain custom themes here, relative to this directory. +#html_theme_path = [] + +# The name for this set of Sphinx documents. If None, it defaults to +# " v documentation". +#html_title = None + +# A shorter title for the navigation bar. Default is the same as html_title. +#html_short_title = None + +# The name of an image file (relative to this directory) to place at the top +# of the sidebar. +#html_logo = None + +# The name of an image file (within the static path) to use as favicon of the +# docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32 +# pixels large. +#html_favicon = None + +# Add any paths that contain custom static files (such as style sheets) here, +# relative to this directory. They are copied after the builtin static files, +# so a file named "default.css" will overwrite the builtin "default.css". +html_static_path = ['_static'] + +# Add any extra paths that contain custom files (such as robots.txt or +# .htaccess) here, relative to this directory. These files are copied +# directly to the root of the documentation. +#html_extra_path = [] + +# If not '', a 'Last updated on:' timestamp is inserted at every page bottom, +# using the given strftime format. +#html_last_updated_fmt = '%b %d, %Y' + +# If true, SmartyPants will be used to convert quotes and dashes to +# typographically correct entities. +#html_use_smartypants = True + +# Custom sidebar templates, maps document names to template names. +#html_sidebars = {} + +# Additional templates that should be rendered to pages, maps page names to +# template names. +#html_additional_pages = {} + +# If false, no module index is generated. +#html_domain_indices = True + +# If false, no index is generated. +#html_use_index = True + +# If true, the index is split into individual pages for each letter. +#html_split_index = False + +# If true, links to the reST sources are added to the pages. +#html_show_sourcelink = True + +# If true, "Created using Sphinx" is shown in the HTML footer. Default is True. +#html_show_sphinx = True + +# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True. +#html_show_copyright = True + +# If true, an OpenSearch description file will be output, and all pages will +# contain a tag referring to it. The value of this option must be the +# base URL from which the finished HTML is served. +#html_use_opensearch = '' + +# This is the file name suffix for HTML files (e.g. ".xhtml"). +#html_file_suffix = None + +# Language to be used for generating the HTML full-text search index. +# Sphinx supports the following languages: +# 'da', 'de', 'en', 'es', 'fi', 'fr', 'hu', 'it', 'ja' +# 'nl', 'no', 'pt', 'ro', 'ru', 'sv', 'tr' +#html_search_language = 'en' + +# A dictionary with options for the search language support, empty by default. +# Now only 'ja' uses this config value +#html_search_options = {'type': 'default'} + +# The name of a javascript file (relative to the configuration directory) that +# implements a search results scorer. If empty, the default will be used. +#html_search_scorer = 'scorer.js' + +# Output file base name for HTML help builder. +htmlhelp_basename = 'generics-eotdoc' + +# -- Options for LaTeX output --------------------------------------------- + +latex_elements = { +# The paper size ('letterpaper' or 'a4paper'). +#'papersize': 'letterpaper', + +# The font size ('10pt', '11pt' or '12pt'). +#'pointsize': '10pt', + +# Additional stuff for the LaTeX preamble. +#'preamble': '', + +# Latex figure (float) alignment +#'figure_align': 'htbp', +} + +# Grouping the document tree into LaTeX files. List of tuples +# (source start file, target name, title, +# author, documentclass [howto, manual, or own class]). +latex_documents = [ + (master_doc, 'generics-eot.tex', u'generics-eot Documentation', + u'Sönke Hahn', 'manual'), +] + +# The name of an image file (relative to this directory) to place at the top of +# the title page. +#latex_logo = None + +# For "manual" documents, if this is true, then toplevel headings are parts, +# not chapters. +#latex_use_parts = False + +# If true, show page references after internal links. +#latex_show_pagerefs = False + +# If true, show URL addresses after external links. +#latex_show_urls = False + +# Documents to append as an appendix to all manuals. +#latex_appendices = [] + +# If false, no module index is generated. +#latex_domain_indices = True + + +# -- Options for manual page output --------------------------------------- + +# One entry per manual page. List of tuples +# (source start file, name, description, authors, manual section). +man_pages = [ + (master_doc, 'generics-eot', u'generics-eot Documentation', + [author], 1) +] + +# If true, show URL addresses after external links. +#man_show_urls = False + + +# -- Options for Texinfo output ------------------------------------------- + +# Grouping the document tree into Texinfo files. List of tuples +# (source start file, target name, title, author, +# dir menu entry, description, category) +texinfo_documents = [ + (master_doc, 'generics-eot', u'generics-eot Documentation', + author, 'generics-eot', 'One line description of project.', + 'Miscellaneous'), +] + +# Documents to append as an appendix to all manuals. +#texinfo_appendices = [] + +# If false, no module index is generated. +#texinfo_domain_indices = True + +# How to display URL addresses: 'footnote', 'no', or 'inline'. +#texinfo_show_urls = 'footnote' + +# If true, do not generate a @detailmenu in the "Top" node's menu. +#texinfo_no_detailmenu = False + +source_parsers = { + '.md': CommonMarkParser, +} diff --git a/tutorial/docs.lhs b/tutorial/docs.lhs new file mode 100644 index 00000000..cb662a54 --- /dev/null +++ b/tutorial/docs.lhs @@ -0,0 +1,227 @@ +--- +title: Generating documentation from API types +toc: true +--- + +The source for this tutorial section is a literate haskell file, so first we +need to have some language extensions and imports: + +> {-# LANGUAGE DataKinds #-} +> {-# LANGUAGE DeriveGeneric #-} +> {-# LANGUAGE FlexibleInstances #-} +> {-# LANGUAGE MultiParamTypeClasses #-} +> {-# LANGUAGE OverloadedStrings #-} +> {-# LANGUAGE TypeOperators #-} +> {-# OPTIONS_GHC -fno-warn-orphans #-} +> +> module Docs where +> +> import Data.ByteString.Lazy (ByteString) +> import Data.Proxy +> import Data.Text.Lazy.Encoding (encodeUtf8) +> import Data.Text.Lazy (pack) +> import Network.HTTP.Types +> import Network.Wai +> import Servant.API +> import Servant.Docs +> import Servant.Server + +And we'll import some things from one of our earlier modules +([Serving an API](/tutorial/server.html)): + +> import Server (Email(..), ClientInfo(..), Position(..), HelloMessage(..), +> server3, emailForClient) + +Like client function generation, documentation generation amounts to inspecting the API type and extracting all the data we need to then present it in some format to users of your API. + +This time however, we have to assist *servant*. While it is able to deduce a lot of things about our API, it can't magically come up with descriptions of the various pieces of our APIs that are human-friendly and explain what's going on "at the business-logic level". A good example to study for documentation generation is our webservice with the `/position`, `/hello` and `/marketing` endpoints from earlier: + +> type ExampleAPI = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position +> :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage +> :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email +> +> exampleAPI :: Proxy ExampleAPI +> exampleAPI = Proxy + +While *servant* can see e.g. that there are 3 endpoints and that the response bodies will be in JSON, it doesn't know what influence the captures, parameters, request bodies and other combinators have on the webservice. This is where some manual work is required. + +For every capture, request body, response body, query param, we have to give some explanations about how it influences the response, what values are possible and the likes. Here's how it looks like for the parameters we have above. + +> instance ToCapture (Capture "x" Int) where +> toCapture _ = +> DocCapture "x" -- name +> "(integer) position on the x axis" -- description +> +> instance ToCapture (Capture "y" Int) where +> toCapture _ = +> DocCapture "y" -- name +> "(integer) position on the y axis" -- description +> +> instance ToSample Position Position where +> toSample _ = Just (Position 3 14) -- example of output +> +> instance ToParam (QueryParam "name" String) where +> toParam _ = +> DocQueryParam "name" -- name +> ["Alp", "John Doe", "..."] -- example of values (not necessarily exhaustive) +> "Name of the person to say hello to." -- description +> Normal -- Normal, List or Flag +> +> instance ToSample HelloMessage HelloMessage where +> toSamples _ = +> [ ("When a value is provided for 'name'", HelloMessage "Hello, Alp") +> , ("When 'name' is not specified", HelloMessage "Hello, anonymous coward") +> ] +> -- mutliple examples to display this time +> +> ci :: ClientInfo +> ci = ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"] +> +> instance ToSample ClientInfo ClientInfo where +> toSample _ = Just ci +> +> instance ToSample Email Email where +> toSample _ = Just (emailForClient ci) + +Types that are used as request or response bodies have to instantiate the `ToSample` typeclass which lets you specify one or more examples of values. `Capture`s and `QueryParam`s have to instantiate their respective `ToCapture` and `ToParam` classes and provide a name and some information about the concrete meaning of that argument, as illustrated in the code above. + +With all of this, we can derive docs for our API. + +> apiDocs :: API +> apiDocs = docs exampleAPI + +`API` is a type provided by *servant-docs* that stores all the information one needs about a web API in order to generate documentation in some format. Out of the box, *servant-docs* only provides a pretty documentation printer that outputs [Markdown](http://en.wikipedia.org/wiki/Markdown), but the [servant-pandoc](http://hackage.haskell.org/package/servant-pandoc) package can be used to target many useful formats. + +*servant*'s markdown pretty printer is a function named `markdown`. + +``` haskell +markdown :: API -> String +``` + +That lets us see what our API docs look down in markdown, by looking at `markdown apiDocs`. + +``` text + ## Welcome + + This is our super webservice's API. + + Enjoy! + + ## GET /hello + + #### GET Parameters: + + - name + - **Values**: *Alp, John Doe, ...* + - **Description**: Name of the person to say hello to. + + + #### Response: + + - Status code 200 + - Headers: [] + + - Supported content types are: + + - `application/json` + + - When a value is provided for 'name' + + ```javascript + {"msg":"Hello, Alp"} + ``` + + - When 'name' is not specified + + ```javascript + {"msg":"Hello, anonymous coward"} + ``` + + ## POST /marketing + + #### Request: + + - Supported content types are: + + - `application/json` + + - Example: `application/json` + + ```javascript + {"email":"alp@foo.com","interested_in":["haskell","mathematics"],"age":26,"name":"Alp"} + ``` + + #### Response: + + - Status code 201 + - Headers: [] + + - Supported content types are: + + - `application/json` + + - Response body as below. + + ```javascript + {"subject":"Hey Alp, we miss you!","body":"Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!","to":"alp@foo.com","from":"great@company.com"} + ``` + + ## GET /position/:x/:y + + #### Captures: + + - *x*: (integer) position on the x axis + - *y*: (integer) position on the y axis + + #### Response: + + - Status code 200 + - Headers: [] + + - Supported content types are: + + - `application/json` + + - Response body as below. + + ```javascript + {"x":3,"y":14} + ``` + +``` + +However, we can also add one or more introduction sections to the document. We just need to tweak the way we generate `apiDocs`. We will also convert the content to a lazy `ByteString` since this is what *wai* expects for `Raw` endpoints. + +> docsBS :: ByteString +> docsBS = encodeUtf8 +> . pack +> . markdown +> $ docsWithIntros [intro] exampleAPI +> +> where intro = DocIntro "Welcome" ["This is our super webservice's API.", "Enjoy!"] + +`docsWithIntros` just takes an additional parameter, a list of `DocIntro`s that must be displayed before any endpoint docs. + +We can now serve the API *and* the API docs with a simple server. + +> type DocsAPI = ExampleAPI :<|> Raw +> +> api :: Proxy DocsAPI +> api = Proxy +> +> server :: Server DocsAPI +> server = Server.server3 :<|> serveDocs +> +> where serveDocs _ respond = +> respond $ responseLBS ok200 [plain] docsBS +> +> plain = ("Content-Type", "text/plain") +> +> app :: Application +> app = serve api server + +And if you spin up this server with `dist/build/tutorial/tutorial 10` and go to anywhere else than `/position`, `/hello` and `/marketing`, you will see the API docs in markdown. This is because `serveDocs` is attempted if the 3 other endpoints don't match and systematically succeeds since its definition is to just return some fixed bytestring with the `text/plain` content type. + + diff --git a/tutorial/index.rst b/tutorial/index.rst new file mode 100644 index 00000000..378155e1 --- /dev/null +++ b/tutorial/index.rst @@ -0,0 +1,68 @@ +Servant tutorial +================ + +This is an introductory tutorial to the current version of *servant*, which is **0.4**. Any comment or issue can be directed to [this website's issue tracker](http://github.com/haskell-servant/haskell-servant.github.io/issues). + +Github +------- + +- the servant packages: [haskell-servant/servant](https://github.com/haskell-servant/servant) +- the website (including this tutorial): [haskell-servant/haskell-servant.github.io](https://github.com/haskell-servant/haskell-servant.github.io/) +- Feel free to use the issue tracker (or to send PRs!) on the website's repository to give feedback and suggestions about this tutorial + +Introduction +------------- + +*servant* has the following guiding principles: + +- concision + + This is a pretty wide-ranging principle. You should be able to get nice + documentation for your web servers, and client libraries, without repeating + yourself. You should not have to manually serialize and deserialize your + resources, but only declare how to do those things *once per type*. If a + bunch of your handlers take the same query parameters, you shouldn't have to + repeat that logic for each handler, but instead just "apply" it to all of + them at once. Your handlers shouldn't be where composition goes to die. And + so on. + +- flexibility + + If we haven't thought of your use case, it should still be easily + achievable. If you want to use templating library X, go ahead. Forms? Do + them however you want, but without difficulty. We're not opinionated. + +- separation of concerns + + Your handlers and your HTTP logic should be separate. True to the philosphy + at the core of HTTP and REST, with *servant* your handlers return normal + Haskell datatypes - that's the resource. And then from a description of your + API, *servant* handles the *presentation* (i.e., the Content-Types). But + that's just one example. + +- type safety + + Want to be sure your API meets a specification? Your compiler can check + that for you. Links you can be sure exist? You got it. + +To stick true to these principles, we do things a little differently than you +might expect. The core idea is *reifying the description of your API*. Once +reified, everything follows. We think we might be the first web framework to +reify API descriptions in an extensible way. We're pretty sure we're the first +to reify it as *types*. + +To be able to write a webservice you only need to read the first two sections, +but the goal of this document being to get you started with servant, we also +cover the couple of ways you can extend servant for a great good. + +Tutorial +--------- + +.. toctree:: + :maxdepth: 2 + + api-type.lhs + server.lhs + client.lhs + javascript.lhs + docs.lhs diff --git a/tutorial/javascript.lhs b/tutorial/javascript.lhs new file mode 100644 index 00000000..33b4f73b --- /dev/null +++ b/tutorial/javascript.lhs @@ -0,0 +1,175 @@ +--- +title: Deriving Javascript functions to query an API +toc: true +--- + +We will now see how *servant* lets you turn an API type into javascript +functions that you can call to query a webservice. The derived code assumes you +use *jQuery* but you could very easily adapt the code to generate ajax requests +based on vanilla javascript or another library than *jQuery*. + +For this, we will consider a simple page divided in two parts. At the top, we +will have a search box that lets us search in a list of Haskell books by +author/title with a list of results that gets updated every time we enter or +remove a character, while at the bottom we will be able to see the classical +[probabilistic method to approximate +pi](http://en.wikipedia.org/wiki/Approximations_of_%CF%80#Summing_a_circle.27s_area), +using a webservice to get random points. Finally, we will serve an HTML file +along with a couple of Javascript files, among which one that's automatically +generated from the API type and which will provide ready-to-use functions to +query your API. + +The source for this tutorial section is a literate haskell file, so first we +need to have some language extensions and imports: + +> {-# LANGUAGE DataKinds #-} +> {-# LANGUAGE DeriveGeneric #-} +> {-# LANGUAGE OverloadedStrings #-} +> {-# LANGUAGE TypeOperators #-} +> +> module Javascript where +> +> import Control.Monad.IO.Class +> import Data.Aeson +> import Data.Proxy +> import Data.Text (Text) +> import qualified Data.Text as T +> import GHC.Generics +> import Language.Javascript.JQuery +> import Network.Wai +> import Servant +> import Servant.JQuery +> import System.Random + +Now let's have the API type(s) and the accompanying datatypes. + +> type API = "point" :> Get '[JSON] Point +> :<|> "books" :> QueryParam "q" Text :> Get '[JSON] (Search Book) +> +> type API' = API :<|> Raw +> +> data Point = Point +> { x :: Double +> , y :: Double +> } deriving Generic +> +> instance ToJSON Point +> +> data Search a = Search +> { query :: Text +> , results :: [a] +> } deriving Generic +> +> mkSearch :: Text -> [a] -> Search a +> mkSearch = Search +> +> instance ToJSON a => ToJSON (Search a) +> +> data Book = Book +> { author :: Text +> , title :: Text +> , year :: Int +> } deriving Generic +> +> instance ToJSON Book +> +> book :: Text -> Text -> Int -> Book +> book = Book + +We need a "book database". For the purpose of this guide, let's restrict ourselves to the following books. + +> books :: [Book] +> books = +> [ book "Paul Hudak" "The Haskell School of Expression: Learning Functional Programming through Multimedia" 2000 +> , book "Bryan O'Sullivan, Don Stewart, and John Goerzen" "Real World Haskell" 2008 +> , book "Miran Lipovača" "Learn You a Haskell for Great Good!" 2011 +> , book "Graham Hutton" "Programming in Haskell" 2007 +> , book "Simon Marlow" "Parallel and Concurrent Programming in Haskell" 2013 +> , book "Richard Bird" "Introduction to Functional Programming using Haskell" 1998 +> ] + +Now, given an optional search string `q`, we want to perform a case insensitive search in that list of books. We're obviously not going to try and implement the best possible algorithm, this is out of scope for this tutorial. The following simple linear scan will do, given how small our list is. + +> searchBook :: Monad m => Maybe Text -> m (Search Book) +> searchBook Nothing = return (mkSearch "" books) +> searchBook (Just q) = return (mkSearch q books') +> +> where books' = filter (\b -> q' `T.isInfixOf` T.toLower (author b) +> || q' `T.isInfixOf` T.toLower (title b) +> ) +> books +> q' = T.toLower q + +We also need an endpoint that generates random points `(x, y)` with `-1 <= x,y <= 1`. The code below uses [random](http://hackage.haskell.org/package/random)'s `System.Random`. + +> randomPoint :: MonadIO m => m Point +> randomPoint = liftIO . getStdRandom $ \g -> +> let (rx, g') = randomR (-1, 1) g +> (ry, g'') = randomR (-1, 1) g' +> in (Point rx ry, g'') + +If we add static file serving, our server is now complete. + +> api :: Proxy API +> api = Proxy +> +> api' :: Proxy API' +> api' = Proxy +> +> server :: Server API +> server = randomPoint +> :<|> searchBook +> +> server' :: Server API' +> server' = server +> :<|> serveDirectory "tutorial/t9" +> +> app :: Application +> app = serve api' server' + +Why two different API types, proxies and servers though? Simply because we don't want to generate javascript functions for the `Raw` part of our API type, so we need a `Proxy` for our API type `API'` without its `Raw` endpoint. + +Very similarly to how one can derive haskell functions, we can derive the javascript with just a simple function call to `jsForAPI` from `Servant.JQuery`. + +> apiJS :: String +> apiJS = jsForAPI api + +This `String` contains 2 Javascript functions: + +``` javascript + +function getpoint(onSuccess, onError) +{ + $.ajax( + { url: '/point' + , success: onSuccess + , error: onError + , method: 'GET' + }); +} + +function getbooks(q, onSuccess, onError) +{ + $.ajax( + { url: '/books' + '?q=' + encodeURIComponent(q) + , success: onSuccess + , error: onError + , method: 'GET' + }); +} +``` + +Right before starting up our server, we will need to write this `String` to a file, say `api.js`, along with a copy of the *jQuery* library, as provided by the [js-jquery](http://hackage.haskell.org/package/js-jquery) package. + +> writeJSFiles :: IO () +> writeJSFiles = do +> writeFile "getting-started/gs9/api.js" apiJS +> jq <- readFile =<< Language.Javascript.JQuery.file +> writeFile "getting-started/gs9/jq.js" jq + +And we're good to go. Start the server with `dist/build/tutorial/tutorial 9` and go to `http://localhost:8081/`. Start typing in the name of one of the authors in our database or part of a book title, and check out how long it takes to approximate π using the method mentioned above. + + diff --git a/tutorial/requirements.txt b/tutorial/requirements.txt new file mode 100644 index 00000000..8f89e4b8 --- /dev/null +++ b/tutorial/requirements.txt @@ -0,0 +1,25 @@ +alabaster==0.7.7 +argh==0.26.1 +Babel==2.2.0 +backports-abc==0.4 +backports.ssl-match-hostname==3.5.0.1 +certifi==2015.11.20.1 +CommonMark==0.5.4 +docutils==0.12 +Jinja2==2.8 +livereload==2.4.1 +MarkupSafe==0.23 +pathtools==0.1.2 +Pygments==2.1 +pytz==2015.7 +PyYAML==3.11 +recommonmark==0.4.0 +singledispatch==3.4.0.3 +six==1.10.0 +snowballstemmer==1.2.1 +Sphinx==1.3.4 +sphinx-autobuild==0.5.2 +sphinx-rtd-theme==0.1.9 +tornado==4.3 +watchdog==0.8.3 +wheel==0.26.0 diff --git a/tutorial/server.lhs b/tutorial/server.lhs new file mode 100644 index 00000000..32f098ba --- /dev/null +++ b/tutorial/server.lhs @@ -0,0 +1,1176 @@ +--- +title: Serving an API +toc: true +--- + +Enough chit-chat about type-level combinators and representing an API as a +type. Can we have a webservice already? + +If you want to follow along with the code and run the examples while you read this guide: + +``` bash +cabal get servant-examples +cd servant-examples- +cabal sandbox init +cabal install --dependencies-only +cabal configure && cabal build +``` + +This will produce a `tutorial` executable in the +`dist/build/tutorial` directory that just runs the example corresponding +to the number specified as a command line argument: + +``` bash +$ dist/build/tutorial/tutorial +Usage: tutorial N + where N is the number of the example you want to run. +``` + +A first example +=============== + +Equipped with some basic knowledge about the way we represent API, let's now write our first webservice. + +The source for this tutorial section is a literate haskell file, so first we +need to have some language extensions and imports: + +> {-# LANGUAGE DataKinds #-} +> {-# LANGUAGE DeriveGeneric #-} +> {-# LANGUAGE FlexibleInstances #-} +> {-# LANGUAGE GeneralizedNewtypeDeriving #-} +> {-# LANGUAGE MultiParamTypeClasses #-} +> {-# LANGUAGE OverloadedStrings #-} +> {-# LANGUAGE ScopedTypeVariables #-} +> {-# LANGUAGE TypeOperators #-} +> +> module Server where +> +> import Control.Monad.IO.Class +> import Control.Monad.Reader +> import Control.Monad.Trans.Either +> import Data.Aeson +> import Data.Aeson.Types +> import Data.Attoparsec.ByteString +> import Data.ByteString (ByteString) +> import Data.Int +> import Data.List +> import Data.String.Conversions +> import Data.Time.Calendar +> import GHC.Generics +> import Lucid +> import Network.HTTP.Media ((//), (/:)) +> import Network.Wai +> import Network.Wai.Handler.Warp +> import Servant +> import System.Directory +> import Text.Blaze +> import Text.Blaze.Html.Renderer.Utf8 +> import qualified Data.Aeson.Parser +> import qualified Text.Blaze.Html + +``` haskell +{-# LANGUAGE TypeFamilies #-} +``` + +**Important**: the `Servant` module comes from the *servant-server* package, the one that lets us run webservers that implement a particular API type. It reexports all the types from the *servant* package that let you declare API types as well as everything you need to turn your request handlers into a fully-fledged webserver. This means that in your applications, you can just add *servant-server* as a dependency, import `Servant` and not worry about anything else. + +We will write a server that will serve the following API. + +> type UserAPI1 = "users" :> Get '[JSON] [User] + +Here's what we would like to see when making a GET request to `/users`. + +``` javascript +[ {"name": "Isaac Newton", "age": 372, "email": "isaac@newton.co.uk", "registration_date": "1683-03-01"} +, {"name": "Albert Einstein", "age": 136, "email": "ae@mc2.org", "registration_date": "1905-12-01"} +] +``` + +Now let's define our `User` data type and write some instances for it. + +> data User = User +> { name :: String +> , age :: Int +> , email :: String +> , registration_date :: Day +> } deriving (Eq, Show, Generic) +> +> instance ToJSON User + +Nothing funny going on here. But we now can define our list of two users. + +> users1 :: [User] +> users1 = +> [ User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1) +> , User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1) +> ] + +Let's also write our API type. + +``` haskell +type UserAPI1 = "users" :> Get '[JSON] [User] +``` + +We can now take care of writing the actual webservice that will handle requests +to such an API. This one will be very simple, being reduced to just a single +endpoint. The type of the web application is determined by the API type, +through a *type family* named `Server`. (Type families are just functions that +take types as input and return types.) The `Server` type family will compute +the right type that a bunch of request handlers should have just from the +corresponding API type. + +The first thing to know about the `Server` type family is that behind the +scenes it will drive the routing, letting you focus only on the business +logic. The second thing to know is that for each endpoint, your handlers will +by default run in the `EitherT ServantErr IO` monad. This is overridable very +easily, as explained near the end of this guide. Third thing, the type of the +value returned in that monad must be the same as the second argument of the +HTTP method combinator used for the corresponding endpoint. In our case, it +means we must provide a handler of type `EitherT ServantErr IO [User]`. Well, +we have a monad, let's just `return` our list: + +> server1 :: Server UserAPI1 +> server1 = return users1 + +That's it. Now we can turn `server` into an actual webserver using [wai](http://hackage.haskell.org/package/wai) and [warp](http://hackage.haskell.org/package/warp): + +> userAPI :: Proxy UserAPI1 +> userAPI = Proxy +> +> -- 'serve' comes from servant and hands you a WAI Application, +> -- which you can think of as an "abstract" web application, +> -- not yet a webserver. +> app1 :: Application +> app1 = serve userAPI server1 + +The `userAPI` bit is, alas, boilerplate (we need it to guide type inference). +But that's about as much boilerplate as you get. + +And we're done! Let's run our webservice on the port 8081. + +> main :: IO () +> main = run 8081 app1 + +You can put this all into a file or just grab [servant's +repo](http://github.com/haskell-servant/servant) and look at the +*servant-examples* directory. The code we have just explored is in +*tutorial/T1.hs*, runnable with +`dist/build/tutorial/tutorial 1`. + +If you run it, you can go to `http://localhost:8081/users` in your browser or +query it with curl and you see: + +``` bash +$ curl http://localhost:8081/users +[{"email":"isaac@newton.co.uk","registration_date":"1683-03-01","age":372,"name":"Isaac Newton"},{"email":"ae@mc2.org","registration_date":"1905-12-01","age":136,"name":"Albert Einstein"}] +``` + +More endpoints +============== + +What if we want more than one endpoint? Let's add `/albert` and `/isaac` to view the corresponding users encoded in JSON. + +> type UserAPI2 = "users" :> Get '[JSON] [User] +> :<|> "albert" :> Get '[JSON] User +> :<|> "isaac" :> Get '[JSON] User + +And let's adapt our code a bit. + +> isaac :: User +> isaac = User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1) +> +> albert :: User +> albert = User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1) +> +> users2 :: [User] +> users2 = [isaac, albert] + +Now, just like we separate the various endpoints in `UserAPI` with `:<|>`, we +are going to separate the handlers with `:<|>` too! They must be provided in +the same order as the one they appear in in the API type. + +> server2 :: Server UserAPI2 +> server2 = return users2 +> :<|> return albert +> :<|> return isaac + +And that's it! You can run this example with +`dist/build/tutorial/tutorial 2` and check out the data available +at `/users`, `/albert` and `/isaac`. + +From combinators to handler arguments +===================================== + +Fine, we can write trivial webservices easily, but none of the two above use +any "fancy" combinator from servant. Let's address this and use `QueryParam`, +`Capture` and `ReqBody` right away. You'll see how each occurence of these +combinators in an endpoint makes the corresponding handler receive an +argument of the appropriate type automatically. You don't have to worry about +manually looking up URL captures or query string parameters, or +decoding/encoding data from/to JSON. Never. + +We are going to use the following data types and functions to implement a server for `API`. + +> type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position +> :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage +> :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email +> +> data Position = Position +> { x :: Int +> , y :: Int +> } deriving Generic +> +> instance ToJSON Position +> +> newtype HelloMessage = HelloMessage { msg :: String } +> deriving Generic +> +> instance ToJSON HelloMessage +> +> data ClientInfo = ClientInfo +> { clientName :: String +> , clientEmail :: String +> , clientAge :: Int +> , clientInterestedIn :: [String] +> } deriving Generic +> +> instance FromJSON ClientInfo +> instance ToJSON ClientInfo +> +> data Email = Email +> { from :: String +> , to :: String +> , subject :: String +> , body :: String +> } deriving Generic +> +> instance ToJSON Email +> +> emailForClient :: ClientInfo -> Email +> emailForClient c = Email from' to' subject' body' +> +> where from' = "great@company.com" +> to' = clientEmail c +> subject' = "Hey " ++ clientName c ++ ", we miss you!" +> body' = "Hi " ++ clientName c ++ ",\n\n" +> ++ "Since you've recently turned " ++ show (clientAge c) +> ++ ", have you checked out our latest " +> ++ intercalate ", " (clientInterestedIn c) +> ++ " products? Give us a visit!" + +We can implement handlers for the three endpoints: + +> server3 :: Server API +> server3 = position +> :<|> hello +> :<|> marketing +> +> where position :: Int -> Int -> EitherT ServantErr IO Position +> position x y = return (Position x y) +> +> hello :: Maybe String -> EitherT ServantErr IO HelloMessage +> hello mname = return . HelloMessage $ case mname of +> Nothing -> "Hello, anonymous coward" +> Just n -> "Hello, " ++ n +> +> marketing :: ClientInfo -> EitherT ServantErr IO Email +> marketing clientinfo = return (emailForClient clientinfo) + +Did you see that? The types for your handlers changed to be just what we +needed! In particular: + + - a `Capture "something" a` becomes an argument of type `a` (for `position`); + - a `QueryParam "something" a` becomes an argument of type `Maybe a` (because +an endpoint can technically be accessed without specifying any query +string parameter, we decided to "force" handlers to be aware that the +parameter might not always be there); + + - a `ReqBody contentTypeList a` becomes an argument of type `a`; + +And that's it. You can see this example in action by running `dist/build/tutorial/tutorial 3`. + +``` bash +$ curl http://localhost:8081/position/1/2 +{"x":1,"y":2} +$ curl http://localhost:8081/hello +{"msg":"Hello, anonymous coward"} +$ curl http://localhost:8081/hello?name=Alp +{"msg":"Hello, Alp"} +$ curl -X POST -d '{"name":"Alp Mestanogullari", "email" : "alp@foo.com", "age": 25, "interested_in": ["haskell", "mathematics"]}' -H 'Accept: application/json' -H 'Content-type: application/json' http://localhost:8081/marketing +{"subject":"Hey Alp Mestanogullari, we miss you!","body":"Hi Alp Mestanogullari,\n\nSince you've recently turned 25, have you checked out our latest haskell, mathematics products? Give us a visit!","to":"alp@foo.com","from":"great@company.com"} +``` + +For reference, here's a list of some combinators from *servant* and for those +that get turned into arguments to the handlers, the type of the argument. + + > - `Delete`, `Get`, `Patch`, `Post`, `Put`: these do not become arguments. They provide the return type of handlers, which usually is `EitherT ServantErr IO `. + > - `Capture "something" a` becomes an argument of type `a`. + > - `QueryParam "something" a`, `MatrixParam "something" a`, `Header "something" a` all become arguments of type `Maybe a`, because there might be no value at all specified by the client for these. + > - `QueryFlag "something"` and `MatrixFlag "something"` get turned into arguments of type `Bool`. + > - `QueryParams "something" a` and `MatrixParams "something" a` get turned into arguments of type `[a]`. + > - `ReqBody contentTypes a` gets turned into an argument of type `a`. + +The `FromText`/`ToText` classes +=============================== + +Wait... How does *servant* know how to decode the `Int`s from the URL? Or how +to decode a `ClientInfo` value from the request body? This is what this and the +following two sections address. + +`Capture`s and `QueryParam`s are represented by some textual value in URLs. +`Header`s are similarly represented by a pair of a header name and a +corresponding (textual) value in the request's "metadata". This is why we +decided to provide a pair of typeclasses, `FromText` and `ToText` which just +let you say that you can respectively *extract* or *encode* values of some type +*from*/*to* text. Here are the definitions: + +``` haskell +class FromText a where + fromText :: Text -> Maybe a + +class ToText a where + toText :: a -> Text +``` + +And as long as the type that a `Capture`/`QueryParam`/`Header`/etc will be +decoded to provides a `FromText` instance, it will Just Work. *servant* +provides a decent number of instances, but here are some examples of defining +your own. + +> -- A typical enumeration +> data Direction +> = Up +> | Down +> | Left +> | Right +> +> instance FromText Direction where +> -- requires {-# LANGUAGE OverloadedStrings #-} +> fromText "up" = Just Up +> fromText "down" = Just Down +> fromText "left" = Just Server.Left +> fromText "right" = Just Server.Right +> fromText _ = Nothing +> +> instance ToText Direction where +> toText Up = "up" +> toText Down = "down" +> toText Server.Left = "left" +> toText Server.Right = "right" +> +> newtype UserId = UserId Int64 +> deriving (FromText, ToText) + +or writing the instances by hand: + +``` haskell +instance FromText UserId where + fromText = fmap UserId fromText + +instance ToText UserId where + toText (UserId i) = toText i +``` + +There's not much else to say about these classes. You will need instances for +them when using `Capture`, `QueryParam`, `QueryParams`, `MatrixParam`, +`MatrixParams` and `Header` with your types. You will need `FromText` instances +for server-side request handlers and `ToText` instances only when using +*servant-client*, as described in the [section about deriving haskell +functions to query an API](/tutorial/client.html). + +Using content-types with your data types +======================================== + +The same principle was operating when decoding request bodies from JSON, and +responses *into* JSON. (JSON is just the running example - you can do this with +any content-type.) + +This section introduces a couple of typeclasses provided by *servant* that make +all of this work. + +The truth behind `JSON` +----------------------- + +What exactly is `JSON`? Like the 3 other content types provided out of the box +by *servant*, it's a really dumb data type. + +``` haskell +data JSON +data PlainText +data FormUrlEncoded +data OctetStream +``` + +Obviously, this is not all there is to `JSON`, otherwise it would be quite +pointless. Like most of the data types in *servant*, `JSON` is mostly there as +a special *symbol* that's associated with encoding (resp. decoding) to (resp. +from) the *JSON* format. The way this association is performed can be +decomposed into two steps. + +The first step is to provide a proper +[`MediaType`](https://hackage.haskell.org/package/http-media-0.6.2/docs/Network-HTTP-Media.html) +representation for `JSON`, or for your own content types. If you look at the +haddocks from this link, you can see that we just have to specify +`application/json` using the appropriate functions. In our case, we can just +use `(//) :: ByteString -> ByteString -> MediaType`. The precise way to specify +the `MediaType` is to write an instance for the `Accept` class: + +``` haskell +-- for reference: +class Accept ctype where + contentType :: Proxy ctype -> MediaType + +instance Accept JSON where + contentType _ = "application" // "json" +``` + +The second step is centered around the `MimeRender` and `MimeUnrender` classes. +These classes just let you specify a way to respectively encode and decode +values respectively into or from your content-type's representation. + +``` haskell +class Accept ctype => MimeRender ctype a where + mimeRender :: Proxy ctype -> a -> ByteString + -- alternatively readable as: + mimeRender :: Proxy ctype -> (a -> ByteString) +``` + +Given a content-type and some user type, `MimeRender` provides a function that +encodes values of type `a` to lazy `ByteString`s. + +In the case of `JSON`, this is easily dealt with! For any type `a` with a +`ToJSON` instance, we can render values of that type to JSON using +`Data.Aeson.encode`. + +``` haskell +instance ToJSON a => MimeRender JSON a where + mimeRender _ = encode +``` + +And now the `MimeUnrender` class, which lets us extract values from lazy +`ByteString`s, alternatively failing with an error string. + +``` haskell +class Accept ctype => MimeUnrender ctype a where + mimeUnrender :: Proxy ctype -> ByteString -> Either String a + -- alternatively: + mimeUnrender :: Proxy ctype -> (ByteString -> Either String a) +``` + +We don't have much work to do there either, `Data.Aeson.eitherDecode` is +precisely what we need. However, it only allows arrays and objects as toplevel +JSON values and this has proven to get in our way more than help us so we wrote +our own little function around *aeson* and *attoparsec* that allows any type of +JSON value at the toplevel of a "JSON document". Here's the definition in case +you are curious. + +> eitherDecodeLenient :: FromJSON a => ByteString -> Either String a +> eitherDecodeLenient input = do +> v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input) +> parseEither parseJSON v + +This function is exactly what we need for our `MimeUnrender` instance. + +``` haskell +instance FromJSON a => MimeUnrender JSON a where + mimeUnrender _ = eitherDecodeLenient +``` + +And this is all the code that lets you use `JSON` for with `ReqBody`, `Get`, +`Post` and friends. We can check our understanding by implementing support +for an `HTML` content type, so that users of your webservice can access an +HTML representation of the data they want, ready to be included in any HTML +document, e.g. using [jQuery's `load` function](https://api.jquery.com/load/), simply by adding `Accept: +text/html` to their request headers. + +Case-studies: *servant-blaze* and *servant-lucid* +------------------------------------------------- + +These days, most of the haskellers who write their HTML UIs directly from +Haskell use either [blaze-html](http://hackage.haskell.org/package/blaze-html) +or [lucid](http://hackage.haskell.org/package/lucid). The best option for +*servant* is obviously to support both (and hopefully other templating +solutions!). + +> data HTMLLucid + +Once again, the data type is just there as a symbol for the encoding/decoding +functions, except that this time we will only worry about encoding since +*blaze-html* and *lucid* don't provide a way to extract data from HTML. + +Both packages also have the same `Accept` instance for their `HTMLLucid` type. + +> instance Accept HTMLLucid where +> contentType _ = "text" // "html" /: ("charset", "utf-8") + +Note that this instance uses the `(/:)` operator from *http-media* which lets +us specify additional information about a content-type, like the charset here. + +The rendering instances for both packages both call similar functions that take +types with an appropriate instance to an "abstract" HTML representation and +then write that to a `ByteString`. + +For *lucid*: + +> instance ToHtml a => MimeRender HTMLLucid a where +> mimeRender _ = renderBS . toHtml +> +> -- let's also provide an instance for lucid's +> -- 'Html' wrapper. +> instance MimeRender HTMLLucid (Html a) where +> mimeRender _ = renderBS + +For *blaze-html*: + +> -- For this tutorial to compile 'HTMLLucid' and 'HTMLBlaze' have to be +> -- distinct. Usually you would stick to one html rendering library and then +> -- you can go with one 'HTML' type. +> data HTMLBlaze +> +> instance Accept HTMLBlaze where +> contentType _ = "text" // "html" /: ("charset", "utf-8") +> +> instance ToMarkup a => MimeRender HTMLBlaze a where +> mimeRender _ = renderHtml . Text.Blaze.Html.toHtml +> +> -- while we're at it, just like for lucid we can +> -- provide an instance for rendering blaze's 'Html' type +> instance MimeRender HTMLBlaze Text.Blaze.Html.Html where +> mimeRender _ = renderHtml + +Both [servant-blaze](http://hackage.haskell.org/package/servant-blaze) and +[servant-lucid](http://hackage.haskell.org/package/servant-lucid) let you use +`HTMLLucid` in any content type list as long as you provide an instance of the +appropriate class (`ToMarkup` for *blaze-html*, `ToHtml` for *lucid*). + +We can now write webservice that uses *servant-lucid* to show the `HTMLLucid` +content type in action. First off, imports and pragmas as usual. + +We will be serving the following API: + +> type PersonAPI = "persons" :> Get '[JSON, HTMLLucid] [Person] + +where `Person` is defined as follows: + +> data Person = Person +> { firstName :: String +> , lastName :: String +> } deriving Generic -- for the JSON instance +> +> instance ToJSON Person + +Now, let's teach *lucid* how to render a `Person` as a row in a table, and then +a list of `Person`s as a table with a row per person. + +> -- HTML serialization of a single person +> instance ToHtml Person where +> toHtml person = +> tr_ $ do +> td_ (toHtml $ firstName person) +> td_ (toHtml $ lastName person) +> +> -- do not worry too much about this +> toHtmlRaw = toHtml +> +> -- HTML serialization of a list of persons +> instance ToHtml [Person] where +> toHtml persons = table_ $ do +> tr_ $ do +> th_ "first name" +> th_ "last name" +> +> -- this just calls toHtml on each person of the list +> -- and concatenates the resulting pieces of HTML together +> foldMap toHtml persons +> +> toHtmlRaw = toHtml + +We create some `Person` values and serve them as a list: + +> persons :: [Person] +> persons = +> [ Person "Isaac" "Newton" +> , Person "Albert" "Einstein" +> ] +> +> personAPI :: Proxy PersonAPI +> personAPI = Proxy +> +> server4 :: Server PersonAPI +> server4 = return persons +> +> app2 :: Application +> app2 = serve personAPI server4 + +And we're good to go. You can run this example with `dist/build/tutorial/tutorial 4`. + +``` bash + $ curl http://localhost:8081/persons + [{"lastName":"Newton","firstName":"Isaac"},{"lastName":"Einstein","firstName":"Albert"}] + $ curl -H 'Accept: text/html' http://localhost:8081/persons +
first namelast name
IsaacNewton
AlbertEinstein
+ # or just point your browser to http://localhost:8081/persons +``` + +The `EitherT ServantErr IO` monad +================================= + +At the heart of the handlers is the monad they run in, namely `EitherT +ServantErr IO`. One might wonder: why this monad? The answer is that it is the +simplest monad with the following properties: + +- it lets us both return a successful result (with the `Right` branch of +`Either`) or "fail" with a descriptive error (with the `Left` branch of +`Either`); +- it lets us perform IO, which is absolutely vital since most webservices exist +as interfaces to databases that we interact with in `IO`; + +Let's recall some definitions. + +``` haskell +-- from the Prelude +data Either e a = Left e | Right a + +-- from the 'either' package at +-- http://hackage.haskell.org/package/either-4.3.3.2/docs/Control-Monad-Trans-Either.html +newtype EitherT e m a + = EitherT { runEitherT :: m (Either e a) } +``` + +In short, this means that a handler of type `EitherT ServantErr IO a` is simply +equivalent to a computation of type `IO (Either ServantErr a)`, that is, an IO +action that either returns an error or a result. + +The aforementioned `either` package is worth taking a look at. Perhaps most +importantly: + +``` haskell +left :: Monad m => e -> EitherT e m a +``` +Allows you to return an error from your handler (whereas `return` is enough to +return a success). + +Most of what you'll be doing in your handlers is running some IO and, +depending on the result, you might sometimes want to throw an error of some +kind and abort early. The next two sections cover how to do just that. + +Performing IO +------------- + +Another important instance from the list above is `MonadIO m => MonadIO (EitherT e m)`. [`MonadIO`](http://hackage.haskell.org/package/transformers-0.4.3.0/docs/Control-Monad-IO-Class.html) is a class from the *transformers* package defined as: + +``` haskell +class Monad m => MonadIO m where + liftIO :: IO a -> m a +``` + +Obviously, the `IO` monad provides a `MonadIO` instance. Hence for any type `e`, `EitherT e IO` has a `MonadIO` instance. So if you want to run any kind of IO computation in your handlers, just use `liftIO`: + +> type IOAPI1 = "myfile.txt" :> Get '[JSON] FileContent +> +> newtype FileContent = FileContent +> { content :: String } +> deriving Generic +> +> instance ToJSON FileContent +> +> server5 :: Server IOAPI1 +> server5 = do +> filecontent <- liftIO (readFile "myfile.txt") +> return (FileContent filecontent) + +Failing, through `ServantErr` +----------------------------- + +If you want to explicitly fail at providing the result promised by an endpoint +using the appropriate HTTP status code (not found, unauthorized, etc) and some +error message, all you have to do is use the `left` function mentioned above +and provide it with the appropriate value of type `ServantErr`, which is +defined as: + +``` haskell +data ServantErr = ServantErr + { errHTTPCode :: Int + , errReasonPhrase :: String + , errBody :: ByteString -- lazy bytestring + , errHeaders :: [Header] + } +``` + +Many standard values are provided out of the box by the `Servant.Server` +module. If you want to use these values but add a body or some headers, just +use record update syntax: + +> failingHandler :: EitherT ServantErr IO () +> failingHandler = left myerr +> +> where myerr :: ServantErr +> myerr = err503 { errBody = "Sorry dear user." } + +Here's an example where we return a customised 404-Not-Found error message in +the response body if "myfile.txt" isn't there: + +> server6 :: Server IOAPI1 +> server6 = do +> exists <- liftIO (doesFileExist "myfile.txt") +> if exists +> then liftIO (readFile "myfile.txt") >>= return . FileContent +> else left custom404Err +> +> where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." } + +Let's run this server (`dist/build/tutorial/tutorial 5`) and +query it, first without the file and then with the file. + +``` bash + $ curl --verbose http://localhost:8081/myfile.txt + [snip] + * Connected to localhost (127.0.0.1) port 8081 (#0) + > GET /myfile.txt HTTP/1.1 + > User-Agent: curl/7.30.0 + > Host: localhost:8081 + > Accept: */* + > + < HTTP/1.1 404 Not Found + [snip] + myfile.txt just isnt there, please leave this server alone. + + $ echo Hello > myfile.txt + + $ curl --verbose http://localhost:8081/myfile.txt + [snip] + * Connected to localhost (127.0.0.1) port 8081 (#0) + > GET /myfile.txt HTTP/1.1 + > User-Agent: curl/7.30.0 + > Host: localhost:8081 + > Accept: */* + > + < HTTP/1.1 200 OK + [snip] + < Content-Type: application/json + [snip] + {"content":"Hello\n"} +``` + +Response headers +================ + +To add headers to your response, use [addHeader](http://hackage.haskell.org/package/servant-0.4.4/docs/Servant-API-ResponseHeaders.html). +Note that this changes the type of your API, as we can see in the following example: + +> type MyHandler = Get '[JSON] (Headers '[Header "X-An-Int" Int] User) +> +> myHandler :: Server MyHandler +> myHandler = return $ addHeader 1797 albert + + +Serving static files +==================== + +*servant-server* also provides a way to just serve the content of a directory +under some path in your web API. As mentioned earlier in this document, the +`Raw` combinator can be used in your APIs to mean "plug here any WAI +application". Well, servant-server provides a function to get a file and +directory serving WAI application, namely: + +``` haskell +-- exported by Servant and Servant.Server +serveDirectory :: FilePath -> Server Raw +``` + +`serveDirectory`'s argument must be a path to a valid directory. You can see an +example below, runnable with `dist/build/tutorial/tutorial 6` +(you **must** run it from within the *servant-examples/* directory!), which is +a webserver that serves the various bits of code covered in this +getting-started. + +The API type will be the following. + +> type CodeAPI = "code" :> Raw + +And the server: + +> codeAPI :: Proxy CodeAPI +> codeAPI = Proxy + +> server7 :: Server CodeAPI +> server7 = serveDirectory "tutorial" +> +> app3 :: Application +> app3 = serve codeAPI server7 + +This server will match any request whose path starts with `/code` and will look for a file at the path described by the rest of the request path, inside the *tutorial/* directory of the path you run the program from. + +In other words: + +- If a client requests `/code/foo.txt`, the server will look for a file at `./tutorial/foo.txt` (and fail) +- If a client requests `/code/T1.hs`, the server will look for a file at `./tutorial/T1.hs` (and succeed) +- If a client requests `/code/foo/bar/baz/movie.mp4`, the server will look for a file at `./tutorial/foo/bar/baz/movie.mp4` (and fail) + +Here is our little server in action. + +``` haskell +$ curl http://localhost:8081/code/T1.hs +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} +module T1 where + +import Data.Aeson +import Data.Time.Calendar +import GHC.Generics +import Network.Wai +import Servant + +data User = User + { name :: String + , age :: Int + , email :: String + , registration_date :: Day + } deriving (Eq, Show, Generic) + +-- orphan ToJSON instance for Day. necessary to derive one for User +instance ToJSON Day where + -- display a day in YYYY-mm-dd format + toJSON d = toJSON (showGregorian d) + +instance ToJSON User + +type UserAPI = "users" :> Get '[JSON] [User] + +users :: [User] +users = + [ User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1) + , User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1) + ] + +userAPI :: Proxy UserAPI +userAPI = Proxy + +server :: Server UserAPI +server = return users + +app :: Application +app = serve userAPI server +$ curl http://localhost:8081/code/tutorial.hs +import Network.Wai +import Network.Wai.Handler.Warp +import System.Environment + +import qualified T1 +import qualified T2 +import qualified T3 +import qualified T4 +import qualified T5 +import qualified T6 +import qualified T7 +import qualified T9 +import qualified T10 + +app :: String -> (Application -> IO ()) -> IO () +app n f = case n of + "1" -> f T1.app + "2" -> f T2.app + "3" -> f T3.app + "4" -> f T4.app + "5" -> f T5.app + "6" -> f T6.app + "7" -> f T7.app + "8" -> f T3.app + "9" -> T9.writeJSFiles >> f T9.app + "10" -> f T10.app + _ -> usage + +main :: IO () +main = do + args <- getArgs + case args of + [n] -> app n (run 8081) + _ -> usage + +usage :: IO () +usage = do + putStrLn "Usage:\t tutorial N" + putStrLn "\t\twhere N is the number of the example you want to run." + +$ curl http://localhost:8081/foo +not found +``` + +Nested APIs +=========== + +Let's see how you can define APIs in a modular way, while avoiding repetition. Consider this simple example: + +> type UserAPI3 = -- view the user with given userid, in JSON +> Capture "userid" Int :> Get '[JSON] User +> +> :<|> -- delete the user with given userid. empty response +> Capture "userid" Int :> Delete '[] () + +We can instead factor out the `userid`: + +> type UserAPI4 = Capture "userid" Int :> +> ( Get '[JSON] User +> :<|> Delete '[] () +> ) + +However, you have to be aware that this has an effect on the type of the corresponding `Server`: + +``` haskell +Server UserAPI3 = (Int -> EitherT ServantErr IO User) + :<|> (Int -> EitherT ServantErr IO ()) + +Server UserAPI4 = Int -> ( EitherT ServantErr IO User + :<|> EitherT ServantErr IO () + ) +``` + +In the first case, each handler receives the *userid* argument. In the latter, +the whole `Server` takes the *userid* and has handlers that are just computations in `EitherT`, with no arguments. In other words: + +> server8 :: Server UserAPI3 +> server8 = getUser :<|> deleteUser +> +> where getUser :: Int -> EitherT ServantErr IO User +> getUser _userid = error "..." +> +> deleteUser :: Int -> EitherT ServantErr IO () +> deleteUser _userid = error "..." +> +> -- notice how getUser and deleteUser +> -- have a different type! no argument anymore, +> -- the argument directly goes to the whole Server +> server9 :: Server UserAPI4 +> server9 userid = getUser userid :<|> deleteUser userid +> +> where getUser :: Int -> EitherT ServantErr IO User +> getUser = error "..." +> +> deleteUser :: Int -> EitherT ServantErr IO () +> deleteUser = error "..." + +Note that there's nothing special about `Capture` that lets you "factor it out": this can be done with any combinator. Here are a few examples of APIs with a combinator factored out for which we can write a perfectly valid `Server`. + +> -- we just factor out the "users" path fragment +> type API1 = "users" :> +> ( Get '[JSON] [User] -- user listing +> :<|> Capture "userid" Int :> Get '[JSON] User -- view a particular user +> ) +> +> -- we factor out the Request Body +> type API2 = ReqBody '[JSON] User :> +> ( Get '[JSON] User -- just display the same user back, don't register it +> :<|> Post '[JSON] () -- register the user. empty response +> ) +> +> -- we factor out a Header +> type API3 = Header "Authorization" Token :> +> ( Get '[JSON] SecretData -- get some secret data, if authorized +> :<|> ReqBody '[JSON] SecretData :> Post '[] () -- add some secret data, if authorized +> ) +> +> newtype Token = Token ByteString +> newtype SecretData = SecretData ByteString + +This approach lets you define APIs modularly and assemble them all into one big API type only at the end. + +> type UsersAPI = +> Get '[JSON] [User] -- list users +> :<|> ReqBody '[JSON] User :> Post '[] () -- add a user +> :<|> Capture "userid" Int :> +> ( Get '[JSON] User -- view a user +> :<|> ReqBody '[JSON] User :> Put '[] () -- update a user +> :<|> Delete '[] () -- delete a user +> ) +> +> usersServer :: Server UsersAPI +> usersServer = getUsers :<|> newUser :<|> userOperations +> +> where getUsers :: EitherT ServantErr IO [User] +> getUsers = error "..." +> +> newUser :: User -> EitherT ServantErr IO () +> newUser = error "..." +> +> userOperations userid = +> viewUser userid :<|> updateUser userid :<|> deleteUser userid +> +> where +> viewUser :: Int -> EitherT ServantErr IO User +> viewUser = error "..." +> +> updateUser :: Int -> User -> EitherT ServantErr IO () +> updateUser = error "..." +> +> deleteUser :: Int -> EitherT ServantErr IO () +> deleteUser = error "..." + +> type ProductsAPI = +> Get '[JSON] [Product] -- list products +> :<|> ReqBody '[JSON] Product :> Post '[] () -- add a product +> :<|> Capture "productid" Int :> +> ( Get '[JSON] Product -- view a product +> :<|> ReqBody '[JSON] Product :> Put '[] () -- update a product +> :<|> Delete '[] () -- delete a product +> ) +> +> data Product = Product { productId :: Int } +> +> productsServer :: Server ProductsAPI +> productsServer = getProducts :<|> newProduct :<|> productOperations +> +> where getProducts :: EitherT ServantErr IO [Product] +> getProducts = error "..." +> +> newProduct :: Product -> EitherT ServantErr IO () +> newProduct = error "..." +> +> productOperations productid = +> viewProduct productid :<|> updateProduct productid :<|> deleteProduct productid +> +> where +> viewProduct :: Int -> EitherT ServantErr IO Product +> viewProduct = error "..." +> +> updateProduct :: Int -> Product -> EitherT ServantErr IO () +> updateProduct = error "..." +> +> deleteProduct :: Int -> EitherT ServantErr IO () +> deleteProduct = error "..." + +> type CombinedAPI = "users" :> UsersAPI +> :<|> "products" :> ProductsAPI +> +> server10 :: Server CombinedAPI +> server10 = usersServer :<|> productsServer + +Finally, we can realize the user and product APIs are quite similar and abstract that away: + +> -- API for values of type 'a' +> -- indexed by values of type 'i' +> type APIFor a i = +> Get '[JSON] [a] -- list 'a's +> :<|> ReqBody '[JSON] a :> Post '[] () -- add an 'a' +> :<|> Capture "id" i :> +> ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i' +> :<|> ReqBody '[JSON] a :> Put '[] () -- update an 'a' +> :<|> Delete '[] () -- delete an 'a' +> ) +> +> -- Build the appropriate 'Server' +> -- given the handlers of the right type. +> serverFor :: EitherT ServantErr IO [a] -- handler for listing of 'a's +> -> (a -> EitherT ServantErr IO ()) -- handler for adding an 'a' +> -> (i -> EitherT ServantErr IO a) -- handler for viewing an 'a' given its identifier of type 'i' +> -> (i -> a -> EitherT ServantErr IO ()) -- updating an 'a' with given id +> -> (i -> EitherT ServantErr IO ()) -- deleting an 'a' given its id +> -> Server (APIFor a i) +> serverFor = error "..." +> -- implementation left as an exercise. contact us on IRC +> -- or the mailing list if you get stuck! + +Using another monad for your handlers +===================================== + +Remember how `Server` turns combinators for HTTP methods into `EitherT ServantErr IO`? Well, actually, there's more to that. `Server` is actually a simple type synonym. + +``` haskell +type Server api = ServerT api (EitherT ServantErr IO) +``` + +`ServerT` is the actual type family that computes the required types for the handlers that's part of the `HasServer` class. It's like `Server` except that it takes a third parameter which is the monad you want your handlers to run in, or more generally the return types of your handlers. This third parameter is used for specifying the return type of the handler for an endpoint, e.g when computing `ServerT (Get '[JSON] Person) SomeMonad`. The result would be `SomeMonad Person`. + +The first and main question one might have then is: how do we write handlers that run in another monad? How can we "bring back" the value from a given monad into something *servant* can understand? + +Natural transformations +----------------------- + +If we have a function that gets us from an `m a` to an `n a`, for any `a`, what +do we have? + +``` haskell +newtype m :~> n = Nat { unNat :: forall a. m a -> n a} + +-- For example +-- listToMaybeNat ::`[] :~> Maybe` +-- listToMaybeNat = Nat listToMaybe -- from Data.Maybe +``` +(`Nat` comes from "natural transformation", in case you're wondering.) + +So if you want to write handlers using another monad/type than `EitherT +ServantErr IO`, say the `Reader String` monad, the first thing you have to +prepare is a function: + +``` haskell +readerToEither :: Reader String :~> EitherT ServantErr IO +``` + +Let's start with `readerToEither'`. We obviously have to run the `Reader` +computation by supplying it with a `String`, like `"hi"`. We get an `a` out +from that and can then just `return` it into `EitherT`. We can then just wrap +that function with the `Nat` constructor to make it have the fancier type. + +> readerToEither' :: forall a. Reader String a -> EitherT ServantErr IO a +> readerToEither' r = return (runReader r "hi") +> +> readerToEither :: Reader String :~> EitherT ServantErr IO +> readerToEither = Nat readerToEither' + +We can write some simple webservice with the handlers running in `Reader String`. + +> type ReaderAPI = "a" :> Get '[JSON] Int +> :<|> "b" :> Get '[JSON] String +> +> readerAPI :: Proxy ReaderAPI +> readerAPI = Proxy +> +> readerServerT :: ServerT ReaderAPI (Reader String) +> readerServerT = a :<|> b +> +> where a :: Reader String Int +> a = return 1797 +> +> b :: Reader String String +> b = ask + +We unfortunately can't use `readerServerT` as an argument of `serve`, because +`serve` wants a `Server ReaderAPI`, i.e., with handlers running in `EitherT +ServantErr IO`. But there's a simple solution to this. + +Enter `enter` +------------- + +That's right. We have just written `readerToEither`, which is exactly what we +would need to apply to the results of all handlers to make the handlers have the +right type for `serve`. Being cumbersome to do by hand, we provide a function +`enter` which takes a natural transformation between two parametrized types `m` +and `n` and a `ServerT someapi m`, and returns a `ServerT someapi n`. + +In our case, we can wrap up our little webservice by using `enter readerToEither` on our handlers. + +> readerServer :: Server ReaderAPI +> readerServer = enter readerToEither readerServerT +> +> app4 :: Application +> app4 = serve readerAPI readerServer + +And we can indeed see this webservice in action by running `dist/build/tutorial/tutorial 7`. + +``` bash +$ curl http://localhost:8081/a +1797 +$ curl http://localhost:8081/b +"hi" +``` + +Conclusion +========== + +You're now equipped to write any kind of webservice/web-application using *servant*. One thing not covered here is how to incorporate your own combinators and will be the topic of a page on the website. The rest of this document focuses on *servant-client*, *servant-jquery* and *servant-docs*. + + From 6c0a7ba8d85b29a3a43342906337188bedd99d7b Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 25 Jan 2016 14:24:38 +0100 Subject: [PATCH 099/180] Fix links --- tutorial/conf.py | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/tutorial/conf.py b/tutorial/conf.py index 6d4f897d..832c0cf8 100644 --- a/tutorial/conf.py +++ b/tutorial/conf.py @@ -1,6 +1,6 @@ # -*- coding: utf-8 -*- # -# generics-eot documentation build configuration file, created by +# servant documentation build configuration file, created by # sphinx-quickstart on Fri Jan 22 12:22:48 2016. # # This file is execfile()d with the current directory set to its @@ -36,7 +36,7 @@ templates_path = ['_templates'] # The suffix(es) of source filenames. # You can specify multiple suffix as a list of string: -source_suffix = ['.md', '.rst'] +source_suffix = ['.md', '.rst', '.lhs'] # The encoding of source files. #source_encoding = 'utf-8-sig' @@ -45,9 +45,9 @@ source_suffix = ['.md', '.rst'] master_doc = 'index' # General information about the project. -project = u'generics-eot' -copyright = u'2016, Sönke Hahn' -author = u'Sönke Hahn' +project = u'servant' +copyright = u'2016, Servant Contributors' +author = u'Servant Contributors' # The version info for the project you're documenting, acts as replacement for # |version| and |release|, also used in various other places throughout the @@ -199,7 +199,7 @@ html_static_path = ['_static'] #html_search_scorer = 'scorer.js' # Output file base name for HTML help builder. -htmlhelp_basename = 'generics-eotdoc' +htmlhelp_basename = 'servantdoc' # -- Options for LaTeX output --------------------------------------------- @@ -221,8 +221,8 @@ latex_elements = { # (source start file, target name, title, # author, documentclass [howto, manual, or own class]). latex_documents = [ - (master_doc, 'generics-eot.tex', u'generics-eot Documentation', - u'Sönke Hahn', 'manual'), + (master_doc, 'servant.tex', u'servant Documentation', + u'Servant Contributors', 'manual'), ] # The name of an image file (relative to this directory) to place at the top of @@ -251,7 +251,7 @@ latex_documents = [ # One entry per manual page. List of tuples # (source start file, name, description, authors, manual section). man_pages = [ - (master_doc, 'generics-eot', u'generics-eot Documentation', + (master_doc, 'servant', u'servant Documentation', [author], 1) ] @@ -265,8 +265,8 @@ man_pages = [ # (source start file, target name, title, author, # dir menu entry, description, category) texinfo_documents = [ - (master_doc, 'generics-eot', u'generics-eot Documentation', - author, 'generics-eot', 'One line description of project.', + (master_doc, 'servant', u'servant Documentation', + author, 'servant', 'One line description of project.', 'Miscellaneous'), ] @@ -284,4 +284,5 @@ texinfo_documents = [ source_parsers = { '.md': CommonMarkParser, + '.lhs': CommonMarkParser, } From 7bb393fe17ed8262dd36c72e99d83a142a50a0de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 25 Jan 2016 22:06:44 +0100 Subject: [PATCH 100/180] switch to rtd default theme --- tutorial/conf.py | 2 +- tutorial/index.md | 68 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 69 insertions(+), 1 deletion(-) create mode 100644 tutorial/index.md diff --git a/tutorial/conf.py b/tutorial/conf.py index 832c0cf8..48d677b6 100644 --- a/tutorial/conf.py +++ b/tutorial/conf.py @@ -107,7 +107,7 @@ todo_include_todos = False # The theme to use for HTML and HTML Help pages. See the documentation for # a list of builtin themes. -html_theme = 'alabaster' +html_theme = 'sphinx_rtd_theme' # Theme options are theme-specific and customize the look and feel of a theme # further. For a list of options available for each theme, see the diff --git a/tutorial/index.md b/tutorial/index.md new file mode 100644 index 00000000..378155e1 --- /dev/null +++ b/tutorial/index.md @@ -0,0 +1,68 @@ +Servant tutorial +================ + +This is an introductory tutorial to the current version of *servant*, which is **0.4**. Any comment or issue can be directed to [this website's issue tracker](http://github.com/haskell-servant/haskell-servant.github.io/issues). + +Github +------- + +- the servant packages: [haskell-servant/servant](https://github.com/haskell-servant/servant) +- the website (including this tutorial): [haskell-servant/haskell-servant.github.io](https://github.com/haskell-servant/haskell-servant.github.io/) +- Feel free to use the issue tracker (or to send PRs!) on the website's repository to give feedback and suggestions about this tutorial + +Introduction +------------- + +*servant* has the following guiding principles: + +- concision + + This is a pretty wide-ranging principle. You should be able to get nice + documentation for your web servers, and client libraries, without repeating + yourself. You should not have to manually serialize and deserialize your + resources, but only declare how to do those things *once per type*. If a + bunch of your handlers take the same query parameters, you shouldn't have to + repeat that logic for each handler, but instead just "apply" it to all of + them at once. Your handlers shouldn't be where composition goes to die. And + so on. + +- flexibility + + If we haven't thought of your use case, it should still be easily + achievable. If you want to use templating library X, go ahead. Forms? Do + them however you want, but without difficulty. We're not opinionated. + +- separation of concerns + + Your handlers and your HTTP logic should be separate. True to the philosphy + at the core of HTTP and REST, with *servant* your handlers return normal + Haskell datatypes - that's the resource. And then from a description of your + API, *servant* handles the *presentation* (i.e., the Content-Types). But + that's just one example. + +- type safety + + Want to be sure your API meets a specification? Your compiler can check + that for you. Links you can be sure exist? You got it. + +To stick true to these principles, we do things a little differently than you +might expect. The core idea is *reifying the description of your API*. Once +reified, everything follows. We think we might be the first web framework to +reify API descriptions in an extensible way. We're pretty sure we're the first +to reify it as *types*. + +To be able to write a webservice you only need to read the first two sections, +but the goal of this document being to get you started with servant, we also +cover the couple of ways you can extend servant for a great good. + +Tutorial +--------- + +.. toctree:: + :maxdepth: 2 + + api-type.lhs + server.lhs + client.lhs + javascript.lhs + docs.lhs From 1d4e3a1e5b88aa7b54802a7e40aa606a5126c391 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Mon, 25 Jan 2016 22:30:16 +0100 Subject: [PATCH 101/180] Moved tutorial to servant-examples/tutorial and include it in doc/index.rst --- .gitignore | 2 +- {tutorial => doc}/Makefile | 0 doc/conf.py | 15 +- doc/index.rst | 3 +- {tutorial => doc}/requirements.txt | 0 doc/tutorial | 1 + servant-examples/tutorial/T8.hs | 49 --- .../tutorial}/api-type.lhs | 0 .../tutorial}/client.lhs | 0 .../tutorial}/docs.lhs | 0 .../tutorial}/index.rst | 2 +- .../tutorial}/javascript.lhs | 0 .../tutorial}/server.lhs | 0 servant-examples/tutorial/t8-main.hs | 4 - servant-examples/tutorial/t9/index.html | 26 -- servant-examples/tutorial/t9/ui.js | 61 ---- servant-examples/tutorial/tutorial.hs | 39 --- tutorial/conf.py | 288 ------------------ tutorial/index.md | 68 ----- 19 files changed, 13 insertions(+), 545 deletions(-) rename {tutorial => doc}/Makefile (100%) rename {tutorial => doc}/requirements.txt (100%) create mode 120000 doc/tutorial delete mode 100644 servant-examples/tutorial/T8.hs rename {tutorial => servant-examples/tutorial}/api-type.lhs (100%) rename {tutorial => servant-examples/tutorial}/client.lhs (100%) rename {tutorial => servant-examples/tutorial}/docs.lhs (100%) rename {tutorial => servant-examples/tutorial}/index.rst (99%) rename {tutorial => servant-examples/tutorial}/javascript.lhs (100%) rename {tutorial => servant-examples/tutorial}/server.lhs (100%) delete mode 100644 servant-examples/tutorial/t8-main.hs delete mode 100644 servant-examples/tutorial/t9/index.html delete mode 100644 servant-examples/tutorial/t9/ui.js delete mode 100644 servant-examples/tutorial/tutorial.hs delete mode 100644 tutorial/conf.py delete mode 100644 tutorial/index.md diff --git a/.gitignore b/.gitignore index ee3cbf51..f42f014b 100644 --- a/.gitignore +++ b/.gitignore @@ -25,4 +25,4 @@ Setup .stack-work shell.nix default.nix -tutorial/_build +doc/_build diff --git a/tutorial/Makefile b/doc/Makefile similarity index 100% rename from tutorial/Makefile rename to doc/Makefile diff --git a/doc/conf.py b/doc/conf.py index c2761418..4e31a37d 100644 --- a/doc/conf.py +++ b/doc/conf.py @@ -37,7 +37,7 @@ templates_path = ['_templates'] # The suffix(es) of source filenames. # You can specify multiple suffix as a list of string: -source_suffix = ['.md', '.rst'] +source_suffix = ['.md', '.rst', '.lhs'] # The encoding of source files. #source_encoding = 'utf-8-sig' @@ -47,8 +47,8 @@ master_doc = 'index' # General information about the project. project = u'servant' -copyright = u'2015-2016, Servant contributors' -author = u'Servant contributors' +copyright = u'2016, Servant Contributors' +author = u'Servant Contributors' # The version info for the project you're documenting, acts as replacement for # |version| and |release|, also used in various other places throughout the @@ -74,7 +74,7 @@ language = None # List of patterns, relative to source directory, that match files and # directories to ignore when looking for source files. -exclude_patterns = ['_build'] +exclude_patterns = ['_build', 'venv'] # The reST default role (used for this markup: `text`) to use for all # documents. @@ -108,7 +108,7 @@ todo_include_todos = False # The theme to use for HTML and HTML Help pages. See the documentation for # a list of builtin themes. -# html_theme = 'alabaster' +html_theme = 'sphinx_rtd_theme' # Theme options are theme-specific and customize the look and feel of a theme # further. For a list of options available for each theme, see the @@ -222,8 +222,8 @@ latex_elements = { # (source start file, target name, title, # author, documentclass [howto, manual, or own class]). latex_documents = [ - (master_doc, 'servant.tex', u'servant Documentation', - u'Servant contributors', 'manual'), + (master_doc, 'servant.tex', u'servant Documentation', + u'Servant Contributors', 'manual'), ] # The name of an image file (relative to this directory) to place at the top of @@ -285,4 +285,5 @@ texinfo_documents = [ source_parsers = { '.md': CommonMarkParser, + '.lhs': CommonMarkParser, } diff --git a/doc/index.rst b/doc/index.rst index 41b48c52..ca7b5e5f 100644 --- a/doc/index.rst +++ b/doc/index.rst @@ -5,7 +5,8 @@ Documentation table of contents ------------------------------- .. toctree:: + :maxdepth: 2 README.md + tutorial/index.rst CONTRIBUTING.md - diff --git a/tutorial/requirements.txt b/doc/requirements.txt similarity index 100% rename from tutorial/requirements.txt rename to doc/requirements.txt diff --git a/doc/tutorial b/doc/tutorial new file mode 120000 index 00000000..6072fcb4 --- /dev/null +++ b/doc/tutorial @@ -0,0 +1 @@ +../servant-examples/tutorial \ No newline at end of file diff --git a/servant-examples/tutorial/T8.hs b/servant-examples/tutorial/T8.hs deleted file mode 100644 index 4e55df6f..00000000 --- a/servant-examples/tutorial/T8.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T8 where - -import Control.Monad.Trans.Except -import Network.HTTP.Client (Manager, defaultManagerSettings, - newManager) -import Servant -import Servant.Client -import System.IO.Unsafe (unsafePerformIO) - -import T3 - -position :: Int -- ^ value for "x" - -> Int -- ^ value for "y" - -> ExceptT ServantError IO Position - -hello :: Maybe String -- ^ an optional value for "name" - -> ExceptT ServantError IO HelloMessage - -marketing :: ClientInfo -- ^ value for the request body - -> ExceptT ServantError IO Email - -position :<|> hello :<|> marketing = client api baseUrl manager - -baseUrl :: BaseUrl -baseUrl = BaseUrl Http "localhost" 8081 "" - -{-# NOINLINE manager #-} -manager :: Manager -manager = unsafePerformIO $ newManager defaultManagerSettings - -queries :: ExceptT ServantError IO (Position, HelloMessage, Email) -queries = do - pos <- position 10 10 - msg <- hello (Just "servant") - em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) - return (pos, msg, em) - -run :: IO () -run = do - res <- runExceptT queries - case res of - Left err -> putStrLn $ "Error: " ++ show err - Right (pos, msg, em) -> do - print pos - print msg - print em diff --git a/tutorial/api-type.lhs b/servant-examples/tutorial/api-type.lhs similarity index 100% rename from tutorial/api-type.lhs rename to servant-examples/tutorial/api-type.lhs diff --git a/tutorial/client.lhs b/servant-examples/tutorial/client.lhs similarity index 100% rename from tutorial/client.lhs rename to servant-examples/tutorial/client.lhs diff --git a/tutorial/docs.lhs b/servant-examples/tutorial/docs.lhs similarity index 100% rename from tutorial/docs.lhs rename to servant-examples/tutorial/docs.lhs diff --git a/tutorial/index.rst b/servant-examples/tutorial/index.rst similarity index 99% rename from tutorial/index.rst rename to servant-examples/tutorial/index.rst index 378155e1..9044a4d5 100644 --- a/tutorial/index.rst +++ b/servant-examples/tutorial/index.rst @@ -59,7 +59,7 @@ Tutorial --------- .. toctree:: - :maxdepth: 2 + :maxdepth: 1 api-type.lhs server.lhs diff --git a/tutorial/javascript.lhs b/servant-examples/tutorial/javascript.lhs similarity index 100% rename from tutorial/javascript.lhs rename to servant-examples/tutorial/javascript.lhs diff --git a/tutorial/server.lhs b/servant-examples/tutorial/server.lhs similarity index 100% rename from tutorial/server.lhs rename to servant-examples/tutorial/server.lhs diff --git a/servant-examples/tutorial/t8-main.hs b/servant-examples/tutorial/t8-main.hs deleted file mode 100644 index b0e4979d..00000000 --- a/servant-examples/tutorial/t8-main.hs +++ /dev/null @@ -1,4 +0,0 @@ -import T8 - -main :: IO () -main = run diff --git a/servant-examples/tutorial/t9/index.html b/servant-examples/tutorial/t9/index.html deleted file mode 100644 index 7ec49c70..00000000 --- a/servant-examples/tutorial/t9/index.html +++ /dev/null @@ -1,26 +0,0 @@ - - - - - - Tutorial - 9 - servant-jquery - - -

Books

- -
-

Results for ""

-
    -
-
-
-

Approximating π

-

Count: 0

-

Successes: 0

-

- - - - - - \ No newline at end of file diff --git a/servant-examples/tutorial/t9/ui.js b/servant-examples/tutorial/t9/ui.js deleted file mode 100644 index 7148827a..00000000 --- a/servant-examples/tutorial/t9/ui.js +++ /dev/null @@ -1,61 +0,0 @@ -/* book search */ -function updateResults(data) -{ - console.log(data); - $('#results').html(""); - $('#query').text("\"" + data.query + "\""); - for(var i = 0; i < data.results.length; i++) - { - $('#results').append(renderBook(data.results[i])); - } -} - -function renderBook(book) -{ - var li = '
  • ' + book.title + ', ' - + book.author + ' - ' + book.year + '
    • '; - return li; -} - -function searchBooks() -{ - var q = $('#q').val(); - getBooks(q, updateResults, console.log) -} - -searchBooks(); -$('#q').keyup(function() { - searchBooks(); -}); - -/* approximating pi */ -var count = 0; -var successes = 0; - -function f(data) -{ - var x = data.x, y = data.y; - if(x*x + y*y <= 1) - { - successes++; - } - - count++; - - update('#count', count); - update('#successes', successes); - update('#pi', 4*successes/count); -} - -function update(id, val) -{ - $(id).text(val); -} - -function refresh() -{ - getPoint(f, console.log); -} - -window.setInterval(refresh, 200); - diff --git a/servant-examples/tutorial/tutorial.hs b/servant-examples/tutorial/tutorial.hs deleted file mode 100644 index 32dc4c06..00000000 --- a/servant-examples/tutorial/tutorial.hs +++ /dev/null @@ -1,39 +0,0 @@ -import Network.Wai -import Network.Wai.Handler.Warp -import System.Environment - -import qualified T1 -import qualified T10 -import qualified T2 -import qualified T3 -import qualified T4 -import qualified T5 -import qualified T6 -import qualified T7 -import qualified T9 - -app :: String -> (Application -> IO ()) -> IO () -app n f = case n of - "1" -> f T1.app - "2" -> f T2.app - "3" -> f T3.app - "4" -> f T4.app - "5" -> f T5.app - "6" -> f T6.app - "7" -> f T7.app - "8" -> f T3.app - "9" -> T9.writeJSFiles >> f T9.app - "10" -> f T10.app - _ -> usage - -main :: IO () -main = do - args <- getArgs - case args of - [n] -> app n (run 8081) - _ -> usage - -usage :: IO () -usage = do - putStrLn "Usage:\t tutorial N" - putStrLn "\t\twhere N is the number of the example you want to run." diff --git a/tutorial/conf.py b/tutorial/conf.py deleted file mode 100644 index 48d677b6..00000000 --- a/tutorial/conf.py +++ /dev/null @@ -1,288 +0,0 @@ -# -*- coding: utf-8 -*- -# -# servant documentation build configuration file, created by -# sphinx-quickstart on Fri Jan 22 12:22:48 2016. -# -# This file is execfile()d with the current directory set to its -# containing dir. -# -# Note that not all possible configuration values are present in this -# autogenerated file. -# -# All configuration values have a default; values that are commented out -# serve to show the default. - -import sys -import os -from recommonmark.parser import CommonMarkParser - -# If extensions (or modules to document with autodoc) are in another directory, -# add these directories to sys.path here. If the directory is relative to the -# documentation root, use os.path.abspath to make it absolute, like shown here. -#sys.path.insert(0, os.path.abspath('.')) - -# -- General configuration ------------------------------------------------ - -# If your documentation needs a minimal Sphinx version, state it here. -#needs_sphinx = '1.0' - -# Add any Sphinx extension module names here, as strings. They can be -# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom -# ones. -extensions = [] - -# Add any paths that contain templates here, relative to this directory. -templates_path = ['_templates'] - -# The suffix(es) of source filenames. -# You can specify multiple suffix as a list of string: -source_suffix = ['.md', '.rst', '.lhs'] - -# The encoding of source files. -#source_encoding = 'utf-8-sig' - -# The master toctree document. -master_doc = 'index' - -# General information about the project. -project = u'servant' -copyright = u'2016, Servant Contributors' -author = u'Servant Contributors' - -# The version info for the project you're documenting, acts as replacement for -# |version| and |release|, also used in various other places throughout the -# built documents. -# -# The short X.Y version. -version = u'0.1' -# The full version, including alpha/beta/rc tags. -release = u'0.1' - -# The language for content autogenerated by Sphinx. Refer to documentation -# for a list of supported languages. -# -# This is also used if you do content translation via gettext catalogs. -# Usually you set "language" from the command line for these cases. -language = None - -# There are two options for replacing |today|: either, you set today to some -# non-false value, then it is used: -#today = '' -# Else, today_fmt is used as the format for a strftime call. -#today_fmt = '%B %d, %Y' - -# List of patterns, relative to source directory, that match files and -# directories to ignore when looking for source files. -exclude_patterns = ['_build', 'venv'] - -# The reST default role (used for this markup: `text`) to use for all -# documents. -#default_role = None - -# If true, '()' will be appended to :func: etc. cross-reference text. -#add_function_parentheses = True - -# If true, the current module name will be prepended to all description -# unit titles (such as .. function::). -#add_module_names = True - -# If true, sectionauthor and moduleauthor directives will be shown in the -# output. They are ignored by default. -#show_authors = False - -# The name of the Pygments (syntax highlighting) style to use. -pygments_style = 'sphinx' - -# A list of ignored prefixes for module index sorting. -#modindex_common_prefix = [] - -# If true, keep warnings as "system message" paragraphs in the built documents. -#keep_warnings = False - -# If true, `todo` and `todoList` produce output, else they produce nothing. -todo_include_todos = False - - -# -- Options for HTML output ---------------------------------------------- - -# The theme to use for HTML and HTML Help pages. See the documentation for -# a list of builtin themes. -html_theme = 'sphinx_rtd_theme' - -# Theme options are theme-specific and customize the look and feel of a theme -# further. For a list of options available for each theme, see the -# documentation. -#html_theme_options = {} - -# Add any paths that contain custom themes here, relative to this directory. -#html_theme_path = [] - -# The name for this set of Sphinx documents. If None, it defaults to -# " v documentation". -#html_title = None - -# A shorter title for the navigation bar. Default is the same as html_title. -#html_short_title = None - -# The name of an image file (relative to this directory) to place at the top -# of the sidebar. -#html_logo = None - -# The name of an image file (within the static path) to use as favicon of the -# docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32 -# pixels large. -#html_favicon = None - -# Add any paths that contain custom static files (such as style sheets) here, -# relative to this directory. They are copied after the builtin static files, -# so a file named "default.css" will overwrite the builtin "default.css". -html_static_path = ['_static'] - -# Add any extra paths that contain custom files (such as robots.txt or -# .htaccess) here, relative to this directory. These files are copied -# directly to the root of the documentation. -#html_extra_path = [] - -# If not '', a 'Last updated on:' timestamp is inserted at every page bottom, -# using the given strftime format. -#html_last_updated_fmt = '%b %d, %Y' - -# If true, SmartyPants will be used to convert quotes and dashes to -# typographically correct entities. -#html_use_smartypants = True - -# Custom sidebar templates, maps document names to template names. -#html_sidebars = {} - -# Additional templates that should be rendered to pages, maps page names to -# template names. -#html_additional_pages = {} - -# If false, no module index is generated. -#html_domain_indices = True - -# If false, no index is generated. -#html_use_index = True - -# If true, the index is split into individual pages for each letter. -#html_split_index = False - -# If true, links to the reST sources are added to the pages. -#html_show_sourcelink = True - -# If true, "Created using Sphinx" is shown in the HTML footer. Default is True. -#html_show_sphinx = True - -# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True. -#html_show_copyright = True - -# If true, an OpenSearch description file will be output, and all pages will -# contain a tag referring to it. The value of this option must be the -# base URL from which the finished HTML is served. -#html_use_opensearch = '' - -# This is the file name suffix for HTML files (e.g. ".xhtml"). -#html_file_suffix = None - -# Language to be used for generating the HTML full-text search index. -# Sphinx supports the following languages: -# 'da', 'de', 'en', 'es', 'fi', 'fr', 'hu', 'it', 'ja' -# 'nl', 'no', 'pt', 'ro', 'ru', 'sv', 'tr' -#html_search_language = 'en' - -# A dictionary with options for the search language support, empty by default. -# Now only 'ja' uses this config value -#html_search_options = {'type': 'default'} - -# The name of a javascript file (relative to the configuration directory) that -# implements a search results scorer. If empty, the default will be used. -#html_search_scorer = 'scorer.js' - -# Output file base name for HTML help builder. -htmlhelp_basename = 'servantdoc' - -# -- Options for LaTeX output --------------------------------------------- - -latex_elements = { -# The paper size ('letterpaper' or 'a4paper'). -#'papersize': 'letterpaper', - -# The font size ('10pt', '11pt' or '12pt'). -#'pointsize': '10pt', - -# Additional stuff for the LaTeX preamble. -#'preamble': '', - -# Latex figure (float) alignment -#'figure_align': 'htbp', -} - -# Grouping the document tree into LaTeX files. List of tuples -# (source start file, target name, title, -# author, documentclass [howto, manual, or own class]). -latex_documents = [ - (master_doc, 'servant.tex', u'servant Documentation', - u'Servant Contributors', 'manual'), -] - -# The name of an image file (relative to this directory) to place at the top of -# the title page. -#latex_logo = None - -# For "manual" documents, if this is true, then toplevel headings are parts, -# not chapters. -#latex_use_parts = False - -# If true, show page references after internal links. -#latex_show_pagerefs = False - -# If true, show URL addresses after external links. -#latex_show_urls = False - -# Documents to append as an appendix to all manuals. -#latex_appendices = [] - -# If false, no module index is generated. -#latex_domain_indices = True - - -# -- Options for manual page output --------------------------------------- - -# One entry per manual page. List of tuples -# (source start file, name, description, authors, manual section). -man_pages = [ - (master_doc, 'servant', u'servant Documentation', - [author], 1) -] - -# If true, show URL addresses after external links. -#man_show_urls = False - - -# -- Options for Texinfo output ------------------------------------------- - -# Grouping the document tree into Texinfo files. List of tuples -# (source start file, target name, title, author, -# dir menu entry, description, category) -texinfo_documents = [ - (master_doc, 'servant', u'servant Documentation', - author, 'servant', 'One line description of project.', - 'Miscellaneous'), -] - -# Documents to append as an appendix to all manuals. -#texinfo_appendices = [] - -# If false, no module index is generated. -#texinfo_domain_indices = True - -# How to display URL addresses: 'footnote', 'no', or 'inline'. -#texinfo_show_urls = 'footnote' - -# If true, do not generate a @detailmenu in the "Top" node's menu. -#texinfo_no_detailmenu = False - -source_parsers = { - '.md': CommonMarkParser, - '.lhs': CommonMarkParser, -} diff --git a/tutorial/index.md b/tutorial/index.md deleted file mode 100644 index 378155e1..00000000 --- a/tutorial/index.md +++ /dev/null @@ -1,68 +0,0 @@ -Servant tutorial -================ - -This is an introductory tutorial to the current version of *servant*, which is **0.4**. Any comment or issue can be directed to [this website's issue tracker](http://github.com/haskell-servant/haskell-servant.github.io/issues). - -Github -------- - -- the servant packages: [haskell-servant/servant](https://github.com/haskell-servant/servant) -- the website (including this tutorial): [haskell-servant/haskell-servant.github.io](https://github.com/haskell-servant/haskell-servant.github.io/) -- Feel free to use the issue tracker (or to send PRs!) on the website's repository to give feedback and suggestions about this tutorial - -Introduction -------------- - -*servant* has the following guiding principles: - -- concision - - This is a pretty wide-ranging principle. You should be able to get nice - documentation for your web servers, and client libraries, without repeating - yourself. You should not have to manually serialize and deserialize your - resources, but only declare how to do those things *once per type*. If a - bunch of your handlers take the same query parameters, you shouldn't have to - repeat that logic for each handler, but instead just "apply" it to all of - them at once. Your handlers shouldn't be where composition goes to die. And - so on. - -- flexibility - - If we haven't thought of your use case, it should still be easily - achievable. If you want to use templating library X, go ahead. Forms? Do - them however you want, but without difficulty. We're not opinionated. - -- separation of concerns - - Your handlers and your HTTP logic should be separate. True to the philosphy - at the core of HTTP and REST, with *servant* your handlers return normal - Haskell datatypes - that's the resource. And then from a description of your - API, *servant* handles the *presentation* (i.e., the Content-Types). But - that's just one example. - -- type safety - - Want to be sure your API meets a specification? Your compiler can check - that for you. Links you can be sure exist? You got it. - -To stick true to these principles, we do things a little differently than you -might expect. The core idea is *reifying the description of your API*. Once -reified, everything follows. We think we might be the first web framework to -reify API descriptions in an extensible way. We're pretty sure we're the first -to reify it as *types*. - -To be able to write a webservice you only need to read the first two sections, -but the goal of this document being to get you started with servant, we also -cover the couple of ways you can extend servant for a great good. - -Tutorial ---------- - -.. toctree:: - :maxdepth: 2 - - api-type.lhs - server.lhs - client.lhs - javascript.lhs - docs.lhs From db602e8a79ad8eee652bd3d7e2be74787d11a34a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Tue, 26 Jan 2016 00:27:07 +0100 Subject: [PATCH 102/180] tutorial: add tutorial compiling script and conversion script --- .gitignore | 1 + servant-examples/tutorial/check/check.sh | 11 +++++++++ servant-examples/tutorial/check/tinc.yaml | 15 ++++++++++++ servant-examples/tutorial/convert.hs | 30 +++++++++++++++++++++++ 4 files changed, 57 insertions(+) create mode 100755 servant-examples/tutorial/check/check.sh create mode 100644 servant-examples/tutorial/check/tinc.yaml create mode 100644 servant-examples/tutorial/convert.hs diff --git a/.gitignore b/.gitignore index f42f014b..1ea6ffef 100644 --- a/.gitignore +++ b/.gitignore @@ -26,3 +26,4 @@ Setup shell.nix default.nix doc/_build +doc/venv diff --git a/servant-examples/tutorial/check/check.sh b/servant-examples/tutorial/check/check.sh new file mode 100755 index 00000000..5425d80a --- /dev/null +++ b/servant-examples/tutorial/check/check.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash + +set -o errexit + +# tinc + +cabal exec -- ghc -Wall -Werror -outputdir build-output ../api-type.lhs -O0 -c -pgmL markdown-unlit +#cabal exec -- ghc -Wall -Werror -outputdir build-output ../server.lhs -O0 -c -fno-warn-missing-methods -fno-warn-name-shadowing +#cabal exec -- ghc -Wall -Werror -outputdir build-output ../client.lhs -O0 -c -fno-warn-missing-methods -fno-warn-name-shadowing +#cabal exec -- ghc -Wall -Werror -outputdir build-output ../javascript.lhs -O0 -c -fno-warn-missing-methods +#cabal exec -- ghc -Wall -Werror -ibuild-output -outputdir build-output ../docs.lhs -O0 -c -fno-warn-missing-methods diff --git a/servant-examples/tutorial/check/tinc.yaml b/servant-examples/tutorial/check/tinc.yaml new file mode 100644 index 00000000..2a32c412 --- /dev/null +++ b/servant-examples/tutorial/check/tinc.yaml @@ -0,0 +1,15 @@ +dependencies: + - name: servant + path: ../../../servant + - name: servant-server + path: ../../../servant-server + - name: servant-client + path: ../../../servant-client + - name: servant-js + path: ../../../servant-js + - name: servant-lucid + path: ../../../servant-lucid + - name: servant-docs + path: ../../../servant-docs + - name: servant-foreign + path: ../../../servant-foreign diff --git a/servant-examples/tutorial/convert.hs b/servant-examples/tutorial/convert.hs new file mode 100644 index 00000000..ebcca21e --- /dev/null +++ b/servant-examples/tutorial/convert.hs @@ -0,0 +1,30 @@ + +import Control.Arrow +import Data.Foldable +import Data.List +import System.Environment + +main = do + files <- getArgs + forM_ files $ \ file -> do + convertM file + +convertM :: FilePath -> IO () +convertM file = do + contents <- readFile file + seq (length contents) (return ()) + writeFile file (convert contents) + +convert :: String -> String +convert = + lines >>> + groupBy (\ a b -> take 1 a == take 1 b) >>> + map go >>> + concat >>> + unlines + where + go :: [String] -> [String] + go (a : r) + | ">" `isPrefixOf` a + = "``` haskell" : map (drop 2) (a : r) ++ "```" : [] + go x = x From 62fffed1f1e3d68d74031ee90a04d9803ac344ad Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 27 Jan 2016 22:04:13 +0100 Subject: [PATCH 103/180] Remove servant-examples --- doc/tutorial | 1 - .../tutorial/api-type.lhs | 0 .../tutorial/check/check.sh | 0 .../tutorial/check/tinc.yaml | 0 {servant-examples => doc}/tutorial/client.lhs | 0 {servant-examples => doc}/tutorial/convert.hs | 0 {servant-examples => doc}/tutorial/docs.lhs | 0 {servant-examples => doc}/tutorial/index.rst | 0 .../tutorial/javascript.lhs | 0 {servant-examples => doc}/tutorial/server.lhs | 0 servant-examples/LICENSE | 30 -- servant-examples/Setup.hs | 2 - servant-examples/hackage/hackage.hs | 90 ------ servant-examples/include/overlapping-compat.h | 8 - servant-examples/socket-io-chat/Chat.hs | 109 ------- .../socket-io-chat/resources/index.html | 28 -- .../socket-io-chat/resources/main.js | 274 ------------------ .../socket-io-chat/resources/style.css | 150 ---------- servant-examples/tinc.yaml | 15 - 19 files changed, 707 deletions(-) delete mode 120000 doc/tutorial rename {servant-examples => doc}/tutorial/api-type.lhs (100%) rename {servant-examples => doc}/tutorial/check/check.sh (100%) rename {servant-examples => doc}/tutorial/check/tinc.yaml (100%) rename {servant-examples => doc}/tutorial/client.lhs (100%) rename {servant-examples => doc}/tutorial/convert.hs (100%) rename {servant-examples => doc}/tutorial/docs.lhs (100%) rename {servant-examples => doc}/tutorial/index.rst (100%) rename {servant-examples => doc}/tutorial/javascript.lhs (100%) rename {servant-examples => doc}/tutorial/server.lhs (100%) delete mode 100644 servant-examples/LICENSE delete mode 100644 servant-examples/Setup.hs delete mode 100644 servant-examples/hackage/hackage.hs delete mode 100644 servant-examples/include/overlapping-compat.h delete mode 100644 servant-examples/socket-io-chat/Chat.hs delete mode 100644 servant-examples/socket-io-chat/resources/index.html delete mode 100644 servant-examples/socket-io-chat/resources/main.js delete mode 100644 servant-examples/socket-io-chat/resources/style.css delete mode 100644 servant-examples/tinc.yaml diff --git a/doc/tutorial b/doc/tutorial deleted file mode 120000 index 6072fcb4..00000000 --- a/doc/tutorial +++ /dev/null @@ -1 +0,0 @@ -../servant-examples/tutorial \ No newline at end of file diff --git a/servant-examples/tutorial/api-type.lhs b/doc/tutorial/api-type.lhs similarity index 100% rename from servant-examples/tutorial/api-type.lhs rename to doc/tutorial/api-type.lhs diff --git a/servant-examples/tutorial/check/check.sh b/doc/tutorial/check/check.sh similarity index 100% rename from servant-examples/tutorial/check/check.sh rename to doc/tutorial/check/check.sh diff --git a/servant-examples/tutorial/check/tinc.yaml b/doc/tutorial/check/tinc.yaml similarity index 100% rename from servant-examples/tutorial/check/tinc.yaml rename to doc/tutorial/check/tinc.yaml diff --git a/servant-examples/tutorial/client.lhs b/doc/tutorial/client.lhs similarity index 100% rename from servant-examples/tutorial/client.lhs rename to doc/tutorial/client.lhs diff --git a/servant-examples/tutorial/convert.hs b/doc/tutorial/convert.hs similarity index 100% rename from servant-examples/tutorial/convert.hs rename to doc/tutorial/convert.hs diff --git a/servant-examples/tutorial/docs.lhs b/doc/tutorial/docs.lhs similarity index 100% rename from servant-examples/tutorial/docs.lhs rename to doc/tutorial/docs.lhs diff --git a/servant-examples/tutorial/index.rst b/doc/tutorial/index.rst similarity index 100% rename from servant-examples/tutorial/index.rst rename to doc/tutorial/index.rst diff --git a/servant-examples/tutorial/javascript.lhs b/doc/tutorial/javascript.lhs similarity index 100% rename from servant-examples/tutorial/javascript.lhs rename to doc/tutorial/javascript.lhs diff --git a/servant-examples/tutorial/server.lhs b/doc/tutorial/server.lhs similarity index 100% rename from servant-examples/tutorial/server.lhs rename to doc/tutorial/server.lhs diff --git a/servant-examples/LICENSE b/servant-examples/LICENSE deleted file mode 100644 index 68d30586..00000000 --- a/servant-examples/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2015-2016, Servant Contributors - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Alp Mestanogullari nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/servant-examples/Setup.hs b/servant-examples/Setup.hs deleted file mode 100644 index 44671092..00000000 --- a/servant-examples/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/servant-examples/hackage/hackage.hs b/servant-examples/hackage/hackage.hs deleted file mode 100644 index 4d29b556..00000000 --- a/servant-examples/hackage/hackage.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -import Control.Applicative -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Except -import Data.Aeson -import Data.Monoid -import Data.Proxy -import Data.Text (Text) -import GHC.Generics -import Network.HTTP.Client (Manager, defaultManagerSettings, - newManager) -import System.IO.Unsafe (unsafePerformIO) -import Servant.API -import Servant.Client - -import qualified Data.Text as T -import qualified Data.Text.IO as T - -type HackageAPI = - "users" :> Get '[JSON] [UserSummary] - :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed - :<|> "packages" :> Get '[JSON] [Package] - -type Username = Text - -data UserSummary = UserSummary - { summaryUsername :: Username - , summaryUserid :: Int - } deriving (Eq, Show) - -instance FromJSON UserSummary where - parseJSON (Object o) = - UserSummary <$> o .: "username" - <*> o .: "userid" - - parseJSON _ = mzero - -type Group = Text - -data UserDetailed = UserDetailed - { username :: Username - , userid :: Int - , groups :: [Group] - } deriving (Eq, Show, Generic) - -instance FromJSON UserDetailed - -newtype Package = Package { packageName :: Text } - deriving (Eq, Show, Generic) - -instance FromJSON Package - -hackageAPI :: Proxy HackageAPI -hackageAPI = Proxy - - -{-# NOINLINE manager #-} -manager :: Manager -manager = unsafePerformIO $ newManager defaultManagerSettings - -getUsers :: ExceptT ServantError IO [UserSummary] -getUser :: Username -> ExceptT ServantError IO UserDetailed -getPackages :: ExceptT ServantError IO [Package] -getUsers :<|> getUser :<|> getPackages = - client hackageAPI (BaseUrl Http "hackage.haskell.org" 80 "") manager - -main :: IO () -main = print =<< uselessNumbers - -uselessNumbers :: IO (Either ServantError ()) -uselessNumbers = runExceptT $ do - users <- getUsers - liftIO . putStrLn $ show (length users) ++ " users" - - user <- liftIO $ do - putStrLn "Enter a valid hackage username" - T.getLine - userDetailed <- getUser user - liftIO . T.putStrLn $ user <> " maintains " <> T.pack (show (length $ groups userDetailed)) <> " packages" - - packages <- getPackages - let monadPackages = filter (isMonadPackage . packageName) packages - liftIO . putStrLn $ show (length monadPackages) ++ " monad packages" - - where isMonadPackage = T.isInfixOf "monad" diff --git a/servant-examples/include/overlapping-compat.h b/servant-examples/include/overlapping-compat.h deleted file mode 100644 index eef9d4ea..00000000 --- a/servant-examples/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/servant-examples/socket-io-chat/Chat.hs b/servant-examples/socket-io-chat/Chat.hs deleted file mode 100644 index 9f2faa92..00000000 --- a/servant-examples/socket-io-chat/Chat.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} - -module Chat (eioServer, ServerState (..)) where - -import Prelude hiding (mapM_) - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), pure) -#endif -import Control.Monad.State.Class (MonadState) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.IO.Class (liftIO) -import Data.Aeson ((.=)) -import Data.Foldable (mapM_) - -import qualified Control.Concurrent.STM as STM -import qualified Data.Aeson as Aeson -import qualified Data.Text as Text -import qualified Network.SocketIO as SocketIO - - -data AddUser = AddUser Text.Text - -instance Aeson.FromJSON AddUser where - parseJSON = Aeson.withText "AddUser" $ pure . AddUser - - -data NumConnected = NumConnected !Int - -instance Aeson.ToJSON NumConnected where - toJSON (NumConnected n) = Aeson.object [ "numUsers" .= n] - - -data NewMessage = NewMessage Text.Text - -instance Aeson.FromJSON NewMessage where - parseJSON = Aeson.withText "NewMessage" $ pure . NewMessage - - -data Said = Said Text.Text Text.Text - -instance Aeson.ToJSON Said where - toJSON (Said username message) = Aeson.object - [ "username" .= username - , "message" .= message - ] - -data UserName = UserName Text.Text - -instance Aeson.ToJSON UserName where - toJSON (UserName un) = Aeson.object [ "username" .= un ] - - -data UserJoined = UserJoined Text.Text Int - -instance Aeson.ToJSON UserJoined where - toJSON (UserJoined un n) = Aeson.object - [ "username" .= un - , "numUsers" .= n - ] - - --------------------------------------------------------------------------------- -data ServerState = ServerState { ssNConnected :: STM.TVar Int } - ---server :: ServerState -> StateT SocketIO.RoutingTable Snap.Snap () -eioServer :: forall (m :: * -> *). (MonadState SocketIO.RoutingTable m, MonadIO m) => ServerState -> m () -eioServer state = do - userNameMVar <- liftIO STM.newEmptyTMVarIO - let forUserName m = liftIO (STM.atomically (STM.tryReadTMVar userNameMVar)) >>= mapM_ m - - SocketIO.on "new message" $ \(NewMessage message) -> - forUserName $ \userName -> - SocketIO.broadcast "new message" (Said userName message) - - SocketIO.on "add user" $ \(AddUser userName) -> do - n <- liftIO $ STM.atomically $ do - n <- (+ 1) <$> STM.readTVar (ssNConnected state) - STM.putTMVar userNameMVar userName - STM.writeTVar (ssNConnected state) n - return n - - SocketIO.emit "login" (NumConnected n) - SocketIO.broadcast "user joined" (UserJoined userName n) - - SocketIO.appendDisconnectHandler $ do - (n, mUserName) <- liftIO $ STM.atomically $ do - n <- (+ (-1)) <$> STM.readTVar (ssNConnected state) - mUserName <- STM.tryReadTMVar userNameMVar - STM.writeTVar (ssNConnected state) n - return (n, mUserName) - - case mUserName of - Nothing -> return () - Just userName -> - SocketIO.broadcast "user left" (UserJoined userName n) - - SocketIO.on "typing" $ - forUserName $ \userName -> - SocketIO.broadcast "typing" (UserName userName) - - SocketIO.on "stop typing" $ - forUserName $ \userName -> - SocketIO.broadcast "stop typing" (UserName userName) - diff --git a/servant-examples/socket-io-chat/resources/index.html b/servant-examples/socket-io-chat/resources/index.html deleted file mode 100644 index 92b055ff..00000000 --- a/servant-examples/socket-io-chat/resources/index.html +++ /dev/null @@ -1,28 +0,0 @@ - - - - - Socket.IO Chat Example - - - -
      -
    • -
      -
        -
        - -
        • - -
      - - - - - - diff --git a/servant-examples/socket-io-chat/resources/main.js b/servant-examples/socket-io-chat/resources/main.js deleted file mode 100644 index 08be0ad4..00000000 --- a/servant-examples/socket-io-chat/resources/main.js +++ /dev/null @@ -1,274 +0,0 @@ -$(function() { - var FADE_TIME = 150; // ms - var TYPING_TIMER_LENGTH = 400; // ms - var COLORS = [ - '#e21400', '#91580f', '#f8a700', '#f78b00', - '#58dc00', '#287b00', '#a8f07a', '#4ae8c4', - '#3b88eb', '#3824aa', '#a700ff', '#d300e7' - ]; - - // Initialize varibles - var $window = $(window); - var $usernameInput = $('.usernameInput'); // Input for username - var $messages = $('.messages'); // Messages area - var $inputMessage = $('.inputMessage'); // Input message input box - - var $loginPage = $('.login.page'); // The login page - var $chatPage = $('.chat.page'); // The chatroom page - - // Prompt for setting a username - var username; - var connected = false; - var typing = false; - var lastTypingTime; - var $currentInput = $usernameInput.focus(); - - var socket = io(); - - function addParticipantsMessage (data) { - var message = ''; - if (data.numUsers === 1) { - message += "there's 1 participant"; - } else { - message += "there're " + data.numUsers + " participants"; - } - log(message); - } - - // Sets the client's username - function setUsername () { - username = cleanInput($usernameInput.val().trim()); - - // If the username is valid - if (username) { - $loginPage.fadeOut(); - $chatPage.show(); - $loginPage.off('click'); - $currentInput = $inputMessage.focus(); - - // Tell the server your username - socket.emit('add user', username); - } - } - - // Sends a chat message - function sendMessage () { - var message = $inputMessage.val(); - // Prevent markup from being injected into the message - message = cleanInput(message); - // if there is a non-empty message and a socket connection - if (message && connected) { - $inputMessage.val(''); - addChatMessage({ - username: username, - message: message - }); - // tell server to execute 'new message' and send along one parameter - socket.emit('new message', message); - } - } - - // Log a message - function log (message, options) { - var $el = $('
    • ').addClass('log').text(message); - addMessageElement($el, options); - } - - // Adds the visual chat message to the message list - function addChatMessage (data, options) { - // Don't fade the message in if there is an 'X was typing' - var $typingMessages = getTypingMessages(data); - options = options || {}; - if ($typingMessages.length !== 0) { - options.fade = false; - $typingMessages.remove(); - } - - var $usernameDiv = $('') - .text(data.username) - .css('color', getUsernameColor(data.username)); - var $messageBodyDiv = $('') - .text(data.message); - - var typingClass = data.typing ? 'typing' : ''; - var $messageDiv = $('
    • ') - .data('username', data.username) - .addClass(typingClass) - .append($usernameDiv, $messageBodyDiv); - - addMessageElement($messageDiv, options); - } - - // Adds the visual chat typing message - function addChatTyping (data) { - data.typing = true; - data.message = 'is typing'; - addChatMessage(data); - } - - // Removes the visual chat typing message - function removeChatTyping (data) { - getTypingMessages(data).fadeOut(function () { - $(this).remove(); - }); - } - - // Adds a message element to the messages and scrolls to the bottom - // el - The element to add as a message - // options.fade - If the element should fade-in (default = true) - // options.prepend - If the element should prepend - // all other messages (default = false) - function addMessageElement (el, options) { - var $el = $(el); - - // Setup default options - if (!options) { - options = {}; - } - if (typeof options.fade === 'undefined') { - options.fade = true; - } - if (typeof options.prepend === 'undefined') { - options.prepend = false; - } - - // Apply options - if (options.fade) { - $el.hide().fadeIn(FADE_TIME); - } - if (options.prepend) { - $messages.prepend($el); - } else { - $messages.append($el); - } - $messages[0].scrollTop = $messages[0].scrollHeight; - } - - // Prevents input from having injected markup - function cleanInput (input) { - return $('
      ').text(input).text(); - } - - // Updates the typing event - function updateTyping () { - if (connected) { - if (!typing) { - typing = true; - socket.emit('typing'); - } - lastTypingTime = (new Date()).getTime(); - - setTimeout(function () { - var typingTimer = (new Date()).getTime(); - var timeDiff = typingTimer - lastTypingTime; - if (timeDiff >= TYPING_TIMER_LENGTH && typing) { - socket.emit('stop typing'); - typing = false; - } - }, TYPING_TIMER_LENGTH); - } - } - - // Gets the 'X is typing' messages of a user - function getTypingMessages (data) { - return $('.typing.message').filter(function (i) { - return $(this).data('username') === data.username; - }); - } - - // Gets the color of a username through our hash function - function getUsernameColor (username) { - // Compute hash code - var hash = 7; - for (var i = 0; i < username.length; i++) { - hash = username.charCodeAt(i) + (hash << 5) - hash; - } - // Calculate color - var index = Math.abs(hash % COLORS.length); - return COLORS[index]; - } - - // Keyboard events - - $window.keydown(function (event) { - // Auto-focus the current input when a key is typed - if (!(event.ctrlKey || event.metaKey || event.altKey)) { - $currentInput.focus(); - } - // When the client hits ENTER on their keyboard - if (event.which === 13) { - if (username) { - sendMessage(); - socket.emit('stop typing'); - typing = false; - } else { - setUsername(); - } - } - }); - - $inputMessage.on('input', function() { - updateTyping(); - }); - - // Click events - - // Focus input when clicking anywhere on login page - $loginPage.click(function () { - $currentInput.focus(); - }); - - // Focus input when clicking on the message input's border - $inputMessage.click(function () { - $inputMessage.focus(); - }); - - // Socket events - socket.on('connected', function (data) { - console.log('connected:', data); - }); - - // Socket events - socket.on('changes', function (data) { - console.log('changes:', data); - }); - - // Whenever the server emits 'login', log the login message - socket.on('login', function (data) { - connected = true; - // Display the welcome message - var message = "Welcome to Socket.IO Chat — "; - log(message, { - prepend: true - }); - addParticipantsMessage(data); - }); - - // Whenever the server emits 'new message', update the chat body - socket.on('new message', function (data) { - addChatMessage(data); - }); - - // Whenever the server emits 'user joined', log it in the chat body - socket.on('user joined', function (data) { - log(data.username + ' joined'); - addParticipantsMessage(data); - }); - - // Whenever the server emits 'user left', log it in the chat body - socket.on('user left', function (data) { - log(data.username + ' left'); - addParticipantsMessage(data); - removeChatTyping(data); - }); - - // Whenever the server emits 'typing', show the typing message - socket.on('typing', function (data) { - addChatTyping(data); - }); - - // Whenever the server emits 'stop typing', kill the typing message - socket.on('stop typing', function (data) { - removeChatTyping(data); - }); -}); diff --git a/servant-examples/socket-io-chat/resources/style.css b/servant-examples/socket-io-chat/resources/style.css deleted file mode 100644 index 62cbe093..00000000 --- a/servant-examples/socket-io-chat/resources/style.css +++ /dev/null @@ -1,150 +0,0 @@ -/* Fix user-agent */ - -* { - box-sizing: border-box; -} - -html { - font-weight: 300; - -webkit-font-smoothing: antialiased; -} - -html, input { - font-family: - "HelveticaNeue-Light", - "Helvetica Neue Light", - "Helvetica Neue", - Helvetica, - Arial, - "Lucida Grande", - sans-serif; -} - -html, body { - height: 100%; - margin: 0; - padding: 0; -} - -ul { - list-style: none; - word-wrap: break-word; -} - -/* Pages */ - -.pages { - height: 100%; - margin: 0; - padding: 0; - width: 100%; -} - -.page { - height: 100%; - position: absolute; - width: 100%; -} - -/* Login Page */ - -.login.page { - background-color: #000; -} - -.login.page .form { - height: 100px; - margin-top: -100px; - position: absolute; - - text-align: center; - top: 50%; - width: 100%; -} - -.login.page .form .usernameInput { - background-color: transparent; - border: none; - border-bottom: 2px solid #fff; - outline: none; - padding-bottom: 15px; - text-align: center; - width: 400px; -} - -.login.page .title { - font-size: 200%; -} - -.login.page .usernameInput { - font-size: 200%; - letter-spacing: 3px; -} - -.login.page .title, .login.page .usernameInput { - color: #fff; - font-weight: 100; -} - -/* Chat page */ - -.chat.page { - display: none; -} - -/* Font */ - -.messages { - font-size: 150%; -} - -.inputMessage { - font-size: 100%; -} - -.log { - color: gray; - font-size: 70%; - margin: 5px; - text-align: center; -} - -/* Messages */ - -.chatArea { - height: 100%; - padding-bottom: 60px; -} - -.messages { - height: 100%; - margin: 0; - overflow-y: scroll; - padding: 10px 20px 10px 20px; -} - -.message.typing .messageBody { - color: gray; -} - -.username { - float: left; - font-weight: 700; - overflow: hidden; - padding-right: 15px; - text-align: right; -} - -/* Input */ - -.inputMessage { - border: 10px solid #000; - bottom: 0; - height: 60px; - left: 0; - outline: none; - padding-left: 10px; - position: absolute; - right: 0; - width: 100%; -} diff --git a/servant-examples/tinc.yaml b/servant-examples/tinc.yaml deleted file mode 100644 index 10af8970..00000000 --- a/servant-examples/tinc.yaml +++ /dev/null @@ -1,15 +0,0 @@ -dependencies: - - name: servant - path: ../servant - - name: servant-server - path: ../servant-server - - name: servant-client - path: ../servant-client - - name: servant-js - path: ../servant-js - - name: servant-lucid - path: ../servant-lucid - - name: servant-docs - path: ../servant-docs - - name: servant-foreign - path: ../servant-foreign From 5542ce8916fff43d0ca7bae4df3e868e22a24c1d Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 27 Jan 2016 22:17:59 +0100 Subject: [PATCH 104/180] Start tutorial project --- doc/tutorial/LICENSE | 30 ++++++++++++++++++++++++++++++ doc/tutorial/Setup.hs | 2 ++ doc/tutorial/tutorial.cabal | 22 ++++++++++++++++++++++ 3 files changed, 54 insertions(+) create mode 100644 doc/tutorial/LICENSE create mode 100644 doc/tutorial/Setup.hs create mode 100644 doc/tutorial/tutorial.cabal diff --git a/doc/tutorial/LICENSE b/doc/tutorial/LICENSE new file mode 100644 index 00000000..fc4415bd --- /dev/null +++ b/doc/tutorial/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Servant Contributors + +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 Servant Contributors 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. diff --git a/doc/tutorial/Setup.hs b/doc/tutorial/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/doc/tutorial/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal new file mode 100644 index 00000000..47fc2ebd --- /dev/null +++ b/doc/tutorial/tutorial.cabal @@ -0,0 +1,22 @@ +name: tutorial +version: 0.1.0.0 +synopsis: The servant tutorial +-- description: +homepage: http://haskell-servant.github.io/ +license: BSD3 +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +-- copyright: +-- category: +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: api-type.lhs + -- other-modules: + -- other-extensions: + build-depends: base >=4.8 && <4.9 + -- hs-source-dirs: + default-language: Haskell2010 From 7af73d63ea6b9f47415c919fa3ad2dbf2b396417 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 27 Jan 2016 22:26:59 +0100 Subject: [PATCH 105/180] Explicit ignore --- doc/tutorial/api-type.lhs | 14 +++++++------- doc/tutorial/client.lhs | 2 +- doc/tutorial/convert.hs | 2 +- doc/tutorial/docs.lhs | 2 +- doc/tutorial/server.lhs | 40 +++++++++++++++++++-------------------- 5 files changed, 30 insertions(+), 30 deletions(-) diff --git a/doc/tutorial/api-type.lhs b/doc/tutorial/api-type.lhs index 71c84631..7b49ec8a 100644 --- a/doc/tutorial/api-type.lhs +++ b/doc/tutorial/api-type.lhs @@ -88,7 +88,7 @@ them amounts to `/`-separating them in a URL. These 5 combinators are very similar except that they each describe a different HTTP method. This is how they're declared -``` haskell +``` haskell ignore data Delete (contentTypes :: [*]) a data Get (contentTypes :: [*]) a data Patch (contentTypes :: [*]) a @@ -116,7 +116,7 @@ The `Capture` combinator in servant takes a (type-level) string representing the "name of the variable" and a type, which indicates the type we want to decode the "captured value" to. -``` haskell +``` haskell ignore data Capture (s :: Symbol) a -- s :: Symbol just says that 's' must be a type-level string. ``` @@ -153,7 +153,7 @@ active users whereas `/users` would list them all. Here are the corresponding data type declarations: -``` haskell +``` haskell ignore data QueryParam (sym :: Symbol) a data QueryParams (sym :: Symbol) a data QueryFlag (sym :: Symbol) @@ -171,7 +171,7 @@ after *January 1st, 2005*. Corresponding data type declarations below. -``` haskell +``` haskell ignore data MatrixParam (sym :: Symbol) a data MatrixParams (sym :: Symbol) a data MatrixFlag (sym :: Symbol) @@ -206,7 +206,7 @@ Request` or `Unsupported Content Type` as appropriate. Here's the data type declaration for it: -``` haskell +``` haskell ignore data ReqBody (contentTypes :: [*]) a ``` @@ -235,7 +235,7 @@ The `Header` combinator in servant takes a type-level string for the header name and the type to which we want to decode the header's value (from some textual representation), as illustrated below: -``` haskell +``` haskell ignore data Header (sym :: Symbol) a ``` @@ -274,7 +274,7 @@ headers too. *servant* provides a `Headers` combinator that carries a list of `Header` and can be used by simply wrapping the "return type" of an endpoint with it. -``` haskell +``` haskell ignore data Headers (ls :: [*]) a ``` diff --git a/doc/tutorial/client.lhs b/doc/tutorial/client.lhs index 21779f2b..f557c413 100644 --- a/doc/tutorial/client.lhs +++ b/doc/tutorial/client.lhs @@ -83,7 +83,7 @@ Each function makes available as an argument any value that the response may dep As you can see in the code above, we just "pattern match our way" to these functions. If we try to derive less or more functions than there are endpoints in the API, we obviously get an error. The `BaseUrl` value there is just: -``` haskell +``` haskell ignore -- | URI scheme to use data Scheme = Http -- ^ http:// diff --git a/doc/tutorial/convert.hs b/doc/tutorial/convert.hs index ebcca21e..ffcb60a7 100644 --- a/doc/tutorial/convert.hs +++ b/doc/tutorial/convert.hs @@ -26,5 +26,5 @@ convert = go :: [String] -> [String] go (a : r) | ">" `isPrefixOf` a - = "``` haskell" : map (drop 2) (a : r) ++ "```" : [] + = "``` haskell ignore" : map (drop 2) (a : r) ++ "```" : [] go x = x diff --git a/doc/tutorial/docs.lhs b/doc/tutorial/docs.lhs index cb662a54..2b85b9fa 100644 --- a/doc/tutorial/docs.lhs +++ b/doc/tutorial/docs.lhs @@ -94,7 +94,7 @@ With all of this, we can derive docs for our API. *servant*'s markdown pretty printer is a function named `markdown`. -``` haskell +``` haskell ignore markdown :: API -> String ``` diff --git a/doc/tutorial/server.lhs b/doc/tutorial/server.lhs index 32f098ba..411ec1fb 100644 --- a/doc/tutorial/server.lhs +++ b/doc/tutorial/server.lhs @@ -68,7 +68,7 @@ need to have some language extensions and imports: > import qualified Data.Aeson.Parser > import qualified Text.Blaze.Html -``` haskell +``` haskell ignore {-# LANGUAGE TypeFamilies #-} ``` @@ -107,7 +107,7 @@ Nothing funny going on here. But we now can define our list of two users. Let's also write our API type. -``` haskell +``` haskell ignore type UserAPI1 = "users" :> Get '[JSON] [User] ``` @@ -324,7 +324,7 @@ decided to provide a pair of typeclasses, `FromText` and `ToText` which just let you say that you can respectively *extract* or *encode* values of some type *from*/*to* text. Here are the definitions: -``` haskell +``` haskell ignore class FromText a where fromText :: Text -> Maybe a @@ -363,7 +363,7 @@ your own. or writing the instances by hand: -``` haskell +``` haskell ignore instance FromText UserId where fromText = fmap UserId fromText @@ -394,7 +394,7 @@ The truth behind `JSON` What exactly is `JSON`? Like the 3 other content types provided out of the box by *servant*, it's a really dumb data type. -``` haskell +``` haskell ignore data JSON data PlainText data FormUrlEncoded @@ -415,7 +415,7 @@ haddocks from this link, you can see that we just have to specify use `(//) :: ByteString -> ByteString -> MediaType`. The precise way to specify the `MediaType` is to write an instance for the `Accept` class: -``` haskell +``` haskell ignore -- for reference: class Accept ctype where contentType :: Proxy ctype -> MediaType @@ -428,7 +428,7 @@ The second step is centered around the `MimeRender` and `MimeUnrender` classes. These classes just let you specify a way to respectively encode and decode values respectively into or from your content-type's representation. -``` haskell +``` haskell ignore class Accept ctype => MimeRender ctype a where mimeRender :: Proxy ctype -> a -> ByteString -- alternatively readable as: @@ -442,7 +442,7 @@ In the case of `JSON`, this is easily dealt with! For any type `a` with a `ToJSON` instance, we can render values of that type to JSON using `Data.Aeson.encode`. -``` haskell +``` haskell ignore instance ToJSON a => MimeRender JSON a where mimeRender _ = encode ``` @@ -450,7 +450,7 @@ instance ToJSON a => MimeRender JSON a where And now the `MimeUnrender` class, which lets us extract values from lazy `ByteString`s, alternatively failing with an error string. -``` haskell +``` haskell ignore class Accept ctype => MimeUnrender ctype a where mimeUnrender :: Proxy ctype -> ByteString -> Either String a -- alternatively: @@ -471,7 +471,7 @@ you are curious. This function is exactly what we need for our `MimeUnrender` instance. -``` haskell +``` haskell ignore instance FromJSON a => MimeUnrender JSON a where mimeUnrender _ = eitherDecodeLenient ``` @@ -627,7 +627,7 @@ as interfaces to databases that we interact with in `IO`; Let's recall some definitions. -``` haskell +``` haskell ignore -- from the Prelude data Either e a = Left e | Right a @@ -644,7 +644,7 @@ action that either returns an error or a result. The aforementioned `either` package is worth taking a look at. Perhaps most importantly: -``` haskell +``` haskell ignore left :: Monad m => e -> EitherT e m a ``` Allows you to return an error from your handler (whereas `return` is enough to @@ -659,7 +659,7 @@ Performing IO Another important instance from the list above is `MonadIO m => MonadIO (EitherT e m)`. [`MonadIO`](http://hackage.haskell.org/package/transformers-0.4.3.0/docs/Control-Monad-IO-Class.html) is a class from the *transformers* package defined as: -``` haskell +``` haskell ignore class Monad m => MonadIO m where liftIO :: IO a -> m a ``` @@ -688,7 +688,7 @@ error message, all you have to do is use the `left` function mentioned above and provide it with the appropriate value of type `ServantErr`, which is defined as: -``` haskell +``` haskell ignore data ServantErr = ServantErr { errHTTPCode :: Int , errReasonPhrase :: String @@ -773,7 +773,7 @@ under some path in your web API. As mentioned earlier in this document, the application". Well, servant-server provides a function to get a file and directory serving WAI application, namely: -``` haskell +``` haskell ignore -- exported by Servant and Servant.Server serveDirectory :: FilePath -> Server Raw ``` @@ -809,7 +809,7 @@ In other words: Here is our little server in action. -``` haskell +``` haskell ignore $ curl http://localhost:8081/code/T1.hs {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -918,7 +918,7 @@ We can instead factor out the `userid`: However, you have to be aware that this has an effect on the type of the corresponding `Server`: -``` haskell +``` haskell ignore Server UserAPI3 = (Int -> EitherT ServantErr IO User) :<|> (Int -> EitherT ServantErr IO ()) @@ -1076,7 +1076,7 @@ Using another monad for your handlers Remember how `Server` turns combinators for HTTP methods into `EitherT ServantErr IO`? Well, actually, there's more to that. `Server` is actually a simple type synonym. -``` haskell +``` haskell ignore type Server api = ServerT api (EitherT ServantErr IO) ``` @@ -1090,7 +1090,7 @@ Natural transformations If we have a function that gets us from an `m a` to an `n a`, for any `a`, what do we have? -``` haskell +``` haskell ignore newtype m :~> n = Nat { unNat :: forall a. m a -> n a} -- For example @@ -1103,7 +1103,7 @@ So if you want to write handlers using another monad/type than `EitherT ServantErr IO`, say the `Reader String` monad, the first thing you have to prepare is a function: -``` haskell +``` haskell ignore readerToEither :: Reader String :~> EitherT ServantErr IO ``` From 8b1bf02af843ef603a746191e87504ed89d02763 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 27 Jan 2016 22:28:58 +0100 Subject: [PATCH 106/180] Remove bird-tracks --- doc/tutorial/api-type.lhs | 136 +++--- doc/tutorial/client.lhs | 158 +++--- doc/tutorial/docs.lhs | 186 +++---- doc/tutorial/javascript.lhs | 208 ++++---- doc/tutorial/server.lhs | 938 +++++++++++++++++++----------------- 5 files changed, 886 insertions(+), 740 deletions(-) diff --git a/doc/tutorial/api-type.lhs b/doc/tutorial/api-type.lhs index 7b49ec8a..fbf42644 100644 --- a/doc/tutorial/api-type.lhs +++ b/doc/tutorial/api-type.lhs @@ -6,13 +6,15 @@ toc: true The source for this tutorial section is a literate haskell file, so first we need to have some language extensions and imports: -> {-# LANGUAGE DataKinds #-} -> {-# LANGUAGE TypeOperators #-} -> -> module ApiType where -> -> import Data.Text -> import Servant.API +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module ApiType where + +import Data.Text +import Servant.API +``` Consider the following informal specification of an API: @@ -29,14 +31,16 @@ getting some client libraries, and documentation (and in the future, who knows How would we describe it with servant? As mentioned earlier, an endpoint description is a good old Haskell **type**: -> type UserAPI = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User] -> -> data SortBy = Age | Name -> -> data User = User { -> name :: String, -> age :: Int -> } +``` haskell +type UserAPI = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User] + +data SortBy = Age | Name + +data User = User { + name :: String, + age :: Int +} +``` Let's break that down: @@ -61,8 +65,10 @@ equivalent to `/`, but sometimes it just lets you chain another combinator. We can also describe APIs with multiple endpoints by using the `:<|>` combinators. Here's an example: -> type UserAPI2 = "users" :> "list-all" :> Get '[JSON] [User] -> :<|> "list-all" :> "users" :> Get '[JSON] [User] +``` haskell +type UserAPI2 = "users" :> "list-all" :> Get '[JSON] [User] + :<|> "list-all" :> "users" :> Get '[JSON] [User] +``` *servant* provides a fair amount of combinators out-of-the-box, but you can always write your own when you need it. Here's a quick overview of all the @@ -78,9 +84,11 @@ As you've already seen, you can use type-level strings (enabled with the `DataKinds` language extension) for static path fragments. Chaining them amounts to `/`-separating them in a URL. -> type UserAPI3 = "users" :> "list-all" :> "now" :> Get '[JSON] [User] -> -- describes an endpoint reachable at: -> -- /users/list-all/now +``` haskell +type UserAPI3 = "users" :> "list-all" :> "now" :> Get '[JSON] [User] + -- describes an endpoint reachable at: + -- /users/list-all/now +``` `Delete`, `Get`, `Patch`, `Post` and `Put` ------------------------------------------ @@ -99,8 +107,10 @@ data Put (contentTypes :: [*]) a An endpoint ends with one of the 5 combinators above (unless you write your own). Examples: -> type UserAPI4 = "users" :> Get '[JSON] [User] -> :<|> "admins" :> Get '[JSON] [User] +``` haskell +type UserAPI4 = "users" :> Get '[JSON] [User] + :<|> "admins" :> Get '[JSON] [User] +``` `Capture` --------- @@ -127,13 +137,15 @@ class, which the captured value must be an instance of. Examples: -> type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User -> -- equivalent to 'GET /user/:userid' -> -- except that we explicitly say that "userid" -> -- must be an integer -> -> :<|> "user" :> Capture "userid" Integer :> Delete '[] () -> -- equivalent to 'DELETE /user/:userid' +``` haskell +type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User + -- equivalent to 'GET /user/:userid' + -- except that we explicitly say that "userid" + -- must be an integer + + :<|> "user" :> Capture "userid" Integer :> Delete '[] () + -- equivalent to 'DELETE /user/:userid' +``` `QueryParam`, `QueryParams`, `QueryFlag`, `MatrixParam`, `MatrixParams` and `MatrixFlag` ---------------------------------------------------------------------------------------- @@ -179,11 +191,13 @@ data MatrixFlag (sym :: Symbol) Examples: -> type UserAPI6 = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User] -> -- equivalent to 'GET /users?sortby={age, name}' -> -> :<|> "users" :> MatrixParam "sortby" SortBy :> Get '[JSON] [User] -> -- equivalent to 'GET /users;sortby={age, name}' +``` haskell +type UserAPI6 = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User] + -- equivalent to 'GET /users?sortby={age, name}' + + :<|> "users" :> MatrixParam "sortby" SortBy :> Get '[JSON] [User] + -- equivalent to 'GET /users;sortby={age, name}' +``` Again, your handlers don't have to deserialize these things (into, for example, a `SortBy`). *servant* takes care of it. @@ -212,17 +226,19 @@ data ReqBody (contentTypes :: [*]) a Examples: -> type UserAPI7 = "users" :> ReqBody '[JSON] User :> Post '[JSON] User -> -- - equivalent to 'POST /users' with a JSON object -> -- describing a User in the request body -> -- - returns a User encoded in JSON -> -> :<|> "users" :> Capture "userid" Integer -> :> ReqBody '[JSON] User -> :> Put '[JSON] User -> -- - equivalent to 'PUT /users/:userid' with a JSON -> -- object describing a User in the request body -> -- - returns a User encoded in JSON +``` haskell +type UserAPI7 = "users" :> ReqBody '[JSON] User :> Post '[JSON] User + -- - equivalent to 'POST /users' with a JSON object + -- describing a User in the request body + -- - returns a User encoded in JSON + + :<|> "users" :> Capture "userid" Integer + :> ReqBody '[JSON] User + :> Put '[JSON] User + -- - equivalent to 'PUT /users/:userid' with a JSON + -- object describing a User in the request body + -- - returns a User encoded in JSON +``` Request `Header`s ----------------- @@ -243,7 +259,9 @@ Here's an example where we declare that an endpoint makes use of the `User-Agent` header which specifies the name of the software/library used by the client to send the request. -> type UserAPI8 = "users" :> Header "User-Agent" Text :> Get '[JSON] [User] +``` haskell +type UserAPI8 = "users" :> Header "User-Agent" Text :> Get '[JSON] [User] +``` Content types ------------- @@ -257,7 +275,9 @@ Four content-types are provided out-of-the-box by the core *servant* package: reason you wanted one of your endpoints to make your user data available under those 4 formats, you would write the API type as below: -> type UserAPI9 = "users" :> Get '[JSON, PlainText, FormUrlEncoded, OctetStream] [User] +``` haskell +type UserAPI9 = "users" :> Get '[JSON, PlainText, FormUrlEncoded, OctetStream] [User] +``` We also provide an HTML content-type, but since there's no single library that everyone uses, we decided to release 2 packages, *servant-lucid* and @@ -281,7 +301,9 @@ data Headers (ls :: [*]) a If you want to describe an endpoint that returns a "User-Count" header in each response, you could write it as below: -> type UserAPI10 = "users" :> Get '[JSON] (Headers '[Header "User-Count" Integer] [User]) +``` haskell +type UserAPI10 = "users" :> Get '[JSON] (Headers '[Header "User-Count" Integer] [User]) +``` Interoperability with other WAI `Application`s: `Raw` ----------------------------------------------------- @@ -290,14 +312,16 @@ Finally, we also include a combinator named `Raw` that can be used for two reaso - You want to serve static files from a given directory. In that case you can just say: -> type UserAPI11 = "users" :> Get '[JSON] [User] -> -- a /users endpoint -> -> :<|> Raw -> -- requests to anything else than /users -> -- go here, where the server will try to -> -- find a file with the right name -> -- at the right path +``` haskell +type UserAPI11 = "users" :> Get '[JSON] [User] + -- a /users endpoint + + :<|> Raw + -- requests to anything else than /users + -- go here, where the server will try to + -- find a file with the right name + -- at the right path +``` - You more generally want to plug a [WAI `Application`](http://hackage.haskell.org/package/wai) into your webservice. Static file serving is a specific example of that. The API type would look the diff --git a/doc/tutorial/client.lhs b/doc/tutorial/client.lhs index f557c413..9571ec8c 100644 --- a/doc/tutorial/client.lhs +++ b/doc/tutorial/client.lhs @@ -11,75 +11,85 @@ and friends. By *derive*, we mean that there's no code generation involved, the The source for this tutorial section is a literate haskell file, so first we need to have some language extensions and imports: -> {-# LANGUAGE DataKinds #-} -> {-# LANGUAGE DeriveGeneric #-} -> {-# LANGUAGE TypeOperators #-} -> -> module Client where -> -> import Control.Monad.Trans.Either -> import Data.Aeson -> import Data.Proxy -> import GHC.Generics -> import Servant.API -> import Servant.Client +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} + +module Client where + +import Control.Monad.Trans.Either +import Data.Aeson +import Data.Proxy +import GHC.Generics +import Servant.API +import Servant.Client +``` Also, we need examples for some domain specific data types: -> data Position = Position -> { x :: Int -> , y :: Int -> } deriving (Show, Generic) -> -> instance FromJSON Position -> -> newtype HelloMessage = HelloMessage { msg :: String } -> deriving (Show, Generic) -> -> instance FromJSON HelloMessage -> -> data ClientInfo = ClientInfo -> { clientName :: String -> , clientEmail :: String -> , clientAge :: Int -> , clientInterestedIn :: [String] -> } deriving Generic -> -> instance ToJSON ClientInfo -> -> data Email = Email -> { from :: String -> , to :: String -> , subject :: String -> , body :: String -> } deriving (Show, Generic) -> -> instance FromJSON Email +``` haskell +data Position = Position + { x :: Int + , y :: Int + } deriving (Show, Generic) + +instance FromJSON Position + +newtype HelloMessage = HelloMessage { msg :: String } + deriving (Show, Generic) + +instance FromJSON HelloMessage + +data ClientInfo = ClientInfo + { clientName :: String + , clientEmail :: String + , clientAge :: Int + , clientInterestedIn :: [String] + } deriving Generic + +instance ToJSON ClientInfo + +data Email = Email + { from :: String + , to :: String + , subject :: String + , body :: String + } deriving (Show, Generic) + +instance FromJSON Email +``` Enough chitchat, let's see an example. Consider the following API type from the previous section: -> type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position -> :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage -> :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email +``` haskell +type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position + :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage + :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email +``` What we are going to get with *servant-client* here is 3 functions, one to query each endpoint: -> position :: Int -- ^ value for "x" -> -> Int -- ^ value for "y" -> -> EitherT ServantError IO Position -> -> hello :: Maybe String -- ^ an optional value for "name" -> -> EitherT ServantError IO HelloMessage -> -> marketing :: ClientInfo -- ^ value for the request body -> -> EitherT ServantError IO Email +``` haskell +position :: Int -- ^ value for "x" + -> Int -- ^ value for "y" + -> EitherT ServantError IO Position + +hello :: Maybe String -- ^ an optional value for "name" + -> EitherT ServantError IO HelloMessage + +marketing :: ClientInfo -- ^ value for the request body + -> EitherT ServantError IO Email +``` Each function makes available as an argument any value that the response may depend on, as evidenced in the API type. How do we get these functions? Just give a `Proxy` to your API and a host to make the requests to: -> api :: Proxy API -> api = Proxy -> -> position :<|> hello :<|> marketing = client api (BaseUrl Http "localhost" 8081) +``` haskell +api :: Proxy API +api = Proxy + +position :<|> hello :<|> marketing = client api (BaseUrl Http "localhost" 8081) +``` As you can see in the code above, we just "pattern match our way" to these functions. If we try to derive less or more functions than there are endpoints in the API, we obviously get an error. The `BaseUrl` value there is just: @@ -101,22 +111,24 @@ data BaseUrl = BaseUrl That's it. Let's now write some code that uses our client functions. -> queries :: EitherT ServantError IO (Position, HelloMessage, Email) -> queries = do -> pos <- position 10 10 -> msg <- hello (Just "servant") -> em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) -> return (pos, msg, em) -> -> run :: IO () -> run = do -> res <- runEitherT queries -> case res of -> Left err -> putStrLn $ "Error: " ++ show err -> Right (pos, msg, em) -> do -> print pos -> print msg -> print em +``` haskell +queries :: EitherT ServantError IO (Position, HelloMessage, Email) +queries = do + pos <- position 10 10 + msg <- hello (Just "servant") + em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) + return (pos, msg, em) + +run :: IO () +run = do + res <- runEitherT queries + case res of + Left err -> putStrLn $ "Error: " ++ show err + Right (pos, msg, em) -> do + print pos + print msg + print em +``` You can now run `dist/build/tutorial/tutorial 8` (the server) and `dist/build/t8-main/t8-main` (the client) to see them both in action. diff --git a/doc/tutorial/docs.lhs b/doc/tutorial/docs.lhs index 2b85b9fa..1ae4570e 100644 --- a/doc/tutorial/docs.lhs +++ b/doc/tutorial/docs.lhs @@ -6,89 +6,99 @@ toc: true The source for this tutorial section is a literate haskell file, so first we need to have some language extensions and imports: -> {-# LANGUAGE DataKinds #-} -> {-# LANGUAGE DeriveGeneric #-} -> {-# LANGUAGE FlexibleInstances #-} -> {-# LANGUAGE MultiParamTypeClasses #-} -> {-# LANGUAGE OverloadedStrings #-} -> {-# LANGUAGE TypeOperators #-} -> {-# OPTIONS_GHC -fno-warn-orphans #-} -> -> module Docs where -> -> import Data.ByteString.Lazy (ByteString) -> import Data.Proxy -> import Data.Text.Lazy.Encoding (encodeUtf8) -> import Data.Text.Lazy (pack) -> import Network.HTTP.Types -> import Network.Wai -> import Servant.API -> import Servant.Docs -> import Servant.Server +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Docs where + +import Data.ByteString.Lazy (ByteString) +import Data.Proxy +import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Text.Lazy (pack) +import Network.HTTP.Types +import Network.Wai +import Servant.API +import Servant.Docs +import Servant.Server +``` And we'll import some things from one of our earlier modules ([Serving an API](/tutorial/server.html)): -> import Server (Email(..), ClientInfo(..), Position(..), HelloMessage(..), -> server3, emailForClient) +``` haskell +import Server (Email(..), ClientInfo(..), Position(..), HelloMessage(..), + server3, emailForClient) +``` Like client function generation, documentation generation amounts to inspecting the API type and extracting all the data we need to then present it in some format to users of your API. This time however, we have to assist *servant*. While it is able to deduce a lot of things about our API, it can't magically come up with descriptions of the various pieces of our APIs that are human-friendly and explain what's going on "at the business-logic level". A good example to study for documentation generation is our webservice with the `/position`, `/hello` and `/marketing` endpoints from earlier: -> type ExampleAPI = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position -> :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage -> :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email -> -> exampleAPI :: Proxy ExampleAPI -> exampleAPI = Proxy +``` haskell +type ExampleAPI = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position + :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage + :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email + +exampleAPI :: Proxy ExampleAPI +exampleAPI = Proxy +``` While *servant* can see e.g. that there are 3 endpoints and that the response bodies will be in JSON, it doesn't know what influence the captures, parameters, request bodies and other combinators have on the webservice. This is where some manual work is required. For every capture, request body, response body, query param, we have to give some explanations about how it influences the response, what values are possible and the likes. Here's how it looks like for the parameters we have above. -> instance ToCapture (Capture "x" Int) where -> toCapture _ = -> DocCapture "x" -- name -> "(integer) position on the x axis" -- description -> -> instance ToCapture (Capture "y" Int) where -> toCapture _ = -> DocCapture "y" -- name -> "(integer) position on the y axis" -- description -> -> instance ToSample Position Position where -> toSample _ = Just (Position 3 14) -- example of output -> -> instance ToParam (QueryParam "name" String) where -> toParam _ = -> DocQueryParam "name" -- name -> ["Alp", "John Doe", "..."] -- example of values (not necessarily exhaustive) -> "Name of the person to say hello to." -- description -> Normal -- Normal, List or Flag -> -> instance ToSample HelloMessage HelloMessage where -> toSamples _ = -> [ ("When a value is provided for 'name'", HelloMessage "Hello, Alp") -> , ("When 'name' is not specified", HelloMessage "Hello, anonymous coward") -> ] -> -- mutliple examples to display this time -> -> ci :: ClientInfo -> ci = ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"] -> -> instance ToSample ClientInfo ClientInfo where -> toSample _ = Just ci -> -> instance ToSample Email Email where -> toSample _ = Just (emailForClient ci) +``` haskell +instance ToCapture (Capture "x" Int) where + toCapture _ = + DocCapture "x" -- name + "(integer) position on the x axis" -- description + +instance ToCapture (Capture "y" Int) where + toCapture _ = + DocCapture "y" -- name + "(integer) position on the y axis" -- description + +instance ToSample Position Position where + toSample _ = Just (Position 3 14) -- example of output + +instance ToParam (QueryParam "name" String) where + toParam _ = + DocQueryParam "name" -- name + ["Alp", "John Doe", "..."] -- example of values (not necessarily exhaustive) + "Name of the person to say hello to." -- description + Normal -- Normal, List or Flag + +instance ToSample HelloMessage HelloMessage where + toSamples _ = + [ ("When a value is provided for 'name'", HelloMessage "Hello, Alp") + , ("When 'name' is not specified", HelloMessage "Hello, anonymous coward") + ] + -- mutliple examples to display this time + +ci :: ClientInfo +ci = ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"] + +instance ToSample ClientInfo ClientInfo where + toSample _ = Just ci + +instance ToSample Email Email where + toSample _ = Just (emailForClient ci) +``` Types that are used as request or response bodies have to instantiate the `ToSample` typeclass which lets you specify one or more examples of values. `Capture`s and `QueryParam`s have to instantiate their respective `ToCapture` and `ToParam` classes and provide a name and some information about the concrete meaning of that argument, as illustrated in the code above. With all of this, we can derive docs for our API. -> apiDocs :: API -> apiDocs = docs exampleAPI +``` haskell +apiDocs :: API +apiDocs = docs exampleAPI +``` `API` is a type provided by *servant-docs* that stores all the information one needs about a web API in order to generate documentation in some format. Out of the box, *servant-docs* only provides a pretty documentation printer that outputs [Markdown](http://en.wikipedia.org/wiki/Markdown), but the [servant-pandoc](http://hackage.haskell.org/package/servant-pandoc) package can be used to target many useful formats. @@ -192,33 +202,37 @@ That lets us see what our API docs look down in markdown, by looking at `markdow However, we can also add one or more introduction sections to the document. We just need to tweak the way we generate `apiDocs`. We will also convert the content to a lazy `ByteString` since this is what *wai* expects for `Raw` endpoints. -> docsBS :: ByteString -> docsBS = encodeUtf8 -> . pack -> . markdown -> $ docsWithIntros [intro] exampleAPI -> -> where intro = DocIntro "Welcome" ["This is our super webservice's API.", "Enjoy!"] +``` haskell +docsBS :: ByteString +docsBS = encodeUtf8 + . pack + . markdown + $ docsWithIntros [intro] exampleAPI + + where intro = DocIntro "Welcome" ["This is our super webservice's API.", "Enjoy!"] +``` `docsWithIntros` just takes an additional parameter, a list of `DocIntro`s that must be displayed before any endpoint docs. We can now serve the API *and* the API docs with a simple server. -> type DocsAPI = ExampleAPI :<|> Raw -> -> api :: Proxy DocsAPI -> api = Proxy -> -> server :: Server DocsAPI -> server = Server.server3 :<|> serveDocs -> -> where serveDocs _ respond = -> respond $ responseLBS ok200 [plain] docsBS -> -> plain = ("Content-Type", "text/plain") -> -> app :: Application -> app = serve api server +``` haskell +type DocsAPI = ExampleAPI :<|> Raw + +api :: Proxy DocsAPI +api = Proxy + +server :: Server DocsAPI +server = Server.server3 :<|> serveDocs + + where serveDocs _ respond = + respond $ responseLBS ok200 [plain] docsBS + + plain = ("Content-Type", "text/plain") + +app :: Application +app = serve api server +``` And if you spin up this server with `dist/build/tutorial/tutorial 10` and go to anywhere else than `/position`, `/hello` and `/marketing`, you will see the API docs in markdown. This is because `serveDocs` is attempted if the 3 other endpoints don't match and systematically succeeds since its definition is to just return some fixed bytestring with the `text/plain` content type. diff --git a/doc/tutorial/javascript.lhs b/doc/tutorial/javascript.lhs index 33b4f73b..9098fe8d 100644 --- a/doc/tutorial/javascript.lhs +++ b/doc/tutorial/javascript.lhs @@ -22,117 +22,131 @@ query your API. The source for this tutorial section is a literate haskell file, so first we need to have some language extensions and imports: -> {-# LANGUAGE DataKinds #-} -> {-# LANGUAGE DeriveGeneric #-} -> {-# LANGUAGE OverloadedStrings #-} -> {-# LANGUAGE TypeOperators #-} -> -> module Javascript where -> -> import Control.Monad.IO.Class -> import Data.Aeson -> import Data.Proxy -> import Data.Text (Text) -> import qualified Data.Text as T -> import GHC.Generics -> import Language.Javascript.JQuery -> import Network.Wai -> import Servant -> import Servant.JQuery -> import System.Random +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Javascript where + +import Control.Monad.IO.Class +import Data.Aeson +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics +import Language.Javascript.JQuery +import Network.Wai +import Servant +import Servant.JQuery +import System.Random +``` Now let's have the API type(s) and the accompanying datatypes. -> type API = "point" :> Get '[JSON] Point -> :<|> "books" :> QueryParam "q" Text :> Get '[JSON] (Search Book) -> -> type API' = API :<|> Raw -> -> data Point = Point -> { x :: Double -> , y :: Double -> } deriving Generic -> -> instance ToJSON Point -> -> data Search a = Search -> { query :: Text -> , results :: [a] -> } deriving Generic -> -> mkSearch :: Text -> [a] -> Search a -> mkSearch = Search -> -> instance ToJSON a => ToJSON (Search a) -> -> data Book = Book -> { author :: Text -> , title :: Text -> , year :: Int -> } deriving Generic -> -> instance ToJSON Book -> -> book :: Text -> Text -> Int -> Book -> book = Book +``` haskell +type API = "point" :> Get '[JSON] Point + :<|> "books" :> QueryParam "q" Text :> Get '[JSON] (Search Book) + +type API' = API :<|> Raw + +data Point = Point + { x :: Double + , y :: Double + } deriving Generic + +instance ToJSON Point + +data Search a = Search + { query :: Text + , results :: [a] + } deriving Generic + +mkSearch :: Text -> [a] -> Search a +mkSearch = Search + +instance ToJSON a => ToJSON (Search a) + +data Book = Book + { author :: Text + , title :: Text + , year :: Int + } deriving Generic + +instance ToJSON Book + +book :: Text -> Text -> Int -> Book +book = Book +``` We need a "book database". For the purpose of this guide, let's restrict ourselves to the following books. -> books :: [Book] -> books = -> [ book "Paul Hudak" "The Haskell School of Expression: Learning Functional Programming through Multimedia" 2000 -> , book "Bryan O'Sullivan, Don Stewart, and John Goerzen" "Real World Haskell" 2008 -> , book "Miran Lipovača" "Learn You a Haskell for Great Good!" 2011 -> , book "Graham Hutton" "Programming in Haskell" 2007 -> , book "Simon Marlow" "Parallel and Concurrent Programming in Haskell" 2013 -> , book "Richard Bird" "Introduction to Functional Programming using Haskell" 1998 -> ] +``` haskell +books :: [Book] +books = + [ book "Paul Hudak" "The Haskell School of Expression: Learning Functional Programming through Multimedia" 2000 + , book "Bryan O'Sullivan, Don Stewart, and John Goerzen" "Real World Haskell" 2008 + , book "Miran Lipovača" "Learn You a Haskell for Great Good!" 2011 + , book "Graham Hutton" "Programming in Haskell" 2007 + , book "Simon Marlow" "Parallel and Concurrent Programming in Haskell" 2013 + , book "Richard Bird" "Introduction to Functional Programming using Haskell" 1998 + ] +``` Now, given an optional search string `q`, we want to perform a case insensitive search in that list of books. We're obviously not going to try and implement the best possible algorithm, this is out of scope for this tutorial. The following simple linear scan will do, given how small our list is. -> searchBook :: Monad m => Maybe Text -> m (Search Book) -> searchBook Nothing = return (mkSearch "" books) -> searchBook (Just q) = return (mkSearch q books') -> -> where books' = filter (\b -> q' `T.isInfixOf` T.toLower (author b) -> || q' `T.isInfixOf` T.toLower (title b) -> ) -> books -> q' = T.toLower q +``` haskell +searchBook :: Monad m => Maybe Text -> m (Search Book) +searchBook Nothing = return (mkSearch "" books) +searchBook (Just q) = return (mkSearch q books') + + where books' = filter (\b -> q' `T.isInfixOf` T.toLower (author b) + || q' `T.isInfixOf` T.toLower (title b) + ) + books + q' = T.toLower q +``` We also need an endpoint that generates random points `(x, y)` with `-1 <= x,y <= 1`. The code below uses [random](http://hackage.haskell.org/package/random)'s `System.Random`. -> randomPoint :: MonadIO m => m Point -> randomPoint = liftIO . getStdRandom $ \g -> -> let (rx, g') = randomR (-1, 1) g -> (ry, g'') = randomR (-1, 1) g' -> in (Point rx ry, g'') +``` haskell +randomPoint :: MonadIO m => m Point +randomPoint = liftIO . getStdRandom $ \g -> + let (rx, g') = randomR (-1, 1) g + (ry, g'') = randomR (-1, 1) g' + in (Point rx ry, g'') +``` If we add static file serving, our server is now complete. -> api :: Proxy API -> api = Proxy -> -> api' :: Proxy API' -> api' = Proxy -> -> server :: Server API -> server = randomPoint -> :<|> searchBook -> -> server' :: Server API' -> server' = server -> :<|> serveDirectory "tutorial/t9" -> -> app :: Application -> app = serve api' server' +``` haskell +api :: Proxy API +api = Proxy + +api' :: Proxy API' +api' = Proxy + +server :: Server API +server = randomPoint + :<|> searchBook + +server' :: Server API' +server' = server + :<|> serveDirectory "tutorial/t9" + +app :: Application +app = serve api' server' +``` Why two different API types, proxies and servers though? Simply because we don't want to generate javascript functions for the `Raw` part of our API type, so we need a `Proxy` for our API type `API'` without its `Raw` endpoint. Very similarly to how one can derive haskell functions, we can derive the javascript with just a simple function call to `jsForAPI` from `Servant.JQuery`. -> apiJS :: String -> apiJS = jsForAPI api +``` haskell +apiJS :: String +apiJS = jsForAPI api +``` This `String` contains 2 Javascript functions: @@ -161,11 +175,13 @@ function getbooks(q, onSuccess, onError) Right before starting up our server, we will need to write this `String` to a file, say `api.js`, along with a copy of the *jQuery* library, as provided by the [js-jquery](http://hackage.haskell.org/package/js-jquery) package. -> writeJSFiles :: IO () -> writeJSFiles = do -> writeFile "getting-started/gs9/api.js" apiJS -> jq <- readFile =<< Language.Javascript.JQuery.file -> writeFile "getting-started/gs9/jq.js" jq +``` haskell +writeJSFiles :: IO () +writeJSFiles = do + writeFile "getting-started/gs9/api.js" apiJS + jq <- readFile =<< Language.Javascript.JQuery.file + writeFile "getting-started/gs9/jq.js" jq +``` And we're good to go. Start the server with `dist/build/tutorial/tutorial 9` and go to `http://localhost:8081/`. Start typing in the name of one of the authors in our database or part of a book title, and check out how long it takes to approximate π using the method mentioned above. diff --git a/doc/tutorial/server.lhs b/doc/tutorial/server.lhs index 411ec1fb..29ca6cb8 100644 --- a/doc/tutorial/server.lhs +++ b/doc/tutorial/server.lhs @@ -34,39 +34,41 @@ Equipped with some basic knowledge about the way we represent API, let's now wri The source for this tutorial section is a literate haskell file, so first we need to have some language extensions and imports: -> {-# LANGUAGE DataKinds #-} -> {-# LANGUAGE DeriveGeneric #-} -> {-# LANGUAGE FlexibleInstances #-} -> {-# LANGUAGE GeneralizedNewtypeDeriving #-} -> {-# LANGUAGE MultiParamTypeClasses #-} -> {-# LANGUAGE OverloadedStrings #-} -> {-# LANGUAGE ScopedTypeVariables #-} -> {-# LANGUAGE TypeOperators #-} -> -> module Server where -> -> import Control.Monad.IO.Class -> import Control.Monad.Reader -> import Control.Monad.Trans.Either -> import Data.Aeson -> import Data.Aeson.Types -> import Data.Attoparsec.ByteString -> import Data.ByteString (ByteString) -> import Data.Int -> import Data.List -> import Data.String.Conversions -> import Data.Time.Calendar -> import GHC.Generics -> import Lucid -> import Network.HTTP.Media ((//), (/:)) -> import Network.Wai -> import Network.Wai.Handler.Warp -> import Servant -> import System.Directory -> import Text.Blaze -> import Text.Blaze.Html.Renderer.Utf8 -> import qualified Data.Aeson.Parser -> import qualified Text.Blaze.Html +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Server where + +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.Trans.Either +import Data.Aeson +import Data.Aeson.Types +import Data.Attoparsec.ByteString +import Data.ByteString (ByteString) +import Data.Int +import Data.List +import Data.String.Conversions +import Data.Time.Calendar +import GHC.Generics +import Lucid +import Network.HTTP.Media ((//), (/:)) +import Network.Wai +import Network.Wai.Handler.Warp +import Servant +import System.Directory +import Text.Blaze +import Text.Blaze.Html.Renderer.Utf8 +import qualified Data.Aeson.Parser +import qualified Text.Blaze.Html +``` ``` haskell ignore {-# LANGUAGE TypeFamilies #-} @@ -76,7 +78,9 @@ need to have some language extensions and imports: We will write a server that will serve the following API. -> type UserAPI1 = "users" :> Get '[JSON] [User] +``` haskell +type UserAPI1 = "users" :> Get '[JSON] [User] +``` Here's what we would like to see when making a GET request to `/users`. @@ -88,22 +92,26 @@ Here's what we would like to see when making a GET request to `/users`. Now let's define our `User` data type and write some instances for it. -> data User = User -> { name :: String -> , age :: Int -> , email :: String -> , registration_date :: Day -> } deriving (Eq, Show, Generic) -> -> instance ToJSON User +``` haskell +data User = User + { name :: String + , age :: Int + , email :: String + , registration_date :: Day + } deriving (Eq, Show, Generic) + +instance ToJSON User +``` Nothing funny going on here. But we now can define our list of two users. -> users1 :: [User] -> users1 = -> [ User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1) -> , User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1) -> ] +``` haskell +users1 :: [User] +users1 = + [ User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1) + , User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1) + ] +``` Let's also write our API type. @@ -129,27 +137,33 @@ HTTP method combinator used for the corresponding endpoint. In our case, it means we must provide a handler of type `EitherT ServantErr IO [User]`. Well, we have a monad, let's just `return` our list: -> server1 :: Server UserAPI1 -> server1 = return users1 +``` haskell +server1 :: Server UserAPI1 +server1 = return users1 +``` That's it. Now we can turn `server` into an actual webserver using [wai](http://hackage.haskell.org/package/wai) and [warp](http://hackage.haskell.org/package/warp): -> userAPI :: Proxy UserAPI1 -> userAPI = Proxy -> -> -- 'serve' comes from servant and hands you a WAI Application, -> -- which you can think of as an "abstract" web application, -> -- not yet a webserver. -> app1 :: Application -> app1 = serve userAPI server1 +``` haskell +userAPI :: Proxy UserAPI1 +userAPI = Proxy + +-- 'serve' comes from servant and hands you a WAI Application, +-- which you can think of as an "abstract" web application, +-- not yet a webserver. +app1 :: Application +app1 = serve userAPI server1 +``` The `userAPI` bit is, alas, boilerplate (we need it to guide type inference). But that's about as much boilerplate as you get. And we're done! Let's run our webservice on the port 8081. -> main :: IO () -> main = run 8081 app1 +``` haskell +main :: IO () +main = run 8081 app1 +``` You can put this all into a file or just grab [servant's repo](http://github.com/haskell-servant/servant) and look at the @@ -170,29 +184,35 @@ More endpoints What if we want more than one endpoint? Let's add `/albert` and `/isaac` to view the corresponding users encoded in JSON. -> type UserAPI2 = "users" :> Get '[JSON] [User] -> :<|> "albert" :> Get '[JSON] User -> :<|> "isaac" :> Get '[JSON] User +``` haskell +type UserAPI2 = "users" :> Get '[JSON] [User] + :<|> "albert" :> Get '[JSON] User + :<|> "isaac" :> Get '[JSON] User +``` And let's adapt our code a bit. -> isaac :: User -> isaac = User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1) -> -> albert :: User -> albert = User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1) -> -> users2 :: [User] -> users2 = [isaac, albert] +``` haskell +isaac :: User +isaac = User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1) + +albert :: User +albert = User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1) + +users2 :: [User] +users2 = [isaac, albert] +``` Now, just like we separate the various endpoints in `UserAPI` with `:<|>`, we are going to separate the handlers with `:<|>` too! They must be provided in the same order as the one they appear in in the API type. -> server2 :: Server UserAPI2 -> server2 = return users2 -> :<|> return albert -> :<|> return isaac +``` haskell +server2 :: Server UserAPI2 +server2 = return users2 + :<|> return albert + :<|> return isaac +``` And that's it! You can run this example with `dist/build/tutorial/tutorial 2` and check out the data available @@ -211,70 +231,74 @@ decoding/encoding data from/to JSON. Never. We are going to use the following data types and functions to implement a server for `API`. -> type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position -> :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage -> :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email -> -> data Position = Position -> { x :: Int -> , y :: Int -> } deriving Generic -> -> instance ToJSON Position -> -> newtype HelloMessage = HelloMessage { msg :: String } -> deriving Generic -> -> instance ToJSON HelloMessage -> -> data ClientInfo = ClientInfo -> { clientName :: String -> , clientEmail :: String -> , clientAge :: Int -> , clientInterestedIn :: [String] -> } deriving Generic -> -> instance FromJSON ClientInfo -> instance ToJSON ClientInfo -> -> data Email = Email -> { from :: String -> , to :: String -> , subject :: String -> , body :: String -> } deriving Generic -> -> instance ToJSON Email -> -> emailForClient :: ClientInfo -> Email -> emailForClient c = Email from' to' subject' body' -> -> where from' = "great@company.com" -> to' = clientEmail c -> subject' = "Hey " ++ clientName c ++ ", we miss you!" -> body' = "Hi " ++ clientName c ++ ",\n\n" -> ++ "Since you've recently turned " ++ show (clientAge c) -> ++ ", have you checked out our latest " -> ++ intercalate ", " (clientInterestedIn c) -> ++ " products? Give us a visit!" +``` haskell +type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position + :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage + :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email + +data Position = Position + { x :: Int + , y :: Int + } deriving Generic + +instance ToJSON Position + +newtype HelloMessage = HelloMessage { msg :: String } + deriving Generic + +instance ToJSON HelloMessage + +data ClientInfo = ClientInfo + { clientName :: String + , clientEmail :: String + , clientAge :: Int + , clientInterestedIn :: [String] + } deriving Generic + +instance FromJSON ClientInfo +instance ToJSON ClientInfo + +data Email = Email + { from :: String + , to :: String + , subject :: String + , body :: String + } deriving Generic + +instance ToJSON Email + +emailForClient :: ClientInfo -> Email +emailForClient c = Email from' to' subject' body' + + where from' = "great@company.com" + to' = clientEmail c + subject' = "Hey " ++ clientName c ++ ", we miss you!" + body' = "Hi " ++ clientName c ++ ",\n\n" + ++ "Since you've recently turned " ++ show (clientAge c) + ++ ", have you checked out our latest " + ++ intercalate ", " (clientInterestedIn c) + ++ " products? Give us a visit!" +``` We can implement handlers for the three endpoints: -> server3 :: Server API -> server3 = position -> :<|> hello -> :<|> marketing -> -> where position :: Int -> Int -> EitherT ServantErr IO Position -> position x y = return (Position x y) -> -> hello :: Maybe String -> EitherT ServantErr IO HelloMessage -> hello mname = return . HelloMessage $ case mname of -> Nothing -> "Hello, anonymous coward" -> Just n -> "Hello, " ++ n -> -> marketing :: ClientInfo -> EitherT ServantErr IO Email -> marketing clientinfo = return (emailForClient clientinfo) +``` haskell +server3 :: Server API +server3 = position + :<|> hello + :<|> marketing + + where position :: Int -> Int -> EitherT ServantErr IO Position + position x y = return (Position x y) + + hello :: Maybe String -> EitherT ServantErr IO HelloMessage + hello mname = return . HelloMessage $ case mname of + Nothing -> "Hello, anonymous coward" + Just n -> "Hello, " ++ n + + marketing :: ClientInfo -> EitherT ServantErr IO Email + marketing clientinfo = return (emailForClient clientinfo) +``` Did you see that? The types for your handlers changed to be just what we needed! In particular: @@ -337,29 +361,31 @@ decoded to provides a `FromText` instance, it will Just Work. *servant* provides a decent number of instances, but here are some examples of defining your own. -> -- A typical enumeration -> data Direction -> = Up -> | Down -> | Left -> | Right -> -> instance FromText Direction where -> -- requires {-# LANGUAGE OverloadedStrings #-} -> fromText "up" = Just Up -> fromText "down" = Just Down -> fromText "left" = Just Server.Left -> fromText "right" = Just Server.Right -> fromText _ = Nothing -> -> instance ToText Direction where -> toText Up = "up" -> toText Down = "down" -> toText Server.Left = "left" -> toText Server.Right = "right" -> -> newtype UserId = UserId Int64 -> deriving (FromText, ToText) +``` haskell +-- A typical enumeration +data Direction + = Up + | Down + | Left + | Right + +instance FromText Direction where + -- requires {-# LANGUAGE OverloadedStrings #-} + fromText "up" = Just Up + fromText "down" = Just Down + fromText "left" = Just Server.Left + fromText "right" = Just Server.Right + fromText _ = Nothing + +instance ToText Direction where + toText Up = "up" + toText Down = "down" + toText Server.Left = "left" + toText Server.Right = "right" + +newtype UserId = UserId Int64 + deriving (FromText, ToText) +``` or writing the instances by hand: @@ -464,10 +490,12 @@ our own little function around *aeson* and *attoparsec* that allows any type of JSON value at the toplevel of a "JSON document". Here's the definition in case you are curious. -> eitherDecodeLenient :: FromJSON a => ByteString -> Either String a -> eitherDecodeLenient input = do -> v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input) -> parseEither parseJSON v +``` haskell +eitherDecodeLenient :: FromJSON a => ByteString -> Either String a +eitherDecodeLenient input = do + v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input) + parseEither parseJSON v +``` This function is exactly what we need for our `MimeUnrender` instance. @@ -492,7 +520,9 @@ or [lucid](http://hackage.haskell.org/package/lucid). The best option for *servant* is obviously to support both (and hopefully other templating solutions!). -> data HTMLLucid +``` haskell +data HTMLLucid +``` Once again, the data type is just there as a symbol for the encoding/decoding functions, except that this time we will only worry about encoding since @@ -500,8 +530,10 @@ functions, except that this time we will only worry about encoding since Both packages also have the same `Accept` instance for their `HTMLLucid` type. -> instance Accept HTMLLucid where -> contentType _ = "text" // "html" /: ("charset", "utf-8") +``` haskell +instance Accept HTMLLucid where + contentType _ = "text" // "html" /: ("charset", "utf-8") +``` Note that this instance uses the `(/:)` operator from *http-media* which lets us specify additional information about a content-type, like the charset here. @@ -512,31 +544,35 @@ then write that to a `ByteString`. For *lucid*: -> instance ToHtml a => MimeRender HTMLLucid a where -> mimeRender _ = renderBS . toHtml -> -> -- let's also provide an instance for lucid's -> -- 'Html' wrapper. -> instance MimeRender HTMLLucid (Html a) where -> mimeRender _ = renderBS +``` haskell +instance ToHtml a => MimeRender HTMLLucid a where + mimeRender _ = renderBS . toHtml + +-- let's also provide an instance for lucid's +-- 'Html' wrapper. +instance MimeRender HTMLLucid (Html a) where + mimeRender _ = renderBS +``` For *blaze-html*: -> -- For this tutorial to compile 'HTMLLucid' and 'HTMLBlaze' have to be -> -- distinct. Usually you would stick to one html rendering library and then -> -- you can go with one 'HTML' type. -> data HTMLBlaze -> -> instance Accept HTMLBlaze where -> contentType _ = "text" // "html" /: ("charset", "utf-8") -> -> instance ToMarkup a => MimeRender HTMLBlaze a where -> mimeRender _ = renderHtml . Text.Blaze.Html.toHtml -> -> -- while we're at it, just like for lucid we can -> -- provide an instance for rendering blaze's 'Html' type -> instance MimeRender HTMLBlaze Text.Blaze.Html.Html where -> mimeRender _ = renderHtml +``` haskell +-- For this tutorial to compile 'HTMLLucid' and 'HTMLBlaze' have to be +-- distinct. Usually you would stick to one html rendering library and then +-- you can go with one 'HTML' type. +data HTMLBlaze + +instance Accept HTMLBlaze where + contentType _ = "text" // "html" /: ("charset", "utf-8") + +instance ToMarkup a => MimeRender HTMLBlaze a where + mimeRender _ = renderHtml . Text.Blaze.Html.toHtml + +-- while we're at it, just like for lucid we can +-- provide an instance for rendering blaze's 'Html' type +instance MimeRender HTMLBlaze Text.Blaze.Html.Html where + mimeRender _ = renderHtml +``` Both [servant-blaze](http://hackage.haskell.org/package/servant-blaze) and [servant-lucid](http://hackage.haskell.org/package/servant-lucid) let you use @@ -548,59 +584,67 @@ content type in action. First off, imports and pragmas as usual. We will be serving the following API: -> type PersonAPI = "persons" :> Get '[JSON, HTMLLucid] [Person] +``` haskell +type PersonAPI = "persons" :> Get '[JSON, HTMLLucid] [Person] +``` where `Person` is defined as follows: -> data Person = Person -> { firstName :: String -> , lastName :: String -> } deriving Generic -- for the JSON instance -> -> instance ToJSON Person +``` haskell +data Person = Person + { firstName :: String + , lastName :: String + } deriving Generic -- for the JSON instance + +instance ToJSON Person +``` Now, let's teach *lucid* how to render a `Person` as a row in a table, and then a list of `Person`s as a table with a row per person. -> -- HTML serialization of a single person -> instance ToHtml Person where -> toHtml person = -> tr_ $ do -> td_ (toHtml $ firstName person) -> td_ (toHtml $ lastName person) -> -> -- do not worry too much about this -> toHtmlRaw = toHtml -> -> -- HTML serialization of a list of persons -> instance ToHtml [Person] where -> toHtml persons = table_ $ do -> tr_ $ do -> th_ "first name" -> th_ "last name" -> -> -- this just calls toHtml on each person of the list -> -- and concatenates the resulting pieces of HTML together -> foldMap toHtml persons -> -> toHtmlRaw = toHtml +``` haskell +-- HTML serialization of a single person +instance ToHtml Person where + toHtml person = + tr_ $ do + td_ (toHtml $ firstName person) + td_ (toHtml $ lastName person) + + -- do not worry too much about this + toHtmlRaw = toHtml + +-- HTML serialization of a list of persons +instance ToHtml [Person] where + toHtml persons = table_ $ do + tr_ $ do + th_ "first name" + th_ "last name" + + -- this just calls toHtml on each person of the list + -- and concatenates the resulting pieces of HTML together + foldMap toHtml persons + + toHtmlRaw = toHtml +``` We create some `Person` values and serve them as a list: -> persons :: [Person] -> persons = -> [ Person "Isaac" "Newton" -> , Person "Albert" "Einstein" -> ] -> -> personAPI :: Proxy PersonAPI -> personAPI = Proxy -> -> server4 :: Server PersonAPI -> server4 = return persons -> -> app2 :: Application -> app2 = serve personAPI server4 +``` haskell +persons :: [Person] +persons = + [ Person "Isaac" "Newton" + , Person "Albert" "Einstein" + ] + +personAPI :: Proxy PersonAPI +personAPI = Proxy + +server4 :: Server PersonAPI +server4 = return persons + +app2 :: Application +app2 = serve personAPI server4 +``` And we're good to go. You can run this example with `dist/build/tutorial/tutorial 4`. @@ -666,18 +710,20 @@ class Monad m => MonadIO m where Obviously, the `IO` monad provides a `MonadIO` instance. Hence for any type `e`, `EitherT e IO` has a `MonadIO` instance. So if you want to run any kind of IO computation in your handlers, just use `liftIO`: -> type IOAPI1 = "myfile.txt" :> Get '[JSON] FileContent -> -> newtype FileContent = FileContent -> { content :: String } -> deriving Generic -> -> instance ToJSON FileContent -> -> server5 :: Server IOAPI1 -> server5 = do -> filecontent <- liftIO (readFile "myfile.txt") -> return (FileContent filecontent) +``` haskell +type IOAPI1 = "myfile.txt" :> Get '[JSON] FileContent + +newtype FileContent = FileContent + { content :: String } + deriving Generic + +instance ToJSON FileContent + +server5 :: Server IOAPI1 +server5 = do + filecontent <- liftIO (readFile "myfile.txt") + return (FileContent filecontent) +``` Failing, through `ServantErr` ----------------------------- @@ -701,23 +747,27 @@ Many standard values are provided out of the box by the `Servant.Server` module. If you want to use these values but add a body or some headers, just use record update syntax: -> failingHandler :: EitherT ServantErr IO () -> failingHandler = left myerr -> -> where myerr :: ServantErr -> myerr = err503 { errBody = "Sorry dear user." } +``` haskell +failingHandler :: EitherT ServantErr IO () +failingHandler = left myerr + + where myerr :: ServantErr + myerr = err503 { errBody = "Sorry dear user." } +``` Here's an example where we return a customised 404-Not-Found error message in the response body if "myfile.txt" isn't there: -> server6 :: Server IOAPI1 -> server6 = do -> exists <- liftIO (doesFileExist "myfile.txt") -> if exists -> then liftIO (readFile "myfile.txt") >>= return . FileContent -> else left custom404Err -> -> where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." } +``` haskell +server6 :: Server IOAPI1 +server6 = do + exists <- liftIO (doesFileExist "myfile.txt") + if exists + then liftIO (readFile "myfile.txt") >>= return . FileContent + else left custom404Err + + where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." } +``` Let's run this server (`dist/build/tutorial/tutorial 5`) and query it, first without the file and then with the file. @@ -758,10 +808,12 @@ Response headers To add headers to your response, use [addHeader](http://hackage.haskell.org/package/servant-0.4.4/docs/Servant-API-ResponseHeaders.html). Note that this changes the type of your API, as we can see in the following example: -> type MyHandler = Get '[JSON] (Headers '[Header "X-An-Int" Int] User) -> -> myHandler :: Server MyHandler -> myHandler = return $ addHeader 1797 albert +``` haskell +type MyHandler = Get '[JSON] (Headers '[Header "X-An-Int" Int] User) + +myHandler :: Server MyHandler +myHandler = return $ addHeader 1797 albert +``` Serving static files @@ -786,18 +838,24 @@ getting-started. The API type will be the following. -> type CodeAPI = "code" :> Raw +``` haskell +type CodeAPI = "code" :> Raw +``` And the server: -> codeAPI :: Proxy CodeAPI -> codeAPI = Proxy +``` haskell +codeAPI :: Proxy CodeAPI +codeAPI = Proxy +``` -> server7 :: Server CodeAPI -> server7 = serveDirectory "tutorial" -> -> app3 :: Application -> app3 = serve codeAPI server7 +``` haskell +server7 :: Server CodeAPI +server7 = serveDirectory "tutorial" + +app3 :: Application +app3 = serve codeAPI server7 +``` This server will match any request whose path starts with `/code` and will look for a file at the path described by the rest of the request path, inside the *tutorial/* directory of the path you run the program from. @@ -903,18 +961,22 @@ Nested APIs Let's see how you can define APIs in a modular way, while avoiding repetition. Consider this simple example: -> type UserAPI3 = -- view the user with given userid, in JSON -> Capture "userid" Int :> Get '[JSON] User -> -> :<|> -- delete the user with given userid. empty response -> Capture "userid" Int :> Delete '[] () +``` haskell +type UserAPI3 = -- view the user with given userid, in JSON + Capture "userid" Int :> Get '[JSON] User + + :<|> -- delete the user with given userid. empty response + Capture "userid" Int :> Delete '[] () +``` We can instead factor out the `userid`: -> type UserAPI4 = Capture "userid" Int :> -> ( Get '[JSON] User -> :<|> Delete '[] () -> ) +``` haskell +type UserAPI4 = Capture "userid" Int :> + ( Get '[JSON] User + :<|> Delete '[] () + ) +``` However, you have to be aware that this has an effect on the type of the corresponding `Server`: @@ -930,146 +992,158 @@ Server UserAPI4 = Int -> ( EitherT ServantErr IO User In the first case, each handler receives the *userid* argument. In the latter, the whole `Server` takes the *userid* and has handlers that are just computations in `EitherT`, with no arguments. In other words: -> server8 :: Server UserAPI3 -> server8 = getUser :<|> deleteUser -> -> where getUser :: Int -> EitherT ServantErr IO User -> getUser _userid = error "..." -> -> deleteUser :: Int -> EitherT ServantErr IO () -> deleteUser _userid = error "..." -> -> -- notice how getUser and deleteUser -> -- have a different type! no argument anymore, -> -- the argument directly goes to the whole Server -> server9 :: Server UserAPI4 -> server9 userid = getUser userid :<|> deleteUser userid -> -> where getUser :: Int -> EitherT ServantErr IO User -> getUser = error "..." -> -> deleteUser :: Int -> EitherT ServantErr IO () -> deleteUser = error "..." +``` haskell +server8 :: Server UserAPI3 +server8 = getUser :<|> deleteUser + + where getUser :: Int -> EitherT ServantErr IO User + getUser _userid = error "..." + + deleteUser :: Int -> EitherT ServantErr IO () + deleteUser _userid = error "..." + +-- notice how getUser and deleteUser +-- have a different type! no argument anymore, +-- the argument directly goes to the whole Server +server9 :: Server UserAPI4 +server9 userid = getUser userid :<|> deleteUser userid + + where getUser :: Int -> EitherT ServantErr IO User + getUser = error "..." + + deleteUser :: Int -> EitherT ServantErr IO () + deleteUser = error "..." +``` Note that there's nothing special about `Capture` that lets you "factor it out": this can be done with any combinator. Here are a few examples of APIs with a combinator factored out for which we can write a perfectly valid `Server`. -> -- we just factor out the "users" path fragment -> type API1 = "users" :> -> ( Get '[JSON] [User] -- user listing -> :<|> Capture "userid" Int :> Get '[JSON] User -- view a particular user -> ) -> -> -- we factor out the Request Body -> type API2 = ReqBody '[JSON] User :> -> ( Get '[JSON] User -- just display the same user back, don't register it -> :<|> Post '[JSON] () -- register the user. empty response -> ) -> -> -- we factor out a Header -> type API3 = Header "Authorization" Token :> -> ( Get '[JSON] SecretData -- get some secret data, if authorized -> :<|> ReqBody '[JSON] SecretData :> Post '[] () -- add some secret data, if authorized -> ) -> -> newtype Token = Token ByteString -> newtype SecretData = SecretData ByteString +``` haskell +-- we just factor out the "users" path fragment +type API1 = "users" :> + ( Get '[JSON] [User] -- user listing + :<|> Capture "userid" Int :> Get '[JSON] User -- view a particular user + ) + +-- we factor out the Request Body +type API2 = ReqBody '[JSON] User :> + ( Get '[JSON] User -- just display the same user back, don't register it + :<|> Post '[JSON] () -- register the user. empty response + ) + +-- we factor out a Header +type API3 = Header "Authorization" Token :> + ( Get '[JSON] SecretData -- get some secret data, if authorized + :<|> ReqBody '[JSON] SecretData :> Post '[] () -- add some secret data, if authorized + ) + +newtype Token = Token ByteString +newtype SecretData = SecretData ByteString +``` This approach lets you define APIs modularly and assemble them all into one big API type only at the end. -> type UsersAPI = -> Get '[JSON] [User] -- list users -> :<|> ReqBody '[JSON] User :> Post '[] () -- add a user -> :<|> Capture "userid" Int :> -> ( Get '[JSON] User -- view a user -> :<|> ReqBody '[JSON] User :> Put '[] () -- update a user -> :<|> Delete '[] () -- delete a user -> ) -> -> usersServer :: Server UsersAPI -> usersServer = getUsers :<|> newUser :<|> userOperations -> -> where getUsers :: EitherT ServantErr IO [User] -> getUsers = error "..." -> -> newUser :: User -> EitherT ServantErr IO () -> newUser = error "..." -> -> userOperations userid = -> viewUser userid :<|> updateUser userid :<|> deleteUser userid -> -> where -> viewUser :: Int -> EitherT ServantErr IO User -> viewUser = error "..." -> -> updateUser :: Int -> User -> EitherT ServantErr IO () -> updateUser = error "..." -> -> deleteUser :: Int -> EitherT ServantErr IO () -> deleteUser = error "..." +``` haskell +type UsersAPI = + Get '[JSON] [User] -- list users + :<|> ReqBody '[JSON] User :> Post '[] () -- add a user + :<|> Capture "userid" Int :> + ( Get '[JSON] User -- view a user + :<|> ReqBody '[JSON] User :> Put '[] () -- update a user + :<|> Delete '[] () -- delete a user + ) -> type ProductsAPI = -> Get '[JSON] [Product] -- list products -> :<|> ReqBody '[JSON] Product :> Post '[] () -- add a product -> :<|> Capture "productid" Int :> -> ( Get '[JSON] Product -- view a product -> :<|> ReqBody '[JSON] Product :> Put '[] () -- update a product -> :<|> Delete '[] () -- delete a product -> ) -> -> data Product = Product { productId :: Int } -> -> productsServer :: Server ProductsAPI -> productsServer = getProducts :<|> newProduct :<|> productOperations -> -> where getProducts :: EitherT ServantErr IO [Product] -> getProducts = error "..." -> -> newProduct :: Product -> EitherT ServantErr IO () -> newProduct = error "..." -> -> productOperations productid = -> viewProduct productid :<|> updateProduct productid :<|> deleteProduct productid -> -> where -> viewProduct :: Int -> EitherT ServantErr IO Product -> viewProduct = error "..." -> -> updateProduct :: Int -> Product -> EitherT ServantErr IO () -> updateProduct = error "..." -> -> deleteProduct :: Int -> EitherT ServantErr IO () -> deleteProduct = error "..." +usersServer :: Server UsersAPI +usersServer = getUsers :<|> newUser :<|> userOperations -> type CombinedAPI = "users" :> UsersAPI -> :<|> "products" :> ProductsAPI -> -> server10 :: Server CombinedAPI -> server10 = usersServer :<|> productsServer + where getUsers :: EitherT ServantErr IO [User] + getUsers = error "..." + + newUser :: User -> EitherT ServantErr IO () + newUser = error "..." + + userOperations userid = + viewUser userid :<|> updateUser userid :<|> deleteUser userid + + where + viewUser :: Int -> EitherT ServantErr IO User + viewUser = error "..." + + updateUser :: Int -> User -> EitherT ServantErr IO () + updateUser = error "..." + + deleteUser :: Int -> EitherT ServantErr IO () + deleteUser = error "..." +``` + +``` haskell +type ProductsAPI = + Get '[JSON] [Product] -- list products + :<|> ReqBody '[JSON] Product :> Post '[] () -- add a product + :<|> Capture "productid" Int :> + ( Get '[JSON] Product -- view a product + :<|> ReqBody '[JSON] Product :> Put '[] () -- update a product + :<|> Delete '[] () -- delete a product + ) + +data Product = Product { productId :: Int } + +productsServer :: Server ProductsAPI +productsServer = getProducts :<|> newProduct :<|> productOperations + + where getProducts :: EitherT ServantErr IO [Product] + getProducts = error "..." + + newProduct :: Product -> EitherT ServantErr IO () + newProduct = error "..." + + productOperations productid = + viewProduct productid :<|> updateProduct productid :<|> deleteProduct productid + + where + viewProduct :: Int -> EitherT ServantErr IO Product + viewProduct = error "..." + + updateProduct :: Int -> Product -> EitherT ServantErr IO () + updateProduct = error "..." + + deleteProduct :: Int -> EitherT ServantErr IO () + deleteProduct = error "..." +``` + +``` haskell +type CombinedAPI = "users" :> UsersAPI + :<|> "products" :> ProductsAPI + +server10 :: Server CombinedAPI +server10 = usersServer :<|> productsServer +``` Finally, we can realize the user and product APIs are quite similar and abstract that away: -> -- API for values of type 'a' -> -- indexed by values of type 'i' -> type APIFor a i = -> Get '[JSON] [a] -- list 'a's -> :<|> ReqBody '[JSON] a :> Post '[] () -- add an 'a' -> :<|> Capture "id" i :> -> ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i' -> :<|> ReqBody '[JSON] a :> Put '[] () -- update an 'a' -> :<|> Delete '[] () -- delete an 'a' -> ) -> -> -- Build the appropriate 'Server' -> -- given the handlers of the right type. -> serverFor :: EitherT ServantErr IO [a] -- handler for listing of 'a's -> -> (a -> EitherT ServantErr IO ()) -- handler for adding an 'a' -> -> (i -> EitherT ServantErr IO a) -- handler for viewing an 'a' given its identifier of type 'i' -> -> (i -> a -> EitherT ServantErr IO ()) -- updating an 'a' with given id -> -> (i -> EitherT ServantErr IO ()) -- deleting an 'a' given its id -> -> Server (APIFor a i) -> serverFor = error "..." -> -- implementation left as an exercise. contact us on IRC -> -- or the mailing list if you get stuck! +``` haskell +-- API for values of type 'a' +-- indexed by values of type 'i' +type APIFor a i = + Get '[JSON] [a] -- list 'a's + :<|> ReqBody '[JSON] a :> Post '[] () -- add an 'a' + :<|> Capture "id" i :> + ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i' + :<|> ReqBody '[JSON] a :> Put '[] () -- update an 'a' + :<|> Delete '[] () -- delete an 'a' + ) + +-- Build the appropriate 'Server' +-- given the handlers of the right type. +serverFor :: EitherT ServantErr IO [a] -- handler for listing of 'a's + -> (a -> EitherT ServantErr IO ()) -- handler for adding an 'a' + -> (i -> EitherT ServantErr IO a) -- handler for viewing an 'a' given its identifier of type 'i' + -> (i -> a -> EitherT ServantErr IO ()) -- updating an 'a' with given id + -> (i -> EitherT ServantErr IO ()) -- deleting an 'a' given its id + -> Server (APIFor a i) +serverFor = error "..." +-- implementation left as an exercise. contact us on IRC +-- or the mailing list if you get stuck! +``` Using another monad for your handlers ===================================== @@ -1112,28 +1186,32 @@ computation by supplying it with a `String`, like `"hi"`. We get an `a` out from that and can then just `return` it into `EitherT`. We can then just wrap that function with the `Nat` constructor to make it have the fancier type. -> readerToEither' :: forall a. Reader String a -> EitherT ServantErr IO a -> readerToEither' r = return (runReader r "hi") -> -> readerToEither :: Reader String :~> EitherT ServantErr IO -> readerToEither = Nat readerToEither' +``` haskell +readerToEither' :: forall a. Reader String a -> EitherT ServantErr IO a +readerToEither' r = return (runReader r "hi") + +readerToEither :: Reader String :~> EitherT ServantErr IO +readerToEither = Nat readerToEither' +``` We can write some simple webservice with the handlers running in `Reader String`. -> type ReaderAPI = "a" :> Get '[JSON] Int -> :<|> "b" :> Get '[JSON] String -> -> readerAPI :: Proxy ReaderAPI -> readerAPI = Proxy -> -> readerServerT :: ServerT ReaderAPI (Reader String) -> readerServerT = a :<|> b -> -> where a :: Reader String Int -> a = return 1797 -> -> b :: Reader String String -> b = ask +``` haskell +type ReaderAPI = "a" :> Get '[JSON] Int + :<|> "b" :> Get '[JSON] String + +readerAPI :: Proxy ReaderAPI +readerAPI = Proxy + +readerServerT :: ServerT ReaderAPI (Reader String) +readerServerT = a :<|> b + + where a :: Reader String Int + a = return 1797 + + b :: Reader String String + b = ask +``` We unfortunately can't use `readerServerT` as an argument of `serve`, because `serve` wants a `Server ReaderAPI`, i.e., with handlers running in `EitherT @@ -1150,11 +1228,13 @@ and `n` and a `ServerT someapi m`, and returns a `ServerT someapi n`. In our case, we can wrap up our little webservice by using `enter readerToEither` on our handlers. -> readerServer :: Server ReaderAPI -> readerServer = enter readerToEither readerServerT -> -> app4 :: Application -> app4 = serve readerAPI readerServer +``` haskell +readerServer :: Server ReaderAPI +readerServer = enter readerToEither readerServerT + +app4 :: Application +app4 = serve readerAPI readerServer +``` And we can indeed see this webservice in action by running `dist/build/tutorial/tutorial 7`. From a7c3880c67a4a099708b53a03424ec18e978960f Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 27 Jan 2016 22:30:18 +0100 Subject: [PATCH 107/180] Remove convert script --- doc/tutorial/convert.hs | 30 ------------------------------ 1 file changed, 30 deletions(-) delete mode 100644 doc/tutorial/convert.hs diff --git a/doc/tutorial/convert.hs b/doc/tutorial/convert.hs deleted file mode 100644 index ffcb60a7..00000000 --- a/doc/tutorial/convert.hs +++ /dev/null @@ -1,30 +0,0 @@ - -import Control.Arrow -import Data.Foldable -import Data.List -import System.Environment - -main = do - files <- getArgs - forM_ files $ \ file -> do - convertM file - -convertM :: FilePath -> IO () -convertM file = do - contents <- readFile file - seq (length contents) (return ()) - writeFile file (convert contents) - -convert :: String -> String -convert = - lines >>> - groupBy (\ a b -> take 1 a == take 1 b) >>> - map go >>> - concat >>> - unlines - where - go :: [String] -> [String] - go (a : r) - | ">" `isPrefixOf` a - = "``` haskell ignore" : map (drop 2) (a : r) ++ "```" : [] - go x = x From f601cbf3b12cf4381f0fa0e3e69cff4ec4259444 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 27 Jan 2016 22:46:28 +0100 Subject: [PATCH 108/180] Fix cabal file, stack.yaml, and sources.txt --- doc/tutorial/{api-type.lhs => ApiType.lhs} | 72 ++++++++----------- doc/tutorial/{client.lhs => Client.lhs} | 0 doc/tutorial/{docs.lhs => Docs.lhs} | 0 .../{javascript.lhs => Javascript.lhs} | 0 doc/tutorial/{server.lhs => Server.lhs} | 0 doc/tutorial/tutorial.cabal | 11 ++- sources.txt | 1 - stack.yaml | 2 +- 8 files changed, 41 insertions(+), 45 deletions(-) rename doc/tutorial/{api-type.lhs => ApiType.lhs} (86%) rename doc/tutorial/{client.lhs => Client.lhs} (100%) rename doc/tutorial/{docs.lhs => Docs.lhs} (100%) rename doc/tutorial/{javascript.lhs => Javascript.lhs} (100%) rename doc/tutorial/{server.lhs => Server.lhs} (100%) diff --git a/doc/tutorial/api-type.lhs b/doc/tutorial/ApiType.lhs similarity index 86% rename from doc/tutorial/api-type.lhs rename to doc/tutorial/ApiType.lhs index fbf42644..b13f1747 100644 --- a/doc/tutorial/api-type.lhs +++ b/doc/tutorial/ApiType.lhs @@ -1,7 +1,4 @@ ---- -title: A web API as a type -toc: true ---- +# A web API as a type The source for this tutorial section is a literate haskell file, so first we need to have some language extensions and imports: @@ -25,8 +22,7 @@ Consider the following informal specification of an API: You *should* be able to formalize that. And then use the formalized version to get you much of the way towards writing a web app. And all the way towards -getting some client libraries, and documentation (and in the future, who knows -- tests, HATEOAS, ...). +getting some client libraries, and documentation, and more. How would we describe it with servant? As mentioned earlier, an endpoint description is a good old Haskell **type**: @@ -45,22 +41,22 @@ data User = User { Let's break that down: - `"users"` says that our endpoint will be accessible under `/users`; -- `QueryParam "sortby" SortBy`, where `SortBy` is defined by `data SortBy = Age -| Name`, says that the endpoint has a query string parameter named `sortby` -whose value will be extracted as a value of type `SortBy`. +- `QueryParam "sortby" SortBy`, where `SortBy` is defined by `data SortBy = Age | Name`, + says that the endpoint has a query string parameter named `sortby` + whose value will be extracted as a value of type `SortBy`. - `Get '[JSON] [User]` says that the endpoint will be accessible through HTTP -GET requests, returning a list of users encoded as JSON. You will see -later how you can make use of this to make your data available under different -formats, the choice being made depending on the [Accept -header](http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html) specified in -the client's request. -- the `:>` operator that separates the various "combinators" just lets you -sequence static path fragments, URL captures and other combinators. The -ordering only matters for static path fragments and URL captures. `"users" :> -"list-all" :> Get '[JSON] [User]`, equivalent to `/users/list-all`, is -obviously not the same as `"list-all" :> "users" :> Get '[JSON] [User]`, which -is equivalent to `/list-all/users`. This means that sometimes `:>` is somehow -equivalent to `/`, but sometimes it just lets you chain another combinator. + GET requests, returning a list of users encoded as JSON. You will see + later how you can make use of this to make your data available under different + formats, the choice being made depending on the [Accept + header](http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html) specified in + the client's request. +- The `:>` operator that separates the various "combinators" just lets you + sequence static path fragments, URL captures and other combinators. The + ordering only matters for static path fragments and URL captures. `"users" :> + "list-all" :> Get '[JSON] [User]`, equivalent to `/users/list-all`, is + obviously not the same as `"list-all" :> "users" :> Get '[JSON] [User]`, which + is equivalent to `/list-all/users`. This means that sometimes `:>` is somehow + equivalent to `/`, but sometimes it just lets you chain another combinator. We can also describe APIs with multiple endpoints by using the `:<|>` combinators. Here's an example: @@ -74,11 +70,10 @@ type UserAPI2 = "users" :> "list-all" :> Get '[JSON] [User] always write your own when you need it. Here's a quick overview of all the combinators that servant comes with. -Combinators -=========== +## Combinators + +### Static strings -Static strings --------------- As you've already seen, you can use type-level strings (enabled with the `DataKinds` language extension) for static path fragments. Chaining @@ -90,8 +85,8 @@ type UserAPI3 = "users" :> "list-all" :> "now" :> Get '[JSON] [User] -- /users/list-all/now ``` -`Delete`, `Get`, `Patch`, `Post` and `Put` ------------------------------------------- +### `Delete`, `Get`, `Patch`, `Post` and `Put` + These 5 combinators are very similar except that they each describe a different HTTP method. This is how they're declared @@ -112,8 +107,8 @@ type UserAPI4 = "users" :> Get '[JSON] [User] :<|> "admins" :> Get '[JSON] [User] ``` -`Capture` ---------- +### `Capture` + URL captures are parts of the URL that are variable and whose actual value is captured and passed to the request handlers. In many web frameworks, you'll see @@ -147,8 +142,7 @@ type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User -- equivalent to 'DELETE /user/:userid' ``` -`QueryParam`, `QueryParams`, `QueryFlag`, `MatrixParam`, `MatrixParams` and `MatrixFlag` ----------------------------------------------------------------------------------------- +### `QueryParam`, `QueryParams`, `QueryFlag`, `MatrixParam`, `MatrixParams` and `MatrixFlag` `QueryParam`, `QueryParams` and `QueryFlag` are about query string parameters, i.e., those parameters that come after the question mark @@ -202,8 +196,7 @@ type UserAPI6 = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User] Again, your handlers don't have to deserialize these things (into, for example, a `SortBy`). *servant* takes care of it. -`ReqBody` ---------- +### `ReqBody` Each HTTP request can carry some additional data that the server can use in its *body*, and this data can be encoded in any format -- as long as the server @@ -240,8 +233,8 @@ type UserAPI7 = "users" :> ReqBody '[JSON] User :> Post '[JSON] User -- - returns a User encoded in JSON ``` -Request `Header`s ------------------ +### Request `Header`s + Request headers are used for various purposes, from caching to carrying auth-related data. They consist of a header name and an associated value. An @@ -263,8 +256,7 @@ the client to send the request. type UserAPI8 = "users" :> Header "User-Agent" Text :> Get '[JSON] [User] ``` -Content types -------------- +### Content types So far, whenever we have used a combinator that carries a list of content types, we've always specified `'[JSON]`. However, *servant* lets you use several @@ -286,8 +278,7 @@ that everyone uses, we decided to release 2 packages, *servant-lucid* and We will further explain how these content types and your data types can play together in the [section about serving an API](/tutorial/server.html). -Response `Headers` ------------------- +### Response `Headers` Just like an HTTP request, the response generated by a webserver can carry headers too. *servant* provides a `Headers` combinator that carries a list of @@ -305,8 +296,7 @@ response, you could write it as below: type UserAPI10 = "users" :> Get '[JSON] (Headers '[Header "User-Count" Integer] [User]) ``` -Interoperability with other WAI `Application`s: `Raw` ------------------------------------------------------ +### Interoperability with other WAI `Application`s: `Raw` Finally, we also include a combinator named `Raw` that can be used for two reasons: diff --git a/doc/tutorial/client.lhs b/doc/tutorial/Client.lhs similarity index 100% rename from doc/tutorial/client.lhs rename to doc/tutorial/Client.lhs diff --git a/doc/tutorial/docs.lhs b/doc/tutorial/Docs.lhs similarity index 100% rename from doc/tutorial/docs.lhs rename to doc/tutorial/Docs.lhs diff --git a/doc/tutorial/javascript.lhs b/doc/tutorial/Javascript.lhs similarity index 100% rename from doc/tutorial/javascript.lhs rename to doc/tutorial/Javascript.lhs diff --git a/doc/tutorial/server.lhs b/doc/tutorial/Server.lhs similarity index 100% rename from doc/tutorial/server.lhs rename to doc/tutorial/Server.lhs diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 47fc2ebd..37e60d39 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -1,5 +1,5 @@ name: tutorial -version: 0.1.0.0 +version: 0.5 synopsis: The servant tutorial -- description: homepage: http://haskell-servant.github.io/ @@ -14,9 +14,16 @@ build-type: Simple cabal-version: >=1.10 library - exposed-modules: api-type.lhs + exposed-modules: ApiType + , Client + , Docs + , Javascript + , Server -- other-modules: -- other-extensions: build-depends: base >=4.8 && <4.9 + , text + , servant -- hs-source-dirs: default-language: Haskell2010 + ghc-options: -Wall -Werror -c -pgmL markdown-unlit diff --git a/sources.txt b/sources.txt index 24719355..2d3f8107 100644 --- a/sources.txt +++ b/sources.txt @@ -5,7 +5,6 @@ servant-docs servant-foreign servant-js servant-server -servant-examples servant-blaze servant-lucid servant-mock diff --git a/stack.yaml b/stack.yaml index adec1495..feaea42b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,12 +7,12 @@ packages: - servant-cassava/ - servant-client/ - servant-docs/ -- servant-examples/ - servant-foreign/ - servant-js/ - servant-lucid/ - servant-mock/ - servant-server/ +- doc/tutorial extra-deps: - base-compat-0.9.0 - engine-io-wai-1.0.2 From c6dfac5203daf7b4ca0359633671ee5689070ee9 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 27 Jan 2016 22:49:09 +0100 Subject: [PATCH 109/180] Remove matrix params --- doc/tutorial/ApiType.lhs | 22 +--------------------- 1 file changed, 1 insertion(+), 21 deletions(-) diff --git a/doc/tutorial/ApiType.lhs b/doc/tutorial/ApiType.lhs index b13f1747..28ecb5e8 100644 --- a/doc/tutorial/ApiType.lhs +++ b/doc/tutorial/ApiType.lhs @@ -142,7 +142,7 @@ type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User -- equivalent to 'DELETE /user/:userid' ``` -### `QueryParam`, `QueryParams`, `QueryFlag`, `MatrixParam`, `MatrixParams` and `MatrixFlag` +### `QueryParam`, `QueryParams`, `QueryFlag` `QueryParam`, `QueryParams` and `QueryFlag` are about query string parameters, i.e., those parameters that come after the question mark @@ -165,32 +165,12 @@ data QueryParams (sym :: Symbol) a data QueryFlag (sym :: Symbol) ``` -[Matrix parameters](http://www.w3.org/DesignIssues/MatrixURIs.html) -are similar to query string parameters, but they can appear anywhere -in the paths (click the link for more details). A URL with matrix -parameters in it looks like `/users;sortby=age`, as opposed to -`/users?sortby=age` with query string parameters. The big advantage is -that they are not necessarily at the end of the URL. You could have -`/users;active=true;registered_after=2005-01-01/locations` to get -geolocation data about users whom are still active and registered -after *January 1st, 2005*. - -Corresponding data type declarations below. - -``` haskell ignore -data MatrixParam (sym :: Symbol) a -data MatrixParams (sym :: Symbol) a -data MatrixFlag (sym :: Symbol) -``` - Examples: ``` haskell type UserAPI6 = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User] -- equivalent to 'GET /users?sortby={age, name}' - :<|> "users" :> MatrixParam "sortby" SortBy :> Get '[JSON] [User] - -- equivalent to 'GET /users;sortby={age, name}' ``` Again, your handlers don't have to deserialize these things (into, for example, From 8e63078691c1ae4f4c86d89397fe0e594cee553b Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 27 Jan 2016 22:54:22 +0100 Subject: [PATCH 110/180] compiling ApiType.lhs --- doc/tutorial/tutorial.cabal | 32 ++++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 37e60d39..5a907a65 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -15,15 +15,35 @@ cabal-version: >=1.10 library exposed-modules: ApiType - , Client - , Docs - , Javascript - , Server + -- , Client + -- , Docs + -- , Javascript + -- , Server -- other-modules: -- other-extensions: build-depends: base >=4.8 && <4.9 , text - , servant + , aeson + , blaze-html + , directory + , blaze-markup + , servant == 0.5.* + , servant-server == 0.5.* + , servant-client == 0.5.* + , servant-docs == 0.5.* + , warp + , http-media + , lucid + , time + , string-conversions + , bytestring + , attoparsec + , mtl + , random + , js-jquery + , wai + , http-types + , transformers -- hs-source-dirs: default-language: Haskell2010 - ghc-options: -Wall -Werror -c -pgmL markdown-unlit + ghc-options: -Wall -Werror -pgmL markdown-unlit From 8990ebb16e89baaa93f8f0f92fc3add52641e788 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Wed, 27 Jan 2016 22:58:38 +0100 Subject: [PATCH 111/180] Fix toctree and page titles --- doc/tutorial/Client.lhs | 5 +---- doc/tutorial/Docs.lhs | 5 +---- doc/tutorial/Javascript.lhs | 5 +---- doc/tutorial/index.rst | 10 +++++----- 4 files changed, 8 insertions(+), 17 deletions(-) diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index 9571ec8c..1a186596 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -1,7 +1,4 @@ ---- -title: Deriving Haskell functions to query an API -toc: true ---- +# Deriving Haskell functions to query an API While defining handlers that serve an API has a lot to it, querying an API is simpler: we do not care about what happens inside the webserver, we just need to know how to talk to it and get a response back. Except that we usually have to write the querying functions by hand because the structure of the API isn't a first class citizen and can't be inspected to generate a bunch of client-side functions. diff --git a/doc/tutorial/Docs.lhs b/doc/tutorial/Docs.lhs index 1ae4570e..2aa2c377 100644 --- a/doc/tutorial/Docs.lhs +++ b/doc/tutorial/Docs.lhs @@ -1,7 +1,4 @@ ---- -title: Generating documentation from API types -toc: true ---- +# Generating documentation from API types The source for this tutorial section is a literate haskell file, so first we need to have some language extensions and imports: diff --git a/doc/tutorial/Javascript.lhs b/doc/tutorial/Javascript.lhs index 9098fe8d..69d96547 100644 --- a/doc/tutorial/Javascript.lhs +++ b/doc/tutorial/Javascript.lhs @@ -1,7 +1,4 @@ ---- -title: Deriving Javascript functions to query an API -toc: true ---- +# Deriving Javascript functions to query an API We will now see how *servant* lets you turn an API type into javascript functions that you can call to query a webservice. The derived code assumes you diff --git a/doc/tutorial/index.rst b/doc/tutorial/index.rst index 9044a4d5..92f9ffba 100644 --- a/doc/tutorial/index.rst +++ b/doc/tutorial/index.rst @@ -61,8 +61,8 @@ Tutorial .. toctree:: :maxdepth: 1 - api-type.lhs - server.lhs - client.lhs - javascript.lhs - docs.lhs + ApiType.lhs + Server.lhs + Client.lhs + Javascript.lhs + Docs.lhs From c53945098d0a7f6fc8e042e97ad9ed9b07471df4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 28 Jan 2016 12:27:49 +0100 Subject: [PATCH 112/180] tutorial: compile during CI --- doc/tutorial/check/check.sh | 11 ----------- doc/tutorial/check/tinc.yaml | 15 --------------- doc/tutorial/tinc.yaml | 15 +++++++++++++++ sources.txt | 1 + 4 files changed, 16 insertions(+), 26 deletions(-) delete mode 100755 doc/tutorial/check/check.sh delete mode 100644 doc/tutorial/check/tinc.yaml create mode 100644 doc/tutorial/tinc.yaml diff --git a/doc/tutorial/check/check.sh b/doc/tutorial/check/check.sh deleted file mode 100755 index 5425d80a..00000000 --- a/doc/tutorial/check/check.sh +++ /dev/null @@ -1,11 +0,0 @@ -#!/usr/bin/env bash - -set -o errexit - -# tinc - -cabal exec -- ghc -Wall -Werror -outputdir build-output ../api-type.lhs -O0 -c -pgmL markdown-unlit -#cabal exec -- ghc -Wall -Werror -outputdir build-output ../server.lhs -O0 -c -fno-warn-missing-methods -fno-warn-name-shadowing -#cabal exec -- ghc -Wall -Werror -outputdir build-output ../client.lhs -O0 -c -fno-warn-missing-methods -fno-warn-name-shadowing -#cabal exec -- ghc -Wall -Werror -outputdir build-output ../javascript.lhs -O0 -c -fno-warn-missing-methods -#cabal exec -- ghc -Wall -Werror -ibuild-output -outputdir build-output ../docs.lhs -O0 -c -fno-warn-missing-methods diff --git a/doc/tutorial/check/tinc.yaml b/doc/tutorial/check/tinc.yaml deleted file mode 100644 index 2a32c412..00000000 --- a/doc/tutorial/check/tinc.yaml +++ /dev/null @@ -1,15 +0,0 @@ -dependencies: - - name: servant - path: ../../../servant - - name: servant-server - path: ../../../servant-server - - name: servant-client - path: ../../../servant-client - - name: servant-js - path: ../../../servant-js - - name: servant-lucid - path: ../../../servant-lucid - - name: servant-docs - path: ../../../servant-docs - - name: servant-foreign - path: ../../../servant-foreign diff --git a/doc/tutorial/tinc.yaml b/doc/tutorial/tinc.yaml new file mode 100644 index 00000000..b2164752 --- /dev/null +++ b/doc/tutorial/tinc.yaml @@ -0,0 +1,15 @@ +dependencies: + - name: servant + path: ../../servant + - name: servant-server + path: ../../servant-server + - name: servant-client + path: ../../servant-client + - name: servant-js + path: ../../servant-js + - name: servant-lucid + path: ../../servant-lucid + - name: servant-docs + path: ../../servant-docs + - name: servant-foreign + path: ../../servant-foreign diff --git a/sources.txt b/sources.txt index 2d3f8107..2b2ca454 100644 --- a/sources.txt +++ b/sources.txt @@ -8,3 +8,4 @@ servant-server servant-blaze servant-lucid servant-mock +doc/tutorial From 207d51bbf9ae60b1ef718f9d1f7192431fdb62ea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 28 Jan 2016 12:47:03 +0100 Subject: [PATCH 113/180] docs: add documentation on how to build the docs locally --- doc/building-the-docs | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 doc/building-the-docs diff --git a/doc/building-the-docs b/doc/building-the-docs new file mode 100644 index 00000000..34f8b16f --- /dev/null +++ b/doc/building-the-docs @@ -0,0 +1,8 @@ +To build the docs locally: + +$ virtualenv venv +$ . ./venv/bin/activate +$ pip install -r requirements.txt +$ make html + +Docs will be built in _build/html/index.html . From 4fbf28c3c07f7be72fe5db405377855fceadf8f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 28 Jan 2016 12:50:29 +0100 Subject: [PATCH 114/180] tutorial: add markdown-unlit as a cabal dependency --- doc/tutorial/tutorial.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 5a907a65..96e31c04 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -44,6 +44,7 @@ library , wai , http-types , transformers + , markdown-unlit >= 0.4 -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall -Werror -pgmL markdown-unlit From 21426a223ea295f81d50dab237393add884c8937 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Thu, 28 Jan 2016 13:18:12 +0100 Subject: [PATCH 115/180] Rewrite the part on verbs. --- doc/tutorial/ApiType.lhs | 31 +++++++++++++++++++++---------- 1 file changed, 21 insertions(+), 10 deletions(-) diff --git a/doc/tutorial/ApiType.lhs b/doc/tutorial/ApiType.lhs index 28ecb5e8..8c2629f9 100644 --- a/doc/tutorial/ApiType.lhs +++ b/doc/tutorial/ApiType.lhs @@ -88,19 +88,30 @@ type UserAPI3 = "users" :> "list-all" :> "now" :> Get '[JSON] [User] ### `Delete`, `Get`, `Patch`, `Post` and `Put` -These 5 combinators are very similar except that they each describe a -different HTTP method. This is how they're declared - +The `Get` combinator is defined in terms of the more general `Verb`: ``` haskell ignore -data Delete (contentTypes :: [*]) a -data Get (contentTypes :: [*]) a -data Patch (contentTypes :: [*]) a -data Post (contentTypes :: [*]) a -data Put (contentTypes :: [*]) a +data Verb method (statusCode :: Nat) (contentType :: [*]) a +type Get = Verb 'GET 200 ``` -An endpoint ends with one of the 5 combinators above (unless you write your -own). Examples: +There are other predefined type synonyms for other common HTTP methods, +such as e.g.: +``` haskell ignore +data Delete = Verb 'DELETE 200 +data Patch = Verb 'PATCH 200 +data Post = Verb 'POST 200 +data Put = Verb 'PUT 200 +``` + +There are also variants that do not return a 200 status code, such +as for example: +``` haskell ignore +type PostCreated = Verb 'POST 201 +type PostAccepted = Verb 'POST 202 +``` + +An endpoint always ends with a variant of the `Verb` combinator +(unless you write your own combinators). Examples: ``` haskell type UserAPI4 = "users" :> Get '[JSON] [User] From 52b1a233fe4a0ea406963157dfed8dd138636279 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Thu, 28 Jan 2016 13:30:58 +0100 Subject: [PATCH 116/180] Add / expand the documentation of the NoContent case. --- doc/tutorial/ApiType.lhs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/doc/tutorial/ApiType.lhs b/doc/tutorial/ApiType.lhs index 8c2629f9..bbe1da43 100644 --- a/doc/tutorial/ApiType.lhs +++ b/doc/tutorial/ApiType.lhs @@ -149,10 +149,15 @@ type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User -- except that we explicitly say that "userid" -- must be an integer - :<|> "user" :> Capture "userid" Integer :> Delete '[] () + :<|> "user" :> Capture "userid" Integer :> DeleteNoContent '[JSON] NoContent -- equivalent to 'DELETE /user/:userid' ``` +In the second case, `DeleteNoContent` specifies a 204 response code, +`JSON` specifies the content types on which the handler will match, +and `NoContent` is a Haskell type isomorphic to `()` used to represent +a trivial piece of information. + ### `QueryParam`, `QueryParams`, `QueryFlag` `QueryParam`, `QueryParams` and `QueryFlag` are about query string From df363cecb095410a7a5d87f5f85a3f62f33af964 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 28 Jan 2016 13:22:20 +0100 Subject: [PATCH 117/180] tutorial: make Client.lhs compile --- doc/tutorial/Client.lhs | 29 ++++++++++++++++++----------- doc/tutorial/tutorial.cabal | 5 ++++- 2 files changed, 22 insertions(+), 12 deletions(-) diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index 1a186596..ea8bdbfa 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -15,12 +15,14 @@ need to have some language extensions and imports: module Client where -import Control.Monad.Trans.Either +import Control.Monad.Trans.Except import Data.Aeson import Data.Proxy import GHC.Generics +import Network.HTTP.Client (Manager, newManager, defaultManagerSettings) import Servant.API import Servant.Client +import System.IO.Unsafe ``` Also, we need examples for some domain specific data types: @@ -70,13 +72,13 @@ What we are going to get with *servant-client* here is 3 functions, one to query ``` haskell position :: Int -- ^ value for "x" -> Int -- ^ value for "y" - -> EitherT ServantError IO Position + -> ExceptT ServantError IO Position hello :: Maybe String -- ^ an optional value for "name" - -> EitherT ServantError IO HelloMessage + -> ExceptT ServantError IO HelloMessage marketing :: ClientInfo -- ^ value for the request body - -> EitherT ServantError IO Email + -> ExceptT ServantError IO Email ``` Each function makes available as an argument any value that the response may depend on, as evidenced in the API type. How do we get these functions? Just give a `Proxy` to your API and a host to make the requests to: @@ -85,7 +87,12 @@ Each function makes available as an argument any value that the response may dep api :: Proxy API api = Proxy -position :<|> hello :<|> marketing = client api (BaseUrl Http "localhost" 8081) +{-# NOINLINE __manager #-} +__manager :: Manager +__manager = unsafePerformIO $ newManager defaultManagerSettings + +position :<|> hello :<|> marketing = + client api (BaseUrl Http "localhost" 8081 "") __manager ``` As you can see in the code above, we just "pattern match our way" to these functions. If we try to derive less or more functions than there are endpoints in the API, we obviously get an error. The `BaseUrl` value there is just: @@ -109,21 +116,21 @@ data BaseUrl = BaseUrl That's it. Let's now write some code that uses our client functions. ``` haskell -queries :: EitherT ServantError IO (Position, HelloMessage, Email) +queries :: ExceptT ServantError IO (Position, HelloMessage, Email) queries = do pos <- position 10 10 - msg <- hello (Just "servant") + message <- hello (Just "servant") em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) - return (pos, msg, em) + return (pos, message, em) run :: IO () run = do - res <- runEitherT queries + res <- runExceptT queries case res of Left err -> putStrLn $ "Error: " ++ show err - Right (pos, msg, em) -> do + Right (pos, message, em) -> do print pos - print msg + print message print em ``` diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 96e31c04..628ca87f 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -15,7 +15,7 @@ cabal-version: >=1.10 library exposed-modules: ApiType - -- , Client + , Client -- , Docs -- , Javascript -- , Server @@ -45,6 +45,9 @@ library , http-types , transformers , markdown-unlit >= 0.4 + , http-client -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall -Werror -pgmL markdown-unlit + -- to silence aeson-0.10 warnings: + ghc-options: -fno-warn-missing-methods From ad48c0efa612451ca753b0c7f7df61be91bbdcbe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 28 Jan 2016 13:26:41 +0100 Subject: [PATCH 118/180] tutorial: allow older ghcs in cabal file --- doc/tutorial/tutorial.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 628ca87f..e6ec21c9 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -21,7 +21,7 @@ library -- , Server -- other-modules: -- other-extensions: - build-depends: base >=4.8 && <4.9 + build-depends: base == 4.* , text , aeson , blaze-html From a7424c47530f8fbc053b5dc2829330242372f62f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 28 Jan 2016 14:12:24 +0100 Subject: [PATCH 119/180] tutorial: make Server compile --- doc/tutorial/Server.lhs | 123 ++++++++++++++++-------------------- doc/tutorial/tutorial.cabal | 3 +- 2 files changed, 56 insertions(+), 70 deletions(-) diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index 29ca6cb8..56add0ab 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -48,7 +48,7 @@ module Server where import Control.Monad.IO.Class import Control.Monad.Reader -import Control.Monad.Trans.Either +import Control.Monad.Trans.Except import Data.Aeson import Data.Aeson.Types import Data.Attoparsec.ByteString @@ -130,11 +130,11 @@ corresponding API type. The first thing to know about the `Server` type family is that behind the scenes it will drive the routing, letting you focus only on the business logic. The second thing to know is that for each endpoint, your handlers will -by default run in the `EitherT ServantErr IO` monad. This is overridable very +by default run in the `ExceptT ServantErr IO` monad. This is overridable very easily, as explained near the end of this guide. Third thing, the type of the value returned in that monad must be the same as the second argument of the HTTP method combinator used for the corresponding endpoint. In our case, it -means we must provide a handler of type `EitherT ServantErr IO [User]`. Well, +means we must provide a handler of type `ExceptT ServantErr IO [User]`. Well, we have a monad, let's just `return` our list: ``` haskell @@ -152,7 +152,7 @@ userAPI = Proxy -- which you can think of as an "abstract" web application, -- not yet a webserver. app1 :: Application -app1 = serve userAPI server1 +app1 = serve userAPI EmptyConfig server1 ``` The `userAPI` bit is, alas, boilerplate (we need it to guide type inference). @@ -288,15 +288,15 @@ server3 = position :<|> hello :<|> marketing - where position :: Int -> Int -> EitherT ServantErr IO Position + where position :: Int -> Int -> ExceptT ServantErr IO Position position x y = return (Position x y) - hello :: Maybe String -> EitherT ServantErr IO HelloMessage + hello :: Maybe String -> ExceptT ServantErr IO HelloMessage hello mname = return . HelloMessage $ case mname of Nothing -> "Hello, anonymous coward" Just n -> "Hello, " ++ n - marketing :: ClientInfo -> EitherT ServantErr IO Email + marketing :: ClientInfo -> ExceptT ServantErr IO Email marketing clientinfo = return (emailForClient clientinfo) ``` @@ -327,7 +327,7 @@ $ curl -X POST -d '{"name":"Alp Mestanogullari", "email" : "alp@foo.com", "age": For reference, here's a list of some combinators from *servant* and for those that get turned into arguments to the handlers, the type of the argument. - > - `Delete`, `Get`, `Patch`, `Post`, `Put`: these do not become arguments. They provide the return type of handlers, which usually is `EitherT ServantErr IO `. + > - `Delete`, `Get`, `Patch`, `Post`, `Put`: these do not become arguments. They provide the return type of handlers, which usually is `ExceptT ServantErr IO `. > - `Capture "something" a` becomes an argument of type `a`. > - `QueryParam "something" a`, `MatrixParam "something" a`, `Header "something" a` all become arguments of type `Maybe a`, because there might be no value at all specified by the client for these. > - `QueryFlag "something"` and `MatrixFlag "something"` get turned into arguments of type `Bool`. @@ -369,22 +369,7 @@ data Direction | Left | Right -instance FromText Direction where - -- requires {-# LANGUAGE OverloadedStrings #-} - fromText "up" = Just Up - fromText "down" = Just Down - fromText "left" = Just Server.Left - fromText "right" = Just Server.Right - fromText _ = Nothing - -instance ToText Direction where - toText Up = "up" - toText Down = "down" - toText Server.Left = "left" - toText Server.Right = "right" - newtype UserId = UserId Int64 - deriving (FromText, ToText) ``` or writing the instances by hand: @@ -643,7 +628,7 @@ server4 :: Server PersonAPI server4 = return persons app2 :: Application -app2 = serve personAPI server4 +app2 = serve personAPI EmptyConfig server4 ``` And we're good to go. You can run this example with `dist/build/tutorial/tutorial 4`. @@ -656,10 +641,10 @@ And we're good to go. You can run this example with `dist/build/tutorial/tutoria # or just point your browser to http://localhost:8081/persons ``` -The `EitherT ServantErr IO` monad +The `ExceptT ServantErr IO` monad ================================= -At the heart of the handlers is the monad they run in, namely `EitherT +At the heart of the handlers is the monad they run in, namely `ExceptT ServantErr IO`. One might wonder: why this monad? The answer is that it is the simplest monad with the following properties: @@ -677,11 +662,11 @@ data Either e a = Left e | Right a -- from the 'either' package at -- http://hackage.haskell.org/package/either-4.3.3.2/docs/Control-Monad-Trans-Either.html -newtype EitherT e m a - = EitherT { runEitherT :: m (Either e a) } +newtype ExceptT e m a + = ExceptT { runEitherT :: m (Either e a) } ``` -In short, this means that a handler of type `EitherT ServantErr IO a` is simply +In short, this means that a handler of type `ExceptT ServantErr IO a` is simply equivalent to a computation of type `IO (Either ServantErr a)`, that is, an IO action that either returns an error or a result. @@ -689,7 +674,7 @@ The aforementioned `either` package is worth taking a look at. Perhaps most importantly: ``` haskell ignore -left :: Monad m => e -> EitherT e m a +left :: Monad m => e -> ExceptT e m a ``` Allows you to return an error from your handler (whereas `return` is enough to return a success). @@ -701,14 +686,14 @@ kind and abort early. The next two sections cover how to do just that. Performing IO ------------- -Another important instance from the list above is `MonadIO m => MonadIO (EitherT e m)`. [`MonadIO`](http://hackage.haskell.org/package/transformers-0.4.3.0/docs/Control-Monad-IO-Class.html) is a class from the *transformers* package defined as: +Another important instance from the list above is `MonadIO m => MonadIO (ExceptT e m)`. [`MonadIO`](http://hackage.haskell.org/package/transformers-0.4.3.0/docs/Control-Monad-IO-Class.html) is a class from the *transformers* package defined as: ``` haskell ignore class Monad m => MonadIO m where liftIO :: IO a -> m a ``` -Obviously, the `IO` monad provides a `MonadIO` instance. Hence for any type `e`, `EitherT e IO` has a `MonadIO` instance. So if you want to run any kind of IO computation in your handlers, just use `liftIO`: +Obviously, the `IO` monad provides a `MonadIO` instance. Hence for any type `e`, `ExceptT e IO` has a `MonadIO` instance. So if you want to run any kind of IO computation in your handlers, just use `liftIO`: ``` haskell type IOAPI1 = "myfile.txt" :> Get '[JSON] FileContent @@ -748,8 +733,8 @@ module. If you want to use these values but add a body or some headers, just use record update syntax: ``` haskell -failingHandler :: EitherT ServantErr IO () -failingHandler = left myerr +failingHandler :: ExceptT ServantErr IO () +failingHandler = throwE myerr where myerr :: ServantErr myerr = err503 { errBody = "Sorry dear user." } @@ -764,7 +749,7 @@ server6 = do exists <- liftIO (doesFileExist "myfile.txt") if exists then liftIO (readFile "myfile.txt") >>= return . FileContent - else left custom404Err + else throwE custom404Err where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." } ``` @@ -854,7 +839,7 @@ server7 :: Server CodeAPI server7 = serveDirectory "tutorial" app3 :: Application -app3 = serve codeAPI server7 +app3 = serve codeAPI EmptyConfig server7 ``` This server will match any request whose path starts with `/code` and will look for a file at the path described by the rest of the request path, inside the *tutorial/* directory of the path you run the program from. @@ -981,25 +966,25 @@ type UserAPI4 = Capture "userid" Int :> However, you have to be aware that this has an effect on the type of the corresponding `Server`: ``` haskell ignore -Server UserAPI3 = (Int -> EitherT ServantErr IO User) - :<|> (Int -> EitherT ServantErr IO ()) +Server UserAPI3 = (Int -> ExceptT ServantErr IO User) + :<|> (Int -> ExceptT ServantErr IO ()) -Server UserAPI4 = Int -> ( EitherT ServantErr IO User - :<|> EitherT ServantErr IO () +Server UserAPI4 = Int -> ( ExceptT ServantErr IO User + :<|> ExceptT ServantErr IO () ) ``` In the first case, each handler receives the *userid* argument. In the latter, -the whole `Server` takes the *userid* and has handlers that are just computations in `EitherT`, with no arguments. In other words: +the whole `Server` takes the *userid* and has handlers that are just computations in `ExceptT`, with no arguments. In other words: ``` haskell server8 :: Server UserAPI3 server8 = getUser :<|> deleteUser - where getUser :: Int -> EitherT ServantErr IO User + where getUser :: Int -> ExceptT ServantErr IO User getUser _userid = error "..." - deleteUser :: Int -> EitherT ServantErr IO () + deleteUser :: Int -> ExceptT ServantErr IO () deleteUser _userid = error "..." -- notice how getUser and deleteUser @@ -1008,10 +993,10 @@ server8 = getUser :<|> deleteUser server9 :: Server UserAPI4 server9 userid = getUser userid :<|> deleteUser userid - where getUser :: Int -> EitherT ServantErr IO User + where getUser :: Int -> ExceptT ServantErr IO User getUser = error "..." - deleteUser :: Int -> EitherT ServantErr IO () + deleteUser :: Int -> ExceptT ServantErr IO () deleteUser = error "..." ``` @@ -1055,23 +1040,23 @@ type UsersAPI = usersServer :: Server UsersAPI usersServer = getUsers :<|> newUser :<|> userOperations - where getUsers :: EitherT ServantErr IO [User] + where getUsers :: ExceptT ServantErr IO [User] getUsers = error "..." - newUser :: User -> EitherT ServantErr IO () + newUser :: User -> ExceptT ServantErr IO () newUser = error "..." userOperations userid = viewUser userid :<|> updateUser userid :<|> deleteUser userid where - viewUser :: Int -> EitherT ServantErr IO User + viewUser :: Int -> ExceptT ServantErr IO User viewUser = error "..." - updateUser :: Int -> User -> EitherT ServantErr IO () + updateUser :: Int -> User -> ExceptT ServantErr IO () updateUser = error "..." - deleteUser :: Int -> EitherT ServantErr IO () + deleteUser :: Int -> ExceptT ServantErr IO () deleteUser = error "..." ``` @@ -1090,23 +1075,23 @@ data Product = Product { productId :: Int } productsServer :: Server ProductsAPI productsServer = getProducts :<|> newProduct :<|> productOperations - where getProducts :: EitherT ServantErr IO [Product] + where getProducts :: ExceptT ServantErr IO [Product] getProducts = error "..." - newProduct :: Product -> EitherT ServantErr IO () + newProduct :: Product -> ExceptT ServantErr IO () newProduct = error "..." productOperations productid = viewProduct productid :<|> updateProduct productid :<|> deleteProduct productid where - viewProduct :: Int -> EitherT ServantErr IO Product + viewProduct :: Int -> ExceptT ServantErr IO Product viewProduct = error "..." - updateProduct :: Int -> Product -> EitherT ServantErr IO () + updateProduct :: Int -> Product -> ExceptT ServantErr IO () updateProduct = error "..." - deleteProduct :: Int -> EitherT ServantErr IO () + deleteProduct :: Int -> ExceptT ServantErr IO () deleteProduct = error "..." ``` @@ -1134,11 +1119,11 @@ type APIFor a i = -- Build the appropriate 'Server' -- given the handlers of the right type. -serverFor :: EitherT ServantErr IO [a] -- handler for listing of 'a's - -> (a -> EitherT ServantErr IO ()) -- handler for adding an 'a' - -> (i -> EitherT ServantErr IO a) -- handler for viewing an 'a' given its identifier of type 'i' - -> (i -> a -> EitherT ServantErr IO ()) -- updating an 'a' with given id - -> (i -> EitherT ServantErr IO ()) -- deleting an 'a' given its id +serverFor :: ExceptT ServantErr IO [a] -- handler for listing of 'a's + -> (a -> ExceptT ServantErr IO ()) -- handler for adding an 'a' + -> (i -> ExceptT ServantErr IO a) -- handler for viewing an 'a' given its identifier of type 'i' + -> (i -> a -> ExceptT ServantErr IO ()) -- updating an 'a' with given id + -> (i -> ExceptT ServantErr IO ()) -- deleting an 'a' given its id -> Server (APIFor a i) serverFor = error "..." -- implementation left as an exercise. contact us on IRC @@ -1148,10 +1133,10 @@ serverFor = error "..." Using another monad for your handlers ===================================== -Remember how `Server` turns combinators for HTTP methods into `EitherT ServantErr IO`? Well, actually, there's more to that. `Server` is actually a simple type synonym. +Remember how `Server` turns combinators for HTTP methods into `ExceptT ServantErr IO`? Well, actually, there's more to that. `Server` is actually a simple type synonym. ``` haskell ignore -type Server api = ServerT api (EitherT ServantErr IO) +type Server api = ServerT api (ExceptT ServantErr IO) ``` `ServerT` is the actual type family that computes the required types for the handlers that's part of the `HasServer` class. It's like `Server` except that it takes a third parameter which is the monad you want your handlers to run in, or more generally the return types of your handlers. This third parameter is used for specifying the return type of the handler for an endpoint, e.g when computing `ServerT (Get '[JSON] Person) SomeMonad`. The result would be `SomeMonad Person`. @@ -1173,24 +1158,24 @@ newtype m :~> n = Nat { unNat :: forall a. m a -> n a} ``` (`Nat` comes from "natural transformation", in case you're wondering.) -So if you want to write handlers using another monad/type than `EitherT +So if you want to write handlers using another monad/type than `ExceptT ServantErr IO`, say the `Reader String` monad, the first thing you have to prepare is a function: ``` haskell ignore -readerToEither :: Reader String :~> EitherT ServantErr IO +readerToEither :: Reader String :~> ExceptT ServantErr IO ``` Let's start with `readerToEither'`. We obviously have to run the `Reader` computation by supplying it with a `String`, like `"hi"`. We get an `a` out -from that and can then just `return` it into `EitherT`. We can then just wrap +from that and can then just `return` it into `ExceptT`. We can then just wrap that function with the `Nat` constructor to make it have the fancier type. ``` haskell -readerToEither' :: forall a. Reader String a -> EitherT ServantErr IO a +readerToEither' :: forall a. Reader String a -> ExceptT ServantErr IO a readerToEither' r = return (runReader r "hi") -readerToEither :: Reader String :~> EitherT ServantErr IO +readerToEither :: Reader String :~> ExceptT ServantErr IO readerToEither = Nat readerToEither' ``` @@ -1214,7 +1199,7 @@ readerServerT = a :<|> b ``` We unfortunately can't use `readerServerT` as an argument of `serve`, because -`serve` wants a `Server ReaderAPI`, i.e., with handlers running in `EitherT +`serve` wants a `Server ReaderAPI`, i.e., with handlers running in `ExceptT ServantErr IO`. But there's a simple solution to this. Enter `enter` @@ -1233,7 +1218,7 @@ readerServer :: Server ReaderAPI readerServer = enter readerToEither readerServerT app4 :: Application -app4 = serve readerAPI readerServer +app4 = serve readerAPI EmptyConfig readerServer ``` And we can indeed see this webservice in action by running `dist/build/tutorial/tutorial 7`. diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index e6ec21c9..54f24096 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -18,7 +18,7 @@ library , Client -- , Docs -- , Javascript - -- , Server + , Server -- other-modules: -- other-extensions: build-depends: base == 4.* @@ -51,3 +51,4 @@ library ghc-options: -Wall -Werror -pgmL markdown-unlit -- to silence aeson-0.10 warnings: ghc-options: -fno-warn-missing-methods + ghc-options: -fno-warn-name-shadowing From 6cb529fc5fd43a07b59efae380a204e614232b21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 28 Jan 2016 14:16:05 +0100 Subject: [PATCH 120/180] tutorial: added working .ghci --- doc/tutorial/.ghci | 1 + 1 file changed, 1 insertion(+) create mode 100644 doc/tutorial/.ghci diff --git a/doc/tutorial/.ghci b/doc/tutorial/.ghci new file mode 100644 index 00000000..7d8e760c --- /dev/null +++ b/doc/tutorial/.ghci @@ -0,0 +1 @@ +:set -pgmL markdown-unlit -Wall -Werror -fno-warn-missing-methods -fno-warn-name-shadowing From 678d50796ba368c2b5188f3ef5b6068351b97180 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 28 Jan 2016 14:39:54 +0100 Subject: [PATCH 121/180] tutorial: fix for ghc-7.8 --- doc/tutorial/Server.lhs | 3 +++ doc/tutorial/tutorial.cabal | 1 + 2 files changed, 4 insertions(+) diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index 56add0ab..a6b7696c 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -46,6 +46,9 @@ need to have some language extensions and imports: module Server where +import Prelude () +import Prelude.Compat + import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Except diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 54f24096..c22fd8aa 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -22,6 +22,7 @@ library -- other-modules: -- other-extensions: build-depends: base == 4.* + , base-compat , text , aeson , blaze-html From 7445d56c6808d0300915d3ea44c3fac567cfcc7b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 28 Jan 2016 15:46:56 +0100 Subject: [PATCH 122/180] tutorial: make Docs.lhs compile --- doc/tutorial/Docs.lhs | 16 ++++++++-------- doc/tutorial/tutorial.cabal | 2 +- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/doc/tutorial/Docs.lhs b/doc/tutorial/Docs.lhs index 2aa2c377..c006c0b1 100644 --- a/doc/tutorial/Docs.lhs +++ b/doc/tutorial/Docs.lhs @@ -61,8 +61,8 @@ instance ToCapture (Capture "y" Int) where DocCapture "y" -- name "(integer) position on the y axis" -- description -instance ToSample Position Position where - toSample _ = Just (Position 3 14) -- example of output +instance ToSample Position where + toSamples _ = singleSample (Position 3 14) -- example of output instance ToParam (QueryParam "name" String) where toParam _ = @@ -71,7 +71,7 @@ instance ToParam (QueryParam "name" String) where "Name of the person to say hello to." -- description Normal -- Normal, List or Flag -instance ToSample HelloMessage HelloMessage where +instance ToSample HelloMessage where toSamples _ = [ ("When a value is provided for 'name'", HelloMessage "Hello, Alp") , ("When 'name' is not specified", HelloMessage "Hello, anonymous coward") @@ -81,11 +81,11 @@ instance ToSample HelloMessage HelloMessage where ci :: ClientInfo ci = ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"] -instance ToSample ClientInfo ClientInfo where - toSample _ = Just ci +instance ToSample ClientInfo where + toSamples _ = singleSample ci -instance ToSample Email Email where - toSample _ = Just (emailForClient ci) +instance ToSample Email where + toSamples _ = singleSample (emailForClient ci) ``` Types that are used as request or response bodies have to instantiate the `ToSample` typeclass which lets you specify one or more examples of values. `Capture`s and `QueryParam`s have to instantiate their respective `ToCapture` and `ToParam` classes and provide a name and some information about the concrete meaning of that argument, as illustrated in the code above. @@ -228,7 +228,7 @@ server = Server.server3 :<|> serveDocs plain = ("Content-Type", "text/plain") app :: Application -app = serve api server +app = serve api EmptyConfig server ``` And if you spin up this server with `dist/build/tutorial/tutorial 10` and go to anywhere else than `/position`, `/hello` and `/marketing`, you will see the API docs in markdown. This is because `serveDocs` is attempted if the 3 other endpoints don't match and systematically succeeds since its definition is to just return some fixed bytestring with the `text/plain` content type. diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index c22fd8aa..501dace4 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -16,7 +16,7 @@ cabal-version: >=1.10 library exposed-modules: ApiType , Client - -- , Docs + , Docs -- , Javascript , Server -- other-modules: From 487746f9e0c62647398b3ce48fc181286afd4338 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 28 Jan 2016 18:44:37 +0100 Subject: [PATCH 123/180] tutorial: make Javascript.lhs compile --- doc/tutorial/Javascript.lhs | 17 +++++++++-------- doc/tutorial/tinc.yaml | 2 -- doc/tutorial/tutorial.cabal | 3 ++- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/doc/tutorial/Javascript.lhs b/doc/tutorial/Javascript.lhs index 69d96547..9ab4740e 100644 --- a/doc/tutorial/Javascript.lhs +++ b/doc/tutorial/Javascript.lhs @@ -30,13 +30,14 @@ module Javascript where import Control.Monad.IO.Class import Data.Aeson import Data.Proxy -import Data.Text (Text) +import Data.Text as T (Text) +import Data.Text.IO as T (writeFile, readFile) import qualified Data.Text as T import GHC.Generics import Language.Javascript.JQuery import Network.Wai import Servant -import Servant.JQuery +import Servant.JS import System.Random ``` @@ -133,7 +134,7 @@ server' = server :<|> serveDirectory "tutorial/t9" app :: Application -app = serve api' server' +app = serve api' EmptyConfig server' ``` Why two different API types, proxies and servers though? Simply because we don't want to generate javascript functions for the `Raw` part of our API type, so we need a `Proxy` for our API type `API'` without its `Raw` endpoint. @@ -141,8 +142,8 @@ Why two different API types, proxies and servers though? Simply because we don't Very similarly to how one can derive haskell functions, we can derive the javascript with just a simple function call to `jsForAPI` from `Servant.JQuery`. ``` haskell -apiJS :: String -apiJS = jsForAPI api +apiJS :: Text +apiJS = jsForAPI api vanillaJS ``` This `String` contains 2 Javascript functions: @@ -175,9 +176,9 @@ Right before starting up our server, we will need to write this `String` to a fi ``` haskell writeJSFiles :: IO () writeJSFiles = do - writeFile "getting-started/gs9/api.js" apiJS - jq <- readFile =<< Language.Javascript.JQuery.file - writeFile "getting-started/gs9/jq.js" jq + T.writeFile "getting-started/gs9/api.js" apiJS + jq <- T.readFile =<< Language.Javascript.JQuery.file + T.writeFile "getting-started/gs9/jq.js" jq ``` And we're good to go. Start the server with `dist/build/tutorial/tutorial 9` and go to `http://localhost:8081/`. Start typing in the name of one of the authors in our database or part of a book title, and check out how long it takes to approximate π using the method mentioned above. diff --git a/doc/tutorial/tinc.yaml b/doc/tutorial/tinc.yaml index b2164752..f52bab2d 100644 --- a/doc/tutorial/tinc.yaml +++ b/doc/tutorial/tinc.yaml @@ -7,8 +7,6 @@ dependencies: path: ../../servant-client - name: servant-js path: ../../servant-js - - name: servant-lucid - path: ../../servant-lucid - name: servant-docs path: ../../servant-docs - name: servant-foreign diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 501dace4..9c3d664b 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -17,7 +17,7 @@ library exposed-modules: ApiType , Client , Docs - -- , Javascript + , Javascript , Server -- other-modules: -- other-extensions: @@ -32,6 +32,7 @@ library , servant-server == 0.5.* , servant-client == 0.5.* , servant-docs == 0.5.* + , servant-js == 0.5.* , warp , http-media , lucid From 73ab3062abe1168505e477c0c1dfc618850d36cc Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sat, 6 Feb 2016 13:33:53 +0200 Subject: [PATCH 124/180] Use rst links syntax (it's not a markdown) --- doc/tutorial/index.rst | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/doc/tutorial/index.rst b/doc/tutorial/index.rst index 92f9ffba..ab212368 100644 --- a/doc/tutorial/index.rst +++ b/doc/tutorial/index.rst @@ -1,13 +1,15 @@ Servant tutorial ================ -This is an introductory tutorial to the current version of *servant*, which is **0.4**. Any comment or issue can be directed to [this website's issue tracker](http://github.com/haskell-servant/haskell-servant.github.io/issues). +This is an introductory tutorial to the current version of *servant*, which is +**0.4**. Any comment or issue can be directed to `this website's issue +tracker `_. Github ------- -- the servant packages: [haskell-servant/servant](https://github.com/haskell-servant/servant) -- the website (including this tutorial): [haskell-servant/haskell-servant.github.io](https://github.com/haskell-servant/haskell-servant.github.io/) +- the servant packages: `haskell-servant/servant `_ +- the website (including this tutorial): `haskell-servant/haskell-servant.github.io `_ - Feel free to use the issue tracker (or to send PRs!) on the website's repository to give feedback and suggestions about this tutorial Introduction From 9d2d7104d0cf0c9c9ca14a83cea63e5db80d96eb Mon Sep 17 00:00:00 2001 From: rwobben Date: Tue, 9 Feb 2016 11:56:23 +0000 Subject: [PATCH 125/180] Changed so two titles are displayed correctly --- doc/tutorial/Server.lhs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index a6b7696c..5c0e9f2d 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -1,7 +1,4 @@ ---- -title: Serving an API -toc: true ---- +# Serving an API Enough chit-chat about type-level combinators and representing an API as a type. Can we have a webservice already? From e1312c1bb6abb8e89bbfff30122db74ad8cb2e39 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 18 Feb 2016 00:39:40 +0100 Subject: [PATCH 126/180] sundry tutorial improvements --- doc/conf.py | 5 ++ doc/requirements.txt | 2 +- doc/tutorial/Server.lhs | 159 +++++++++++++++--------------------- doc/tutorial/tutorial.cabal | 2 +- stack.yaml | 3 + 5 files changed, 76 insertions(+), 95 deletions(-) diff --git a/doc/conf.py b/doc/conf.py index 4e31a37d..1c7aba02 100644 --- a/doc/conf.py +++ b/doc/conf.py @@ -94,6 +94,11 @@ exclude_patterns = ['_build', 'venv'] # The name of the Pygments (syntax highlighting) style to use. pygments_style = 'sphinx' +def setup(app): + from sphinx.highlighting import lexers + from pygments.lexers import HaskellLexer + lexers['haskell ignore'] = HaskellLexer(stripnl=False) + # A list of ignored prefixes for module index sorting. #modindex_common_prefix = [] diff --git a/doc/requirements.txt b/doc/requirements.txt index 8f89e4b8..0c9c95a8 100644 --- a/doc/requirements.txt +++ b/doc/requirements.txt @@ -10,7 +10,7 @@ Jinja2==2.8 livereload==2.4.1 MarkupSafe==0.23 pathtools==0.1.2 -Pygments==2.1 +Pygments==2.1.1 pytz==2015.7 PyYAML==3.11 recommonmark==0.4.0 diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index 5c0e9f2d..79588da7 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -23,8 +23,7 @@ Usage: tutorial N where N is the number of the example you want to run. ``` -A first example -=============== +## A first example Equipped with some basic knowledge about the way we represent API, let's now write our first webservice. @@ -53,7 +52,6 @@ import Data.Aeson import Data.Aeson.Types import Data.Attoparsec.ByteString import Data.ByteString (ByteString) -import Data.Int import Data.List import Data.String.Conversions import Data.Time.Calendar @@ -97,7 +95,7 @@ data User = User { name :: String , age :: Int , email :: String - , registration_date :: Day + , registrationDate :: Day } deriving (Eq, Show, Generic) instance ToJSON User @@ -179,8 +177,7 @@ $ curl http://localhost:8081/users [{"email":"isaac@newton.co.uk","registration_date":"1683-03-01","age":372,"name":"Isaac Newton"},{"email":"ae@mc2.org","registration_date":"1905-12-01","age":136,"name":"Albert Einstein"}] ``` -More endpoints -============== +## More endpoints What if we want more than one endpoint? Let's add `/albert` and `/isaac` to view the corresponding users encoded in JSON. @@ -218,8 +215,7 @@ And that's it! You can run this example with `dist/build/tutorial/tutorial 2` and check out the data available at `/users`, `/albert` and `/isaac`. -From combinators to handler arguments -===================================== +## From combinators to handler arguments Fine, we can write trivial webservices easily, but none of the two above use any "fancy" combinator from servant. Let's address this and use `QueryParam`, @@ -237,8 +233,8 @@ type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Posit :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email data Position = Position - { x :: Int - , y :: Int + { xCoord :: Int + , yCoord :: Int } deriving Generic instance ToJSON Position @@ -334,8 +330,7 @@ that get turned into arguments to the handlers, the type of the argument. > - `QueryParams "something" a` and `MatrixParams "something" a` get turned into arguments of type `[a]`. > - `ReqBody contentTypes a` gets turned into an argument of type `a`. -The `FromText`/`ToText` classes -=============================== +## The `FromHttpApiData`/`ToHttpApiData` classes Wait... How does *servant* know how to decode the `Int`s from the URL? Or how to decode a `ClientInfo` value from the request body? This is what this and the @@ -343,54 +338,42 @@ following two sections address. `Capture`s and `QueryParam`s are represented by some textual value in URLs. `Header`s are similarly represented by a pair of a header name and a -corresponding (textual) value in the request's "metadata". This is why we -decided to provide a pair of typeclasses, `FromText` and `ToText` which just -let you say that you can respectively *extract* or *encode* values of some type -*from*/*to* text. Here are the definitions: +corresponding (textual) value in the request's "metadata". How types are +decoded from headers, captures, and query params is expressed in a class +`FromHttpApiData` (from the package +[*http-api-data*](http://hackage.haskell.org/package/http-api-data)): ``` haskell ignore -class FromText a where - fromText :: Text -> Maybe a +class FromHttpApiData a where + {-# MINIMAL parseUrlPiece | parseQueryParam #-} + -- | Parse URL path piece. + parseUrlPiece :: Text -> Either Text a + parseUrlPiece = parseQueryParam -class ToText a where - toText :: a -> Text + -- | Parse HTTP header value. + parseHeader :: ByteString -> Either Text a + parseHeader = parseUrlPiece . decodeUtf8 + + -- | Parse query param value. + parseQueryParam :: Text -> Either Text a + parseQueryParam = parseUrlPiece ``` -And as long as the type that a `Capture`/`QueryParam`/`Header`/etc will be -decoded to provides a `FromText` instance, it will Just Work. *servant* -provides a decent number of instances, but here are some examples of defining -your own. +As you can see, as long as you provide either `parseUrlPiece` (for `Capture`s) +or `parseQueryParam` (for `QueryParam`s), the other methods will be defined in +terms of this. -``` haskell --- A typical enumeration -data Direction - = Up - | Down - | Left - | Right - -newtype UserId = UserId Int64 -``` - -or writing the instances by hand: - -``` haskell ignore -instance FromText UserId where - fromText = fmap UserId fromText - -instance ToText UserId where - toText (UserId i) = toText i -``` +*http-api-data* provides a decent number of instances, helpers for defining new +ones, and wonderful documentation. There's not much else to say about these classes. You will need instances for -them when using `Capture`, `QueryParam`, `QueryParams`, `MatrixParam`, -`MatrixParams` and `Header` with your types. You will need `FromText` instances -for server-side request handlers and `ToText` instances only when using +them when using `Capture`, `QueryParam`, `QueryParams`, and `Header` with your +types. You will need `FromHttpApiData` instances for server-side request +handlers and `ToHttpApiData` instances only when using *servant-client*, as described in the [section about deriving haskell functions to query an API](/tutorial/client.html). -Using content-types with your data types -======================================== +## Using content-types with your data types The same principle was operating when decoding request bodies from JSON, and responses *into* JSON. (JSON is just the running example - you can do this with @@ -399,8 +382,8 @@ any content-type.) This section introduces a couple of typeclasses provided by *servant* that make all of this work. -The truth behind `JSON` ------------------------ +### The truth behind `JSON` + What exactly is `JSON`? Like the 3 other content types provided out of the box by *servant*, it's a really dumb data type. @@ -464,8 +447,6 @@ And now the `MimeUnrender` class, which lets us extract values from lazy ``` haskell ignore class Accept ctype => MimeUnrender ctype a where mimeUnrender :: Proxy ctype -> ByteString -> Either String a - -- alternatively: - mimeUnrender :: Proxy ctype -> (ByteString -> Either String a) ``` We don't have much work to do there either, `Data.Aeson.eitherDecode` is @@ -496,8 +477,7 @@ HTML representation of the data they want, ready to be included in any HTML document, e.g. using [jQuery's `load` function](https://api.jquery.com/load/), simply by adding `Accept: text/html` to their request headers. -Case-studies: *servant-blaze* and *servant-lucid* -------------------------------------------------- +### Case-studies: *servant-blaze* and *servant-lucid* These days, most of the haskellers who write their HTML UIs directly from Haskell use either [blaze-html](http://hackage.haskell.org/package/blaze-html) @@ -615,8 +595,8 @@ instance ToHtml [Person] where We create some `Person` values and serve them as a list: ``` haskell -persons :: [Person] -persons = +people :: [Person] +people = [ Person "Isaac" "Newton" , Person "Albert" "Einstein" ] @@ -625,7 +605,7 @@ personAPI :: Proxy PersonAPI personAPI = Proxy server4 :: Server PersonAPI -server4 = return persons +server4 = return people app2 :: Application app2 = serve personAPI EmptyConfig server4 @@ -641,8 +621,7 @@ And we're good to go. You can run this example with `dist/build/tutorial/tutoria # or just point your browser to http://localhost:8081/persons ``` -The `ExceptT ServantErr IO` monad -================================= +## The `ExceptT ServantErr IO` monad At the heart of the handlers is the monad they run in, namely `ExceptT ServantErr IO`. One might wonder: why this monad? The answer is that it is the @@ -660,40 +639,39 @@ Let's recall some definitions. -- from the Prelude data Either e a = Left e | Right a --- from the 'either' package at --- http://hackage.haskell.org/package/either-4.3.3.2/docs/Control-Monad-Trans-Either.html -newtype ExceptT e m a - = ExceptT { runEitherT :: m (Either e a) } +-- from the 'mtl' package at +newtype ExceptT e m a = ExceptT ( m (Either e a) ) ``` In short, this means that a handler of type `ExceptT ServantErr IO a` is simply equivalent to a computation of type `IO (Either ServantErr a)`, that is, an IO action that either returns an error or a result. -The aforementioned `either` package is worth taking a look at. Perhaps most -importantly: - -``` haskell ignore -left :: Monad m => e -> ExceptT e m a -``` -Allows you to return an error from your handler (whereas `return` is enough to -return a success). +The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT) +from which `ExceptT` comes is worth looking at. +Perhaps most importantly, `ExceptT` is an instance of `MonadError`, so +`throwError` can be used to return an error from your handler (whereas `return` + is enough to return a success). Most of what you'll be doing in your handlers is running some IO and, depending on the result, you might sometimes want to throw an error of some kind and abort early. The next two sections cover how to do just that. -Performing IO -------------- +### Performing IO -Another important instance from the list above is `MonadIO m => MonadIO (ExceptT e m)`. [`MonadIO`](http://hackage.haskell.org/package/transformers-0.4.3.0/docs/Control-Monad-IO-Class.html) is a class from the *transformers* package defined as: +Another important instance from the list above is `MonadIO m => MonadIO +(ExceptT e m)`. +[`MonadIO`](http://hackage.haskell.org/package/transformers-0.4.3.0/docs/Control-Monad-IO-Class.html) +is a class from the *transformers* package defined as: ``` haskell ignore class Monad m => MonadIO m where liftIO :: IO a -> m a ``` -Obviously, the `IO` monad provides a `MonadIO` instance. Hence for any type `e`, `ExceptT e IO` has a `MonadIO` instance. So if you want to run any kind of IO computation in your handlers, just use `liftIO`: +Obviously, the `IO` monad provides a `MonadIO` instance. Hence for any type +`e`, `ExceptT e IO` has a `MonadIO` instance. So if you want to run any kind of +IO computation in your handlers, just use `liftIO`: ``` haskell type IOAPI1 = "myfile.txt" :> Get '[JSON] FileContent @@ -710,8 +688,7 @@ server5 = do return (FileContent filecontent) ``` -Failing, through `ServantErr` ------------------------------ +### Failing, through `ServantErr` If you want to explicitly fail at providing the result promised by an endpoint using the appropriate HTTP status code (not found, unauthorized, etc) and some @@ -787,8 +764,7 @@ query it, first without the file and then with the file. {"content":"Hello\n"} ``` -Response headers -================ +## Response headers To add headers to your response, use [addHeader](http://hackage.haskell.org/package/servant-0.4.4/docs/Servant-API-ResponseHeaders.html). Note that this changes the type of your API, as we can see in the following example: @@ -800,9 +776,9 @@ myHandler :: Server MyHandler myHandler = return $ addHeader 1797 albert ``` +Note that the type of `addHeader x` is different than the type of `x`! -Serving static files -==================== +## Serving static files *servant-server* also provides a way to just serve the content of a directory under some path in your web API. As mentioned earlier in this document, the @@ -842,7 +818,9 @@ app3 :: Application app3 = serve codeAPI EmptyConfig server7 ``` -This server will match any request whose path starts with `/code` and will look for a file at the path described by the rest of the request path, inside the *tutorial/* directory of the path you run the program from. +This server will match any request whose path starts with `/code` and will look +for a file at the path described by the rest of the request path, inside the + *tutorial/* directory of the path you run the program from. In other words: @@ -941,8 +919,7 @@ $ curl http://localhost:8081/foo not found ``` -Nested APIs -=========== +## Nested APIs Let's see how you can define APIs in a modular way, while avoiding repetition. Consider this simple example: @@ -1130,8 +1107,7 @@ serverFor = error "..." -- or the mailing list if you get stuck! ``` -Using another monad for your handlers -===================================== +## Using another monad for your handlers Remember how `Server` turns combinators for HTTP methods into `ExceptT ServantErr IO`? Well, actually, there's more to that. `Server` is actually a simple type synonym. @@ -1143,8 +1119,7 @@ type Server api = ServerT api (ExceptT ServantErr IO) The first and main question one might have then is: how do we write handlers that run in another monad? How can we "bring back" the value from a given monad into something *servant* can understand? -Natural transformations ------------------------ +### Natural transformations If we have a function that gets us from an `m a` to an `n a`, for any `a`, what do we have? @@ -1202,8 +1177,7 @@ We unfortunately can't use `readerServerT` as an argument of `serve`, because `serve` wants a `Server ReaderAPI`, i.e., with handlers running in `ExceptT ServantErr IO`. But there's a simple solution to this. -Enter `enter` -------------- +### Enter `enter` That's right. We have just written `readerToEither`, which is exactly what we would need to apply to the results of all handlers to make the handlers have the @@ -1230,8 +1204,7 @@ $ curl http://localhost:8081/b "hi" ``` -Conclusion -========== +## Conclusion You're now equipped to write any kind of webservice/web-application using *servant*. One thing not covered here is how to incorporate your own combinators and will be the topic of a page on the website. The rest of this document focuses on *servant-client*, *servant-jquery* and *servant-docs*. diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 9c3d664b..a39602c1 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -24,7 +24,7 @@ library build-depends: base == 4.* , base-compat , text - , aeson + , aeson >= 0.11 , blaze-html , directory , blaze-markup diff --git a/stack.yaml b/stack.yaml index feaea42b..40ddab48 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,4 +18,7 @@ extra-deps: - engine-io-wai-1.0.2 - control-monad-omega-0.3.1 - should-not-typecheck-2.0.1 +- markdown-unlit-0.4.0 +- aeson-0.11.0.0 +- fail-4.9.0.0 resolver: nightly-2015-10-08 From 0daa8048c42c7d34d4a8265d52f17e6e24f3e64b Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 18 Feb 2016 00:43:34 +0100 Subject: [PATCH 127/180] Remove stale next/previous --- doc/tutorial/Client.lhs | 5 ----- doc/tutorial/Docs.lhs | 4 ---- doc/tutorial/Javascript.lhs | 5 ----- 3 files changed, 14 deletions(-) diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index ea8bdbfa..60dc88e4 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -147,8 +147,3 @@ You can now run `dist/build/tutorial/tutorial 8` (the server) and ``` The types of the arguments for the functions are the same as for (server-side) request handlers. You now know how to use *servant-client*! - - diff --git a/doc/tutorial/Docs.lhs b/doc/tutorial/Docs.lhs index c006c0b1..adc63924 100644 --- a/doc/tutorial/Docs.lhs +++ b/doc/tutorial/Docs.lhs @@ -232,7 +232,3 @@ app = serve api EmptyConfig server ``` And if you spin up this server with `dist/build/tutorial/tutorial 10` and go to anywhere else than `/position`, `/hello` and `/marketing`, you will see the API docs in markdown. This is because `serveDocs` is attempted if the 3 other endpoints don't match and systematically succeeds since its definition is to just return some fixed bytestring with the `text/plain` content type. - - diff --git a/doc/tutorial/Javascript.lhs b/doc/tutorial/Javascript.lhs index 9ab4740e..c5f118b1 100644 --- a/doc/tutorial/Javascript.lhs +++ b/doc/tutorial/Javascript.lhs @@ -182,8 +182,3 @@ writeJSFiles = do ``` And we're good to go. Start the server with `dist/build/tutorial/tutorial 9` and go to `http://localhost:8081/`. Start typing in the name of one of the authors in our database or part of a book title, and check out how long it takes to approximate π using the method mentioned above. - - From 5625f5273e024da06789d62111244a2d976c8191 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 18 Feb 2016 00:48:05 +0100 Subject: [PATCH 128/180] more consistent line breaks --- doc/tutorial/Server.lhs | 114 ++++++++++++++++++++++------------------ 1 file changed, 64 insertions(+), 50 deletions(-) diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index 79588da7..93769b54 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -3,29 +3,10 @@ Enough chit-chat about type-level combinators and representing an API as a type. Can we have a webservice already? -If you want to follow along with the code and run the examples while you read this guide: - -``` bash -cabal get servant-examples -cd servant-examples- -cabal sandbox init -cabal install --dependencies-only -cabal configure && cabal build -``` - -This will produce a `tutorial` executable in the -`dist/build/tutorial` directory that just runs the example corresponding -to the number specified as a command line argument: - -``` bash -$ dist/build/tutorial/tutorial -Usage: tutorial N - where N is the number of the example you want to run. -``` - ## A first example -Equipped with some basic knowledge about the way we represent API, let's now write our first webservice. +Equipped with some basic knowledge about the way we represent API, let's now +write our first webservice. The source for this tutorial section is a literate haskell file, so first we need to have some language extensions and imports: @@ -72,7 +53,13 @@ import qualified Text.Blaze.Html {-# LANGUAGE TypeFamilies #-} ``` -**Important**: the `Servant` module comes from the *servant-server* package, the one that lets us run webservers that implement a particular API type. It reexports all the types from the *servant* package that let you declare API types as well as everything you need to turn your request handlers into a fully-fledged webserver. This means that in your applications, you can just add *servant-server* as a dependency, import `Servant` and not worry about anything else. +**Important**: the `Servant` module comes from the *servant-server* package, +the one that lets us run webservers that implement a particular API type. It +reexports all the types from the *servant* package that let you declare API +types as well as everything you need to turn your request handlers into a +fully-fledged webserver. This means that in your applications, you can just add +*servant-server* as a dependency, import `Servant` and not worry about anything +else. We will write a server that will serve the following API. @@ -95,7 +82,7 @@ data User = User { name :: String , age :: Int , email :: String - , registrationDate :: Day + , registration_date :: Day } deriving (Eq, Show, Generic) instance ToJSON User @@ -140,7 +127,9 @@ server1 :: Server UserAPI1 server1 = return users1 ``` -That's it. Now we can turn `server` into an actual webserver using [wai](http://hackage.haskell.org/package/wai) and [warp](http://hackage.haskell.org/package/warp): +That's it. Now we can turn `server` into an actual webserver using +[wai](http://hackage.haskell.org/package/wai) and +[warp](http://hackage.haskell.org/package/warp): ``` haskell userAPI :: Proxy UserAPI1 @@ -179,7 +168,8 @@ $ curl http://localhost:8081/users ## More endpoints -What if we want more than one endpoint? Let's add `/albert` and `/isaac` to view the corresponding users encoded in JSON. +What if we want more than one endpoint? Let's add `/albert` and `/isaac` to +view the corresponding users encoded in JSON. ``` haskell type UserAPI2 = "users" :> Get '[JSON] [User] @@ -225,7 +215,8 @@ argument of the appropriate type automatically. You don't have to worry about manually looking up URL captures or query string parameters, or decoding/encoding data from/to JSON. Never. -We are going to use the following data types and functions to implement a server for `API`. +We are going to use the following data types and functions to implement a +server for `API`. ``` haskell type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position @@ -307,7 +298,8 @@ parameter might not always be there); - a `ReqBody contentTypeList a` becomes an argument of type `a`; -And that's it. You can see this example in action by running `dist/build/tutorial/tutorial 3`. +And that's it. You can see this example in action by running +`dist/build/tutorial/tutorial 3`. ``` bash $ curl http://localhost:8081/position/1/2 @@ -474,8 +466,8 @@ And this is all the code that lets you use `JSON` for with `ReqBody`, `Get`, `Post` and friends. We can check our understanding by implementing support for an `HTML` content type, so that users of your webservice can access an HTML representation of the data they want, ready to be included in any HTML -document, e.g. using [jQuery's `load` function](https://api.jquery.com/load/), simply by adding `Accept: -text/html` to their request headers. +document, e.g. using [jQuery's `load` function](https://api.jquery.com/load/), +simply by adding `Accept: text/html` to their request headers. ### Case-studies: *servant-blaze* and *servant-lucid* @@ -766,7 +758,8 @@ query it, first without the file and then with the file. ## Response headers -To add headers to your response, use [addHeader](http://hackage.haskell.org/package/servant-0.4.4/docs/Servant-API-ResponseHeaders.html). +To add headers to your response, use +[addHeader](http://hackage.haskell.org/package/servant/docs/Servant-API-ResponseHeaders.html). Note that this changes the type of your API, as we can see in the following example: ``` haskell @@ -824,9 +817,12 @@ for a file at the path described by the rest of the request path, inside the In other words: -- If a client requests `/code/foo.txt`, the server will look for a file at `./tutorial/foo.txt` (and fail) -- If a client requests `/code/T1.hs`, the server will look for a file at `./tutorial/T1.hs` (and succeed) -- If a client requests `/code/foo/bar/baz/movie.mp4`, the server will look for a file at `./tutorial/foo/bar/baz/movie.mp4` (and fail) +- If a client requests `/code/foo.txt`, the server will look for a file at + `./tutorial/foo.txt` (and fail) +- If a client requests `/code/T1.hs`, the server will look for a file at + `./tutorial/T1.hs` (and succeed) +- If a client requests `/code/foo/bar/baz/movie.mp4`, the server will look for + a file at `./tutorial/foo/bar/baz/movie.mp4` (and fail) Here is our little server in action. @@ -921,7 +917,8 @@ not found ## Nested APIs -Let's see how you can define APIs in a modular way, while avoiding repetition. Consider this simple example: +Let's see how you can define APIs in a modular way, while avoiding repetition. +Consider this simple example: ``` haskell type UserAPI3 = -- view the user with given userid, in JSON @@ -940,7 +937,8 @@ type UserAPI4 = Capture "userid" Int :> ) ``` -However, you have to be aware that this has an effect on the type of the corresponding `Server`: +However, you have to be aware that this has an effect on the type of the +corresponding `Server`: ``` haskell ignore Server UserAPI3 = (Int -> ExceptT ServantErr IO User) @@ -952,7 +950,8 @@ Server UserAPI4 = Int -> ( ExceptT ServantErr IO User ``` In the first case, each handler receives the *userid* argument. In the latter, -the whole `Server` takes the *userid* and has handlers that are just computations in `ExceptT`, with no arguments. In other words: +the whole `Server` takes the *userid* and has handlers that are just +computations in `ExceptT`, with no arguments. In other words: ``` haskell server8 :: Server UserAPI3 @@ -977,7 +976,10 @@ server9 userid = getUser userid :<|> deleteUser userid deleteUser = error "..." ``` -Note that there's nothing special about `Capture` that lets you "factor it out": this can be done with any combinator. Here are a few examples of APIs with a combinator factored out for which we can write a perfectly valid `Server`. +Note that there's nothing special about `Capture` that lets you "factor it +out": this can be done with any combinator. Here are a few examples of APIs +with a combinator factored out for which we can write a perfectly valid +`Server`. ``` haskell -- we just factor out the "users" path fragment @@ -1002,7 +1004,8 @@ newtype Token = Token ByteString newtype SecretData = SecretData ByteString ``` -This approach lets you define APIs modularly and assemble them all into one big API type only at the end. +This approach lets you define APIs modularly and assemble them all into one big +API type only at the end. ``` haskell type UsersAPI = @@ -1080,7 +1083,8 @@ server10 :: Server CombinedAPI server10 = usersServer :<|> productsServer ``` -Finally, we can realize the user and product APIs are quite similar and abstract that away: +Finally, we can realize the user and product APIs are quite similar and +abstract that away: ``` haskell -- API for values of type 'a' @@ -1109,15 +1113,25 @@ serverFor = error "..." ## Using another monad for your handlers -Remember how `Server` turns combinators for HTTP methods into `ExceptT ServantErr IO`? Well, actually, there's more to that. `Server` is actually a simple type synonym. +Remember how `Server` turns combinators for HTTP methods into `ExceptT +ServantErr IO`? Well, actually, there's more to that. `Server` is actually a +simple type synonym. ``` haskell ignore type Server api = ServerT api (ExceptT ServantErr IO) ``` -`ServerT` is the actual type family that computes the required types for the handlers that's part of the `HasServer` class. It's like `Server` except that it takes a third parameter which is the monad you want your handlers to run in, or more generally the return types of your handlers. This third parameter is used for specifying the return type of the handler for an endpoint, e.g when computing `ServerT (Get '[JSON] Person) SomeMonad`. The result would be `SomeMonad Person`. +`ServerT` is the actual type family that computes the required types for the +handlers that's part of the `HasServer` class. It's like `Server` except that +it takes a third parameter which is the monad you want your handlers to run in, +or more generally the return types of your handlers. This third parameter is +used for specifying the return type of the handler for an endpoint, e.g when +computing `ServerT (Get '[JSON] Person) SomeMonad`. The result would be +`SomeMonad Person`. -The first and main question one might have then is: how do we write handlers that run in another monad? How can we "bring back" the value from a given monad into something *servant* can understand? +The first and main question one might have then is: how do we write handlers +that run in another monad? How can we "bring back" the value from a given monad +into something *servant* can understand? ### Natural transformations @@ -1185,7 +1199,8 @@ right type for `serve`. Being cumbersome to do by hand, we provide a function `enter` which takes a natural transformation between two parametrized types `m` and `n` and a `ServerT someapi m`, and returns a `ServerT someapi n`. -In our case, we can wrap up our little webservice by using `enter readerToEither` on our handlers. +In our case, we can wrap up our little webservice by using `enter +readerToEither` on our handlers. ``` haskell readerServer :: Server ReaderAPI @@ -1195,7 +1210,8 @@ app4 :: Application app4 = serve readerAPI EmptyConfig readerServer ``` -And we can indeed see this webservice in action by running `dist/build/tutorial/tutorial 7`. +And we can indeed see this webservice in action by running +`dist/build/tutorial/tutorial 7`. ``` bash $ curl http://localhost:8081/a @@ -1206,9 +1222,7 @@ $ curl http://localhost:8081/b ## Conclusion -You're now equipped to write any kind of webservice/web-application using *servant*. One thing not covered here is how to incorporate your own combinators and will be the topic of a page on the website. The rest of this document focuses on *servant-client*, *servant-jquery* and *servant-docs*. - - +You're now equipped to write any kind of webservice/web-application using +*servant*. One thing not covered here is how to incorporate your own +combinators and will be the topic of a page on the website. The rest of this +document focuses on *servant-client*, *servant-jquery* and *servant-docs*. From 9263f9790f1d4bf98c637c64af79501e2c5606c2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 18 Feb 2016 17:02:11 +0100 Subject: [PATCH 129/180] tutorial: restructuring --- doc/CONTRIBUTING.md | 1 - doc/README.md | 1 - doc/index.rst | 14 +++++----- doc/introduction.rst | 44 ++++++++++++++++++++++++++++++++ doc/links.rst | 34 +++++++++++++++++++++++++ doc/tutorial/index.rst | 58 ++---------------------------------------- 6 files changed, 88 insertions(+), 64 deletions(-) delete mode 120000 doc/CONTRIBUTING.md delete mode 120000 doc/README.md create mode 100644 doc/introduction.rst create mode 100644 doc/links.rst diff --git a/doc/CONTRIBUTING.md b/doc/CONTRIBUTING.md deleted file mode 120000 index 44fcc634..00000000 --- a/doc/CONTRIBUTING.md +++ /dev/null @@ -1 +0,0 @@ -../CONTRIBUTING.md \ No newline at end of file diff --git a/doc/README.md b/doc/README.md deleted file mode 120000 index 32d46ee8..00000000 --- a/doc/README.md +++ /dev/null @@ -1 +0,0 @@ -../README.md \ No newline at end of file diff --git a/doc/index.rst b/doc/index.rst index ca7b5e5f..9757ec1b 100644 --- a/doc/index.rst +++ b/doc/index.rst @@ -1,12 +1,14 @@ -servant – Type-Level Web DSL -============================ +servant – A Type-Level Web DSL +============================== + +.. image:: https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png Documentation table of contents ------------------------------- .. toctree:: - :maxdepth: 2 + :maxdepth: 2 - README.md - tutorial/index.rst - CONTRIBUTING.md + introduction.rst + tutorial/index.rst + links.rst diff --git a/doc/introduction.rst b/doc/introduction.rst new file mode 100644 index 00000000..6c5050bc --- /dev/null +++ b/doc/introduction.rst @@ -0,0 +1,44 @@ +Introduction +------------ + +*servant* has the following guiding principles: + +- concision + + This is a pretty wide-ranging principle. You should be able to get nice + documentation for your web servers, and client libraries, without repeating + yourself. You should not have to manually serialize and deserialize your + resources, but only declare how to do those things *once per type*. If a + bunch of your handlers take the same query parameters, you shouldn't have to + repeat that logic for each handler, but instead just "apply" it to all of + them at once. Your handlers shouldn't be where composition goes to die. And + so on. + +- flexibility + + If we haven't thought of your use case, it should still be easily + achievable. If you want to use templating library X, go ahead. Forms? Do + them however you want, but without difficulty. We're not opinionated. + +- separation of concerns + + Your handlers and your HTTP logic should be separate. True to the philosphy + at the core of HTTP and REST, with *servant* your handlers return normal + Haskell datatypes - that's the resource. And then from a description of your + API, *servant* handles the *presentation* (i.e., the Content-Types). But + that's just one example. + +- type safety + + Want to be sure your API meets a specification? Your compiler can check + that for you. Links you can be sure exist? You got it. + +To stick true to these principles, we do things a little differently than you +might expect. The core idea is *reifying the description of your API*. Once +reified, everything follows. We think we might be the first web framework to +reify API descriptions in an extensible way. We're pretty sure we're the first +to reify it as *types*. + +To be able to write a webservice you only need to read the first two sections, +but the goal of this document being to get you started with servant, we also +cover the couple of ways you can extend servant for a great good. diff --git a/doc/links.rst b/doc/links.rst new file mode 100644 index 00000000..8f28d16f --- /dev/null +++ b/doc/links.rst @@ -0,0 +1,34 @@ + +Helpful Links +------------- + +- the central documentation (this site): + `haskell-servant.readthedocs.org `_ + +- the github repo: + `github.com/haskell-servant/servant `_ + +- the issue tracker (Feel free to create issues and submit PRs!): + `https://github.com/haskell-servant/servant/issues `_ + +- the irc channel: + #servant on freenode + +- the mailing list: + `groups.google.com/forum/#!forum/haskell-servant `_ + +- blog posts and videos and slides of some talks on servant: + `haskell-servant.github.io `_ + +- the servant packages on hackage: + + - `hackage.haskell.org/package/servant `_ + - `hackage.haskell.org/package/servant-server `_ + - `hackage.haskell.org/package/servant-client `_ + - `hackage.haskell.org/package/servant-blaze `_ + - `hackage.haskell.org/package/servant-lucid `_ + - `hackage.haskell.org/package/servant-cassava `_ + - `hackage.haskell.org/package/servant-docs `_ + - `hackage.haskell.org/package/servant-foreign `_ + - `hackage.haskell.org/package/servant-js `_ + - `hackage.haskell.org/package/servant-mock `_ diff --git a/doc/tutorial/index.rst b/doc/tutorial/index.rst index ab212368..37dab25f 100644 --- a/doc/tutorial/index.rst +++ b/doc/tutorial/index.rst @@ -1,64 +1,10 @@ -Servant tutorial -================ +Tutorial +======== This is an introductory tutorial to the current version of *servant*, which is **0.4**. Any comment or issue can be directed to `this website's issue tracker `_. -Github -------- - -- the servant packages: `haskell-servant/servant `_ -- the website (including this tutorial): `haskell-servant/haskell-servant.github.io `_ -- Feel free to use the issue tracker (or to send PRs!) on the website's repository to give feedback and suggestions about this tutorial - -Introduction -------------- - -*servant* has the following guiding principles: - -- concision - - This is a pretty wide-ranging principle. You should be able to get nice - documentation for your web servers, and client libraries, without repeating - yourself. You should not have to manually serialize and deserialize your - resources, but only declare how to do those things *once per type*. If a - bunch of your handlers take the same query parameters, you shouldn't have to - repeat that logic for each handler, but instead just "apply" it to all of - them at once. Your handlers shouldn't be where composition goes to die. And - so on. - -- flexibility - - If we haven't thought of your use case, it should still be easily - achievable. If you want to use templating library X, go ahead. Forms? Do - them however you want, but without difficulty. We're not opinionated. - -- separation of concerns - - Your handlers and your HTTP logic should be separate. True to the philosphy - at the core of HTTP and REST, with *servant* your handlers return normal - Haskell datatypes - that's the resource. And then from a description of your - API, *servant* handles the *presentation* (i.e., the Content-Types). But - that's just one example. - -- type safety - - Want to be sure your API meets a specification? Your compiler can check - that for you. Links you can be sure exist? You got it. - -To stick true to these principles, we do things a little differently than you -might expect. The core idea is *reifying the description of your API*. Once -reified, everything follows. We think we might be the first web framework to -reify API descriptions in an extensible way. We're pretty sure we're the first -to reify it as *types*. - -To be able to write a webservice you only need to read the first two sections, -but the goal of this document being to get you started with servant, we also -cover the couple of ways you can extend servant for a great good. - -Tutorial ---------- .. toctree:: :maxdepth: 1 From 23d6671c6c8705c2fe40ea4b17ee9a30b5bd326e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 18 Feb 2016 18:13:43 +0100 Subject: [PATCH 130/180] tutorial: tweak some titles --- doc/index.rst | 11 +++++++++-- doc/links.rst | 2 +- doc/tutorial/Client.lhs | 2 +- doc/tutorial/Docs.lhs | 2 +- doc/tutorial/Javascript.lhs | 2 +- 5 files changed, 13 insertions(+), 6 deletions(-) diff --git a/doc/index.rst b/doc/index.rst index 9757ec1b..b1e24c99 100644 --- a/doc/index.rst +++ b/doc/index.rst @@ -3,8 +3,15 @@ servant – A Type-Level Web DSL .. image:: https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png -Documentation table of contents -------------------------------- +``servant`` is a set of packages for writing web applications and tools around them. +It allows to + +- write servers, +- obtain clients (in haskell), +- generate client functions for other programming languages and +- generate documentation for your web applications. + +All in a type-safe manner. .. toctree:: :maxdepth: 2 diff --git a/doc/links.rst b/doc/links.rst index 8f28d16f..5f14c527 100644 --- a/doc/links.rst +++ b/doc/links.rst @@ -12,7 +12,7 @@ Helpful Links `https://github.com/haskell-servant/servant/issues `_ - the irc channel: - #servant on freenode + ``#servant`` on freenode - the mailing list: `groups.google.com/forum/#!forum/haskell-servant `_ diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index 60dc88e4..201f187d 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -1,4 +1,4 @@ -# Deriving Haskell functions to query an API +# Querying an API While defining handlers that serve an API has a lot to it, querying an API is simpler: we do not care about what happens inside the webserver, we just need to know how to talk to it and get a response back. Except that we usually have to write the querying functions by hand because the structure of the API isn't a first class citizen and can't be inspected to generate a bunch of client-side functions. diff --git a/doc/tutorial/Docs.lhs b/doc/tutorial/Docs.lhs index adc63924..b1edc38e 100644 --- a/doc/tutorial/Docs.lhs +++ b/doc/tutorial/Docs.lhs @@ -1,4 +1,4 @@ -# Generating documentation from API types +# Documenting an API The source for this tutorial section is a literate haskell file, so first we need to have some language extensions and imports: diff --git a/doc/tutorial/Javascript.lhs b/doc/tutorial/Javascript.lhs index c5f118b1..85d16e20 100644 --- a/doc/tutorial/Javascript.lhs +++ b/doc/tutorial/Javascript.lhs @@ -1,4 +1,4 @@ -# Deriving Javascript functions to query an API +# Generating Javascript functions to query an API We will now see how *servant* lets you turn an API type into javascript functions that you can call to query a webservice. The derived code assumes you From 71a21403a033a6cefde6009e76fc6321543509ec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 18 Feb 2016 18:17:56 +0100 Subject: [PATCH 131/180] tutorial: tweak index page --- doc/index.rst | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/index.rst b/doc/index.rst index b1e24c99..2f300a1f 100644 --- a/doc/index.rst +++ b/doc/index.rst @@ -3,11 +3,11 @@ servant – A Type-Level Web DSL .. image:: https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png -``servant`` is a set of packages for writing web applications and tools around them. -It allows to +``servant`` is a set of packages for declaring web APIs at the type-level and +then using those API specifications to: -- write servers, -- obtain clients (in haskell), +- write servers (this part of ``servant`` can be considered a web framework), +- obtain client functions (in haskell), - generate client functions for other programming languages and - generate documentation for your web applications. From 140da7a7b0311abd079f278239ba77a99a5bd94e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 18 Feb 2016 22:12:27 +0100 Subject: [PATCH 132/180] tutorial: tweaks --- doc/index.rst | 4 ++-- doc/introduction.rst | 10 +++------- doc/tutorial/index.rst | 8 +++++--- 3 files changed, 10 insertions(+), 12 deletions(-) diff --git a/doc/index.rst b/doc/index.rst index 2f300a1f..2c44df0a 100644 --- a/doc/index.rst +++ b/doc/index.rst @@ -3,10 +3,10 @@ servant – A Type-Level Web DSL .. image:: https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png -``servant`` is a set of packages for declaring web APIs at the type-level and +**servant** is a set of packages for declaring web APIs at the type-level and then using those API specifications to: -- write servers (this part of ``servant`` can be considered a web framework), +- write servers (this part of **servant** can be considered a web framework), - obtain client functions (in haskell), - generate client functions for other programming languages and - generate documentation for your web applications. diff --git a/doc/introduction.rst b/doc/introduction.rst index 6c5050bc..77ef306b 100644 --- a/doc/introduction.rst +++ b/doc/introduction.rst @@ -1,7 +1,7 @@ Introduction ------------ -*servant* has the following guiding principles: +**servant** has the following guiding principles: - concision @@ -23,9 +23,9 @@ Introduction - separation of concerns Your handlers and your HTTP logic should be separate. True to the philosphy - at the core of HTTP and REST, with *servant* your handlers return normal + at the core of HTTP and REST, with **servant** your handlers return normal Haskell datatypes - that's the resource. And then from a description of your - API, *servant* handles the *presentation* (i.e., the Content-Types). But + API, **servant** handles the *presentation* (i.e., the Content-Types). But that's just one example. - type safety @@ -38,7 +38,3 @@ might expect. The core idea is *reifying the description of your API*. Once reified, everything follows. We think we might be the first web framework to reify API descriptions in an extensible way. We're pretty sure we're the first to reify it as *types*. - -To be able to write a webservice you only need to read the first two sections, -but the goal of this document being to get you started with servant, we also -cover the couple of ways you can extend servant for a great good. diff --git a/doc/tutorial/index.rst b/doc/tutorial/index.rst index 37dab25f..cf2cfd8e 100644 --- a/doc/tutorial/index.rst +++ b/doc/tutorial/index.rst @@ -1,9 +1,11 @@ Tutorial ======== -This is an introductory tutorial to the current version of *servant*, which is -**0.4**. Any comment or issue can be directed to `this website's issue -tracker `_. +This is an introductory tutorial to **servant**. + +(Any comments, issues or feedback about the tutorial can be handled +through +`servant's issue tracker `_.) .. toctree:: From 434c163aa1cf934b037189b96cd3290207797492 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Tue, 23 Feb 2016 13:42:48 +0100 Subject: [PATCH 133/180] tutorial: read through ApiType.lhs --- doc/index.rst | 5 +-- doc/tutorial/ApiType.lhs | 72 ++++++++++++++++++---------------------- 2 files changed, 35 insertions(+), 42 deletions(-) diff --git a/doc/index.rst b/doc/index.rst index 2c44df0a..eebba2dd 100644 --- a/doc/index.rst +++ b/doc/index.rst @@ -8,8 +8,9 @@ then using those API specifications to: - write servers (this part of **servant** can be considered a web framework), - obtain client functions (in haskell), -- generate client functions for other programming languages and -- generate documentation for your web applications. +- generate client functions for other programming languages, +- generate documentation for your web applications +- and more... All in a type-safe manner. diff --git a/doc/tutorial/ApiType.lhs b/doc/tutorial/ApiType.lhs index bbe1da43..ff64a0ae 100644 --- a/doc/tutorial/ApiType.lhs +++ b/doc/tutorial/ApiType.lhs @@ -24,8 +24,8 @@ You *should* be able to formalize that. And then use the formalized version to get you much of the way towards writing a web app. And all the way towards getting some client libraries, and documentation, and more. -How would we describe it with servant? As mentioned earlier, an endpoint -description is a good old Haskell **type**: +How would we describe it with **servant**? An endpoint description is a good old +Haskell **type**: ``` haskell type UserAPI = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User] @@ -66,15 +66,14 @@ type UserAPI2 = "users" :> "list-all" :> Get '[JSON] [User] :<|> "list-all" :> "users" :> Get '[JSON] [User] ``` -*servant* provides a fair amount of combinators out-of-the-box, but you can -always write your own when you need it. Here's a quick overview of all the -combinators that servant comes with. +**servant** provides a fair amount of combinators out-of-the-box, but you can +always write your own when you need it. Here's a quick overview of the most +often needed the combinators that **servant** comes with. ## Combinators ### Static strings - As you've already seen, you can use type-level strings (enabled with the `DataKinds` language extension) for static path fragments. Chaining them amounts to `/`-separating them in a URL. @@ -87,7 +86,6 @@ type UserAPI3 = "users" :> "list-all" :> "now" :> Get '[JSON] [User] ### `Delete`, `Get`, `Patch`, `Post` and `Put` - The `Get` combinator is defined in terms of the more general `Verb`: ``` haskell ignore data Verb method (statusCode :: Nat) (contentType :: [*]) a @@ -120,15 +118,14 @@ type UserAPI4 = "users" :> Get '[JSON] [User] ### `Capture` - -URL captures are parts of the URL that are variable and whose actual value is +URL captures are segments of the path of a URL that are variable and whose actual value is captured and passed to the request handlers. In many web frameworks, you'll see it written as in `/users/:userid`, with that leading `:` denoting that `userid` is just some kind of variable name or placeholder. For instance, if `userid` is supposed to range over all integers greater or equal to 1, our endpoint will match requests made to `/users/1`, `/users/143` and so on. -The `Capture` combinator in servant takes a (type-level) string representing +The `Capture` combinator in **servant** takes a (type-level) string representing the "name of the variable" and a type, which indicates the type we want to decode the "captured value" to. @@ -155,17 +152,16 @@ type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User In the second case, `DeleteNoContent` specifies a 204 response code, `JSON` specifies the content types on which the handler will match, -and `NoContent` is a Haskell type isomorphic to `()` used to represent -a trivial piece of information. +and `NoContent` says that the response will always be empty. ### `QueryParam`, `QueryParams`, `QueryFlag` -`QueryParam`, `QueryParams` and `QueryFlag` are about query string -parameters, i.e., those parameters that come after the question mark +`QueryParam`, `QueryParams` and `QueryFlag` are about parameters in the query string, +i.e., those parameters that come after the question mark (`?`) in URLs, like `sortby` in `/users?sortby=age`, whose value is set to `age`. `QueryParams` lets you specify that the query parameter is actually a list of values, which can be specified using -`?param[]=value1¶m[]=value2`. This represents a list of values +`?param=value1¶m=value2`. This represents a list of values composed of `value1` and `value2`. `QueryFlag` lets you specify a boolean-like query parameter where a client isn't forced to specify a value. The absence or presence of the parameter's name in the query @@ -190,7 +186,7 @@ type UserAPI6 = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User] ``` Again, your handlers don't have to deserialize these things (into, for example, -a `SortBy`). *servant* takes care of it. +a `SortBy`). **servant** takes care of it. ### `ReqBody` @@ -201,9 +197,9 @@ users: instead of passing each field of the user as a separate query string parameter or something dirty like that, we can group all the data into a JSON object. This has the advantage of supporting nested objects. -*servant*'s `ReqBody` combinator takes a list of content types in which the +**servant**'s `ReqBody` combinator takes a list of content types in which the data encoded in the request body can be represented and the type of that data. -And, as you might have guessed, you don't have to check the content-type +And, as you might have guessed, you don't have to check the content type header, and do the deserialization yourself. We do it for you. And return `Bad Request` or `Unsupported Content Type` as appropriate. @@ -231,12 +227,11 @@ type UserAPI7 = "users" :> ReqBody '[JSON] User :> Post '[JSON] User ### Request `Header`s - Request headers are used for various purposes, from caching to carrying auth-related data. They consist of a header name and an associated value. An example would be `Accept: application/json`. -The `Header` combinator in servant takes a type-level string for the header +The `Header` combinator in **servant** takes a type-level string for the header name and the type to which we want to decode the header's value (from some textual representation), as illustrated below: @@ -255,10 +250,10 @@ type UserAPI8 = "users" :> Header "User-Agent" Text :> Get '[JSON] [User] ### Content types So far, whenever we have used a combinator that carries a list of content -types, we've always specified `'[JSON]`. However, *servant* lets you use several +types, we've always specified `'[JSON]`. However, **servant** lets you use several content types, and also lets you define your own content types. -Four content-types are provided out-of-the-box by the core *servant* package: +Four content types are provided out-of-the-box by the core **servant** package: `JSON`, `PlainText`, `FormUrlEncoded` and `OctetStream`. If for some obscure reason you wanted one of your endpoints to make your user data available under those 4 formats, you would write the API type as below: @@ -267,18 +262,18 @@ those 4 formats, you would write the API type as below: type UserAPI9 = "users" :> Get '[JSON, PlainText, FormUrlEncoded, OctetStream] [User] ``` -We also provide an HTML content-type, but since there's no single library -that everyone uses, we decided to release 2 packages, *servant-lucid* and -*servant-blaze*, to provide HTML encoding of your data. +(There are other packages that provide other content types. For example +**servant-lucid** and **servant-blaze** allow to generate html pages (using +**lucid** and **blaze-html**) and both come with a content type for html.) We will further explain how these content types and your data types can play -together in the [section about serving an API](/tutorial/server.html). +together in the [section about serving an API](Server.html). ### Response `Headers` Just like an HTTP request, the response generated by a webserver can carry -headers too. *servant* provides a `Headers` combinator that carries a list of -`Header` and can be used by simply wrapping the "return type" of an endpoint +headers too. **servant** provides a `Headers` combinator that carries a list of +`Header` types and can be used by simply wrapping the "return type" of an endpoint with it. ``` haskell ignore @@ -292,11 +287,12 @@ response, you could write it as below: type UserAPI10 = "users" :> Get '[JSON] (Headers '[Header "User-Count" Integer] [User]) ``` -### Interoperability with other WAI `Application`s: `Raw` +### Interoperability with `wai`: `Raw` -Finally, we also include a combinator named `Raw` that can be used for two reasons: - -- You want to serve static files from a given directory. In that case you can just say: +Finally, we also include a combinator named `Raw` that provides an escape hatch +to the underlying low-level web library `wai`. It can be used when +you want to plug a [wai `Application`](http://hackage.haskell.org/package/wai) +into your webservice: ``` haskell type UserAPI11 = "users" :> Get '[JSON] [User] @@ -309,11 +305,7 @@ type UserAPI11 = "users" :> Get '[JSON] [User] -- at the right path ``` -- You more generally want to plug a [WAI `Application`](http://hackage.haskell.org/package/wai) -into your webservice. Static file serving is a specific example of that. The API type would look the -same as above though. (You can even combine *servant* with other web frameworks -this way!) - - +One example for this is if you want to serve a directory of static files along +with the rest of your API. But you can plug in everything that is an +`Application`, e.g. a whole web application written in any of the web +frameworks that support `wai`. From e68cf28750b390c79fd3c22d8a38ab89a333a84b Mon Sep 17 00:00:00 2001 From: rwobben Date: Fri, 26 Feb 2016 10:13:22 +0000 Subject: [PATCH 134/180] change a dependency and delete EmptyConfig --- doc/tutorial/Server.lhs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index 93769b54..d90c2c06 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -29,7 +29,7 @@ import Prelude.Compat import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Except -import Data.Aeson +import Data.Aeson.Compat import Data.Aeson.Types import Data.Attoparsec.ByteString import Data.ByteString (ByteString) @@ -139,7 +139,7 @@ userAPI = Proxy -- which you can think of as an "abstract" web application, -- not yet a webserver. app1 :: Application -app1 = serve userAPI EmptyConfig server1 +app1 = serve userAPI server1 ``` The `userAPI` bit is, alas, boilerplate (we need it to guide type inference). From e84fea334a10c27c38d14d17525d00e7eb8bb429 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sat, 27 Feb 2016 19:53:03 +0100 Subject: [PATCH 135/180] tutorial: read through Server.lhs --- doc/tutorial/Docs.lhs | 2 +- doc/tutorial/Javascript.lhs | 2 +- doc/tutorial/Server.lhs | 326 ++++++++++++------------------------ 3 files changed, 109 insertions(+), 221 deletions(-) diff --git a/doc/tutorial/Docs.lhs b/doc/tutorial/Docs.lhs index b1edc38e..dbd3233d 100644 --- a/doc/tutorial/Docs.lhs +++ b/doc/tutorial/Docs.lhs @@ -228,7 +228,7 @@ server = Server.server3 :<|> serveDocs plain = ("Content-Type", "text/plain") app :: Application -app = serve api EmptyConfig server +app = serve api server ``` And if you spin up this server with `dist/build/tutorial/tutorial 10` and go to anywhere else than `/position`, `/hello` and `/marketing`, you will see the API docs in markdown. This is because `serveDocs` is attempted if the 3 other endpoints don't match and systematically succeeds since its definition is to just return some fixed bytestring with the `text/plain` content type. diff --git a/doc/tutorial/Javascript.lhs b/doc/tutorial/Javascript.lhs index 85d16e20..600c8327 100644 --- a/doc/tutorial/Javascript.lhs +++ b/doc/tutorial/Javascript.lhs @@ -134,7 +134,7 @@ server' = server :<|> serveDirectory "tutorial/t9" app :: Application -app = serve api' EmptyConfig server' +app = serve api' server' ``` Why two different API types, proxies and servers though? Simply because we don't want to generate javascript functions for the `Raw` part of our API type, so we need a `Proxy` for our API type `API'` without its `Raw` endpoint. diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index d90c2c06..ab29b59e 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -5,7 +5,7 @@ type. Can we have a webservice already? ## A first example -Equipped with some basic knowledge about the way we represent API, let's now +Equipped with some basic knowledge about the way we represent APIs, let's now write our first webservice. The source for this tutorial section is a literate haskell file, so first we @@ -26,7 +26,7 @@ module Server where import Prelude () import Prelude.Compat -import Control.Monad.IO.Class +import Control.Monad.Except import Control.Monad.Reader import Control.Monad.Trans.Except import Data.Aeson.Compat @@ -34,6 +34,7 @@ import Data.Aeson.Types import Data.Attoparsec.ByteString import Data.ByteString (ByteString) import Data.List +import Data.Maybe import Data.String.Conversions import Data.Time.Calendar import GHC.Generics @@ -49,16 +50,12 @@ import qualified Data.Aeson.Parser import qualified Text.Blaze.Html ``` -``` haskell ignore -{-# LANGUAGE TypeFamilies #-} -``` - -**Important**: the `Servant` module comes from the *servant-server* package, +**Important**: the `Servant` module comes from the **servant-server** package, the one that lets us run webservers that implement a particular API type. It -reexports all the types from the *servant* package that let you declare API +reexports all the types from the **servant** package that let you declare API types as well as everything you need to turn your request handlers into a fully-fledged webserver. This means that in your applications, you can just add -*servant-server* as a dependency, import `Servant` and not worry about anything +**servant-server** as a dependency, import `Servant` and not worry about anything else. We will write a server that will serve the following API. @@ -154,9 +151,8 @@ main = run 8081 app1 You can put this all into a file or just grab [servant's repo](http://github.com/haskell-servant/servant) and look at the -*servant-examples* directory. The code we have just explored is in -*tutorial/T1.hs*, runnable with -`dist/build/tutorial/tutorial 1`. +*doc/tutorial* directory. This code (the source of this web page) is in +*doc/tutorial/Server.lhs*. If you run it, you can go to `http://localhost:8081/users` in your browser or query it with curl and you see: @@ -192,7 +188,7 @@ users2 = [isaac, albert] Now, just like we separate the various endpoints in `UserAPI` with `:<|>`, we are going to separate the handlers with `:<|>` too! They must be provided in -the same order as the one they appear in in the API type. +the same order as in in the API type. ``` haskell server2 :: Server UserAPI2 @@ -201,9 +197,8 @@ server2 = return users2 :<|> return isaac ``` -And that's it! You can run this example with -`dist/build/tutorial/tutorial 2` and check out the data available -at `/users`, `/albert` and `/isaac`. +And that's it! You can run this example in the same way that we showed for +`server1` and check out the data available at `/users`, `/albert` and `/isaac`. ## From combinators to handler arguments @@ -298,8 +293,7 @@ parameter might not always be there); - a `ReqBody contentTypeList a` becomes an argument of type `a`; -And that's it. You can see this example in action by running -`dist/build/tutorial/tutorial 3`. +And that's it. Here's the example in action: ``` bash $ curl http://localhost:8081/position/1/2 @@ -312,19 +306,18 @@ $ curl -X POST -d '{"name":"Alp Mestanogullari", "email" : "alp@foo.com", "age": {"subject":"Hey Alp Mestanogullari, we miss you!","body":"Hi Alp Mestanogullari,\n\nSince you've recently turned 25, have you checked out our latest haskell, mathematics products? Give us a visit!","to":"alp@foo.com","from":"great@company.com"} ``` -For reference, here's a list of some combinators from *servant* and for those -that get turned into arguments to the handlers, the type of the argument. +For reference, here's a list of some combinators from **servant**: > - `Delete`, `Get`, `Patch`, `Post`, `Put`: these do not become arguments. They provide the return type of handlers, which usually is `ExceptT ServantErr IO `. > - `Capture "something" a` becomes an argument of type `a`. - > - `QueryParam "something" a`, `MatrixParam "something" a`, `Header "something" a` all become arguments of type `Maybe a`, because there might be no value at all specified by the client for these. - > - `QueryFlag "something"` and `MatrixFlag "something"` get turned into arguments of type `Bool`. - > - `QueryParams "something" a` and `MatrixParams "something" a` get turned into arguments of type `[a]`. + > - `QueryParam "something" a`, `Header "something" a` all become arguments of type `Maybe a`, because there might be no value at all specified by the client for these. + > - `QueryFlag "something"` gets turned into an argument of type `Bool`. + > - `QueryParams "something" a` gets turned into an argument of type `[a]`. > - `ReqBody contentTypes a` gets turned into an argument of type `a`. ## The `FromHttpApiData`/`ToHttpApiData` classes -Wait... How does *servant* know how to decode the `Int`s from the URL? Or how +Wait... How does **servant** know how to decode the `Int`s from the URL? Or how to decode a `ClientInfo` value from the request body? This is what this and the following two sections address. @@ -333,7 +326,7 @@ following two sections address. corresponding (textual) value in the request's "metadata". How types are decoded from headers, captures, and query params is expressed in a class `FromHttpApiData` (from the package -[*http-api-data*](http://hackage.haskell.org/package/http-api-data)): +[**http-api-data**](http://hackage.haskell.org/package/http-api-data)): ``` haskell ignore class FromHttpApiData a where @@ -355,15 +348,15 @@ As you can see, as long as you provide either `parseUrlPiece` (for `Capture`s) or `parseQueryParam` (for `QueryParam`s), the other methods will be defined in terms of this. -*http-api-data* provides a decent number of instances, helpers for defining new +**http-api-data** provides a decent number of instances, helpers for defining new ones, and wonderful documentation. There's not much else to say about these classes. You will need instances for them when using `Capture`, `QueryParam`, `QueryParams`, and `Header` with your types. You will need `FromHttpApiData` instances for server-side request handlers and `ToHttpApiData` instances only when using -*servant-client*, as described in the [section about deriving haskell -functions to query an API](/tutorial/client.html). +**servant-client**, as described in the [section about deriving haskell +functions to query an API](Client.html). ## Using content-types with your data types @@ -371,14 +364,15 @@ The same principle was operating when decoding request bodies from JSON, and responses *into* JSON. (JSON is just the running example - you can do this with any content-type.) -This section introduces a couple of typeclasses provided by *servant* that make +This section introduces a couple of typeclasses provided by **servant** that make all of this work. ### The truth behind `JSON` -What exactly is `JSON`? Like the 3 other content types provided out of the box -by *servant*, it's a really dumb data type. +What exactly is `JSON` (the type as used in `Get '[JSON] User`)? Like the 3 +other content-types provided out of the box by **servant**, it's a really dumb +data type. ``` haskell ignore data JSON @@ -388,14 +382,15 @@ data OctetStream ``` Obviously, this is not all there is to `JSON`, otherwise it would be quite -pointless. Like most of the data types in *servant*, `JSON` is mostly there as +pointless. Like most of the data types in **servant**, `JSON` is mostly there as a special *symbol* that's associated with encoding (resp. decoding) to (resp. from) the *JSON* format. The way this association is performed can be decomposed into two steps. The first step is to provide a proper -[`MediaType`](https://hackage.haskell.org/package/http-media-0.6.2/docs/Network-HTTP-Media.html) -representation for `JSON`, or for your own content types. If you look at the +`MediaType` (from +[**http-media**](https://hackage.haskell.org/package/http-media-0.6.2/docs/Network-HTTP-Media.html)) +representation for `JSON`, or for your own content-types. If you look at the haddocks from this link, you can see that we just have to specify `application/json` using the appropriate functions. In our case, we can just use `(//) :: ByteString -> ByteString -> MediaType`. The precise way to specify @@ -411,14 +406,14 @@ instance Accept JSON where ``` The second step is centered around the `MimeRender` and `MimeUnrender` classes. -These classes just let you specify a way to respectively encode and decode -values respectively into or from your content-type's representation. +These classes just let you specify a way to encode and decode +values into or from your content-type's representation. ``` haskell ignore class Accept ctype => MimeRender ctype a where - mimeRender :: Proxy ctype -> a -> ByteString + mimeRender :: Proxy ctype -> a -> ByteString -- alternatively readable as: - mimeRender :: Proxy ctype -> (a -> ByteString) + mimeRender :: Proxy ctype -> (a -> ByteString) ``` Given a content-type and some user type, `MimeRender` provides a function that @@ -444,7 +439,7 @@ class Accept ctype => MimeUnrender ctype a where We don't have much work to do there either, `Data.Aeson.eitherDecode` is precisely what we need. However, it only allows arrays and objects as toplevel JSON values and this has proven to get in our way more than help us so we wrote -our own little function around *aeson* and *attoparsec* that allows any type of +our own little function around **aeson** and **attoparsec** that allows any type of JSON value at the toplevel of a "JSON document". Here's the definition in case you are curious. @@ -462,20 +457,20 @@ instance FromJSON a => MimeUnrender JSON a where mimeUnrender _ = eitherDecodeLenient ``` -And this is all the code that lets you use `JSON` for with `ReqBody`, `Get`, +And this is all the code that lets you use `JSON` with `ReqBody`, `Get`, `Post` and friends. We can check our understanding by implementing support -for an `HTML` content type, so that users of your webservice can access an +for an `HTML` content-type, so that users of your webservice can access an HTML representation of the data they want, ready to be included in any HTML document, e.g. using [jQuery's `load` function](https://api.jquery.com/load/), simply by adding `Accept: text/html` to their request headers. -### Case-studies: *servant-blaze* and *servant-lucid* +### Case-studies: **servant-blaze** and **servant-lucid** These days, most of the haskellers who write their HTML UIs directly from -Haskell use either [blaze-html](http://hackage.haskell.org/package/blaze-html) -or [lucid](http://hackage.haskell.org/package/lucid). The best option for -*servant* is obviously to support both (and hopefully other templating -solutions!). +Haskell use either [**blaze-html**](http://hackage.haskell.org/package/blaze-html) +or [**lucid**](http://hackage.haskell.org/package/lucid). The best option for +**servant** is obviously to support both (and hopefully other templating +solutions!). We're first going to look at **lucid**: ``` haskell data HTMLLucid @@ -483,24 +478,20 @@ data HTMLLucid Once again, the data type is just there as a symbol for the encoding/decoding functions, except that this time we will only worry about encoding since -*blaze-html* and *lucid* don't provide a way to extract data from HTML. - -Both packages also have the same `Accept` instance for their `HTMLLucid` type. +**lucid** doesn't provide a way to extract data from HTML. ``` haskell instance Accept HTMLLucid where contentType _ = "text" // "html" /: ("charset", "utf-8") ``` -Note that this instance uses the `(/:)` operator from *http-media* which lets +Note that this instance uses the `(/:)` operator from **http-media** which lets us specify additional information about a content-type, like the charset here. -The rendering instances for both packages both call similar functions that take +The rendering instances call similar functions that take types with an appropriate instance to an "abstract" HTML representation and then write that to a `ByteString`. -For *lucid*: - ``` haskell instance ToHtml a => MimeRender HTMLLucid a where mimeRender _ = renderBS . toHtml @@ -511,7 +502,7 @@ instance MimeRender HTMLLucid (Html a) where mimeRender _ = renderBS ``` -For *blaze-html*: +For **blaze-html** everything works very similarly: ``` haskell -- For this tutorial to compile 'HTMLLucid' and 'HTMLBlaze' have to be @@ -531,15 +522,13 @@ instance MimeRender HTMLBlaze Text.Blaze.Html.Html where mimeRender _ = renderHtml ``` -Both [servant-blaze](http://hackage.haskell.org/package/servant-blaze) and -[servant-lucid](http://hackage.haskell.org/package/servant-lucid) let you use -`HTMLLucid` in any content type list as long as you provide an instance of the -appropriate class (`ToMarkup` for *blaze-html*, `ToHtml` for *lucid*). +Both [**servant-blaze**](http://hackage.haskell.org/package/servant-blaze) and +[**servant-lucid**](http://hackage.haskell.org/package/servant-lucid) let you use +`HTMLLucid` and `HTMLBlaze` in any content-type list as long as you provide an instance of the +appropriate class (`ToMarkup` for **blaze-html**, `ToHtml` for **lucid**). -We can now write webservice that uses *servant-lucid* to show the `HTMLLucid` -content type in action. First off, imports and pragmas as usual. - -We will be serving the following API: +We can now write a webservice that uses **servant-lucid** to show the `HTMLLucid` +content-type in action. We will be serving the following API: ``` haskell type PersonAPI = "persons" :> Get '[JSON, HTMLLucid] [Person] @@ -556,7 +545,7 @@ data Person = Person instance ToJSON Person ``` -Now, let's teach *lucid* how to render a `Person` as a row in a table, and then +Now, let's teach **lucid** how to render a `Person` as a row in a table, and then a list of `Person`s as a table with a row per person. ``` haskell @@ -600,10 +589,10 @@ server4 :: Server PersonAPI server4 = return people app2 :: Application -app2 = serve personAPI EmptyConfig server4 +app2 = serve personAPI server4 ``` -And we're good to go. You can run this example with `dist/build/tutorial/tutorial 4`. +And we're good to go: ``` bash $ curl http://localhost:8081/persons @@ -616,23 +605,21 @@ And we're good to go. You can run this example with `dist/build/tutorial/tutoria ## The `ExceptT ServantErr IO` monad At the heart of the handlers is the monad they run in, namely `ExceptT -ServantErr IO`. One might wonder: why this monad? The answer is that it is the +ServantErr IO` +([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)). +One might wonder: why this monad? The answer is that it is the simplest monad with the following properties: -- it lets us both return a successful result (with the `Right` branch of -`Either`) or "fail" with a descriptive error (with the `Left` branch of -`Either`); +- it lets us both return a successful result (using `return`) +or "fail" with a descriptive error (using `throwError`); - it lets us perform IO, which is absolutely vital since most webservices exist -as interfaces to databases that we interact with in `IO`; +as interfaces to databases that we interact with in `IO`. Let's recall some definitions. ``` haskell ignore --- from the Prelude -data Either e a = Left e | Right a - -- from the 'mtl' package at -newtype ExceptT e m a = ExceptT ( m (Either e a) ) +newtype ExceptT e m a = ExceptT (m (Either e a)) ``` In short, this means that a handler of type `ExceptT ServantErr IO a` is simply @@ -654,14 +641,14 @@ kind and abort early. The next two sections cover how to do just that. Another important instance from the list above is `MonadIO m => MonadIO (ExceptT e m)`. [`MonadIO`](http://hackage.haskell.org/package/transformers-0.4.3.0/docs/Control-Monad-IO-Class.html) -is a class from the *transformers* package defined as: +is a class from the **transformers** package defined as: ``` haskell ignore class Monad m => MonadIO m where liftIO :: IO a -> m a ``` -Obviously, the `IO` monad provides a `MonadIO` instance. Hence for any type +The `IO` monad provides a `MonadIO` instance. Hence for any type `e`, `ExceptT e IO` has a `MonadIO` instance. So if you want to run any kind of IO computation in your handlers, just use `liftIO`: @@ -684,7 +671,7 @@ server5 = do If you want to explicitly fail at providing the result promised by an endpoint using the appropriate HTTP status code (not found, unauthorized, etc) and some -error message, all you have to do is use the `left` function mentioned above +error message, all you have to do is use the `throwError` function mentioned above and provide it with the appropriate value of type `ServantErr`, which is defined as: @@ -703,7 +690,7 @@ use record update syntax: ``` haskell failingHandler :: ExceptT ServantErr IO () -failingHandler = throwE myerr +failingHandler = throwError myerr where myerr :: ServantErr myerr = err503 { errBody = "Sorry dear user." } @@ -718,13 +705,12 @@ server6 = do exists <- liftIO (doesFileExist "myfile.txt") if exists then liftIO (readFile "myfile.txt") >>= return . FileContent - else throwE custom404Err + else throwError custom404Err where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." } ``` -Let's run this server (`dist/build/tutorial/tutorial 5`) and -query it, first without the file and then with the file. +Here's how that server looks in action: ``` bash $ curl --verbose http://localhost:8081/myfile.txt @@ -773,10 +759,10 @@ Note that the type of `addHeader x` is different than the type of `x`! ## Serving static files -*servant-server* also provides a way to just serve the content of a directory +**servant-server** also provides a way to just serve the content of a directory under some path in your web API. As mentioned earlier in this document, the `Raw` combinator can be used in your APIs to mean "plug here any WAI -application". Well, servant-server provides a function to get a file and +application". Well, **servant-server** provides a function to get a file and directory serving WAI application, namely: ``` haskell ignore @@ -784,136 +770,36 @@ directory serving WAI application, namely: serveDirectory :: FilePath -> Server Raw ``` -`serveDirectory`'s argument must be a path to a valid directory. You can see an -example below, runnable with `dist/build/tutorial/tutorial 6` -(you **must** run it from within the *servant-examples/* directory!), which is -a webserver that serves the various bits of code covered in this -getting-started. +`serveDirectory`'s argument must be a path to a valid directory. -The API type will be the following. +Here's an example API that will serve some static files: ``` haskell -type CodeAPI = "code" :> Raw +type StaticAPI = "static" :> Raw ``` And the server: ``` haskell -codeAPI :: Proxy CodeAPI -codeAPI = Proxy +staticAPI :: Proxy StaticAPI +staticAPI = Proxy ``` ``` haskell -server7 :: Server CodeAPI -server7 = serveDirectory "tutorial" +server7 :: Server StaticAPI +server7 = serveDirectory "static-files" app3 :: Application -app3 = serve codeAPI EmptyConfig server7 +app3 = serve staticAPI server7 ``` -This server will match any request whose path starts with `/code` and will look +This server will match any request whose path starts with `/static` and will look for a file at the path described by the rest of the request path, inside the - *tutorial/* directory of the path you run the program from. + *static-files/* directory of the path you run the program from. -In other words: - -- If a client requests `/code/foo.txt`, the server will look for a file at - `./tutorial/foo.txt` (and fail) -- If a client requests `/code/T1.hs`, the server will look for a file at - `./tutorial/T1.hs` (and succeed) -- If a client requests `/code/foo/bar/baz/movie.mp4`, the server will look for - a file at `./tutorial/foo/bar/baz/movie.mp4` (and fail) - -Here is our little server in action. - -``` haskell ignore -$ curl http://localhost:8081/code/T1.hs -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeOperators #-} -module T1 where - -import Data.Aeson -import Data.Time.Calendar -import GHC.Generics -import Network.Wai -import Servant - -data User = User - { name :: String - , age :: Int - , email :: String - , registration_date :: Day - } deriving (Eq, Show, Generic) - --- orphan ToJSON instance for Day. necessary to derive one for User -instance ToJSON Day where - -- display a day in YYYY-mm-dd format - toJSON d = toJSON (showGregorian d) - -instance ToJSON User - -type UserAPI = "users" :> Get '[JSON] [User] - -users :: [User] -users = - [ User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1) - , User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1) - ] - -userAPI :: Proxy UserAPI -userAPI = Proxy - -server :: Server UserAPI -server = return users - -app :: Application -app = serve userAPI server -$ curl http://localhost:8081/code/tutorial.hs -import Network.Wai -import Network.Wai.Handler.Warp -import System.Environment - -import qualified T1 -import qualified T2 -import qualified T3 -import qualified T4 -import qualified T5 -import qualified T6 -import qualified T7 -import qualified T9 -import qualified T10 - -app :: String -> (Application -> IO ()) -> IO () -app n f = case n of - "1" -> f T1.app - "2" -> f T2.app - "3" -> f T3.app - "4" -> f T4.app - "5" -> f T5.app - "6" -> f T6.app - "7" -> f T7.app - "8" -> f T3.app - "9" -> T9.writeJSFiles >> f T9.app - "10" -> f T10.app - _ -> usage - -main :: IO () -main = do - args <- getArgs - case args of - [n] -> app n (run 8081) - _ -> usage - -usage :: IO () -usage = do - putStrLn "Usage:\t tutorial N" - putStrLn "\t\twhere N is the number of the example you want to run." - -$ curl http://localhost:8081/foo -not found -``` +In other words: If a client requests `/static/foo.txt`, the server will look for a file at +`./static-files/foo.txt`. If that file exists it'll succeed and serve the file. +If it doesn't exist, the handler will fail with a `404` status code. ## Nested APIs @@ -1123,7 +1009,7 @@ type Server api = ServerT api (ExceptT ServantErr IO) `ServerT` is the actual type family that computes the required types for the handlers that's part of the `HasServer` class. It's like `Server` except that -it takes a third parameter which is the monad you want your handlers to run in, +it takes another parameter which is the monad you want your handlers to run in, or more generally the return types of your handlers. This third parameter is used for specifying the return type of the handler for an endpoint, e.g when computing `ServerT (Get '[JSON] Person) SomeMonad`. The result would be @@ -1131,7 +1017,7 @@ computing `ServerT (Get '[JSON] Person) SomeMonad`. The result would be The first and main question one might have then is: how do we write handlers that run in another monad? How can we "bring back" the value from a given monad -into something *servant* can understand? +into something **servant** can understand? ### Natural transformations @@ -1140,11 +1026,15 @@ do we have? ``` haskell ignore newtype m :~> n = Nat { unNat :: forall a. m a -> n a} - --- For example --- listToMaybeNat ::`[] :~> Maybe` --- listToMaybeNat = Nat listToMaybe -- from Data.Maybe ``` + +For example: + +``` haskell +listToMaybeNat :: [] :~> Maybe +listToMaybeNat = Nat listToMaybe -- from Data.Maybe +``` + (`Nat` comes from "natural transformation", in case you're wondering.) So if you want to write handlers using another monad/type than `ExceptT @@ -1152,20 +1042,20 @@ ServantErr IO`, say the `Reader String` monad, the first thing you have to prepare is a function: ``` haskell ignore -readerToEither :: Reader String :~> ExceptT ServantErr IO +readerToHandler :: Reader String :~> ExceptT ServantErr IO ``` -Let's start with `readerToEither'`. We obviously have to run the `Reader` +Let's start with `readerToHandler'`. We obviously have to run the `Reader` computation by supplying it with a `String`, like `"hi"`. We get an `a` out from that and can then just `return` it into `ExceptT`. We can then just wrap that function with the `Nat` constructor to make it have the fancier type. ``` haskell -readerToEither' :: forall a. Reader String a -> ExceptT ServantErr IO a -readerToEither' r = return (runReader r "hi") +readerToHandler' :: forall a. Reader String a -> ExceptT ServantErr IO a +readerToHandler' r = return (runReader r "hi") -readerToEither :: Reader String :~> ExceptT ServantErr IO -readerToEither = Nat readerToEither' +readerToHandler :: Reader String :~> ExceptT ServantErr IO +readerToHandler = Nat readerToHandler' ``` We can write some simple webservice with the handlers running in `Reader String`. @@ -1193,25 +1083,24 @@ ServantErr IO`. But there's a simple solution to this. ### Enter `enter` -That's right. We have just written `readerToEither`, which is exactly what we -would need to apply to the results of all handlers to make the handlers have the +That's right. We have just written `readerToHandler`, which is exactly what we +would need to apply to all handlers to make the handlers have the right type for `serve`. Being cumbersome to do by hand, we provide a function `enter` which takes a natural transformation between two parametrized types `m` and `n` and a `ServerT someapi m`, and returns a `ServerT someapi n`. In our case, we can wrap up our little webservice by using `enter -readerToEither` on our handlers. +readerToHandler` on our handlers. ``` haskell readerServer :: Server ReaderAPI -readerServer = enter readerToEither readerServerT +readerServer = enter readerToHandler readerServerT app4 :: Application -app4 = serve readerAPI EmptyConfig readerServer +app4 = serve readerAPI readerServer ``` -And we can indeed see this webservice in action by running -`dist/build/tutorial/tutorial 7`. +This is the webservice in action: ``` bash $ curl http://localhost:8081/a @@ -1222,7 +1111,6 @@ $ curl http://localhost:8081/b ## Conclusion -You're now equipped to write any kind of webservice/web-application using -*servant*. One thing not covered here is how to incorporate your own -combinators and will be the topic of a page on the website. The rest of this -document focuses on *servant-client*, *servant-jquery* and *servant-docs*. +You're now equipped to write webservices/web-applications using +**servant**. The rest of this document focuses on **servant-client**, +**servant-js** and **servant-docs**. From 2716d508e83a135336a6825c93fd4c4bb7dc0f5e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sun, 28 Feb 2016 22:16:43 +0100 Subject: [PATCH 136/180] tutorial: read through Client.lhs --- doc/tutorial/Client.lhs | 31 +++++++++++++++++++------------ 1 file changed, 19 insertions(+), 12 deletions(-) diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index 201f187d..9cb38a0e 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -2,7 +2,7 @@ While defining handlers that serve an API has a lot to it, querying an API is simpler: we do not care about what happens inside the webserver, we just need to know how to talk to it and get a response back. Except that we usually have to write the querying functions by hand because the structure of the API isn't a first class citizen and can't be inspected to generate a bunch of client-side functions. -*servant* however has a way to inspect API, because APIs are just Haskell types and (GHC) Haskell lets us do quite a few things with types. In the same way that we look at an API type to deduce the types the handlers should have, we can inspect the structure of the API to *derive* Haskell functions that take one argument for each occurence of `Capture`, `ReqBody`, `QueryParam` +**servant** however has a way to inspect APIs, because APIs are just Haskell types and (GHC) Haskell lets us do quite a few things with types. In the same way that we look at an API type to deduce the types the handlers should have, we can inspect the structure of the API to *derive* Haskell functions that take one argument for each occurence of `Capture`, `ReqBody`, `QueryParam` and friends. By *derive*, we mean that there's no code generation involved, the functions are defined just by the structure of the API type. The source for this tutorial section is a literate haskell file, so first we @@ -67,7 +67,7 @@ type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Posit :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email ``` -What we are going to get with *servant-client* here is 3 functions, one to query each endpoint: +What we are going to get with **servant-client** here is 3 functions, one to query each endpoint: ``` haskell position :: Int -- ^ value for "x" @@ -81,7 +81,15 @@ marketing :: ClientInfo -- ^ value for the request body -> ExceptT ServantError IO Email ``` -Each function makes available as an argument any value that the response may depend on, as evidenced in the API type. How do we get these functions? Just give a `Proxy` to your API and a host to make the requests to: +Each function makes available as an argument any value that the response may +depend on, as evidenced in the API type. How do we get these functions? By calling +the function `client`. It takes three arguments: + +- a `Proxy` to your API, +- a `BaseUrl`, consisting of the protocol, the host, the port and an optional subpath -- + this basically tells `client` where the service that you want to query is hosted, +- a `Manager`, (from [http-client](http://hackage.haskell.org/package/http-client)) +which manages http connections. ``` haskell api :: Proxy API @@ -95,6 +103,9 @@ position :<|> hello :<|> marketing = client api (BaseUrl Http "localhost" 8081 "") __manager ``` +(Yes, the usage of `unsafePerformIO` is very ugly, we know. Hopefully soon it'll +be possible to do without.) + As you can see in the code above, we just "pattern match our way" to these functions. If we try to derive less or more functions than there are endpoints in the API, we obviously get an error. The `BaseUrl` value there is just: ``` haskell ignore @@ -134,16 +145,12 @@ run = do print em ``` -You can now run `dist/build/tutorial/tutorial 8` (the server) and -`dist/build/t8-main/t8-main` (the client) to see them both in action. +Here's the output of the above code running against the appropriate server: ``` bash - $ dist/build/tutorial/tutorial 8 - # and in another terminal: - $ dist/build/t8-main/t8-main - Position {x = 10, y = 10} - HelloMessage {msg = "Hello, servant"} - Email {from = "great@company.com", to = "alp@foo.com", subject = "Hey Alp, we miss you!", body = "Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!"} +Position {x = 10, y = 10} +HelloMessage {msg = "Hello, servant"} +Email {from = "great@company.com", to = "alp@foo.com", subject = "Hey Alp, we miss you!", body = "Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!"} ``` -The types of the arguments for the functions are the same as for (server-side) request handlers. You now know how to use *servant-client*! +The types of the arguments for the functions are the same as for (server-side) request handlers. You now know how to use **servant-client**! From ac02a2852740cb53fc801520144ca8c0b709da45 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sun, 28 Feb 2016 22:21:04 +0100 Subject: [PATCH 137/180] tutorial: formatting for bash sections --- doc/tutorial/Server.lhs | 60 ++++++++++++++++++++--------------------- 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index ab29b59e..3d1267dc 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -595,11 +595,11 @@ app2 = serve personAPI server4 And we're good to go: ``` bash - $ curl http://localhost:8081/persons - [{"lastName":"Newton","firstName":"Isaac"},{"lastName":"Einstein","firstName":"Albert"}] - $ curl -H 'Accept: text/html' http://localhost:8081/persons -
      first namelast name
      IsaacNewton
      AlbertEinstein
      - # or just point your browser to http://localhost:8081/persons +$ curl http://localhost:8081/persons +[{"lastName":"Newton","firstName":"Isaac"},{"lastName":"Einstein","firstName":"Albert"}] +$ curl -H 'Accept: text/html' http://localhost:8081/persons +
      first namelast name
      IsaacNewton
      AlbertEinstein
      +# or just point your browser to http://localhost:8081/persons ``` ## The `ExceptT ServantErr IO` monad @@ -713,33 +713,33 @@ server6 = do Here's how that server looks in action: ``` bash - $ curl --verbose http://localhost:8081/myfile.txt - [snip] - * Connected to localhost (127.0.0.1) port 8081 (#0) - > GET /myfile.txt HTTP/1.1 - > User-Agent: curl/7.30.0 - > Host: localhost:8081 - > Accept: */* - > - < HTTP/1.1 404 Not Found - [snip] - myfile.txt just isnt there, please leave this server alone. +$ curl --verbose http://localhost:8081/myfile.txt +[snip] +* Connected to localhost (127.0.0.1) port 8081 (#0) +> GET /myfile.txt HTTP/1.1 +> User-Agent: curl/7.30.0 +> Host: localhost:8081 +> Accept: */* +> +< HTTP/1.1 404 Not Found +[snip] +myfile.txt just isnt there, please leave this server alone. - $ echo Hello > myfile.txt +$ echo Hello > myfile.txt - $ curl --verbose http://localhost:8081/myfile.txt - [snip] - * Connected to localhost (127.0.0.1) port 8081 (#0) - > GET /myfile.txt HTTP/1.1 - > User-Agent: curl/7.30.0 - > Host: localhost:8081 - > Accept: */* - > - < HTTP/1.1 200 OK - [snip] - < Content-Type: application/json - [snip] - {"content":"Hello\n"} +$ curl --verbose http://localhost:8081/myfile.txt +[snip] +* Connected to localhost (127.0.0.1) port 8081 (#0) +> GET /myfile.txt HTTP/1.1 +> User-Agent: curl/7.30.0 +> Host: localhost:8081 +> Accept: */* +> +< HTTP/1.1 200 OK +[snip] +< Content-Type: application/json +[snip] +{"content":"Hello\n"} ``` ## Response headers From 8e4ab060308ae698844e9aeab36f680103e9ed29 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sun, 28 Feb 2016 22:32:53 +0100 Subject: [PATCH 138/180] tutorial: read through Docs.lhs --- doc/tutorial/Docs.lhs | 120 +++++++++++++++++++++--------------------- 1 file changed, 60 insertions(+), 60 deletions(-) diff --git a/doc/tutorial/Docs.lhs b/doc/tutorial/Docs.lhs index dbd3233d..fa7b0c43 100644 --- a/doc/tutorial/Docs.lhs +++ b/doc/tutorial/Docs.lhs @@ -26,7 +26,7 @@ import Servant.Server ``` And we'll import some things from one of our earlier modules -([Serving an API](/tutorial/server.html)): +([Serving an API](Server.html)): ``` haskell import Server (Email(..), ClientInfo(..), Position(..), HelloMessage(..), @@ -35,7 +35,7 @@ import Server (Email(..), ClientInfo(..), Position(..), HelloMessage(..), Like client function generation, documentation generation amounts to inspecting the API type and extracting all the data we need to then present it in some format to users of your API. -This time however, we have to assist *servant*. While it is able to deduce a lot of things about our API, it can't magically come up with descriptions of the various pieces of our APIs that are human-friendly and explain what's going on "at the business-logic level". A good example to study for documentation generation is our webservice with the `/position`, `/hello` and `/marketing` endpoints from earlier: +This time however, we have to assist **servant**. While it is able to deduce a lot of things about our API, it can't magically come up with descriptions of the various pieces of our APIs that are human-friendly and explain what's going on "at the business-logic level". A good example to study for documentation generation is our webservice with the `/position`, `/hello` and `/marketing` endpoints from earlier: ``` haskell type ExampleAPI = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position @@ -46,7 +46,7 @@ exampleAPI :: Proxy ExampleAPI exampleAPI = Proxy ``` -While *servant* can see e.g. that there are 3 endpoints and that the response bodies will be in JSON, it doesn't know what influence the captures, parameters, request bodies and other combinators have on the webservice. This is where some manual work is required. +While **servant** can see e.g. that there are 3 endpoints and that the response bodies will be in JSON, it doesn't know what influence the captures, parameters, request bodies and other combinators have on the webservice. This is where some manual work is required. For every capture, request body, response body, query param, we have to give some explanations about how it influences the response, what values are possible and the likes. Here's how it looks like for the parameters we have above. @@ -97,9 +97,9 @@ apiDocs :: API apiDocs = docs exampleAPI ``` -`API` is a type provided by *servant-docs* that stores all the information one needs about a web API in order to generate documentation in some format. Out of the box, *servant-docs* only provides a pretty documentation printer that outputs [Markdown](http://en.wikipedia.org/wiki/Markdown), but the [servant-pandoc](http://hackage.haskell.org/package/servant-pandoc) package can be used to target many useful formats. +`API` is a type provided by **servant-docs** that stores all the information one needs about a web API in order to generate documentation in some format. Out of the box, **servant-docs** only provides a pretty documentation printer that outputs [Markdown](http://en.wikipedia.org/wiki/Markdown), but the [**servant-pandoc**](http://hackage.haskell.org/package/servant-pandoc) package can be used to target many useful formats. -*servant*'s markdown pretty printer is a function named `markdown`. +**servant**'s markdown pretty printer is a function named `markdown`. ``` haskell ignore markdown :: API -> String @@ -107,97 +107,97 @@ markdown :: API -> String That lets us see what our API docs look down in markdown, by looking at `markdown apiDocs`. -``` text - ## Welcome +````````` text +## Welcome - This is our super webservice's API. +This is our super webservice's API. - Enjoy! +Enjoy! - ## GET /hello +## GET /hello - #### GET Parameters: +#### GET Parameters: - - name - - **Values**: *Alp, John Doe, ...* - - **Description**: Name of the person to say hello to. +- name + - **Values**: *Alp, John Doe, ...* + - **Description**: Name of the person to say hello to. - #### Response: +#### Response: - - Status code 200 - - Headers: [] +- Status code 200 +- Headers: [] - - Supported content types are: +- Supported content types are: - - `application/json` + - `application/json` - - When a value is provided for 'name' +- When a value is provided for 'name' - ```javascript - {"msg":"Hello, Alp"} - ``` + ```javascript + {"msg":"Hello, Alp"} + ``` - - When 'name' is not specified +- When 'name' is not specified - ```javascript - {"msg":"Hello, anonymous coward"} - ``` + ```javascript + {"msg":"Hello, anonymous coward"} + ``` - ## POST /marketing +## POST /marketing - #### Request: +#### Request: - - Supported content types are: +- Supported content types are: - - `application/json` + - `application/json` - - Example: `application/json` +- Example: `application/json` - ```javascript - {"email":"alp@foo.com","interested_in":["haskell","mathematics"],"age":26,"name":"Alp"} - ``` + ```javascript + {"email":"alp@foo.com","interested_in":["haskell","mathematics"],"age":26,"name":"Alp"} + ``` - #### Response: +#### Response: - - Status code 201 - - Headers: [] +- Status code 201 +- Headers: [] - - Supported content types are: +- Supported content types are: - - `application/json` + - `application/json` - - Response body as below. +- Response body as below. - ```javascript - {"subject":"Hey Alp, we miss you!","body":"Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!","to":"alp@foo.com","from":"great@company.com"} - ``` + ```javascript + {"subject":"Hey Alp, we miss you!","body":"Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!","to":"alp@foo.com","from":"great@company.com"} + ``` - ## GET /position/:x/:y +## GET /position/:x/:y - #### Captures: +#### Captures: - - *x*: (integer) position on the x axis - - *y*: (integer) position on the y axis +- *x*: (integer) position on the x axis +- *y*: (integer) position on the y axis - #### Response: +#### Response: - - Status code 200 - - Headers: [] +- Status code 200 +- Headers: [] - - Supported content types are: +- Supported content types are: - - `application/json` + - `application/json` - - Response body as below. +- Response body as below. - ```javascript - {"x":3,"y":14} - ``` + ```javascript + {"x":3,"y":14} + ``` -``` +````````` -However, we can also add one or more introduction sections to the document. We just need to tweak the way we generate `apiDocs`. We will also convert the content to a lazy `ByteString` since this is what *wai* expects for `Raw` endpoints. +However, we can also add one or more introduction sections to the document. We just need to tweak the way we generate `apiDocs`. We will also convert the content to a lazy `ByteString` since this is what **wai** expects for `Raw` endpoints. ``` haskell docsBS :: ByteString @@ -231,4 +231,4 @@ app :: Application app = serve api server ``` -And if you spin up this server with `dist/build/tutorial/tutorial 10` and go to anywhere else than `/position`, `/hello` and `/marketing`, you will see the API docs in markdown. This is because `serveDocs` is attempted if the 3 other endpoints don't match and systematically succeeds since its definition is to just return some fixed bytestring with the `text/plain` content type. +And if you spin up this server and request anything else than `/position`, `/hello` and `/marketing`, you will see the API docs in markdown. This is because `serveDocs` is attempted if the 3 other endpoints don't match and systematically succeeds since its definition is to just return some fixed bytestring with the `text/plain` content type. From 1b928878dd6248091196925b82e2f55a79f6cd03 Mon Sep 17 00:00:00 2001 From: rwobben Date: Tue, 1 Mar 2016 07:16:26 +0000 Subject: [PATCH 139/180] added aeson-compat to the cabal file --- doc/tutorial/tutorial.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index a39602c1..189140de 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -24,7 +24,8 @@ library build-depends: base == 4.* , base-compat , text - , aeson >= 0.11 + , aeson + , aeson-compat , blaze-html , directory , blaze-markup From 027cd827252061a39d40dd443c28bdbe28709b3d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Tue, 1 Mar 2016 19:47:14 +0800 Subject: [PATCH 140/180] tutorial: corrected curl examples --- doc/tutorial/Server.lhs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index 3d1267dc..1a3db276 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -297,12 +297,12 @@ And that's it. Here's the example in action: ``` bash $ curl http://localhost:8081/position/1/2 -{"x":1,"y":2} +{"xCoord":1,"yCoord":2} $ curl http://localhost:8081/hello {"msg":"Hello, anonymous coward"} $ curl http://localhost:8081/hello?name=Alp {"msg":"Hello, Alp"} -$ curl -X POST -d '{"name":"Alp Mestanogullari", "email" : "alp@foo.com", "age": 25, "interested_in": ["haskell", "mathematics"]}' -H 'Accept: application/json' -H 'Content-type: application/json' http://localhost:8081/marketing +$ curl -X POST -d '{"clientName":"Alp Mestanogullari", "clientEmail" : "alp@foo.com", "clientAge": 25, "clientInterestedIn": ["haskell", "mathematics"]}' -H 'Accept: application/json' -H 'Content-type: application/json' http://localhost:8081/marketing {"subject":"Hey Alp Mestanogullari, we miss you!","body":"Hi Alp Mestanogullari,\n\nSince you've recently turned 25, have you checked out our latest haskell, mathematics products? Give us a visit!","to":"alp@foo.com","from":"great@company.com"} ``` From 0985e510225b3697bf54c004a7e5333251217abe Mon Sep 17 00:00:00 2001 From: rwobben Date: Wed, 2 Mar 2016 13:03:18 +0000 Subject: [PATCH 141/180] deleted the Trans.Monad.Except --- doc/tutorial/Server.lhs | 1 - 1 file changed, 1 deletion(-) diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index 1a3db276..bd84b8a0 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -28,7 +28,6 @@ import Prelude.Compat import Control.Monad.Except import Control.Monad.Reader -import Control.Monad.Trans.Except import Data.Aeson.Compat import Data.Aeson.Types import Data.Attoparsec.ByteString From b97a352773d7be6ff14dc272511451ed4a408d0a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sat, 12 Mar 2016 16:03:57 +0800 Subject: [PATCH 142/180] tutorial: updated Javascript.lhs (and wrote some tests for it) --- doc/tutorial/.ghci | 2 +- doc/tutorial/Javascript.lhs | 106 ++++++++++++++++++++-------- doc/tutorial/static/index.html | 26 +++++++ doc/tutorial/static/ui.js | 60 ++++++++++++++++ doc/tutorial/test/JavascriptSpec.hs | 32 +++++++++ doc/tutorial/test/Spec.hs | 1 + doc/tutorial/tutorial.cabal | 19 ++--- 7 files changed, 206 insertions(+), 40 deletions(-) create mode 100644 doc/tutorial/static/index.html create mode 100644 doc/tutorial/static/ui.js create mode 100644 doc/tutorial/test/JavascriptSpec.hs create mode 100644 doc/tutorial/test/Spec.hs diff --git a/doc/tutorial/.ghci b/doc/tutorial/.ghci index 7d8e760c..d8e88521 100644 --- a/doc/tutorial/.ghci +++ b/doc/tutorial/.ghci @@ -1 +1 @@ -:set -pgmL markdown-unlit -Wall -Werror -fno-warn-missing-methods -fno-warn-name-shadowing +:set -pgmL markdown-unlit -Wall -Werror -fno-warn-missing-methods -fno-warn-name-shadowing -itest diff --git a/doc/tutorial/Javascript.lhs b/doc/tutorial/Javascript.lhs index 600c8327..4054e4b3 100644 --- a/doc/tutorial/Javascript.lhs +++ b/doc/tutorial/Javascript.lhs @@ -1,9 +1,7 @@ # Generating Javascript functions to query an API -We will now see how *servant* lets you turn an API type into javascript -functions that you can call to query a webservice. The derived code assumes you -use *jQuery* but you could very easily adapt the code to generate ajax requests -based on vanilla javascript or another library than *jQuery*. +We will now see how **servant** lets you turn an API type into javascript +functions that you can call to query a webservice. For this, we will consider a simple page divided in two parts. At the top, we will have a search box that lets us search in a list of Haskell books by @@ -32,10 +30,11 @@ import Data.Aeson import Data.Proxy import Data.Text as T (Text) import Data.Text.IO as T (writeFile, readFile) -import qualified Data.Text as T import GHC.Generics import Language.Javascript.JQuery import Network.Wai +import Network.Wai.Handler.Warp +import qualified Data.Text as T import Servant import Servant.JS import System.Random @@ -78,7 +77,8 @@ book :: Text -> Text -> Int -> Book book = Book ``` -We need a "book database". For the purpose of this guide, let's restrict ourselves to the following books. +We need a "book database". For the purpose of this guide, let's restrict +ourselves to the following books. ``` haskell books :: [Book] @@ -92,7 +92,10 @@ books = ] ``` -Now, given an optional search string `q`, we want to perform a case insensitive search in that list of books. We're obviously not going to try and implement the best possible algorithm, this is out of scope for this tutorial. The following simple linear scan will do, given how small our list is. +Now, given an optional search string `q`, we want to perform a case insensitive +search in that list of books. We're obviously not going to try and implement +the best possible algorithm, this is out of scope for this tutorial. The +following simple linear scan will do, given how small our list is. ``` haskell searchBook :: Monad m => Maybe Text -> m (Search Book) @@ -106,7 +109,9 @@ searchBook (Just q) = return (mkSearch q books') q' = T.toLower q ``` -We also need an endpoint that generates random points `(x, y)` with `-1 <= x,y <= 1`. The code below uses [random](http://hackage.haskell.org/package/random)'s `System.Random`. +We also need an endpoint that generates random points `(x, y)` with `-1 <= x,y +<= 1`. The code below uses +[random](http://hackage.haskell.org/package/random)'s `System.Random`. ``` haskell randomPoint :: MonadIO m => m Point @@ -131,54 +136,93 @@ server = randomPoint server' :: Server API' server' = server - :<|> serveDirectory "tutorial/t9" + :<|> serveDirectory "static" app :: Application app = serve api' server' + +main :: IO () +main = run 8000 app ``` -Why two different API types, proxies and servers though? Simply because we don't want to generate javascript functions for the `Raw` part of our API type, so we need a `Proxy` for our API type `API'` without its `Raw` endpoint. +Why two different API types, proxies and servers though? Simply because we +don't want to generate javascript functions for the `Raw` part of our API type, +so we need a `Proxy` for our API type `API'` without its `Raw` endpoint. -Very similarly to how one can derive haskell functions, we can derive the javascript with just a simple function call to `jsForAPI` from `Servant.JQuery`. +Very similarly to how one can derive haskell functions, we can derive the +javascript with just a simple function call to `jsForAPI` from +`Servant.JQuery`. ``` haskell apiJS :: Text apiJS = jsForAPI api vanillaJS ``` -This `String` contains 2 Javascript functions: +This `Text` contains 2 Javascript functions, 'getPoint' and 'getBooks': ``` javascript - -function getpoint(onSuccess, onError) +var getPoint = function(onSuccess, onError) { - $.ajax( - { url: '/point' - , success: onSuccess - , error: onError - , method: 'GET' - }); + var xhr = new XMLHttpRequest(); + xhr.open('GET', '/point', true); + xhr.setRequestHeader("Accept","application/json"); + xhr.onreadystatechange = function (e) { + if (xhr.readyState == 4) { + if (xhr.status == 204 || xhr.status == 205) { + onSuccess(); + } else if (xhr.status >= 200 && xhr.status < 300) { + var value = JSON.parse(xhr.responseText); + onSuccess(value); + } else { + var value = JSON.parse(xhr.responseText); + onError(value); + } + } + } + xhr.send(null); } -function getbooks(q, onSuccess, onError) +var getBooks = function(q, onSuccess, onError) { - $.ajax( - { url: '/books' + '?q=' + encodeURIComponent(q) - , success: onSuccess - , error: onError - , method: 'GET' - }); + var xhr = new XMLHttpRequest(); + xhr.open('GET', '/books' + '?q=' + encodeURIComponent(q), true); + xhr.setRequestHeader("Accept","application/json"); + xhr.onreadystatechange = function (e) { + if (xhr.readyState == 4) { + if (xhr.status == 204 || xhr.status == 205) { + onSuccess(); + } else if (xhr.status >= 200 && xhr.status < 300) { + var value = JSON.parse(xhr.responseText); + onSuccess(value); + } else { + var value = JSON.parse(xhr.responseText); + onError(value); + } + } + } + xhr.send(null); } ``` -Right before starting up our server, we will need to write this `String` to a file, say `api.js`, along with a copy of the *jQuery* library, as provided by the [js-jquery](http://hackage.haskell.org/package/js-jquery) package. +We created a directory `static` that contains two static files: `index.html`, +which is the entrypoint to our little web application; and `ui.js`, which +contains some hand-written javascript. This javascript code assumes the two +generated functions `getPoint` and `getBooks` in scope. Therefore we need to +write the generated javascript into a file: ``` haskell writeJSFiles :: IO () writeJSFiles = do - T.writeFile "getting-started/gs9/api.js" apiJS + T.writeFile "static/api.js" apiJS jq <- T.readFile =<< Language.Javascript.JQuery.file - T.writeFile "getting-started/gs9/jq.js" jq + T.writeFile "static/jq.js" jq ``` -And we're good to go. Start the server with `dist/build/tutorial/tutorial 9` and go to `http://localhost:8081/`. Start typing in the name of one of the authors in our database or part of a book title, and check out how long it takes to approximate π using the method mentioned above. +(We're also writing the jquery library into a file, as it's also used by +`ui.js`.) `static/api.js` will be included in `index.html` and the two +generated functions will therefore be available in `ui.js`. + +And we're good to go. You can start the `main` function of this file and go to +`http://localhost:8000/`. Start typing in the name of one of the authors in our +database or part of a book title, and check out how long it takes to +approximate pi using the method mentioned above. diff --git a/doc/tutorial/static/index.html b/doc/tutorial/static/index.html new file mode 100644 index 00000000..6a047c1c --- /dev/null +++ b/doc/tutorial/static/index.html @@ -0,0 +1,26 @@ + + + + + + Tutorial - 9 - servant-jquery + + +

      Books

      + +
      +

      Results for ""

      +
        +
      +
      +
      +

      Approximating π

      +

      Count: 0

      +

      Successes: 0

      +

      + + + + + + diff --git a/doc/tutorial/static/ui.js b/doc/tutorial/static/ui.js new file mode 100644 index 00000000..8bcae8d8 --- /dev/null +++ b/doc/tutorial/static/ui.js @@ -0,0 +1,60 @@ +/* book search */ +function updateResults(data) +{ + console.log(data); + $('#results').html(""); + $('#query').text("\"" + data.query + "\""); + for(var i = 0; i < data.results.length; i++) + { + $('#results').append(renderBook(data.results[i])); + } +} + +function renderBook(book) +{ + var li = '
    • ' + book.title + ', ' + + book.author + ' - ' + book.year + '
      • '; + return li; +} + +function searchBooks() +{ + var q = $('#q').val(); + getBooks(q, updateResults, console.log) +} + +searchBooks(); +$('#q').keyup(function() { + searchBooks(); +}); + +/* approximating pi */ +var count = 0; +var successes = 0; + +function f(data) +{ + var x = data.x, y = data.y; + if(x*x + y*y <= 1) + { + successes++; + } + + count++; + + update('#count', count); + update('#successes', successes); + update('#pi', 4*successes/count); +} + +function update(id, val) +{ + $(id).text(val); +} + +function refresh() +{ + getPoint(f, console.log); +} + +window.setInterval(refresh, 200); diff --git a/doc/tutorial/test/JavascriptSpec.hs b/doc/tutorial/test/JavascriptSpec.hs new file mode 100644 index 00000000..2d6007a5 --- /dev/null +++ b/doc/tutorial/test/JavascriptSpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module JavascriptSpec where + +import Data.List +import Data.String +import Data.String.Conversions +import Test.Hspec +import Test.Hspec.Wai + +import Javascript + +spec :: Spec +spec = do + describe "apiJS" $ do + it "is contained verbatim in Javascript.lhs" $ do + code <- readFile "Javascript.lhs" + cs apiJS `shouldSatisfy` (`isInfixOf` code) + + describe "writeJSFiles" $ do + it "[not a test] write apiJS to static/api.js" $ do + writeJSFiles + + describe "app" $ with (return app) $ do + context "/api.js" $ do + it "delivers apiJS" $ do + get "/api.js" `shouldRespondWith` (fromString (cs apiJS)) + + context "/" $ do + it "delivers something" $ do + get "" `shouldRespondWith` 200 + get "/" `shouldRespondWith` 200 diff --git a/doc/tutorial/test/Spec.hs b/doc/tutorial/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/doc/tutorial/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 189140de..9664ce45 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -1,16 +1,12 @@ name: tutorial version: 0.5 synopsis: The servant tutorial --- description: homepage: http://haskell-servant.github.io/ license: BSD3 license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com --- copyright: --- category: build-type: Simple --- extra-source-files: cabal-version: >=1.10 library @@ -19,13 +15,11 @@ library , Docs , Javascript , Server - -- other-modules: - -- other-extensions: build-depends: base == 4.* , base-compat , text , aeson - , aeson-compat + , aeson-compat , blaze-html , directory , blaze-markup @@ -49,9 +43,18 @@ library , transformers , markdown-unlit >= 0.4 , http-client - -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall -Werror -pgmL markdown-unlit -- to silence aeson-0.10 warnings: ghc-options: -fno-warn-missing-methods ghc-options: -fno-warn-name-shadowing + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: + -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base == 4.* From 4e90308b854fb66df1f199ad4357b30f783ccee2 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 18 Mar 2016 15:09:38 +0100 Subject: [PATCH 143/180] Fix compilation --- doc/tutorial/tutorial.cabal | 7 +++++-- stack.yaml | 2 +- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 9664ce45..7608a60c 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -56,5 +56,8 @@ test-suite spec default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs - build-depends: - base == 4.* + build-depends: base == 4.* + , tutorial + , hspec + , hspec-wai + , string-conversions diff --git a/stack.yaml b/stack.yaml index 40ddab48..947970a5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -21,4 +21,4 @@ extra-deps: - markdown-unlit-0.4.0 - aeson-0.11.0.0 - fail-4.9.0.0 -resolver: nightly-2015-10-08 +resolver: nightly-2016-03-17 From 79029089db3031b6232f3e349e73045522dfc517 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 18 Mar 2016 15:10:56 +0100 Subject: [PATCH 144/180] Remove servant-examples (again) --- .../auth-combinator/auth-combinator.hs | 124 --------------- servant-examples/basic-auth/basic-auth.hs | 105 ------------- servant-examples/servant-examples.cabal | 148 ------------------ .../socket-io-chat/socket-io-chat.hs | 54 ------- servant-examples/tutorial/T1.hs | 45 ------ servant-examples/tutorial/T10.hs | 71 --------- servant-examples/tutorial/T2.hs | 52 ------ servant-examples/tutorial/T3.hs | 84 ---------- servant-examples/tutorial/T4.hs | 63 -------- servant-examples/tutorial/T5.hs | 37 ----- servant-examples/tutorial/T6.hs | 18 --- servant-examples/tutorial/T7.hs | 33 ---- servant-examples/tutorial/T9.hs | 105 ------------- .../wai-middleware/wai-middleware.hs | 51 ------ 14 files changed, 990 deletions(-) delete mode 100644 servant-examples/auth-combinator/auth-combinator.hs delete mode 100644 servant-examples/basic-auth/basic-auth.hs delete mode 100644 servant-examples/servant-examples.cabal delete mode 100644 servant-examples/socket-io-chat/socket-io-chat.hs delete mode 100644 servant-examples/tutorial/T1.hs delete mode 100644 servant-examples/tutorial/T10.hs delete mode 100644 servant-examples/tutorial/T2.hs delete mode 100644 servant-examples/tutorial/T3.hs delete mode 100644 servant-examples/tutorial/T4.hs delete mode 100644 servant-examples/tutorial/T5.hs delete mode 100644 servant-examples/tutorial/T6.hs delete mode 100644 servant-examples/tutorial/T7.hs delete mode 100644 servant-examples/tutorial/T9.hs delete mode 100644 servant-examples/wai-middleware/wai-middleware.hs diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs deleted file mode 100644 index 709efa0c..00000000 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -import Control.Monad.Trans.Except (ExceptT, throwE) -import Data.Aeson hiding ((.:)) -import Data.ByteString (ByteString) -import Data.Monoid ((<>)) -import Data.Map (Map, fromList) -import qualified Data.Map as Map -import Data.Text (Text) -import GHC.Generics -import Network.Wai -import Network.Wai.Handler.Warp -import Servant -import Servant.Server.Experimental.Auth - --- | This file contains an authenticated server using servant's generalized --- authentication support. Our basic authentication scheme is trivial: we --- look for a cookie named "servant-auth-cookie" and its value will contain --- a key, which we use to lookup a User. Obviously this is an absurd example, --- but we pick something simple and non-standard to show you how to extend --- servant's support for authentication. - --- | A user type that we "fetch from the database" after --- performing authentication -newtype User = User { unUser :: Text } - --- | A (pure) database mapping keys to users. -database :: Map ByteString User -database = fromList [ ("key1", User "Anne Briggs") - , ("key2", User "Bruce Cockburn") - , ("key3", User "Ghédalia Tazartès") - ] - --- | A method that, when given a password, will return a User. --- This is our bespoke (and bad) authentication logic. -lookupUser :: ByteString -> ExceptT ServantErr IO User -lookupUser key = case Map.lookup key database of - Nothing -> throwE (err403 { errBody = "Invalid Cookie" }) - Just usr -> return usr - --- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User --- we look for a Cookie and pass the value of the cookie to `lookupUser`. -authHandler :: AuthHandler Request User -authHandler = - let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of - Nothing -> throwE (err401 { errBody = "Missing auth header" }) - Just authCookieKey -> lookupUser authCookieKey - in mkAuthHandler handler - --- | Data types that will be returned from various api endpoints -newtype PrivateData = PrivateData { ssshhh :: Text } - deriving (Eq, Show, Generic) - -instance ToJSON PrivateData - -newtype PublicData = PublicData { somedata :: Text } - deriving (Eq, Show, Generic) - -instance ToJSON PublicData - --- | Our private API that we want to be auth-protected. -type PrivateAPI = Get '[JSON] [PrivateData] - --- | Our public API that doesn't have any protection -type PublicAPI = Get '[JSON] [PublicData] - --- | Our API, with auth-protection -type API = "private" :> AuthProtect "cookie-auth" :> PrivateAPI - :<|> "public" :> PublicAPI - --- | A value holding our type-level API -api :: Proxy API -api = Proxy - --- | We need to specify the data returned after authentication -type instance AuthServerData (AuthProtect "cookie-auth") = User - --- | The context that will be made available to request handlers. We supply the --- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance --- of 'AuthProtect' can extract the handler and run it on the request. -serverContext :: Context (AuthHandler Request User ': '[]) -serverContext = authHandler :. EmptyContext - --- | Our API, where we provide all the author-supplied handlers for each end --- point. Note that 'privateDataFunc' is a function that takes 'User' as an --- argument. We dont' worry about the authentication instrumentation here, --- that is taken care of by supplying context -server :: Server API -server = privateDataFunc :<|> return publicData - - where privateDataFunc (User name) = - return [PrivateData ("this is a secret: " <> name)] - publicData = [PublicData "this is a public piece of data"] - --- | run our server -main :: IO () -main = run 8080 (serveWithContext api serverContext server) - -{- Sample Session: - -$ curl -XGET localhost:8080/private -Missing auth header ->>>>>>> modify auth-combinator example for gen auth ->>>>>>> 8246c1f... modify auth-combinator example for gen auth - -$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3" -[{"ssshhh":"this is a secret: Ghédalia Tazartès"}] - -$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key" -Invalid Cookie - -$ curl -XGET localhost:8080/public -[{"somedata":"this is a public piece of data"}] --} - diff --git a/servant-examples/basic-auth/basic-auth.hs b/servant-examples/basic-auth/basic-auth.hs deleted file mode 100644 index cedd4694..00000000 --- a/servant-examples/basic-auth/basic-auth.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Main where - -import Data.Aeson (ToJSON) -import Data.Proxy (Proxy (Proxy)) -import Data.Text (Text) -import GHC.Generics (Generic) -import Network.Wai.Handler.Warp (run) -import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth, - Get, JSON) -import Servant.API.BasicAuth (BasicAuthData (BasicAuthData)) -import Servant.Server (BasicAuthCheck (BasicAuthCheck), - BasicAuthResult( Authorized - , Unauthorized - ), - Context ((:.), EmptyContext), Server, - serveWithContext) - --- | let's define some types that our API returns. - --- | private data that needs protection -newtype PrivateData = PrivateData { ssshhh :: Text } - deriving (Eq, Show, Generic) - -instance ToJSON PrivateData - --- | public data that anyone can use. -newtype PublicData = PublicData { somedata :: Text } - deriving (Eq, Show, Generic) - -instance ToJSON PublicData - --- | A user we'll grab from the database when we authenticate someone -newtype User = User { userName :: Text } - deriving (Eq, Show) - --- | a type to wrap our public api -type PublicAPI = Get '[JSON] [PublicData] - --- | a type to wrap our private api -type PrivateAPI = Get '[JSON] PrivateData - --- | our API -type API = "public" :> PublicAPI - :<|> "private" :> BasicAuth "foo-realm" User :> PrivateAPI - --- | a value holding a proxy of our API type -api :: Proxy API -api = Proxy - --- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password. -authCheck :: BasicAuthCheck User -authCheck = - let check (BasicAuthData username password) = - if username == "servant" && password == "server" - then return (Authorized (User "servant")) - else return Unauthorized - in BasicAuthCheck check - --- | We need to supply our handlers with the right Context. In this case, --- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value --- tagged with "foo-tag" This context is then supplied to 'server' and threaded --- to the BasicAuth HasServer handlers. -serverContext :: Context (BasicAuthCheck User ': '[]) -serverContext = authCheck :. EmptyContext - --- | an implementation of our server. Here is where we pass all the handlers to our endpoints. --- In particular, for the BasicAuth protected handler, we need to supply a function --- that takes 'User' as an argument. -server :: Server API -server = - let publicAPIHandler = return [PublicData "foo", PublicData "bar"] - privateAPIHandler (user :: User) = return (PrivateData (userName user)) - in publicAPIHandler :<|> privateAPIHandler - --- | hello, server! -main :: IO () -main = run 8080 (serveWithContext api serverContext server) - -{- Sample session - -$ curl -XGET localhost:8080/public -[{"somedata":"foo"},{"somedata":"bar"} - -$ curl -iXGET localhost:8080/private -HTTP/1.1 401 Unauthorized -transfer-encoding: chunked -Date: Thu, 07 Jan 2016 22:36:38 GMT -Server: Warp/3.1.8 -WWW-Authenticate: Basic realm="foo-realm" - -$ curl -iXGET localhost:8080/private -H "Authorization: Basic c2VydmFudDpzZXJ2ZXI=" -HTTP/1.1 200 OK -transfer-encoding: chunked -Date: Thu, 07 Jan 2016 22:37:58 GMT -Server: Warp/3.1.8 -Content-Type: application/json - -{"ssshhh":"servant"} --} diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal deleted file mode 100644 index 1f00349e..00000000 --- a/servant-examples/servant-examples.cabal +++ /dev/null @@ -1,148 +0,0 @@ -name: servant-examples -version: 0.5 -synopsis: Example programs for servant -description: Example programs for servant, - showcasing solutions to common needs. -homepage: http://haskell-servant.github.io/ -license: BSD3 -license-file: LICENSE -author: Servant Contributors -maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2015-2016 Servant Contributors -category: Web -build-type: Simple -cabal-version: >=1.10 -bug-reports: http://github.com/haskell-servant/servant/issues -source-repository head - type: git - location: http://github.com/haskell-servant/servant.git - -executable tutorial - main-is: tutorial.hs - other-modules: T1, T2, T3, T4, T5, T6, T7, T8, T9, T10 - ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-unused-imports - build-depends: - aeson >= 0.8 - , base >= 4.7 && < 5 - , bytestring - , directory - , http-types - , js-jquery - , lucid - , random - , servant == 0.5.* - , servant-docs == 0.5.* - , servant-js == 0.5.* - , servant-lucid == 0.5.* - , servant-server == 0.5.* - , text - , time - , transformers - , transformers-compat - , wai - , warp - hs-source-dirs: tutorial - default-language: Haskell2010 - -executable t8-main - main-is: t8-main.hs - other-modules: T3, T8 - hs-source-dirs: tutorial - default-language: Haskell2010 - ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing - build-depends: - aeson - , base >= 4.7 && < 5 - , http-client > 0.4 && < 0.5 - , servant == 0.5.* - , servant-client == 0.5.* - , servant-server == 0.5.* - , transformers - , transformers-compat - , wai - -executable hackage - main-is: hackage.hs - build-depends: - aeson >= 0.8 - , base >=4.7 && < 5 - , http-client > 0.4 && < 0.5 - , servant == 0.5.* - , servant-client == 0.5.* - , text - , transformers - , transformers-compat - hs-source-dirs: hackage - default-language: Haskell2010 - -executable wai-middleware - main-is: wai-middleware.hs - build-depends: - aeson >= 0.8 - , base >= 4.7 && < 5 - , servant == 0.5.* - , servant-server == 0.5.* - , text - , wai - , wai-extra - , warp - hs-source-dirs: wai-middleware - default-language: Haskell2010 - -executable basic-auth - main-is: basic-auth.hs - ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing - build-depends: - aeson >= 0.8 - , base >= 4.7 && < 5 - , bytestring - , http-types - , servant == 0.5.* - , servant-server == 0.5.* - , text - , wai - , warp - hs-source-dirs: basic-auth - default-language: Haskell2010 - -executable auth-combinator - main-is: auth-combinator.hs - ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing - build-depends: - aeson >= 0.8 - , base >= 4.7 && < 5 - , bytestring - , containers - , http-types - , servant == 0.5.* - , servant-server == 0.5.* - , text - , transformers - , wai - , warp - hs-source-dirs: auth-combinator - default-language: Haskell2010 - -executable socket-io-chat - main-is: socket-io-chat.hs - ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing - other-modules: Chat - build-depends: - aeson >= 0.8 - , base >= 4.7 && < 5 - , bytestring - , http-types - , servant == 0.5.* - , servant-server == 0.5.* - , socket-io - , engine-io - , engine-io-wai - , text - , wai - , warp - , transformers - , stm - , mtl - ghc-options: -Wall -O2 -threaded - hs-source-dirs: socket-io-chat - default-language: Haskell2010 diff --git a/servant-examples/socket-io-chat/socket-io-chat.hs b/servant-examples/socket-io-chat/socket-io-chat.hs deleted file mode 100644 index 1250d8fe..00000000 --- a/servant-examples/socket-io-chat/socket-io-chat.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} - - -import Data.Monoid ((<>)) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import Network.EngineIO.Wai -import Network.Wai -import Network.Wai.Handler.Warp (run) -import Servant - - -import qualified Control.Concurrent.STM as STM -import qualified Network.SocketIO as SocketIO - - -import Chat (ServerState (..), eioServer) - - -type API = "socket.io" :> Raw - :<|> Raw - - -api :: Proxy API -api = Proxy - - -server :: WaiMonad () -> Server API -server sHandler = socketIOHandler - :<|> serveDirectory "socket-io-chat/resources" - - where - socketIOHandler req respond = toWaiApplication sHandler req respond - - -app :: WaiMonad () -> Application -app sHandler = serve api $ server sHandler - -port :: Int -port = 3001 - - -main :: IO () -main = do - state <- ServerState <$> STM.newTVarIO 0 - sHandler <- SocketIO.initialize waiAPI (eioServer state) - putStrLn $ "Running on " <> show port - run port $ app sHandler - - diff --git a/servant-examples/tutorial/T1.hs b/servant-examples/tutorial/T1.hs deleted file mode 100644 index 97bbecb8..00000000 --- a/servant-examples/tutorial/T1.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T1 where - -import Data.Aeson -import Data.Time.Calendar -import GHC.Generics -import Network.Wai -import Servant - -data User = User - { name :: String - , age :: Int - , email :: String - , registration_date :: Day - } deriving (Eq, Show, Generic) - -#if !MIN_VERSION_aeson(0,10,0) --- orphan ToJSON instance for Day. necessary to derive one for User -instance ToJSON Day where - -- display a day in YYYY-mm-dd format - toJSON d = toJSON (showGregorian d) -#endif - -instance ToJSON User - -type UserAPI = "users" :> Get '[JSON] [User] - -users :: [User] -users = - [ User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1) - , User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1) - ] - -userAPI :: Proxy UserAPI -userAPI = Proxy - -server :: Server UserAPI -server = return users - -app :: Application -app = serve userAPI server diff --git a/servant-examples/tutorial/T10.hs b/servant-examples/tutorial/T10.hs deleted file mode 100644 index be5da4cf..00000000 --- a/servant-examples/tutorial/T10.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T10 where - -import Data.ByteString.Lazy (ByteString) -import Data.Text.Lazy (pack) -import Data.Text.Lazy.Encoding (encodeUtf8) -import Network.HTTP.Types -import Network.Wai -import Servant -import Servant.Docs -import qualified T3 - -type DocsAPI = T3.API :<|> Raw - -instance ToCapture (Capture "x" Int) where - toCapture _ = DocCapture "x" "(integer) position on the x axis" - -instance ToCapture (Capture "y" Int) where - toCapture _ = DocCapture "y" "(integer) position on the y axis" - -instance ToSample T3.Position where - toSamples _ = singleSample (T3.Position 3 14) - -instance ToParam (QueryParam "name" String) where - toParam _ = - DocQueryParam "name" - ["Alp", "John Doe", "..."] - "Name of the person to say hello to." - Normal - -instance ToSample T3.HelloMessage where - toSamples _ = - [ ("When a value is provided for 'name'", T3.HelloMessage "Hello, Alp") - , ("When 'name' is not specified", T3.HelloMessage "Hello, anonymous coward") - ] - -ci :: T3.ClientInfo -ci = T3.ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"] - -instance ToSample T3.ClientInfo where - toSamples _ = singleSample ci - -instance ToSample T3.Email where - toSamples _ = singleSample (T3.emailForClient ci) - -api :: Proxy DocsAPI -api = Proxy - -docsBS :: ByteString -docsBS = encodeUtf8 - . pack - . markdown - $ docsWithIntros [intro] T3.api - - where intro = DocIntro "Welcome" ["This is our super webservice's API.", "Enjoy!"] - -server :: Server DocsAPI -server = T3.server :<|> serveDocs - - where serveDocs _ respond = - respond $ responseLBS ok200 [plain] docsBS - - plain = ("Content-Type", "text/plain") - -app :: Application -app = serve api server diff --git a/servant-examples/tutorial/T2.hs b/servant-examples/tutorial/T2.hs deleted file mode 100644 index fc49d256..00000000 --- a/servant-examples/tutorial/T2.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T2 where - -import Data.Aeson -import Data.Time.Calendar -import GHC.Generics -import Network.Wai -import Servant - -data User = User - { name :: String - , age :: Int - , email :: String - , registration_date :: Day - } deriving (Eq, Show, Generic) - -#if !MIN_VERSION_aeson(0,10,0) --- orphan ToJSON instance for Day. necessary to derive one for User -instance ToJSON Day where - -- display a day in YYYY-mm-dd format - toJSON d = toJSON (showGregorian d) -#endif - -instance ToJSON User - -type UserAPI = "users" :> Get '[JSON] [User] - :<|> "albert" :> Get '[JSON] User - :<|> "isaac" :> Get '[JSON] User - -isaac :: User -isaac = User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1) - -albert :: User -albert = User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1) - -users :: [User] -users = [isaac, albert] - -userAPI :: Proxy UserAPI -userAPI = Proxy - -server :: Server UserAPI -server = return users - :<|> return albert - :<|> return isaac - -app :: Application -app = serve userAPI server diff --git a/servant-examples/tutorial/T3.hs b/servant-examples/tutorial/T3.hs deleted file mode 100644 index 7b5bdeb3..00000000 --- a/servant-examples/tutorial/T3.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T3 where - -import Control.Monad.Trans.Except -import Data.Aeson -import Data.List -import GHC.Generics -import Network.Wai -import Servant - -data Position = Position - { x :: Int - , y :: Int - } deriving (Show, Generic) - -instance FromJSON Position -instance ToJSON Position - -newtype HelloMessage = HelloMessage { msg :: String } - deriving (Show, Generic) - -instance FromJSON HelloMessage -instance ToJSON HelloMessage - -data ClientInfo = ClientInfo - { name :: String - , email :: String - , age :: Int - , interested_in :: [String] - } deriving (Show, Generic) - -instance FromJSON ClientInfo -instance ToJSON ClientInfo - -data Email = Email - { from :: String - , to :: String - , subject :: String - , body :: String - } deriving (Show, Generic) - -instance FromJSON Email -instance ToJSON Email - -emailForClient :: ClientInfo -> Email -emailForClient c = Email from' to' subject' body' - - where from' = "great@company.com" - to' = email c - subject' = "Hey " ++ name c ++ ", we miss you!" - body' = "Hi " ++ name c ++ ",\n\n" - ++ "Since you've recently turned " ++ show (age c) - ++ ", have you checked out our latest " - ++ intercalate ", " (interested_in c) - ++ " products? Give us a visit!" - -type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position - :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage - :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email - -api :: Proxy API -api = Proxy - -server :: Server API -server = position - :<|> hello - :<|> marketing - - where position :: Int -> Int -> ExceptT ServantErr IO Position - position x y = return (Position x y) - - hello :: Maybe String -> ExceptT ServantErr IO HelloMessage - hello mname = return . HelloMessage $ case mname of - Nothing -> "Hello, anonymous coward" - Just n -> "Hello, " ++ n - - marketing :: ClientInfo -> ExceptT ServantErr IO Email - marketing clientinfo = return (emailForClient clientinfo) - -app :: Application -app = serve api server diff --git a/servant-examples/tutorial/T4.hs b/servant-examples/tutorial/T4.hs deleted file mode 100644 index 69cbf951..00000000 --- a/servant-examples/tutorial/T4.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T4 where - -import Data.Aeson -import Data.Foldable (foldMap) -import GHC.Generics -import Lucid -import Network.Wai -import Servant -import Servant.HTML.Lucid - -data Person = Person - { firstName :: String - , lastName :: String - , age :: Int - } deriving Generic -- for the JSON instance - --- JSON serialization -instance ToJSON Person - --- HTML serialization of a single person -instance ToHtml Person where - toHtml person = - tr_ $ do - td_ (toHtml $ firstName person) - td_ (toHtml $ lastName person) - td_ (toHtml . show $ age person) - - toHtmlRaw = toHtml - --- HTML serialization of a list of persons -instance ToHtml [Person] where - toHtml persons = table_ $ do - tr_ $ do - th_ "first name" - th_ "last name" - th_ "age" - - foldMap toHtml persons - - toHtmlRaw = toHtml - -persons :: [Person] -persons = - [ Person "Isaac" "Newton" 372 - , Person "Albert" "Einstein" 136 - ] - -type PersonAPI = "persons" :> Get '[JSON, HTML] [Person] - -personAPI :: Proxy PersonAPI -personAPI = Proxy - -server :: Server PersonAPI -server = return persons - -app :: Application -app = serve personAPI server diff --git a/servant-examples/tutorial/T5.hs b/servant-examples/tutorial/T5.hs deleted file mode 100644 index 3b18aedb..00000000 --- a/servant-examples/tutorial/T5.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T5 where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Except -import Data.Aeson -import GHC.Generics -import Network.Wai -import Servant -import System.Directory - -type IOAPI = "myfile.txt" :> Get '[JSON] FileContent - -ioAPI :: Proxy IOAPI -ioAPI = Proxy - -newtype FileContent = FileContent - { content :: String } - deriving Generic - -instance ToJSON FileContent - -server :: Server IOAPI -server = do - exists <- liftIO (doesFileExist "myfile.txt") - if exists - then liftIO (readFile "myfile.txt") >>= return . FileContent - else throwE custom404Err - - where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." } - -app :: Application -app = serve ioAPI server diff --git a/servant-examples/tutorial/T6.hs b/servant-examples/tutorial/T6.hs deleted file mode 100644 index 781bf703..00000000 --- a/servant-examples/tutorial/T6.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T6 where - -import Network.Wai -import Servant - -type API = "code" :> Raw - -api :: Proxy API -api = Proxy - -server :: Server API -server = serveDirectory "tutorial" - -app :: Application -app = serve api server diff --git a/servant-examples/tutorial/T7.hs b/servant-examples/tutorial/T7.hs deleted file mode 100644 index e0145caf..00000000 --- a/servant-examples/tutorial/T7.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T7 where - -import Control.Monad.Trans.Except -import Control.Monad.Trans.Reader -import Network.Wai -import Servant - -type ReaderAPI = "a" :> Get '[JSON] Int - :<|> "b" :> Get '[JSON] String - -readerAPI :: Proxy ReaderAPI -readerAPI = Proxy - -readerServerT :: ServerT ReaderAPI (Reader String) -readerServerT = a :<|> b - - where a :: Reader String Int - a = return 1797 - - b :: Reader String String - b = ask - -readerServer :: Server ReaderAPI -readerServer = enter readerToEither readerServerT - - where readerToEither :: Reader String :~> ExceptT ServantErr IO - readerToEither = Nat $ \r -> return (runReader r "hi") - -app :: Application -app = serve readerAPI readerServer diff --git a/servant-examples/tutorial/T9.hs b/servant-examples/tutorial/T9.hs deleted file mode 100644 index 75dd0630..00000000 --- a/servant-examples/tutorial/T9.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T9 where - -import Control.Applicative -import Control.Monad.IO.Class -import Data.Aeson -import Data.Text (Text) -import GHC.Generics -import Network.Wai -import Servant -import Servant.JS -import System.Random - -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import qualified Language.Javascript.JQuery as JQ - -data Point = Point - { x :: Double - , y :: Double - } deriving Generic - -instance ToJSON Point - -randomPoint :: MonadIO m => m Point -randomPoint = liftIO . getStdRandom $ \g -> - let (rx, g') = randomR (-1, 1) g - (ry, g'') = randomR (-1, 1) g' - in (Point rx ry, g'') - -data Search a = Search - { query :: Text - , results :: [a] - } deriving Generic - -mkSearch :: Text -> [a] -> Search a -mkSearch = Search - -instance ToJSON a => ToJSON (Search a) - -data Book = Book - { author :: Text - , title :: Text - , year :: Int - } deriving Generic - -instance ToJSON Book - -book :: Text -> Text -> Int -> Book -book = Book - -books :: [Book] -books = - [ book "Paul Hudak" "The Haskell School of Expression: Learning Functional Programming through Multimedia" 2000 - , book "Bryan O'Sullivan, Don Stewart, and John Goerzen" "Real World Haskell" 2008 - , book "Miran Lipovača" "Learn You a Haskell for Great Good!" 2011 - , book "Graham Hutton" "Programming in Haskell" 2007 - , book "Simon Marlow" "Parallel and Concurrent Programming in Haskell" 2013 - , book "Richard Bird" "Introduction to Functional Programming using Haskell" 1998 - ] - -searchBook :: Monad m => Maybe Text -> m (Search Book) -searchBook Nothing = return (mkSearch "" books) -searchBook (Just q) = return (mkSearch q books') - - where books' = filter (\b -> q' `T.isInfixOf` T.toLower (author b) - || q' `T.isInfixOf` T.toLower (title b) - ) - books - q' = T.toLower q - -type API = "point" :> Get '[JSON] Point - :<|> "books" :> QueryParam "q" Text :> Get '[JSON] (Search Book) - -type API' = API :<|> Raw - -api :: Proxy API -api = Proxy - -api' :: Proxy API' -api' = Proxy - -server :: Server API -server = randomPoint - :<|> searchBook - -server' :: Server API' -server' = server - :<|> serveDirectory "tutorial/t9" - -apiJS :: Text -apiJS = jsForAPI api jquery - -writeJSFiles :: IO () -writeJSFiles = do - TIO.writeFile "tutorial/t9/api.js" apiJS - jq <- TIO.readFile =<< JQ.file - TIO.writeFile "tutorial/t9/jq.js" jq - -app :: Application -app = serve api' server' diff --git a/servant-examples/wai-middleware/wai-middleware.hs b/servant-examples/wai-middleware/wai-middleware.hs deleted file mode 100644 index a2e95860..00000000 --- a/servant-examples/wai-middleware/wai-middleware.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -import Data.Aeson -import Data.Text -import GHC.Generics -import Network.Wai -import Network.Wai.Handler.Warp -import Network.Wai.Middleware.RequestLogger -import Servant - -data Product = Product - { name :: Text - , brand :: Text - , current_price_eur :: Double - , available :: Bool - } deriving (Eq, Show, Generic) - -instance ToJSON Product - -products :: [Product] -products = [p1, p2] - - where p1 = Product "Haskell laptop sticker" - "GHC Industries" - 2.50 - True - - p2 = Product "Foldable USB drive" - "Well-Typed" - 13.99 - False - -type SimpleAPI = Get '[JSON] [Product] - -simpleAPI :: Proxy SimpleAPI -simpleAPI = Proxy - -server :: Server SimpleAPI -server = return products - --- logStdout :: Middleware --- i.e, logStdout :: Application -> Application --- serve :: Proxy api -> Context context -> Server api -> Application --- so applying a middleware is really as simple as --- applying a function to the result of 'serve' -app :: Application -app = logStdout (serve simpleAPI server) - -main :: IO () -main = run 8080 app From 050f071a0b13a402cf6159ab93aee1112824b405 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sat, 19 Mar 2016 17:16:21 +0800 Subject: [PATCH 145/180] tutorial: update .gitignore --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 1ea6ffef..163de4bd 100644 --- a/.gitignore +++ b/.gitignore @@ -27,3 +27,5 @@ shell.nix default.nix doc/_build doc/venv +doc/tutorial/static/api.js +doc/tutorial/static/jq.js From 610b837e8da4d98dec0565d1a78b07b2aa538266 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sat, 19 Mar 2016 17:28:39 +0800 Subject: [PATCH 146/180] tutorial: html tweak --- doc/tutorial/static/index.html | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/tutorial/static/index.html b/doc/tutorial/static/index.html index 6a047c1c..bfc55b59 100644 --- a/doc/tutorial/static/index.html +++ b/doc/tutorial/static/index.html @@ -3,7 +3,7 @@ - Tutorial - 9 - servant-jquery + servant-js Example

      Books

      From ff34393d4be7e3e48ed1346814b79ec81ce215b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sat, 19 Mar 2016 18:18:39 +0800 Subject: [PATCH 147/180] bump version for servant-cassava to 0.5 --- servant-cassava/servant-cassava.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal index 8aaaa306..e7563eab 100644 --- a/servant-cassava/servant-cassava.cabal +++ b/servant-cassava/servant-cassava.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: servant-cassava -version: 0.4.4.2 +version: 0.5 synopsis: Servant CSV content-type for cassava -- description: homepage: http://haskell-servant.github.io/ From 81ef37323eb45c8185773cb763d93eddbbf12bd6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sat, 19 Mar 2016 18:12:05 +0800 Subject: [PATCH 148/180] rewrite upload script --- scripts/upload.hs | 14 +++++++++++++ scripts/upload.sh | 52 ----------------------------------------------- 2 files changed, 14 insertions(+), 52 deletions(-) create mode 100755 scripts/upload.hs delete mode 100755 scripts/upload.sh diff --git a/scripts/upload.hs b/scripts/upload.hs new file mode 100755 index 00000000..b44dee78 --- /dev/null +++ b/scripts/upload.hs @@ -0,0 +1,14 @@ +#!/usr/bin/env stack +{- stack +--resolver lts-3.10 +--install-ghc runghc +-} + +import Data.Foldable +import System.Process + +main :: IO () +main = do + sources <- words <$> readFile "sources.txt" + forM_ sources $ \ source -> do + callCommand ("stack upload " ++ source) diff --git a/scripts/upload.sh b/scripts/upload.sh deleted file mode 100755 index 344b8e4a..00000000 --- a/scripts/upload.sh +++ /dev/null @@ -1,52 +0,0 @@ -#!/usr/bin/env bash -#=============================================================================== -# -# FILE: upload.sh -# -# USAGE: ./upload.sh -# -# DESCRIPTION: Uploads all servant packages to Hackage -# -# REQUIREMENTS: cabal, bash >= 4 -# AUTHOR: Julian K. Arni -# CREATED: 05.06.2015 13:05 -#=============================================================================== - -set -o nounset -set -o errexit - -DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ) -. "$DIR"/lib/common.sh - -usage () { - echo " upload.sh " - echo " Uploads all servant packages to Hackage" - exit 0 -} - - -upload_package () { - local package="$1" - local user="$2" - local pass="$3" - local cabalFile="$package.cabal" - pushd "$package" - local version=$(grep -i '^version:' $cabalFile | awk '{ print $2 }') - local sdist="dist/${package}-${version}.tar.gz" - cabal sdist - echo "User is: $user" - cabal upload --user="$user" --password="$pass" "$sdist" - popd -} - - -if [ $# -ne 2 ] ; then - echo "expecting two arguments." - usage -fi - -versions_equal - -for s in ${SOURCES[@]} ; do - upload_package "$s" "$1" "$2" -done From 101e138a4b317c73c15fb4bbbfce9aabe906db0b Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 19 Mar 2016 13:26:13 +0100 Subject: [PATCH 149/180] Cut 0.5 in changelogs --- servant-client/CHANGELOG.md | 2 +- servant-docs/CHANGELOG.md | 2 +- servant-foreign/CHANGELOG.md | 2 +- servant-js/CHANGELOG.md | 2 +- servant-server/CHANGELOG.md | 2 +- servant/CHANGELOG.md | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index be3453cc..0cddd5ea 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -1,4 +1,4 @@ -HEAD +0.5 ---- * Use the `text` package instead of `String`. diff --git a/servant-docs/CHANGELOG.md b/servant-docs/CHANGELOG.md index 7f6ed577..44ce0696 100644 --- a/servant-docs/CHANGELOG.md +++ b/servant-docs/CHANGELOG.md @@ -1,4 +1,4 @@ -HEAD +0.5 ---- * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators diff --git a/servant-foreign/CHANGELOG.md b/servant-foreign/CHANGELOG.md index 2fcd5fb7..75628b79 100644 --- a/servant-foreign/CHANGELOG.md +++ b/servant-foreign/CHANGELOG.md @@ -1,4 +1,4 @@ -HEAD +0.5 ----- * Use the `text` package instead of `String`. * Extract javascript-oblivious types and helpers to *servant-foreign* diff --git a/servant-js/CHANGELOG.md b/servant-js/CHANGELOG.md index 575391d0..03e95fd3 100644 --- a/servant-js/CHANGELOG.md +++ b/servant-js/CHANGELOG.md @@ -1,4 +1,4 @@ -HEAD +0.5 ---- * Provide new targets for code generation along with the old jQuery one: vanilla Javascript and Angular.js diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 3c121ddd..f773491d 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,4 +1,4 @@ -HEAD +0.5 ---- * Add `Config` machinery (https://github.com/haskell-servant/servant/pull/327). diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index 3707dda4..efeecf66 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,4 +1,4 @@ -HEAD +0.5 ---- * Add `WithNamedConfig` combinator. From 75da1a1b4b20934bb3141bfe23ec793d67590794 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Sat, 19 Mar 2016 13:41:27 +0100 Subject: [PATCH 150/180] Update servant-js changelog --- servant-js/CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/servant-js/CHANGELOG.md b/servant-js/CHANGELOG.md index 03e95fd3..770f2a72 100644 --- a/servant-js/CHANGELOG.md +++ b/servant-js/CHANGELOG.md @@ -1,6 +1,8 @@ 0.5 ---- +* Extract javascript-obvlious types and helpers to *servant-foreign* +* Use `text` package instead of `String` * Provide new targets for code generation along with the old jQuery one: vanilla Javascript and Angular.js * Greatly simplify usage of this library by reducing down the API to just 2 functions: `jsForAPI` and `writeJSForAPI` + the choice of a code generator * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators From c22d74ca55b694842887b09ae16cadb053c96591 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Sun, 6 Mar 2016 21:04:51 +0100 Subject: [PATCH 151/180] Add basic authentication to tutorial --- doc/tutorial/ApiType.lhs | 47 ++++ doc/tutorial/Authentication.lhs | 417 ++++++++++++++++++++++++++++++++ doc/tutorial/Server.lhs | 2 - 3 files changed, 464 insertions(+), 2 deletions(-) create mode 100644 doc/tutorial/Authentication.lhs diff --git a/doc/tutorial/ApiType.lhs b/doc/tutorial/ApiType.lhs index ff64a0ae..c251b5f3 100644 --- a/doc/tutorial/ApiType.lhs +++ b/doc/tutorial/ApiType.lhs @@ -309,3 +309,50 @@ One example for this is if you want to serve a directory of static files along with the rest of your API. But you can plug in everything that is an `Application`, e.g. a whole web application written in any of the web frameworks that support `wai`. + +### Basic Authentication + +Once you've established the basic routes and semantics of your API, it's time to consider protecting parts of it. Authentication and authorization are broad and nuanced topics; as servant began to explore this space we started small with one of HTTP's earliest authentication schemes: [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication). + +When protecting endpoints with basic authentication, we need to specify two items: + +1. The **realm** of authentication as per the Basic Authentictaion spec. +2. The datatype returned by the server after authentication is verified. This is usually a `User` or `Customer` type datatype. + +With those two items in mind, *servant* provides the following combinator: + +``` haskell ignore +data BasicAuth (realm :: Symbol) (userData :: *) +``` + +You can use this combinator to protect an API as follows: + +``` haskell +-- | Simple data type for our weather api +data WeatherData = + WeatherData { temp :: Double + , wind :: Int + } deriving (Eq, FromJSON, Generic, Ord, ToJSON) + +-- | The user data returned after basic authentication +data User = + User { username :: String + , city :: String + , state :: String + , country :: String + } deriving (Eq, FromJSON, Generic, Ord, ToJSON) + +-- | parts of the API open to the public (no authentication required) +type PublicAPI12 = "public" :> "weather" :> Get '[JSON] WeatherData + +-- | parts of the API protected by basic authentication +type PrivatePAI12 = "private" :> "weather" + :> Capture "city" String + :> ReqBody '[JSON] WeatherData + :> Post '[JSON] () + :<|> "private" :> "account" + :> Get '[PlainText] String + +-- | Our full Weather API, private API protected by basic authentication. +type ProtectedAPI12 = PublicAPI12 + :<|> BasicAuth "weather" User :> PrivateAPI12 diff --git a/doc/tutorial/Authentication.lhs b/doc/tutorial/Authentication.lhs new file mode 100644 index 00000000..b0683979 --- /dev/null +++ b/doc/tutorial/Authentication.lhs @@ -0,0 +1,417 @@ +# Authentication in Servant + +Once you've established the basic routes and semantics of your API, it's time +to consider protecting parts of it. Authentication and authorization are broad +and nuanced topics; as servant began to explore this space we started small +with one of HTTP's earliest authentication schemes: [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication). + +Servant `0.5` shipped with out-of-the-box support for Basic Authentication. +However, we recognize that every web application is its own beautiful snowflake +and are offering experimental support for generalized or ad-hoc authentication. + +In this tutorial we'll build two APIs. One protecting certain routes with Basic +Authentication and another protecting the same routes with a custom, in-house +authentication scheme. + +## Basic Authentication + +When protecting endpoints with basic authentication, we need to specify two +items: + +1. The **realm** of authentication as per the Basic Authentication spec. +2. The datatype returned by the server after authentication is verified. This +is usually a `User` or `Customer` datatype. + +With those two items in mind, *servant* provides the following combinator: + +``` haskell ignore +data BasicAuth (realm :: Symbol) (userData :: *) +``` + +You can use this combinator to protect an API as follows: + +```haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Authentication where + +import Data.Aeson (ToJSON) +import Data.Proxy (Proxy (Proxy)) +import Data.Text (Text) +import GHC.Generics (Generic) +import Network.Wai.Handler.Warp (run) +import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth, + Get, JSON) +import Servant.API.BasicAuth (BasicAuthData (BasicAuthData)) +import Servant.API.Experimental (AuthProtect) +import Servant.Server (BasicAuthCheck (BasicAuthCheck), + BasicAuthResult( Authorized + , Unauthorized + ), + Context ((:.), EmptyContext), Server, + serveWithContext) +import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, + mkAuthHandler) +import Servant.Server.Experimenta.Auth() + +- | private data that needs protection +newtype PrivateData = PrivateData { ssshhh :: Text } + deriving (Eq, Show, Generic) + +instance ToJSON PrivateData + +-- | public data that anyone can use. +newtype PublicData = PublicData { somedata :: Text } + deriving (Eq, Show, Generic) + +instance ToJSON PublicData + +-- | A user we'll grab from the database when we authenticate someone +newtype User = User { userName :: Text } + deriving (Eq, Show) + +-- | a type to wrap our public api +type PublicAPI = Get '[JSON] [PublicData] + +-- | a type to wrap our private api +type PrivateAPI = Get '[JSON] PrivateData + +-- | our API +type BasicAPI = "public" :> PublicAPI + :<|> "private" :> BasicAuth "foo-realm" User :> PrivateAPI + +-- | a value holding a proxy of our API type +basicAuthApi :: Proxy BasicAPI +basicAuthApi = Proxy +``` + +You can see that we've prefixed our public API with "public" and our private +API with "private." Additionally, the private parts of our API use the +`BasicAuth` combinator to protect them under a Basic Authentication scheme (the +realm for this authentication is `"foo-realm"`). + +Unfortunately we're not done. When someone makes a request to our `"private"` +API, we're going to need to provide to servant the logic for validifying +usernames and passwords. This adds a certain conceptual wrinkle in servant's +design that we'll briefly discuss. If you want the **TL;DR**: we supply a lookup +function to servant's new `Context` primitive. + +Until now, all of servant's API combinators extracted information from a request +or dictated the structure of a response (e.g. a `Capture` param is pulled from +the request path). Now consider an API resource protected by basic +authentication. Once the required `WWW-Authenticate` header is checked, we need +to verify the username and password. But how? One solution would be to force an +API author to provide a function of type `BasicAuthData -> ExceptT ServantErr IO User` +and servant should use this function to authenticate a request. Unfortunately +this didn't work prior to `0.5` because all of servant's machinery was +engineered around the idea that each combinator can extract information from +only the request. We cannot extract the function +`BasicAuthData -> ExceptT ServantErr IO User` from a request! Are we doomed? + +Servant `0.5` introduced `Context` to handle this. The type machinery is beyond +the scope of this tutorial, but the idea is simple: provide some data to the +`serve` function, and that data is propagated to the functions that handle each +combinator. Using `Context`, we can supply a function of type +`BasicAuthData -> ExceptT ServantErr IO User` to the `BasicAuth` combinator +handler. This will allow the handler to check authentication and return a `User` +to downstream handlers if successful. + +In practice we wrap `BasicAuthData -> ExceptT ServantErr IO` into a slightly +different function to better capture the semantics of basic authentication: + +``` haskell ignore +-- | The result of authentication/authorization +data BasicAuthResult usr + = Unauthorized + | BadPassword + | NoSuchUser + | Authorized usr + deriving (Eq, Show, Read, Generic, Typeable, Functor) + +-- | Datatype wrapping a function used to check authentication. +newtype BasicAuthCheck usr = BasicAuthCheck + { unBasicAuthCheck :: BasicAuthData + -> IO (BasicAuthResult usr) + } + deriving (Generic, Typeable, Functor) +``` + +We now use this datatype to supply servant with a method to authenticate +requests. In this simple example the only valid username and password is +`"servant"` and `"server"`, respectively, but in a real, production application +you might do some database lookup here. + +```haskell +-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password. +authCheck :: BasicAuthCheck User +authCheck = + let check (BasicAuthData username password) = + if username == "servant" && password == "server" + then return (Authorized (User "servant")) + else return Unauthorized + in BasicAuthCheck check +``` + +And now we create the `Context` used by servant to find `BasicAuthCheck`: + +```haskell +-- | We need to supply our handlers with the right Context. In this case, +-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value +-- tagged with "foo-tag" This context is then supplied to 'server' and threaded +-- to the BasicAuth HasServer handlers. +serverContext :: Context (BasicAuthCheck User ': '[]) +serverContext = authCheck :. EmptyContext +``` + +We're now ready to write our `server` method that will tie everything together: + +```haskell +-- | an implementation of our server. Here is where we pass all the handlers to our endpoints. +-- In particular, for the BasicAuth protected handler, we need to supply a function +-- that takes 'User' as an argument. +server :: Server BasicAPI +server = + let publicAPIHandler = return [PublicData "foo", PublicData "bar"] + privateAPIHandler (user :: User) = return (PrivateData (userName user)) + in publicAPIHandler :<|> privateAPIHandler +``` + +Finally, our main method and a sample session working with our server: + +```haskell +-- | hello, server! +basicAuthMain :: IO () +basicAuthMain = run 8080 (serveWithContext basicAuthApi serverContext server) + +{- Sample session + +$ curl -XGET localhost:8080/public +[{"somedata":"foo"},{"somedata":"bar"} + +$ curl -iXGET localhost:8080/private +HTTP/1.1 401 Unauthorized +transfer-encoding: chunked +Date: Thu, 07 Jan 2016 22:36:38 GMT +Server: Warp/3.1.8 +WWW-Authenticate: Basic realm="foo-realm" + +$ curl -iXGET localhost:8080/private -H "Authorization: Basic c2VydmFudDpzZXJ2ZXI=" +HTTP/1.1 200 OK +transfer-encoding: chunked +Date: Thu, 07 Jan 2016 22:37:58 GMT +Server: Warp/3.1.8 +Content-Type: application/json +{"ssshhh":"servant"} +-} +``` + +## Generalized Authentication + +Sometimes your server's authentication scheme doesn't quite fit with the +standards (or perhaps servant hasn't rolled-out support for that new, fancy +authentication scheme). For such a scenario, servant `0.5` provides easy and +simple experimental support to roll your own authentication. + +Why experimental? We worked on the design for authentication for a long time. We +really struggled to find a nice, type-safe niche in the design space. In fact, +`Context` came out of this work, and while it really fit for schemes like Basic +and JWT, it wasn't enough to fully support something like OAuth or HMAC, which +have flows, roles, and other fancy ceremonies. Further, we weren't sure *how* +people will use auth. + +So, in typical startup fashion, we developed an MVP of 'generalized auth' and +released it in an experimental module, with the hope of getting feedback from you! +So, if you're reading this or using generalized auth support, please give us +your feedback! + +### What is Generalized Authentication? + +**TL;DR**: you throw a tagged `AuthProtect` combinator in front of the endpoints +you want protected and then supply a function `Request -> ExceptT IO ServantErr user` +which we run anytime a request matches a protected endpoint. It precisely solves +the "I just need to protect these endpoints with a function that does some +complicated business logic" and nothing more. Behind the scenes we use a type +family instance (`AuthServerData`) and `Context` to accomplish this. + +### Generalized Authentication in Action + +Let's implement a trivial authentication scheme. We will protect our API by +looking for a cookie named `"servant-auth-cookie"`. This cookie's value will +contain a key from which we can lookup a `User`. + +```haskell +-- | A user type that we "fetch from the database" after +-- performing authentication +newtype User = User { unUser :: Text } + +-- | A (pure) database mapping keys to users. +database :: Map ByteString User +database = fromList [ ("key1", User "Anne Briggs") + , ("key2", User "Bruce Cockburn") + , ("key3", User "Ghédalia Tazartès") + ] + +-- | A method that, when given a password, will return a User. +-- This is our bespoke (and bad) authentication logic. +lookupUser :: ByteString -> ExceptT ServantErr IO User +lookupUser key = case Map.lookup key database of + Nothing -> throwE (err403 { errBody = "Invalid Cookie" }) + Just usr -> return usr +``` + +For generalized authentication, servant exposes the `AuthHandler` type, +which is used to wrap the `Request -> ExceptT IO ServantErr user` logic. Let's +create a value of type `AuthHandler Request User` using the above `lookupUser` +method: + +```haskell +-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User +-- we look for a Cookie and pass the value of the cookie to `lookupUser`. +authHandler :: AuthHandler Request User +authHandler = + let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of + Nothing -> throwE (err401 { errBody = "Missing auth header" }) + Just authCookieKey -> lookupUser authCookieKey + in mkAuthHandler handler +``` + +Let's now protect our API with our new, bespoke authentication scheme. We'll +re-use the endpoints from our Basic Authentication example. + +```haskell +-- | Our API, with auth-protection +type AuthGenAPI = "private" :> AuthProtect "cookie-auth" :> PrivateAPI + :<|> "public" :> PublicAPI + +-- | A value holding our type-level API +genAuthApi :: Proxy AuthGenAPI +genAuthApi = Proxy +``` + +Now we need to bring everything together for the server. We have the +`AuthHandler Request User` value and an `AuthProtected` endpoint. To bind these +together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/type-families.html) +instance that tells the `HasServer` instance that our `Context` will supply a +`User` (via `AuthHandler Request User`) and that downstream combinators will +have access to this `User` value (or an error will be thrown if authentication +fails). + +```haskell + +-- | We need to specify the data returned after authentication +type instance AuthServerData (AuthProtect "cookie-auth") = User +``` + +Note that we specify the type-level tag `"cookie-auth"` when defining the type +family instance. This allows us to have multiple authentication schemes +protecting a single API. + +We now construct the `Context` for our server, allowing us to instantiate a +value of type `Server AuthGenAPI`, in addition to the server value: + +```haskell +-- | The context that will be made available to request handlers. We supply the +-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance +-- of 'AuthProtect' can extract the handler and run it on the request. +serverContext :: Context (AuthHandler Request User ': '[]) +serverContext = authHandler :. EmptyContext + +-- | Our API, where we provide all the author-supplied handlers for each end +-- point. Note that 'privateDataFunc' is a function that takes 'User' as an +-- argument. We dont' worry about the authentication instrumentation here, +-- that is taken care of by supplying context +server :: Server AuthGenAPI +server = + let privateDataFunc (User name) = + return [PrivateData ("this is a secret: " <> name)] + publicData = [PublicData "this is a public piece of data"] + in privateDataFunc :<|> return publicData +``` + +We're now ready to start our server (and provide a sample session)! + +```haskell +-- | run our server +genAuthMain :: IO () +genAuthMain = run 8080 (serveWithContext api serverContext server) + +{- Sample Session: + +$ curl -XGET localhost:8080/private +Missing auth header + +$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3" +[{"ssshhh":"this is a secret: Ghédalia Tazartès"}] + +$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key" +Invalid Cookie + +$ curl -XGET localhost:8080/public +[{"somedata":"this is a public piece of data"}] +-} +``` + +### Recap + +Creating a generalized, ad-hoc authentication scheme was fairly straight +forward: + +1. use the `AuthProtect` combinator to protect your API. +2. choose a application-specific data type used by your server when +authentication is successful (in our case this was `User`). +3. Create a value of `AuthHandler Request User` which encapsulates the +authentication logic (`Request -> ExceptT IO ServantErr User`). This function +will be executed everytime a request matches a protected route. +4. Provide an instance of the `AuthServerData` type family, specifying your +application-specific data type returned when authentication is successful (in +our case this was `User`). + +Caveats: + +1. The module `Servant.Server.Experimental.Auth` contains an orphan `HasServer` +instance for the `AuthProtect` combinator. You may be get orphan instance +warnings when using this. +2. Generalized authentication requires the `UndecidableInstances` extension. + +## Client-side Authentication + +### Basic Authentication + +As of `0.5`, *servant-client* comes with support for basic authentication! +Endpoints protected by Basic Authentication will require a value of type +`BasicAuthData` to complete the request. + +### Generalized Authentication + +Servant `0.5` also shipped with support for generalized authentication. Similar +to the server-side support, clients need to supply an instance of the +`AuthClientData` type family specifying the datatype the client will use to +marshal an unauthenticated request into an authenticated request. Generally, +this will look like: + +```haskell ignore +-- | The datatype we'll use to authenticate a request. If we were wrapping +-- something like OAuth, this might be a Bearer token. +type instance AuthClientData (AuthProtect "cookie-auth") = String + +-- | A method to authenticate a request +authenticateReq :: String -> Req -> Req +authenticateReq s req = SCR.addHeader "my-bespoke-header" s req +``` + +Now, if the client method for our protected endpoint was `getProtected`, then +we could perform authenticated requests as follows: + +```haskell ignore +-- | one could curry this to make it simpler to work with. +result = runExceptT (getProtected (mkAuthenticateReq "secret" authenticateReq)) +``` diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index bd84b8a0..84a784d3 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -1108,8 +1108,6 @@ $ curl http://localhost:8081/b "hi" ``` -## Conclusion - You're now equipped to write webservices/web-applications using **servant**. The rest of this document focuses on **servant-client**, **servant-js** and **servant-docs**. From 45eba28da955d41cd43d7fef8ad9be758e33f6da Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 19 Mar 2016 17:26:52 +0100 Subject: [PATCH 152/180] re-add conclusion --- doc/tutorial/Server.lhs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index 84a784d3..bd84b8a0 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -1108,6 +1108,8 @@ $ curl http://localhost:8081/b "hi" ``` +## Conclusion + You're now equipped to write webservices/web-applications using **servant**. The rest of this document focuses on **servant-client**, **servant-js** and **servant-docs**. From f742a5c4c83c66c66ccd1bc36417dbbf82967b12 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 19 Mar 2016 17:44:05 +0100 Subject: [PATCH 153/180] Simplify auth section in apitypes --- doc/tutorial/ApiType.lhs | 75 +++++++++++++++------------------------- 1 file changed, 28 insertions(+), 47 deletions(-) diff --git a/doc/tutorial/ApiType.lhs b/doc/tutorial/ApiType.lhs index c251b5f3..607191fe 100644 --- a/doc/tutorial/ApiType.lhs +++ b/doc/tutorial/ApiType.lhs @@ -287,6 +287,34 @@ response, you could write it as below: type UserAPI10 = "users" :> Get '[JSON] (Headers '[Header "User-Count" Integer] [User]) ``` +### Basic Authentication + +Once you've established the basic routes and semantics of your API, it's time +to consider protecting parts of it. Authentication and authorization are broad +and nuanced topics; as servant began to explore this space we started small +with one of HTTP's earliest authentication schemes: [Basic +Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication). + +When protecting endpoints with basic authentication, we need to specify two items: + +1. The **realm** of authentication as per the Basic Authentictaion spec. +2. The datatype returned by the server after authentication is verified. This + is usually a `User` or `Customer` type datatype. + +With those two items in mind, *servant* provides the following combinator: + +``` haskell ignore +data BasicAuth (realm :: Symbol) (userData :: *) +``` + +Which is used like so: + +``` haskell +type ProtectedAPI12 + = UserAPI -- this is public + :<|> BasicAuth "my-real" User :> UserAPI2 -- this is protected by auth +``` + ### Interoperability with `wai`: `Raw` Finally, we also include a combinator named `Raw` that provides an escape hatch @@ -309,50 +337,3 @@ One example for this is if you want to serve a directory of static files along with the rest of your API. But you can plug in everything that is an `Application`, e.g. a whole web application written in any of the web frameworks that support `wai`. - -### Basic Authentication - -Once you've established the basic routes and semantics of your API, it's time to consider protecting parts of it. Authentication and authorization are broad and nuanced topics; as servant began to explore this space we started small with one of HTTP's earliest authentication schemes: [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication). - -When protecting endpoints with basic authentication, we need to specify two items: - -1. The **realm** of authentication as per the Basic Authentictaion spec. -2. The datatype returned by the server after authentication is verified. This is usually a `User` or `Customer` type datatype. - -With those two items in mind, *servant* provides the following combinator: - -``` haskell ignore -data BasicAuth (realm :: Symbol) (userData :: *) -``` - -You can use this combinator to protect an API as follows: - -``` haskell --- | Simple data type for our weather api -data WeatherData = - WeatherData { temp :: Double - , wind :: Int - } deriving (Eq, FromJSON, Generic, Ord, ToJSON) - --- | The user data returned after basic authentication -data User = - User { username :: String - , city :: String - , state :: String - , country :: String - } deriving (Eq, FromJSON, Generic, Ord, ToJSON) - --- | parts of the API open to the public (no authentication required) -type PublicAPI12 = "public" :> "weather" :> Get '[JSON] WeatherData - --- | parts of the API protected by basic authentication -type PrivatePAI12 = "private" :> "weather" - :> Capture "city" String - :> ReqBody '[JSON] WeatherData - :> Post '[JSON] () - :<|> "private" :> "account" - :> Get '[PlainText] String - --- | Our full Weather API, private API protected by basic authentication. -type ProtectedAPI12 = PublicAPI12 - :<|> BasicAuth "weather" User :> PrivateAPI12 From 4e3736553425162370f80b3963ff445c47aa53d0 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sun, 20 Mar 2016 19:04:49 +0100 Subject: [PATCH 154/180] Fix type-synonym in tutorial --- doc/tutorial/ApiType.lhs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/tutorial/ApiType.lhs b/doc/tutorial/ApiType.lhs index ff64a0ae..6c3e2337 100644 --- a/doc/tutorial/ApiType.lhs +++ b/doc/tutorial/ApiType.lhs @@ -95,10 +95,10 @@ type Get = Verb 'GET 200 There are other predefined type synonyms for other common HTTP methods, such as e.g.: ``` haskell ignore -data Delete = Verb 'DELETE 200 -data Patch = Verb 'PATCH 200 -data Post = Verb 'POST 200 -data Put = Verb 'PUT 200 +type Delete = Verb 'DELETE 200 +type Patch = Verb 'PATCH 200 +type Post = Verb 'POST 200 +type Put = Verb 'PUT 200 ``` There are also variants that do not return a 200 status code, such From a35aa161a67f52d93db2277858afe1f761df45bd Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Fri, 18 Mar 2016 15:54:22 +0100 Subject: [PATCH 155/180] Fix link to serveDirectory. --- servant/src/Servant/API/Raw.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant/src/Servant/API/Raw.hs b/servant/src/Servant/API/Raw.hs index 90a5f4bd..41077711 100644 --- a/servant/src/Servant/API/Raw.hs +++ b/servant/src/Servant/API/Raw.hs @@ -9,6 +9,6 @@ import Data.Typeable (Typeable) -- a modified (stripped) 'pathInfo' if the 'Application' is being routed with 'Servant.API.Sub.:>'. -- -- In addition to just letting you plug in your existing WAI 'Application's, --- this can also be used with 'Servant.Utils.StaticFiles.serveDirectory' to serve +-- this can also be used with to serve -- static files stored in a particular directory on your filesystem data Raw deriving Typeable From 9c4aeec79291239e328e67a5bc145e677c1fc7e8 Mon Sep 17 00:00:00 2001 From: Jonathan Curran Date: Tue, 22 Mar 2016 08:32:15 -0500 Subject: [PATCH 156/180] Add link to old tutorial --- doc/tutorial/index.rst | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/tutorial/index.rst b/doc/tutorial/index.rst index cf2cfd8e..f2d551a5 100644 --- a/doc/tutorial/index.rst +++ b/doc/tutorial/index.rst @@ -3,6 +3,11 @@ Tutorial This is an introductory tutorial to **servant**. +.. note:: + This tutorial is for the latest version of servant. The tutorial for + servant-0.4 can be viewed + `here `_. + (Any comments, issues or feedback about the tutorial can be handled through `servant's issue tracker `_.) From 0ad60fe09306b76726c734d0179c2e4541cef450 Mon Sep 17 00:00:00 2001 From: Alexander Kjeldaas Date: Fri, 25 Mar 2016 10:53:45 +0100 Subject: [PATCH 157/180] Document http error codes --- .../src/Servant/Server/Internal/ServantErr.hs | 210 ++++++++++++++++++ 1 file changed, 210 insertions(+) diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs index 1b05638c..a044898a 100644 --- a/servant-server/src/Servant/Server/Internal/ServantErr.hs +++ b/servant-server/src/Servant/Server/Internal/ServantErr.hs @@ -23,6 +23,13 @@ responseServantErr ServantErr{..} = responseLBS status errHeaders errBody where status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase) +-- | 'err300' Multiple Choices +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err300 { errBody = "I can't choose." } +-- err300 :: ServantErr err300 = ServantErr { errHTTPCode = 300 , errReasonPhrase = "Multiple Choices" @@ -30,6 +37,13 @@ err300 = ServantErr { errHTTPCode = 300 , errHeaders = [] } +-- | 'err301' Moved Permanently +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr err301 +-- err301 :: ServantErr err301 = ServantErr { errHTTPCode = 301 , errReasonPhrase = "Moved Permanently" @@ -37,6 +51,13 @@ err301 = ServantErr { errHTTPCode = 301 , errHeaders = [] } +-- | 'err302' Found +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr err302 +-- err302 :: ServantErr err302 = ServantErr { errHTTPCode = 302 , errReasonPhrase = "Found" @@ -44,6 +65,13 @@ err302 = ServantErr { errHTTPCode = 302 , errHeaders = [] } +-- | 'err303' See Other +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr err303 +-- err303 :: ServantErr err303 = ServantErr { errHTTPCode = 303 , errReasonPhrase = "See Other" @@ -51,6 +79,13 @@ err303 = ServantErr { errHTTPCode = 303 , errHeaders = [] } +-- | 'err304' Not Modified +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr err304 +-- err304 :: ServantErr err304 = ServantErr { errHTTPCode = 304 , errReasonPhrase = "Not Modified" @@ -58,6 +93,13 @@ err304 = ServantErr { errHTTPCode = 304 , errHeaders = [] } +-- | 'err305' Use Proxy +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr err305 +-- err305 :: ServantErr err305 = ServantErr { errHTTPCode = 305 , errReasonPhrase = "Use Proxy" @@ -65,6 +107,13 @@ err305 = ServantErr { errHTTPCode = 305 , errHeaders = [] } +-- | 'err307' Temporary Redirect +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err307 +-- err307 :: ServantErr err307 = ServantErr { errHTTPCode = 307 , errReasonPhrase = "Temporary Redirect" @@ -72,6 +121,13 @@ err307 = ServantErr { errHTTPCode = 307 , errHeaders = [] } +-- | 'err400' Bad Request +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err400 { errBody = "Your request makes no sense to me." } +-- err400 :: ServantErr err400 = ServantErr { errHTTPCode = 400 , errReasonPhrase = "Bad Request" @@ -79,6 +135,13 @@ err400 = ServantErr { errHTTPCode = 400 , errHeaders = [] } +-- | 'err401' Unauthorized +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err401 { errBody = "Your credentials are invalid." } +-- err401 :: ServantErr err401 = ServantErr { errHTTPCode = 401 , errReasonPhrase = "Unauthorized" @@ -86,6 +149,13 @@ err401 = ServantErr { errHTTPCode = 401 , errHeaders = [] } +-- | 'err402' Payment Required +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err402 { errBody = "You have 0 credits. Please give me $$$." } +-- err402 :: ServantErr err402 = ServantErr { errHTTPCode = 402 , errReasonPhrase = "Payment Required" @@ -93,6 +163,13 @@ err402 = ServantErr { errHTTPCode = 402 , errHeaders = [] } +-- | 'err403' Forbidden +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err403 { errBody = "Please login first." } +-- err403 :: ServantErr err403 = ServantErr { errHTTPCode = 403 , errReasonPhrase = "Forbidden" @@ -100,6 +177,13 @@ err403 = ServantErr { errHTTPCode = 403 , errHeaders = [] } +-- | 'err404' Not Found +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." } +-- err404 :: ServantErr err404 = ServantErr { errHTTPCode = 404 , errReasonPhrase = "Not Found" @@ -107,6 +191,13 @@ err404 = ServantErr { errHTTPCode = 404 , errHeaders = [] } +-- | 'err405' Method Not Allowed +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." } +-- err405 :: ServantErr err405 = ServantErr { errHTTPCode = 405 , errReasonPhrase = "Method Not Allowed" @@ -114,6 +205,13 @@ err405 = ServantErr { errHTTPCode = 405 , errHeaders = [] } +-- | 'err406' Not Acceptable +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err406 +-- err406 :: ServantErr err406 = ServantErr { errHTTPCode = 406 , errReasonPhrase = "Not Acceptable" @@ -121,6 +219,13 @@ err406 = ServantErr { errHTTPCode = 406 , errHeaders = [] } +-- | 'err407' Proxy Authentication Required +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err407 +-- err407 :: ServantErr err407 = ServantErr { errHTTPCode = 407 , errReasonPhrase = "Proxy Authentication Required" @@ -128,6 +233,13 @@ err407 = ServantErr { errHTTPCode = 407 , errHeaders = [] } +-- | 'err409' Conflict +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" } +-- err409 :: ServantErr err409 = ServantErr { errHTTPCode = 409 , errReasonPhrase = "Conflict" @@ -135,6 +247,13 @@ err409 = ServantErr { errHTTPCode = 409 , errHeaders = [] } +-- | 'err410' Gone +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." } +-- err410 :: ServantErr err410 = ServantErr { errHTTPCode = 410 , errReasonPhrase = "Gone" @@ -142,6 +261,13 @@ err410 = ServantErr { errHTTPCode = 410 , errHeaders = [] } +-- | 'err411' Length Required +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err411 +-- err411 :: ServantErr err411 = ServantErr { errHTTPCode = 411 , errReasonPhrase = "Length Required" @@ -149,6 +275,13 @@ err411 = ServantErr { errHTTPCode = 411 , errHeaders = [] } +-- | 'err412' Precondition Failed +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err412 { errBody = "Precondition fail: x < 42 && y > 57" } +-- err412 :: ServantErr err412 = ServantErr { errHTTPCode = 412 , errReasonPhrase = "Precondition Failed" @@ -156,6 +289,13 @@ err412 = ServantErr { errHTTPCode = 412 , errHeaders = [] } +-- | 'err413' Request Entity Too Large +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err413 { errBody = "Request exceeded 64k." } +-- err413 :: ServantErr err413 = ServantErr { errHTTPCode = 413 , errReasonPhrase = "Request Entity Too Large" @@ -163,6 +303,13 @@ err413 = ServantErr { errHTTPCode = 413 , errHeaders = [] } +-- | 'err414' Request-URI Too Large +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err414 { errBody = "Maxiumu length is 64." } +-- err414 :: ServantErr err414 = ServantErr { errHTTPCode = 414 , errReasonPhrase = "Request-URI Too Large" @@ -170,6 +317,13 @@ err414 = ServantErr { errHTTPCode = 414 , errHeaders = [] } +-- | 'err415' Unsupported Media Type +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err415 { errBody = "Supported media types: gif, png" } +-- err415 :: ServantErr err415 = ServantErr { errHTTPCode = 415 , errReasonPhrase = "Unsupported Media Type" @@ -177,6 +331,13 @@ err415 = ServantErr { errHTTPCode = 415 , errHeaders = [] } +-- | 'err416' Request range not satisfiable +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err416 { errBody = "Valid range is [0, 424242]." } +-- err416 :: ServantErr err416 = ServantErr { errHTTPCode = 416 , errReasonPhrase = "Request range not satisfiable" @@ -184,6 +345,13 @@ err416 = ServantErr { errHTTPCode = 416 , errHeaders = [] } +-- | 'err417' Expectation Failed +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err417 { errBody = "I found a quux in the request. This isn't going to work." } +-- err417 :: ServantErr err417 = ServantErr { errHTTPCode = 417 , errReasonPhrase = "Expectation Failed" @@ -191,6 +359,13 @@ err417 = ServantErr { errHTTPCode = 417 , errHeaders = [] } +-- | 'err500' Internal Server Error +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err300 { errBody = "Exception in module A.B.C:55. Have a great day!" } +-- err500 :: ServantErr err500 = ServantErr { errHTTPCode = 500 , errReasonPhrase = "Internal Server Error" @@ -198,6 +373,13 @@ err500 = ServantErr { errHTTPCode = 500 , errHeaders = [] } +-- | 'err501' Not Implemented +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err501 { errBody = "/v1/foo is not supported with quux in the request." } +-- err501 :: ServantErr err501 = ServantErr { errHTTPCode = 501 , errReasonPhrase = "Not Implemented" @@ -205,6 +387,13 @@ err501 = ServantErr { errHTTPCode = 501 , errHeaders = [] } +-- | 'err502' Bad Gateway +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." } +-- err502 :: ServantErr err502 = ServantErr { errHTTPCode = 502 , errReasonPhrase = "Bad Gateway" @@ -212,6 +401,13 @@ err502 = ServantErr { errHTTPCode = 502 , errHeaders = [] } +-- | 'err503' Service Unavailable +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err503 { errBody = "We're rewriting in PHP." } +-- err503 :: ServantErr err503 = ServantErr { errHTTPCode = 503 , errReasonPhrase = "Service Unavailable" @@ -219,6 +415,13 @@ err503 = ServantErr { errHTTPCode = 503 , errHeaders = [] } +-- | 'err504' Gateway Time-out +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err504 { errBody = "Backend foobar did not respond in 5 seconds." } +-- err504 :: ServantErr err504 = ServantErr { errHTTPCode = 504 , errReasonPhrase = "Gateway Time-out" @@ -226,6 +429,13 @@ err504 = ServantErr { errHTTPCode = 504 , errHeaders = [] } +-- | 'err505' HTTP Version not supported +-- +-- Example usage: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err505 { errBody = "I support HTTP/4.0 only." } +-- err505 :: ServantErr err505 = ServantErr { errHTTPCode = 505 , errReasonPhrase = "HTTP Version not supported" From 0c01b0dba45cb11d248cbbeeb418460724ac6fbc Mon Sep 17 00:00:00 2001 From: Alexander Kjeldaas Date: Fri, 25 Mar 2016 19:09:44 +0100 Subject: [PATCH 158/180] Fixed some minor typos --- .../src/Servant/Server/Internal/ServantErr.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs index a044898a..4e646a7a 100644 --- a/servant-server/src/Servant/Server/Internal/ServantErr.hs +++ b/servant-server/src/Servant/Server/Internal/ServantErr.hs @@ -112,7 +112,7 @@ err305 = ServantErr { errHTTPCode = 305 -- Example: -- -- > failingHandler :: ExceptT ServantErr IO () --- > failingHandler = throwErr $ err307 +-- > failingHandler = throwErr err307 -- err307 :: ServantErr err307 = ServantErr { errHTTPCode = 307 @@ -210,7 +210,7 @@ err405 = ServantErr { errHTTPCode = 405 -- Example: -- -- > failingHandler :: ExceptT ServantErr IO () --- > failingHandler = throwErr $ err406 +-- > failingHandler = throwErr err406 -- err406 :: ServantErr err406 = ServantErr { errHTTPCode = 406 @@ -224,7 +224,7 @@ err406 = ServantErr { errHTTPCode = 406 -- Example: -- -- > failingHandler :: ExceptT ServantErr IO () --- > failingHandler = throwErr $ err407 +-- > failingHandler = throwErr err407 -- err407 :: ServantErr err407 = ServantErr { errHTTPCode = 407 @@ -266,7 +266,7 @@ err410 = ServantErr { errHTTPCode = 410 -- Example: -- -- > failingHandler :: ExceptT ServantErr IO () --- > failingHandler = throwErr $ err411 +-- > failingHandler = throwErr err411 -- err411 :: ServantErr err411 = ServantErr { errHTTPCode = 411 @@ -308,7 +308,7 @@ err413 = ServantErr { errHTTPCode = 413 -- Example: -- -- > failingHandler :: ExceptT ServantErr IO () --- > failingHandler = throwErr $ err414 { errBody = "Maxiumu length is 64." } +-- > failingHandler = throwErr $ err414 { errBody = "Maximum length is 64." } -- err414 :: ServantErr err414 = ServantErr { errHTTPCode = 414 @@ -364,7 +364,7 @@ err417 = ServantErr { errHTTPCode = 417 -- Example: -- -- > failingHandler :: ExceptT ServantErr IO () --- > failingHandler = throwErr $ err300 { errBody = "Exception in module A.B.C:55. Have a great day!" } +-- > failingHandler = throwErr $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" } -- err500 :: ServantErr err500 = ServantErr { errHTTPCode = 500 From b4eef7acdee7ea3ce86e9ee1be0abb02f3117854 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Wed, 23 Mar 2016 14:59:46 +0800 Subject: [PATCH 159/180] refactored HasServer Capture instance --- servant-server/src/Servant/Server/Internal.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index c9679d9e..3ae2af6b 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -99,9 +99,6 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont where pa = Proxy :: Proxy a pb = Proxy :: Proxy b -captured :: FromHttpApiData a => proxy (Capture sym a) -> Text -> Maybe a -captured _ = parseUrlPieceMaybe - -- | If you use 'Capture' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by the 'Capture'. @@ -129,12 +126,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) DynamicRouter $ \ first -> route (Proxy :: Proxy sublayout) context - (addCapture d $ case captured captureProxy first of + (addCapture d $ case parseUrlPieceMaybe first :: Maybe a of Nothing -> return $ Fail err404 Just v -> return $ Route v ) - where - captureProxy = Proxy :: Proxy (Capture capture a) allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead From 09c40f61e256260773a6e7fc138a589a6ed9d665 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Wed, 23 Mar 2016 15:06:38 +0800 Subject: [PATCH 160/180] return 400 (instead of 404) on invalid captures --- servant-server/src/Servant/Server/Internal.hs | 2 +- servant-server/test/Servant/Server/ErrorSpec.hs | 2 +- servant-server/test/Servant/ServerSpec.hs | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 3ae2af6b..93b0a2ff 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -127,7 +127,7 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) route (Proxy :: Proxy sublayout) context (addCapture d $ case parseUrlPieceMaybe first :: Maybe a of - Nothing -> return $ Fail err404 + Nothing -> return $ Fail err400 Just v -> return $ Route v ) diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 96d2df6f..94d26d09 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -63,7 +63,7 @@ errorOrderSpec = let badContentType = (hContentType, "text/plain") badAccept = (hAccept, "text/plain") badMethod = methodGet - badUrl = "home/nonexistent" + badUrl = "nonexistent" badBody = "nonsense" badAuth = (hAuthorization, "Basic foofoofoo") goodContentType = (hContentType, "application/json") diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 0e17c022..5499c804 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -202,8 +202,8 @@ captureSpec = do response <- get "/2" liftIO $ decode' (simpleBody response) `shouldBe` Just tweety - it "returns 404 if the decoding fails" $ do - get "/notAnInt" `shouldRespondWith` 404 + it "returns 400 if the decoding fails" $ do + get "/notAnInt" `shouldRespondWith` 400 with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) From 5b068b3ad347c01ce7dea6e2e9aa0dd9148cf2c0 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Sat, 26 Mar 2016 13:56:45 +0100 Subject: [PATCH 161/180] Authentication.lhs in tutorial project + toc --- doc/tutorial/Authentication.lhs | 88 ++++++++++++++++++--------------- doc/tutorial/index.rst | 1 + doc/tutorial/tutorial.cabal | 2 + 3 files changed, 52 insertions(+), 39 deletions(-) diff --git a/doc/tutorial/Authentication.lhs b/doc/tutorial/Authentication.lhs index b0683979..b9117e55 100644 --- a/doc/tutorial/Authentication.lhs +++ b/doc/tutorial/Authentication.lhs @@ -44,26 +44,33 @@ You can use this combinator to protect an API as follows: module Authentication where +import Control.Monad.Trans.Except (ExceptT, throwE) import Data.Aeson (ToJSON) +import Data.ByteString (ByteString) +import Data.Map (Map, fromList) +import Data.Monoid ((<>)) +import qualified Data.Map as Map import Data.Proxy (Proxy (Proxy)) import Data.Text (Text) import GHC.Generics (Generic) +import Network.Wai (Request, requestHeaders) import Network.Wai.Handler.Warp (run) import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth, Get, JSON) import Servant.API.BasicAuth (BasicAuthData (BasicAuthData)) -import Servant.API.Experimental (AuthProtect) +import Servant.API.Experimental.Auth (AuthProtect) import Servant.Server (BasicAuthCheck (BasicAuthCheck), BasicAuthResult( Authorized , Unauthorized ), - Context ((:.), EmptyContext), Server, - serveWithContext) + Context ((:.), EmptyContext), + err401, err403, errBody, Server, + ServantErr, serveWithContext) import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) -import Servant.Server.Experimenta.Auth() +import Servant.Server.Experimental.Auth() -- | private data that needs protection +-- | private data that needs protection newtype PrivateData = PrivateData { ssshhh :: Text } deriving (Eq, Show, Generic) @@ -168,8 +175,8 @@ And now we create the `Context` used by servant to find `BasicAuthCheck`: -- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value -- tagged with "foo-tag" This context is then supplied to 'server' and threaded -- to the BasicAuth HasServer handlers. -serverContext :: Context (BasicAuthCheck User ': '[]) -serverContext = authCheck :. EmptyContext +basicAuthServerContext :: Context (BasicAuthCheck User ': '[]) +basicAuthServerContext = authCheck :. EmptyContext ``` We're now ready to write our `server` method that will tie everything together: @@ -178,8 +185,8 @@ We're now ready to write our `server` method that will tie everything together: -- | an implementation of our server. Here is where we pass all the handlers to our endpoints. -- In particular, for the BasicAuth protected handler, we need to supply a function -- that takes 'User' as an argument. -server :: Server BasicAPI -server = +basicAuthServer :: Server BasicAPI +basicAuthServer = let publicAPIHandler = return [PublicData "foo", PublicData "bar"] privateAPIHandler (user :: User) = return (PrivateData (userName user)) in publicAPIHandler :<|> privateAPIHandler @@ -190,7 +197,10 @@ Finally, our main method and a sample session working with our server: ```haskell -- | hello, server! basicAuthMain :: IO () -basicAuthMain = run 8080 (serveWithContext basicAuthApi serverContext server) +basicAuthMain = run 8080 (serveWithContext basicAuthApi + basicAuthServerContext + basicAuthServer + ) {- Sample session @@ -251,36 +261,36 @@ contain a key from which we can lookup a `User`. ```haskell -- | A user type that we "fetch from the database" after -- performing authentication -newtype User = User { unUser :: Text } +newtype Account = Account { unAccount :: Text } -- | A (pure) database mapping keys to users. -database :: Map ByteString User -database = fromList [ ("key1", User "Anne Briggs") - , ("key2", User "Bruce Cockburn") - , ("key3", User "Ghédalia Tazartès") +database :: Map ByteString Account +database = fromList [ ("key1", Account "Anne Briggs") + , ("key2", Account "Bruce Cockburn") + , ("key3", Account "Ghédalia Tazartès") ] --- | A method that, when given a password, will return a User. +-- | A method that, when given a password, will return a Account. -- This is our bespoke (and bad) authentication logic. -lookupUser :: ByteString -> ExceptT ServantErr IO User -lookupUser key = case Map.lookup key database of +lookupAccount :: ByteString -> ExceptT ServantErr IO Account +lookupAccount key = case Map.lookup key database of Nothing -> throwE (err403 { errBody = "Invalid Cookie" }) Just usr -> return usr ``` For generalized authentication, servant exposes the `AuthHandler` type, which is used to wrap the `Request -> ExceptT IO ServantErr user` logic. Let's -create a value of type `AuthHandler Request User` using the above `lookupUser` +create a value of type `AuthHandler Request Account` using the above `lookupAccount` method: ```haskell --- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User --- we look for a Cookie and pass the value of the cookie to `lookupUser`. -authHandler :: AuthHandler Request User +-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO Account +-- we look for a Cookie and pass the value of the cookie to `lookupAccount`. +authHandler :: AuthHandler Request Account authHandler = let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of Nothing -> throwE (err401 { errBody = "Missing auth header" }) - Just authCookieKey -> lookupUser authCookieKey + Just authCookieKey -> lookupAccount authCookieKey in mkAuthHandler handler ``` @@ -293,22 +303,22 @@ type AuthGenAPI = "private" :> AuthProtect "cookie-auth" :> PrivateAPI :<|> "public" :> PublicAPI -- | A value holding our type-level API -genAuthApi :: Proxy AuthGenAPI -genAuthApi = Proxy +genAuthAPI :: Proxy AuthGenAPI +genAuthAPI = Proxy ``` Now we need to bring everything together for the server. We have the -`AuthHandler Request User` value and an `AuthProtected` endpoint. To bind these +`AuthHandler Request Account` value and an `AuthProtected` endpoint. To bind these together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/type-families.html) instance that tells the `HasServer` instance that our `Context` will supply a -`User` (via `AuthHandler Request User`) and that downstream combinators will -have access to this `User` value (or an error will be thrown if authentication +`Account` (via `AuthHandler Request Account`) and that downstream combinators will +have access to this `Account` value (or an error will be thrown if authentication fails). ```haskell -- | We need to specify the data returned after authentication -type instance AuthServerData (AuthProtect "cookie-auth") = User +type instance AuthServerData (AuthProtect "cookie-auth") = Account ``` Note that we specify the type-level tag `"cookie-auth"` when defining the type @@ -322,19 +332,19 @@ value of type `Server AuthGenAPI`, in addition to the server value: -- | The context that will be made available to request handlers. We supply the -- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance -- of 'AuthProtect' can extract the handler and run it on the request. -serverContext :: Context (AuthHandler Request User ': '[]) -serverContext = authHandler :. EmptyContext +genAuthServerContext :: Context (AuthHandler Request Account ': '[]) +genAuthServerContext = authHandler :. EmptyContext -- | Our API, where we provide all the author-supplied handlers for each end --- point. Note that 'privateDataFunc' is a function that takes 'User' as an +-- point. Note that 'privateDataFunc' is a function that takes 'Account' as an -- argument. We dont' worry about the authentication instrumentation here, -- that is taken care of by supplying context -server :: Server AuthGenAPI -server = - let privateDataFunc (User name) = - return [PrivateData ("this is a secret: " <> name)] - publicData = [PublicData "this is a public piece of data"] - in privateDataFunc :<|> return publicData +genAuthServer :: Server AuthGenAPI +genAuthServer = + let privateDataFunc (Account name) = + return (PrivateData ("this is a secret: " <> name)) + publicData = return [PublicData "this is a public piece of data"] + in privateDataFunc :<|> publicData ``` We're now ready to start our server (and provide a sample session)! @@ -342,7 +352,7 @@ We're now ready to start our server (and provide a sample session)! ```haskell -- | run our server genAuthMain :: IO () -genAuthMain = run 8080 (serveWithContext api serverContext server) +genAuthMain = run 8080 (serveWithContext genAuthAPI genAuthServerContext genAuthServer) {- Sample Session: diff --git a/doc/tutorial/index.rst b/doc/tutorial/index.rst index f2d551a5..1f48cdeb 100644 --- a/doc/tutorial/index.rst +++ b/doc/tutorial/index.rst @@ -21,3 +21,4 @@ through Client.lhs Javascript.lhs Docs.lhs + Authentication.lhs diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 7608a60c..940fce18 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -11,6 +11,7 @@ cabal-version: >=1.10 library exposed-modules: ApiType + , Authentication , Client , Docs , Javascript @@ -23,6 +24,7 @@ library , blaze-html , directory , blaze-markup + , containers , servant == 0.5.* , servant-server == 0.5.* , servant-client == 0.5.* From 5890d5253b2a2c8f428648e5939c683a7b6ab8e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sun, 27 Mar 2016 17:05:59 +0800 Subject: [PATCH 162/180] update changelog --- servant-server/CHANGELOG.md | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index f773491d..cd8dc540 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,5 +1,10 @@ +on master +--------- + +* Query parameters that can't be parsed result in a `400` (was `404`). + 0.5 ----- +--- * Add `Config` machinery (https://github.com/haskell-servant/servant/pull/327). This is a breaking change, as the signatures of both `route`, `serve` and the From 97168459fd7c9ad253389191ce4a527784a706fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Tue, 1 Mar 2016 16:19:13 +0800 Subject: [PATCH 163/180] servant-server: add a test-case for streaming request bodies from client to server --- servant-server/servant-server.cabal | 1 + .../test/Servant/Server/StreamingSpec.hs | 109 ++++++++++++++++++ 2 files changed, 110 insertions(+) create mode 100644 servant-server/test/Servant/Server/StreamingSpec.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index a4609bd5..77302d63 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -109,6 +109,7 @@ test-suite spec Servant.Utils.StaticFilesSpec build-depends: base == 4.* + , base-compat , aeson , bytestring , bytestring-conversion diff --git a/servant-server/test/Servant/Server/StreamingSpec.hs b/servant-server/test/Servant/Server/StreamingSpec.hs new file mode 100644 index 00000000..3752df49 --- /dev/null +++ b/servant-server/test/Servant/Server/StreamingSpec.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module tests whether streaming works from client to server +-- with a server implemented with servant-server. +module Servant.Server.StreamingSpec where + +import Control.Concurrent +import Control.Exception +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Internal +import Prelude () +import Prelude.Compat +import Servant +import qualified System.Timeout +import Test.Hspec + +type TestAPI = + ReqBody '[OctetStream] Lazy.ByteString :> Get '[JSON] NoContent + +testAPI :: Proxy TestAPI +testAPI = Proxy + +spec :: Spec +spec = do + -- The idea of this test is this: + -- + -- - The mock client will + -- - send some data in the request body, but not all, + -- - wait for the server to acknowledge (outside of http, through an MVar) + -- that the server received some data, + -- - send the rest of the request body. + -- - The mock server will + -- - receive some data, + -- - notify the client that it received some data, + -- - receive the rest of the data, + -- - respond with an empty result. + it "client to server can stream lazy ByteStrings" $ timeout $ do + serverReceivedFirstChunk <- newWaiter + + -- - streams some test data + -- - waits for serverReceivedFirstChunk + -- - streams some more test data + streamTestData <- do + mvar :: MVar [IO Strict.ByteString] <- newMVar $ + map return (replicate 1000 "foo") ++ + (waitFor serverReceivedFirstChunk >> return "foo") : + map return (replicate 1000 "foo") + return $ modifyMVar mvar $ \ actions -> case actions of + (a : r) -> (r, ) <$> a + [] -> return ([], "") + + let request = defaultRequest { + requestBody = streamTestData, + requestBodyLength = ChunkedBody + } + + -- - receives the first chunk + -- - notifies serverReceivedFirstChunk + -- - receives the rest of the request + let handler :: Lazy.ByteString -> ExceptT ServantErr IO NoContent + handler input = liftIO $ do + let prefix = Lazy.take 3 input + prefix `shouldBe` "foo" + notify serverReceivedFirstChunk () + input `shouldBe` mconcat (replicate 2001 "foo") + return NoContent + + app = serve testAPI handler + response <- executeRequest app request + statusCode (responseStatus response) `shouldBe` 200 + +executeRequest :: Application -> Request -> IO Response +executeRequest app request = do + responseMVar <- newEmptyMVar + let respond response = do + putMVar responseMVar response + return ResponseReceived + ResponseReceived <- app request respond + takeMVar responseMVar + +timeout :: IO a -> IO a +timeout action = do + result <- System.Timeout.timeout 1000000 action + maybe (throwIO $ ErrorCall "timeout") return result + +-- * waiter + +data Waiter a + = Waiter { + notify :: a -> IO (), + waitFor :: IO a + } + +newWaiter :: IO (Waiter a) +newWaiter = do + mvar <- newEmptyMVar + return $ Waiter { + notify = putMVar mvar, + waitFor = readMVar mvar + } From 7379b7486abebb6be2347710cc14754601dbfd66 Mon Sep 17 00:00:00 2001 From: mbg Date: Mon, 28 Mar 2016 14:11:50 +0100 Subject: [PATCH 164/180] Moved BaseUrl and Manager parameters from the client function to the Client type as discussed in #428 --- servant-client/src/Servant/Client.hs | 93 +++++++++++------------- servant-client/src/Servant/Common/Req.hs | 46 +++++++----- 2 files changed, 70 insertions(+), 69 deletions(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index e73c05a4..fb94fccb 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -27,14 +27,13 @@ module Servant.Client #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad.Trans.Except import Data.ByteString.Lazy (ByteString) import Data.List import Data.Proxy import Data.String.Conversions import Data.Text (unpack) import GHC.TypeLits -import Network.HTTP.Client (Response, Manager) +import Network.HTTP.Client (Response) import Network.HTTP.Media import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as HTTP @@ -58,15 +57,15 @@ import Servant.Common.Req -- > postNewBook :: Book -> ExceptT String IO Book -- > (getAllBooks :<|> postNewBook) = client myApi host manager -- > where host = BaseUrl Http "localhost" 8080 -client :: HasClient layout => Proxy layout -> BaseUrl -> Manager -> Client layout -client p baseurl = clientWithRoute p defReq baseurl +client :: HasClient layout => Proxy layout -> Client layout +client p = clientWithRoute p defReq -- | This class lets us define how each API combinator -- influences the creation of an HTTP request. It's mostly -- an internal class, you can just use 'client'. class HasClient layout where type Client layout :: * - clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Manager -> Client layout + clientWithRoute :: Proxy layout -> Req -> Client layout -- | A client querying function for @a ':<|>' b@ will actually hand you @@ -85,9 +84,9 @@ class HasClient layout where -- > where host = BaseUrl Http "localhost" 8080 instance (HasClient a, HasClient b) => HasClient (a :<|> b) where type Client (a :<|> b) = Client a :<|> Client b - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy a) req baseurl manager :<|> - clientWithRoute (Proxy :: Proxy b) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy a) req :<|> + clientWithRoute (Proxy :: Proxy b) req -- | If you use a 'Capture' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -115,11 +114,9 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) type Client (Capture capture a :> sublayout) = a -> Client sublayout - clientWithRoute Proxy req baseurl manager val = + clientWithRoute Proxy req val = clientWithRoute (Proxy :: Proxy sublayout) (appendToPath p req) - baseurl - manager where p = unpack (toUrlPiece val) @@ -127,27 +124,26 @@ instance OVERLAPPABLE_ -- Note [Non-Empty Content Types] (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) ) => HasClient (Verb method status cts' a) where - type Client (Verb method status cts' a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager + type Client (Verb method status cts' a) = ClientM a + clientWithRoute Proxy req = + snd <$> performRequestCT (Proxy :: Proxy ct) method req where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ (ReflectMethod method) => HasClient (Verb method status cts NoContent) where - type Client (Verb method status cts NoContent) = ExceptT ServantError IO NoContent - clientWithRoute Proxy req baseurl manager = - performRequestNoBody method req baseurl manager >> return NoContent + type Client (Verb method status cts NoContent) = ClientM NoContent + clientWithRoute Proxy req = + performRequestNoBody method req >> return NoContent where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ -- Note [Non-Empty Content Types] ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) ) => HasClient (Verb method status cts' (Headers ls a)) where - type Client (Verb method status cts' (Headers ls a)) - = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager = do + type Client (Verb method status cts' (Headers ls a)) = ClientM (Headers ls a) + clientWithRoute Proxy req = do let method = reflectMethod (Proxy :: Proxy method) - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } @@ -156,10 +152,10 @@ instance OVERLAPPING_ ( BuildHeadersTo ls, ReflectMethod method ) => HasClient (Verb method status cts (Headers ls NoContent)) where type Client (Verb method status cts (Headers ls NoContent)) - = ExceptT ServantError IO (Headers ls NoContent) - clientWithRoute Proxy req baseurl manager = do + = ClientM (Headers ls NoContent) + clientWithRoute Proxy req = do let method = reflectMethod (Proxy :: Proxy method) - hdrs <- performRequestNoBody method req baseurl manager + hdrs <- performRequestNoBody method req return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo hdrs } @@ -197,14 +193,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) type Client (Header sym a :> sublayout) = Maybe a -> Client sublayout - clientWithRoute Proxy req baseurl manager mval = + clientWithRoute Proxy req mval = clientWithRoute (Proxy :: Proxy sublayout) (maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval ) - baseurl - manager where hname = symbolVal (Proxy :: Proxy sym) @@ -252,14 +246,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) Maybe a -> Client sublayout -- if mparam = Nothing, we don't add it to the query string - clientWithRoute Proxy req baseurl manager mparam = + clientWithRoute Proxy req mparam = clientWithRoute (Proxy :: Proxy sublayout) (maybe req (flip (appendToQueryString pname) req . Just) mparamText ) - baseurl - manager where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym) @@ -299,13 +291,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) type Client (QueryParams sym a :> sublayout) = [a] -> Client sublayout - clientWithRoute Proxy req baseurl manager paramlist = + clientWithRoute Proxy req paramlist = clientWithRoute (Proxy :: Proxy sublayout) (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist' ) - baseurl manager where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym) @@ -339,13 +330,12 @@ instance (KnownSymbol sym, HasClient sublayout) type Client (QueryFlag sym :> sublayout) = Bool -> Client sublayout - clientWithRoute Proxy req baseurl manager flag = + clientWithRoute Proxy req flag = clientWithRoute (Proxy :: Proxy sublayout) (if flag then appendToQueryString paramname Nothing req else req ) - baseurl manager where paramname = cs $ symbolVal (Proxy :: Proxy sym) @@ -353,11 +343,12 @@ instance (KnownSymbol sym, HasClient sublayout) -- | Pick a 'Method' and specify where the server you want to query is. You get -- back the full `Response`. instance HasClient Raw where - type Client Raw = H.Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) + type Client Raw + = H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) - clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw - clientWithRoute Proxy req baseurl manager httpMethod = do - performRequest httpMethod req baseurl manager + clientWithRoute :: Proxy Raw -> Req -> Client Raw + clientWithRoute Proxy req httpMethod = do + performRequest httpMethod req -- | If you use a 'ReqBody' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -384,43 +375,41 @@ instance (MimeRender ct a, HasClient sublayout) type Client (ReqBody (ct ': cts) a :> sublayout) = a -> Client sublayout - clientWithRoute Proxy req baseurl manager body = + clientWithRoute Proxy req body = clientWithRoute (Proxy :: Proxy sublayout) (let ctProxy = Proxy :: Proxy ct in setRQBody (mimeRender ctProxy body) (contentType ctProxy) req ) - baseurl manager -- | Make the querying function append @path@ to the request path. instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where type Client (path :> sublayout) = Client sublayout - clientWithRoute Proxy req baseurl manager = + clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy sublayout) (appendToPath p req) - baseurl manager where p = symbolVal (Proxy :: Proxy path) instance HasClient api => HasClient (Vault :> api) where type Client (Vault :> api) = Client api - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy api) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy api) req instance HasClient api => HasClient (RemoteHost :> api) where type Client (RemoteHost :> api) = Client api - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy api) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy api) req instance HasClient api => HasClient (IsSecure :> api) where type Client (IsSecure :> api) = Client api - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy api) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy api) req instance HasClient subapi => HasClient (WithNamedContext name context subapi) where @@ -433,16 +422,16 @@ instance ( HasClient api type Client (AuthProtect tag :> api) = AuthenticateReq (AuthProtect tag) -> Client api - clientWithRoute Proxy req baseurl manager (AuthenticateReq (val,func)) = - clientWithRoute (Proxy :: Proxy api) (func val req) baseurl manager + clientWithRoute Proxy req (AuthenticateReq (val,func)) = + clientWithRoute (Proxy :: Proxy api) (func val req) -- * Basic Authentication instance HasClient api => HasClient (BasicAuth realm usr :> api) where type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api - clientWithRoute Proxy req baseurl manager val = - clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) baseurl manager + clientWithRoute Proxy req val = + clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) {- Note [Non-Empty Content Types] diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 3d72acd9..44551464 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -11,7 +11,9 @@ import Control.Exception import Control.Monad import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) import Data.String import Data.String.Conversions @@ -123,11 +125,21 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) = displayHttpRequest :: Method -> String displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" +type ClientM = ReaderT BaseUrl (ReaderT Manager (ExceptT ServantError IO)) -performRequest :: Method -> Req -> BaseUrl -> Manager - -> ExceptT ServantError IO ( Int, ByteString, MediaType - , [HTTP.Header], Response ByteString) -performRequest reqMethod req reqHost manager = do +runClientM :: ClientM a -> BaseUrl -> Manager -> IO (Either ServantError a) +runClientM m baseUrl manager = runExceptT (runReaderT (runReaderT m baseUrl) manager) + +-- to avoid adding a dependency on mtl +throwError :: ServantError -> ClientM a +throwError = lift . lift . throwE + +performRequest :: Method -> Req + -> ClientM ( Int, ByteString, MediaType + , [HTTP.Header], Response ByteString) +performRequest reqMethod req = do + reqHost <- ask + manager <- lift ask partialRequest <- liftIO $ reqToRequest req reqHost let request = partialRequest { Client.method = reqMethod @@ -137,7 +149,7 @@ performRequest reqMethod req reqHost manager = do eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager case eResponse of Left err -> - throwE . ConnectionError $ SomeException err + throwError . ConnectionError $ SomeException err Right response -> do let status = Client.responseStatus response @@ -147,29 +159,29 @@ performRequest reqMethod req reqHost manager = do ct <- case lookup "Content-Type" $ Client.responseHeaders response of Nothing -> pure $ "application"//"octet-stream" Just t -> case parseAccept t of - Nothing -> throwE $ InvalidContentTypeHeader (cs t) body + Nothing -> throwError $ InvalidContentTypeHeader (cs t) body Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ - throwE $ FailureResponse status ct body + throwError $ FailureResponse status ct body return (status_code, body, ct, hdrs, response) performRequestCT :: MimeUnrender ct result => - Proxy ct -> Method -> Req -> BaseUrl -> Manager - -> ExceptT ServantError IO ([HTTP.Header], result) -performRequestCT ct reqMethod req reqHost manager = do + Proxy ct -> Method -> Req + -> ClientM ([HTTP.Header], result) +performRequestCT ct reqMethod req = do let acceptCT = contentType ct (_status, respBody, respCT, hdrs, _response) <- - performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager - unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody + performRequest reqMethod (req { reqAccept = [acceptCT] }) + unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of - Left err -> throwE $ DecodeFailure err respCT respBody + Left err -> throwError $ DecodeFailure err respCT respBody Right val -> return (hdrs, val) -performRequestNoBody :: Method -> Req -> BaseUrl -> Manager - -> ExceptT ServantError IO [HTTP.Header] -performRequestNoBody reqMethod req reqHost manager = do - (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager +performRequestNoBody :: Method -> Req + -> ClientM [HTTP.Header] +performRequestNoBody reqMethod req = do + (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req return hdrs catchConnectionError :: IO a -> IO (Either ServantError a) From 89b0758dc85465b7ff1f85a145ea96700ddaddb6 Mon Sep 17 00:00:00 2001 From: mbg Date: Mon, 28 Mar 2016 14:52:33 +0100 Subject: [PATCH 165/180] Changed servant-client tests to reflect the changes to the client function --- servant-client/test/Servant/ClientSpec.hs | 99 ++++++++++++----------- 1 file changed, 50 insertions(+), 49 deletions(-) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 0ad3b70e..f998fb31 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -28,7 +28,7 @@ import Control.Applicative ((<$>)) import Control.Arrow (left) import Control.Concurrent (forkIO, killThread, ThreadId) import Control.Exception (bracket) -import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Control.Monad.Trans.Except (ExceptT, throwE) import Data.Aeson import Data.Char (chr, isPrint) import Data.Foldable (forM_) @@ -208,47 +208,48 @@ sucessSpec :: Spec sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "Servant.API.Get" $ \(_, baseUrl) -> do - let getGet = getNth (Proxy :: Proxy 0) $ client api baseUrl manager - (left show <$> runExceptT getGet) `shouldReturn` Right alice + let getGet = getNth (Proxy :: Proxy 0) $ client api + (left show <$> SCR.runClientM getGet baseUrl manager) `shouldReturn` Right alice describe "Servant.API.Delete" $ do it "allows empty content type" $ \(_, baseUrl) -> do - let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager - (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right NoContent + let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api + (left show <$> SCR.runClientM getDeleteEmpty baseUrl manager) `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do - let getDeleteContentType = getLast $ client api baseUrl manager - (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right NoContent + let getDeleteContentType :: SCR.ClientM NoContent + getDeleteContentType = getLast $ client api + (left show <$> SCR.runClientM getDeleteContentType baseUrl manager) `shouldReturn` Right NoContent it "Servant.API.Capture" $ \(_, baseUrl) -> do - let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager - (left show <$> runExceptT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0) + let getCapture = getNth (Proxy :: Proxy 2) $ client api + (left show <$> SCR.runClientM (getCapture "Paula") baseUrl manager) `shouldReturn` Right (Person "Paula" 0) it "Servant.API.ReqBody" $ \(_, baseUrl) -> do let p = Person "Clara" 42 - getBody = getNth (Proxy :: Proxy 3) $ client api baseUrl manager - (left show <$> runExceptT (getBody p)) `shouldReturn` Right p + getBody = getNth (Proxy :: Proxy 3) $ client api + (left show <$> SCR.runClientM (getBody p) baseUrl manager) `shouldReturn` Right p it "Servant.API.QueryParam" $ \(_, baseUrl) -> do - let getQueryParam = getNth (Proxy :: Proxy 4) $ client api baseUrl manager - left show <$> runExceptT (getQueryParam (Just "alice")) `shouldReturn` Right alice - Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob")) + let getQueryParam = getNth (Proxy :: Proxy 4) $ client api + left show <$> SCR.runClientM (getQueryParam (Just "alice")) baseUrl manager `shouldReturn` Right alice + Left FailureResponse{..} <- SCR.runClientM (getQueryParam (Just "bob")) baseUrl manager responseStatus `shouldBe` Status 400 "bob not found" it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do - let getQueryParams = getNth (Proxy :: Proxy 5) $ client api baseUrl manager - (left show <$> runExceptT (getQueryParams [])) `shouldReturn` Right [] - (left show <$> runExceptT (getQueryParams ["alice", "bob"])) + let getQueryParams = getNth (Proxy :: Proxy 5) $ client api + (left show <$> SCR.runClientM (getQueryParams []) baseUrl manager) `shouldReturn` Right [] + (left show <$> SCR.runClientM (getQueryParams ["alice", "bob"]) baseUrl manager) `shouldReturn` Right [Person "alice" 0, Person "bob" 1] context "Servant.API.QueryParam.QueryFlag" $ forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do - let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api baseUrl manager - (left show <$> runExceptT (getQueryFlag flag)) `shouldReturn` Right flag + let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api + (left show <$> SCR.runClientM (getQueryFlag flag) baseUrl manager) `shouldReturn` Right flag it "Servant.API.Raw on success" $ \(_, baseUrl) -> do - let getRawSuccess = getNth (Proxy :: Proxy 7) $ client api baseUrl manager - res <- runExceptT (getRawSuccess methodGet) + let getRawSuccess = getNth (Proxy :: Proxy 7) $ client api + res <- SCR.runClientM (getRawSuccess methodGet) baseUrl manager case res of Left e -> assertFailure $ show e Right (code, body, ct, _, response) -> do @@ -257,8 +258,8 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do C.responseStatus response `shouldBe` ok200 it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do - let getRawFailure = getNth (Proxy :: Proxy 8) $ client api baseUrl manager - res <- runExceptT (getRawFailure methodGet) + let getRawFailure = getNth (Proxy :: Proxy 8) $ client api + res <- SCR.runClientM (getRawFailure methodGet) baseUrl manager case res of Right _ -> assertFailure "expected Left, but got Right" Left e -> do @@ -266,18 +267,18 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do Servant.Client.responseBody e `shouldBe` "rawFailure" it "Returns headers appropriately" $ \(_, baseUrl) -> do - let getRespHeaders = getNth (Proxy :: Proxy 10) $ client api baseUrl manager - res <- runExceptT getRespHeaders + let getRespHeaders = getNth (Proxy :: Proxy 10) $ client api + res <- SCR.runClientM getRespHeaders baseUrl manager case res of Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] modifyMaxSuccess (const 20) $ do it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> - let getMultiple = getNth (Proxy :: Proxy 9) $ client api baseUrl manager + let getMultiple = getNth (Proxy :: Proxy 9) $ client api in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> ioProperty $ do - result <- left show <$> runExceptT (getMultiple cap num flag body) + result <- left show <$> SCR.runClientM (getMultiple cap num flag body) baseUrl manager return $ result === Right (cap, num, flag, body) @@ -289,9 +290,9 @@ wrappedApiSpec = describe "error status codes" $ do let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do - let getResponse :: ExceptT ServantError IO () - getResponse = client api baseUrl manager - Left FailureResponse{..} <- runExceptT getResponse + let getResponse :: SCR.ClientM () + getResponse = client api + Left FailureResponse{..} <- SCR.runClientM getResponse baseUrl manager responseStatus `shouldBe` (Status 500 "error message") in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : @@ -305,43 +306,43 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do - let (_ :<|> getDeleteEmpty :<|> _) = client api baseUrl manager - Left res <- runExceptT getDeleteEmpty + let (_ :<|> getDeleteEmpty :<|> _) = client api + Left res <- SCR.runClientM getDeleteEmpty baseUrl manager case res of FailureResponse (Status 404 "Not Found") _ _ -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> getCapture :<|> _) = client api baseUrl manager - Left res <- runExceptT (getCapture "foo") + let (_ :<|> _ :<|> getCapture :<|> _) = client api + Left res <- SCR.runClientM (getCapture "foo") baseUrl manager case res of DecodeFailure _ ("application/json") _ -> return () _ -> fail $ "expected DecodeFailure, but got " <> show res it "reports ConnectionError" $ \_ -> do - let (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "") manager - Left res <- runExceptT getGetWrongHost + let (getGetWrongHost :<|> _) = client api + Left res <- SCR.runClientM getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "") manager case res of ConnectionError _ -> return () _ -> fail $ "expected ConnectionError, but got " <> show res it "reports UnsupportedContentType" $ \(_, baseUrl) -> do - let (getGet :<|> _ ) = client api baseUrl manager - Left res <- runExceptT getGet + let (getGet :<|> _ ) = client api + Left res <- SCR.runClientM getGet baseUrl manager case res of UnsupportedContentType ("application/octet-stream") _ -> return () _ -> fail $ "expected UnsupportedContentType, but got " <> show res it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api baseUrl manager - Left res <- runExceptT (getBody alice) + let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api + Left res <- SCR.runClientM (getBody alice) baseUrl manager case res of InvalidContentTypeHeader "fooooo" _ -> return () _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a, - HasClient api, Client api ~ ExceptT ServantError IO ()) => + HasClient api, Client api ~ SCR.ClientM ()) => Proxy api -> WrappedApi basicAuthSpec :: Spec @@ -349,16 +350,16 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d context "Authentication works when requests are properly authenticated" $ do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do - let getBasic = client basicAuthAPI baseUrl manager + let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "servant" "server" - (left show <$> runExceptT (getBasic basicAuthData)) `shouldReturn` Right alice + (left show <$> SCR.runClientM (getBasic basicAuthData) baseUrl manager) `shouldReturn` Right alice context "Authentication is rejected when requests are not authenticated properly" $ do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do - let getBasic = client basicAuthAPI baseUrl manager + let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "not" "password" - Left FailureResponse{..} <- runExceptT (getBasic basicAuthData) + Left FailureResponse{..} <- SCR.runClientM (getBasic basicAuthData) baseUrl manager responseStatus `shouldBe` Status 403 "Forbidden" genAuthSpec :: Spec @@ -366,16 +367,16 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do context "Authentication works when requests are properly authenticated" $ do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do - let getProtected = client genAuthAPI baseUrl manager + let getProtected = client genAuthAPI let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req) - (left show <$> runExceptT (getProtected authRequest)) `shouldReturn` Right alice + (left show <$> SCR.runClientM (getProtected authRequest) baseUrl manager) `shouldReturn` Right alice context "Authentication is rejected when requests are not authenticated properly" $ do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do - let getProtected = client genAuthAPI baseUrl manager + let getProtected = client genAuthAPI let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req) - Left FailureResponse{..} <- runExceptT (getProtected authRequest) + Left FailureResponse{..} <- SCR.runClientM (getProtected authRequest) baseUrl manager responseStatus `shouldBe` (Status 401 "Unauthorized") -- * utils From 316737c16daa7fa06ebf90490a921285ece18f82 Mon Sep 17 00:00:00 2001 From: mbg Date: Mon, 28 Mar 2016 14:56:50 +0100 Subject: [PATCH 166/180] Updated documentation in Client.hs to reflect the changes to the client function --- servant-client/src/Servant/Client.hs | 44 ++++++++++++---------------- 1 file changed, 18 insertions(+), 26 deletions(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index fb94fccb..91c07bcb 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -53,10 +53,9 @@ import Servant.Common.Req -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getAllBooks :: ExceptT String IO [Book] --- > postNewBook :: Book -> ExceptT String IO Book --- > (getAllBooks :<|> postNewBook) = client myApi host manager --- > where host = BaseUrl Http "localhost" 8080 +-- > getAllBooks :: ClientM [Book] +-- > postNewBook :: Book -> ClientM Book +-- > (getAllBooks :<|> postNewBook) = client myApi client :: HasClient layout => Proxy layout -> Client layout client p = clientWithRoute p defReq @@ -78,10 +77,9 @@ class HasClient layout where -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getAllBooks :: ExceptT String IO [Book] --- > postNewBook :: Book -> ExceptT String IO Book --- > (getAllBooks :<|> postNewBook) = client myApi host manager --- > where host = BaseUrl Http "localhost" 8080 +-- > getAllBooks :: ClientM [Book] +-- > postNewBook :: Book -> ClientM Book +-- > (getAllBooks :<|> postNewBook) = client myApi instance (HasClient a, HasClient b) => HasClient (a :<|> b) where type Client (a :<|> b) = Client a :<|> Client b clientWithRoute Proxy req = @@ -104,9 +102,8 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBook :: Text -> ExceptT String IO Book --- > getBook = client myApi host manager --- > where host = BaseUrl Http "localhost" 8080 +-- > getBook :: Text -> ClientM Book +-- > getBook = client myApi -- > -- then you can just use "getBook" to query that endpoint instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) => HasClient (Capture capture a :> sublayout) where @@ -182,9 +179,8 @@ instance OVERLAPPING_ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > viewReferer :: Maybe Referer -> ExceptT String IO Book --- > viewReferer = client myApi host --- > where host = BaseUrl Http "localhost" 8080 +-- > viewReferer :: Maybe Referer -> ClientM Book +-- > viewReferer = client myApi -- > -- then you can just use "viewRefer" to query that endpoint -- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) @@ -233,9 +229,8 @@ instance HasClient sublayout -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooksBy :: Maybe Text -> ExceptT String IO [Book] --- > getBooksBy = client myApi host --- > where host = BaseUrl Http "localhost" 8080 +-- > getBooksBy :: Maybe Text -> ClientM [Book] +-- > getBooksBy = client myApi -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooksBy Nothing' for all books -- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov @@ -278,9 +273,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooksBy :: [Text] -> ExceptT String IO [Book] --- > getBooksBy = client myApi host --- > where host = BaseUrl Http "localhost" 8080 +-- > getBooksBy :: [Text] -> ClientM [Book] +-- > getBooksBy = client myApi -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooksBy []' for all books -- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' @@ -318,9 +312,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooks :: Bool -> ExceptT String IO [Book] --- > getBooks = client myApi host --- > where host = BaseUrl Http "localhost" 8080 +-- > getBooks :: Bool -> ClientM [Book] +-- > getBooks = client myApi -- > -- then you can just use "getBooks" to query that endpoint. -- > -- 'getBooksBy False' for all books -- > -- 'getBooksBy True' to only get _already published_ books @@ -365,9 +358,8 @@ instance HasClient Raw where -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > addBook :: Book -> ExceptT String IO Book --- > addBook = client myApi host manager --- > where host = BaseUrl Http "localhost" 8080 +-- > addBook :: Book -> ClientM Book +-- > addBook = client myApi -- > -- then you can just use "addBook" to query that endpoint instance (MimeRender ct a, HasClient sublayout) => HasClient (ReqBody (ct ': cts) a :> sublayout) where From 19a4e037d8c262da47c5be735392fdd7210499d8 Mon Sep 17 00:00:00 2001 From: mbg Date: Mon, 28 Mar 2016 15:27:51 +0100 Subject: [PATCH 167/180] Updated tutorial to reflect the updated `client` function in servant-client --- doc/tutorial/Client.lhs | 32 ++++++++++---------------------- 1 file changed, 10 insertions(+), 22 deletions(-) diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index 9cb38a0e..67f38357 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -15,14 +15,13 @@ need to have some language extensions and imports: module Client where -import Control.Monad.Trans.Except import Data.Aeson import Data.Proxy import GHC.Generics -import Network.HTTP.Client (Manager, newManager, defaultManagerSettings) +import Network.HTTP.Client (newManager, defaultManagerSettings) import Servant.API import Servant.Client -import System.IO.Unsafe +import Servant.Common.Req (ClientM, runClientM) ``` Also, we need examples for some domain specific data types: @@ -72,40 +71,28 @@ What we are going to get with **servant-client** here is 3 functions, one to que ``` haskell position :: Int -- ^ value for "x" -> Int -- ^ value for "y" - -> ExceptT ServantError IO Position + -> ClientM Position hello :: Maybe String -- ^ an optional value for "name" - -> ExceptT ServantError IO HelloMessage + -> ClientM HelloMessage marketing :: ClientInfo -- ^ value for the request body - -> ExceptT ServantError IO Email + -> ClientM Email ``` Each function makes available as an argument any value that the response may depend on, as evidenced in the API type. How do we get these functions? By calling -the function `client`. It takes three arguments: +the function `client`. It takes one argument: - a `Proxy` to your API, -- a `BaseUrl`, consisting of the protocol, the host, the port and an optional subpath -- - this basically tells `client` where the service that you want to query is hosted, -- a `Manager`, (from [http-client](http://hackage.haskell.org/package/http-client)) -which manages http connections. ``` haskell api :: Proxy API api = Proxy -{-# NOINLINE __manager #-} -__manager :: Manager -__manager = unsafePerformIO $ newManager defaultManagerSettings - -position :<|> hello :<|> marketing = - client api (BaseUrl Http "localhost" 8081 "") __manager +position :<|> hello :<|> marketing = client api ``` -(Yes, the usage of `unsafePerformIO` is very ugly, we know. Hopefully soon it'll -be possible to do without.) - As you can see in the code above, we just "pattern match our way" to these functions. If we try to derive less or more functions than there are endpoints in the API, we obviously get an error. The `BaseUrl` value there is just: ``` haskell ignore @@ -127,7 +114,7 @@ data BaseUrl = BaseUrl That's it. Let's now write some code that uses our client functions. ``` haskell -queries :: ExceptT ServantError IO (Position, HelloMessage, Email) +queries :: ClientM (Position, HelloMessage, Email) queries = do pos <- position 10 10 message <- hello (Just "servant") @@ -136,7 +123,8 @@ queries = do run :: IO () run = do - res <- runExceptT queries + manager <- newManager defaultManagerSettings + res <- runClientM queries (BaseUrl Http "localhost" 8081 "") manager case res of Left err -> putStrLn $ "Error: " ++ show err Right (pos, message, em) -> do From 41129e98b3459d3ebf0153c186462f2b69aa72a0 Mon Sep 17 00:00:00 2001 From: mbg Date: Mon, 28 Mar 2016 18:01:53 +0100 Subject: [PATCH 168/180] Removed GetNth and GetLast type classes --- servant-client/test/Servant/ClientSpec.hs | 117 ++++++++++++---------- 1 file changed, 64 insertions(+), 53 deletions(-) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index f998fb31..999c69c9 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -30,17 +30,16 @@ import Control.Concurrent (forkIO, killThread, ThreadId) import Control.Exception (bracket) import Control.Monad.Trans.Except (ExceptT, throwE) import Data.Aeson +import qualified Data.ByteString.Lazy as BS import Data.Char (chr, isPrint) import Data.Foldable (forM_) import Data.Monoid hiding (getLast) import Data.Proxy import qualified Data.Text as T import GHC.Generics (Generic) -import GHC.TypeLits import qualified Network.HTTP.Client as C import Network.HTTP.Media -import Network.HTTP.Types (Status (..), badRequest400, - methodGet, ok200, status400) +import qualified Network.HTTP.Types as HTTP import Network.Socket import Network.Wai (Application, Request, requestHeaders, responseLBS) @@ -120,6 +119,53 @@ type Api = api :: Proxy Api api = Proxy +getGet :: SCR.ClientM Person +getDeleteEmpty :: SCR.ClientM NoContent +getCapture :: String + -> SCR.ClientM Person +getBody :: Person + -> SCR.ClientM Person +getQueryParam :: Maybe String + -> SCR.ClientM Person +getQueryParams :: [String] + -> SCR.ClientM [Person] +getQueryFlag :: Bool + -> SCR.ClientM Bool +getRawSuccess :: HTTP.Method + -> SCR.ClientM ( Int + , BS.ByteString + , MediaType + , [HTTP.Header] + , C.Response BS.ByteString ) +getRawFailure :: HTTP.Method + -> SCR.ClientM ( Int + , BS.ByteString + , MediaType + , [HTTP.Header] + , C.Response BS.ByteString ) +getMultiple :: String + -> Maybe Int + -> Bool + -> [(String, [Rational])] + -> SCR.ClientM ( String + , Maybe Int + , Bool + , [(String, [Rational])] ) +getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool) +getDeleteContentType :: SCR.ClientM NoContent +getGet + :<|> getDeleteEmpty + :<|> getCapture + :<|> getBody + :<|> getQueryParam + :<|> getQueryParams + :<|> getQueryFlag + :<|> getRawSuccess + :<|> getRawFailure + :<|> getMultiple + :<|> getRespHeaders + :<|> getDeleteContentType = client api + server :: Application server = serve api ( return alice @@ -132,8 +178,8 @@ server = serve api ( Nothing -> throwE $ ServantErr 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return - :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") - :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") + :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") + :<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> return NoContent @@ -149,9 +195,9 @@ failApi = Proxy failServer :: Application failServer = serve failApi ( - (\ _request respond -> respond $ responseLBS ok200 [] "") - :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "") - :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") + (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "") + :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "") + :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "") ) -- * basic auth stuff @@ -208,66 +254,54 @@ sucessSpec :: Spec sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "Servant.API.Get" $ \(_, baseUrl) -> do - let getGet = getNth (Proxy :: Proxy 0) $ client api (left show <$> SCR.runClientM getGet baseUrl manager) `shouldReturn` Right alice describe "Servant.API.Delete" $ do it "allows empty content type" $ \(_, baseUrl) -> do - let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api (left show <$> SCR.runClientM getDeleteEmpty baseUrl manager) `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do - let getDeleteContentType :: SCR.ClientM NoContent - getDeleteContentType = getLast $ client api (left show <$> SCR.runClientM getDeleteContentType baseUrl manager) `shouldReturn` Right NoContent it "Servant.API.Capture" $ \(_, baseUrl) -> do - let getCapture = getNth (Proxy :: Proxy 2) $ client api (left show <$> SCR.runClientM (getCapture "Paula") baseUrl manager) `shouldReturn` Right (Person "Paula" 0) it "Servant.API.ReqBody" $ \(_, baseUrl) -> do let p = Person "Clara" 42 - getBody = getNth (Proxy :: Proxy 3) $ client api (left show <$> SCR.runClientM (getBody p) baseUrl manager) `shouldReturn` Right p it "Servant.API.QueryParam" $ \(_, baseUrl) -> do - let getQueryParam = getNth (Proxy :: Proxy 4) $ client api left show <$> SCR.runClientM (getQueryParam (Just "alice")) baseUrl manager `shouldReturn` Right alice Left FailureResponse{..} <- SCR.runClientM (getQueryParam (Just "bob")) baseUrl manager - responseStatus `shouldBe` Status 400 "bob not found" + responseStatus `shouldBe` HTTP.Status 400 "bob not found" it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do - let getQueryParams = getNth (Proxy :: Proxy 5) $ client api (left show <$> SCR.runClientM (getQueryParams []) baseUrl manager) `shouldReturn` Right [] (left show <$> SCR.runClientM (getQueryParams ["alice", "bob"]) baseUrl manager) `shouldReturn` Right [Person "alice" 0, Person "bob" 1] context "Servant.API.QueryParam.QueryFlag" $ forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do - let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api (left show <$> SCR.runClientM (getQueryFlag flag) baseUrl manager) `shouldReturn` Right flag it "Servant.API.Raw on success" $ \(_, baseUrl) -> do - let getRawSuccess = getNth (Proxy :: Proxy 7) $ client api - res <- SCR.runClientM (getRawSuccess methodGet) baseUrl manager + res <- SCR.runClientM (getRawSuccess HTTP.methodGet) baseUrl manager case res of Left e -> assertFailure $ show e Right (code, body, ct, _, response) -> do (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream") C.responseBody response `shouldBe` body - C.responseStatus response `shouldBe` ok200 + C.responseStatus response `shouldBe` HTTP.ok200 it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do - let getRawFailure = getNth (Proxy :: Proxy 8) $ client api - res <- SCR.runClientM (getRawFailure methodGet) baseUrl manager + res <- SCR.runClientM (getRawFailure HTTP.methodGet) baseUrl manager case res of Right _ -> assertFailure "expected Left, but got Right" Left e -> do - Servant.Client.responseStatus e `shouldBe` status400 + Servant.Client.responseStatus e `shouldBe` HTTP.status400 Servant.Client.responseBody e `shouldBe` "rawFailure" it "Returns headers appropriately" $ \(_, baseUrl) -> do - let getRespHeaders = getNth (Proxy :: Proxy 10) $ client api res <- SCR.runClientM getRespHeaders baseUrl manager case res of Left e -> assertFailure $ show e @@ -275,8 +309,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do modifyMaxSuccess (const 20) $ do it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> - let getMultiple = getNth (Proxy :: Proxy 9) $ client api - in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> + property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> ioProperty $ do result <- left show <$> SCR.runClientM (getMultiple cap num flag body) baseUrl manager return $ @@ -293,7 +326,7 @@ wrappedApiSpec = describe "error status codes" $ do let getResponse :: SCR.ClientM () getResponse = client api Left FailureResponse{..} <- SCR.runClientM getResponse baseUrl manager - responseStatus `shouldBe` (Status 500 "error message") + responseStatus `shouldBe` (HTTP.Status 500 "error message") in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : @@ -309,7 +342,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do let (_ :<|> getDeleteEmpty :<|> _) = client api Left res <- SCR.runClientM getDeleteEmpty baseUrl manager case res of - FailureResponse (Status 404 "Not Found") _ _ -> return () + FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do @@ -360,7 +393,7 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "not" "password" Left FailureResponse{..} <- SCR.runClientM (getBasic basicAuthData) baseUrl manager - responseStatus `shouldBe` Status 403 "Forbidden" + responseStatus `shouldBe` HTTP.Status 403 "Forbidden" genAuthSpec :: Spec genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do @@ -377,7 +410,7 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do let getProtected = client genAuthAPI let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req) Left FailureResponse{..} <- SCR.runClientM (getProtected authRequest) baseUrl manager - responseStatus `shouldBe` (Status 401 "Unauthorized") + responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized") -- * utils @@ -408,25 +441,3 @@ pathGen = fmap NonEmpty path filter (not . (`elem` ("?%[]/#;" :: String))) $ filter isPrint $ map chr [0..127] - -class GetNth (n :: Nat) a b | n a -> b where - getNth :: Proxy n -> a -> b - -instance OVERLAPPING_ - GetNth 0 (x :<|> y) x where - getNth _ (x :<|> _) = x - -instance OVERLAPPING_ - (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where - getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x - -class GetLast a b | a -> b where - getLast :: a -> b - -instance OVERLAPPING_ - (GetLast b c) => GetLast (a :<|> b) c where - getLast (_ :<|> b) = getLast b - -instance OVERLAPPING_ - GetLast a a where - getLast a = a From 9e1ba9221d980353d86fc836f7efc673ecc2329a Mon Sep 17 00:00:00 2001 From: mbg Date: Wed, 30 Mar 2016 22:41:39 +0100 Subject: [PATCH 169/180] Manager and BaseUrl are now explicit parameters of all client functions, instead of ReaderTs --- servant-client/src/Servant/Client.hs | 50 ++++----- servant-client/src/Servant/Common/Req.hs | 39 +++---- servant-client/test/Servant/ClientSpec.hs | 125 +++++++++------------- 3 files changed, 93 insertions(+), 121 deletions(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 91c07bcb..9c2fcfbc 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -33,7 +33,7 @@ import Data.Proxy import Data.String.Conversions import Data.Text (unpack) import GHC.TypeLits -import Network.HTTP.Client (Response) +import Network.HTTP.Client (Manager, Response) import Network.HTTP.Media import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as HTTP @@ -53,8 +53,8 @@ import Servant.Common.Req -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getAllBooks :: ClientM [Book] --- > postNewBook :: Book -> ClientM Book +-- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book] +-- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book -- > (getAllBooks :<|> postNewBook) = client myApi client :: HasClient layout => Proxy layout -> Client layout client p = clientWithRoute p defReq @@ -77,8 +77,8 @@ class HasClient layout where -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getAllBooks :: ClientM [Book] --- > postNewBook :: Book -> ClientM Book +-- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book] +-- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book -- > (getAllBooks :<|> postNewBook) = client myApi instance (HasClient a, HasClient b) => HasClient (a :<|> b) where type Client (a :<|> b) = Client a :<|> Client b @@ -102,7 +102,7 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBook :: Text -> ClientM Book +-- > getBook :: Text -> Manager -> BaseUrl -> ClientM Book -- > getBook = client myApi -- > -- then you can just use "getBook" to query that endpoint instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) @@ -121,26 +121,28 @@ instance OVERLAPPABLE_ -- Note [Non-Empty Content Types] (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) ) => HasClient (Verb method status cts' a) where - type Client (Verb method status cts' a) = ClientM a - clientWithRoute Proxy req = - snd <$> performRequestCT (Proxy :: Proxy ct) method req + type Client (Verb method status cts' a) = Manager -> BaseUrl -> ClientM a + clientWithRoute Proxy req manager baseurl = + snd <$> performRequestCT (Proxy :: Proxy ct) method req manager baseurl where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ (ReflectMethod method) => HasClient (Verb method status cts NoContent) where - type Client (Verb method status cts NoContent) = ClientM NoContent - clientWithRoute Proxy req = - performRequestNoBody method req >> return NoContent + type Client (Verb method status cts NoContent) + = Manager -> BaseUrl -> ClientM NoContent + clientWithRoute Proxy req manager baseurl = + performRequestNoBody method req manager baseurl >> return NoContent where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ -- Note [Non-Empty Content Types] ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) ) => HasClient (Verb method status cts' (Headers ls a)) where - type Client (Verb method status cts' (Headers ls a)) = ClientM (Headers ls a) - clientWithRoute Proxy req = do + type Client (Verb method status cts' (Headers ls a)) + = Manager -> BaseUrl -> ClientM (Headers ls a) + clientWithRoute Proxy req manager baseurl = do let method = reflectMethod (Proxy :: Proxy method) - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req manager baseurl return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } @@ -149,10 +151,10 @@ instance OVERLAPPING_ ( BuildHeadersTo ls, ReflectMethod method ) => HasClient (Verb method status cts (Headers ls NoContent)) where type Client (Verb method status cts (Headers ls NoContent)) - = ClientM (Headers ls NoContent) - clientWithRoute Proxy req = do + = Manager -> BaseUrl -> ClientM (Headers ls NoContent) + clientWithRoute Proxy req manager baseurl = do let method = reflectMethod (Proxy :: Proxy method) - hdrs <- performRequestNoBody method req + hdrs <- performRequestNoBody method req manager baseurl return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo hdrs } @@ -179,7 +181,7 @@ instance OVERLAPPING_ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > viewReferer :: Maybe Referer -> ClientM Book +-- > viewReferer :: Maybe Referer -> Manager -> BaseUrl -> ClientM Book -- > viewReferer = client myApi -- > -- then you can just use "viewRefer" to query that endpoint -- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments @@ -229,7 +231,7 @@ instance HasClient sublayout -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooksBy :: Maybe Text -> ClientM [Book] +-- > getBooksBy :: Maybe Text -> Manager -> BaseUrl -> ClientM [Book] -- > getBooksBy = client myApi -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooksBy Nothing' for all books @@ -273,7 +275,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooksBy :: [Text] -> ClientM [Book] +-- > getBooksBy :: [Text] -> Manager -> BaseUrl -> ClientM [Book] -- > getBooksBy = client myApi -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooksBy []' for all books @@ -312,7 +314,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooks :: Bool -> ClientM [Book] +-- > getBooks :: Bool -> Manager -> BaseUrl -> ClientM [Book] -- > getBooks = client myApi -- > -- then you can just use "getBooks" to query that endpoint. -- > -- 'getBooksBy False' for all books @@ -337,7 +339,7 @@ instance (KnownSymbol sym, HasClient sublayout) -- back the full `Response`. instance HasClient Raw where type Client Raw - = H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) + = H.Method -> Manager -> BaseUrl -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) clientWithRoute :: Proxy Raw -> Req -> Client Raw clientWithRoute Proxy req httpMethod = do @@ -358,7 +360,7 @@ instance HasClient Raw where -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > addBook :: Book -> ClientM Book +-- > addBook :: Book -> Manager -> BaseUrl -> ClientM Book -- > addBook = client myApi -- > -- then you can just use "addBook" to query that endpoint instance (MimeRender ct a, HasClient sublayout) diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 44551464..52398637 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -11,9 +11,7 @@ import Control.Exception import Control.Monad import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class -import Control.Monad.Trans.Class import Control.Monad.Trans.Except -import Control.Monad.Trans.Reader import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) import Data.String import Data.String.Conversions @@ -125,21 +123,12 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) = displayHttpRequest :: Method -> String displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" -type ClientM = ReaderT BaseUrl (ReaderT Manager (ExceptT ServantError IO)) +type ClientM = ExceptT ServantError IO -runClientM :: ClientM a -> BaseUrl -> Manager -> IO (Either ServantError a) -runClientM m baseUrl manager = runExceptT (runReaderT (runReaderT m baseUrl) manager) - --- to avoid adding a dependency on mtl -throwError :: ServantError -> ClientM a -throwError = lift . lift . throwE - -performRequest :: Method -> Req +performRequest :: Method -> Req -> Manager -> BaseUrl -> ClientM ( Int, ByteString, MediaType , [HTTP.Header], Response ByteString) -performRequest reqMethod req = do - reqHost <- ask - manager <- lift ask +performRequest reqMethod req manager reqHost = do partialRequest <- liftIO $ reqToRequest req reqHost let request = partialRequest { Client.method = reqMethod @@ -149,7 +138,7 @@ performRequest reqMethod req = do eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager case eResponse of Left err -> - throwError . ConnectionError $ SomeException err + throwE . ConnectionError $ SomeException err Right response -> do let status = Client.responseStatus response @@ -159,29 +148,29 @@ performRequest reqMethod req = do ct <- case lookup "Content-Type" $ Client.responseHeaders response of Nothing -> pure $ "application"//"octet-stream" Just t -> case parseAccept t of - Nothing -> throwError $ InvalidContentTypeHeader (cs t) body + Nothing -> throwE $ InvalidContentTypeHeader (cs t) body Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ - throwError $ FailureResponse status ct body + throwE $ FailureResponse status ct body return (status_code, body, ct, hdrs, response) performRequestCT :: MimeUnrender ct result => - Proxy ct -> Method -> Req + Proxy ct -> Method -> Req -> Manager -> BaseUrl -> ClientM ([HTTP.Header], result) -performRequestCT ct reqMethod req = do +performRequestCT ct reqMethod req manager reqHost = do let acceptCT = contentType ct (_status, respBody, respCT, hdrs, _response) <- - performRequest reqMethod (req { reqAccept = [acceptCT] }) - unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody + performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost + unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of - Left err -> throwError $ DecodeFailure err respCT respBody + Left err -> throwE $ DecodeFailure err respCT respBody Right val -> return (hdrs, val) -performRequestNoBody :: Method -> Req +performRequestNoBody :: Method -> Req -> Manager -> BaseUrl -> ClientM [HTTP.Header] -performRequestNoBody reqMethod req = do - (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req +performRequestNoBody reqMethod req manager reqHost = do + (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost return hdrs catchConnectionError :: IO a -> IO (Either ServantError a) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 999c69c9..2263e9e2 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -28,7 +28,7 @@ import Control.Applicative ((<$>)) import Control.Arrow (left) import Control.Concurrent (forkIO, killThread, ThreadId) import Control.Exception (bracket) -import Control.Monad.Trans.Except (ExceptT, throwE) +import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT) import Data.Aeson import qualified Data.ByteString.Lazy as BS import Data.Char (chr, isPrint) @@ -119,52 +119,33 @@ type Api = api :: Proxy Api api = Proxy -getGet :: SCR.ClientM Person -getDeleteEmpty :: SCR.ClientM NoContent -getCapture :: String - -> SCR.ClientM Person -getBody :: Person - -> SCR.ClientM Person -getQueryParam :: Maybe String - -> SCR.ClientM Person -getQueryParams :: [String] - -> SCR.ClientM [Person] -getQueryFlag :: Bool - -> SCR.ClientM Bool -getRawSuccess :: HTTP.Method - -> SCR.ClientM ( Int - , BS.ByteString - , MediaType - , [HTTP.Header] - , C.Response BS.ByteString ) -getRawFailure :: HTTP.Method - -> SCR.ClientM ( Int - , BS.ByteString - , MediaType - , [HTTP.Header] - , C.Response BS.ByteString ) -getMultiple :: String - -> Maybe Int - -> Bool - -> [(String, [Rational])] - -> SCR.ClientM ( String - , Maybe Int - , Bool - , [(String, [Rational])] ) -getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool) -getDeleteContentType :: SCR.ClientM NoContent +getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person +getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent +getCapture :: String -> C.Manager -> BaseUrl -> SCR.ClientM Person +getBody :: Person -> C.Manager -> BaseUrl -> SCR.ClientM Person +getQueryParam :: Maybe String -> C.Manager -> BaseUrl -> SCR.ClientM Person +getQueryParams :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person] +getQueryFlag :: Bool -> C.Manager -> BaseUrl -> SCR.ClientM Bool +getRawSuccess :: HTTP.Method -> C.Manager -> BaseUrl + -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) +getRawFailure :: HTTP.Method -> C.Manager -> BaseUrl + -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) +getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> C.Manager -> BaseUrl + -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])]) +getRespHeaders :: C.Manager -> BaseUrl -> SCR.ClientM (Headers TestHeaders Bool) +getDeleteContentType :: C.Manager -> BaseUrl -> SCR.ClientM NoContent getGet - :<|> getDeleteEmpty - :<|> getCapture - :<|> getBody - :<|> getQueryParam - :<|> getQueryParams - :<|> getQueryFlag - :<|> getRawSuccess - :<|> getRawFailure - :<|> getMultiple - :<|> getRespHeaders - :<|> getDeleteContentType = client api + :<|> getDeleteEmpty + :<|> getCapture + :<|> getBody + :<|> getQueryParam + :<|> getQueryParams + :<|> getQueryFlag + :<|> getRawSuccess + :<|> getRawFailure + :<|> getMultiple + :<|> getRespHeaders + :<|> getDeleteContentType = client api server :: Application server = serve api ( @@ -254,38 +235,38 @@ sucessSpec :: Spec sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "Servant.API.Get" $ \(_, baseUrl) -> do - (left show <$> SCR.runClientM getGet baseUrl manager) `shouldReturn` Right alice + (left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice describe "Servant.API.Delete" $ do it "allows empty content type" $ \(_, baseUrl) -> do - (left show <$> SCR.runClientM getDeleteEmpty baseUrl manager) `shouldReturn` Right NoContent + (left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do - (left show <$> SCR.runClientM getDeleteContentType baseUrl manager) `shouldReturn` Right NoContent + (left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent it "Servant.API.Capture" $ \(_, baseUrl) -> do - (left show <$> SCR.runClientM (getCapture "Paula") baseUrl manager) `shouldReturn` Right (Person "Paula" 0) + (left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0) it "Servant.API.ReqBody" $ \(_, baseUrl) -> do let p = Person "Clara" 42 - (left show <$> SCR.runClientM (getBody p) baseUrl manager) `shouldReturn` Right p + (left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p it "Servant.API.QueryParam" $ \(_, baseUrl) -> do - left show <$> SCR.runClientM (getQueryParam (Just "alice")) baseUrl manager `shouldReturn` Right alice - Left FailureResponse{..} <- SCR.runClientM (getQueryParam (Just "bob")) baseUrl manager + left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice + Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl) responseStatus `shouldBe` HTTP.Status 400 "bob not found" it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do - (left show <$> SCR.runClientM (getQueryParams []) baseUrl manager) `shouldReturn` Right [] - (left show <$> SCR.runClientM (getQueryParams ["alice", "bob"]) baseUrl manager) + (left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right [] + (left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl)) `shouldReturn` Right [Person "alice" 0, Person "bob" 1] context "Servant.API.QueryParam.QueryFlag" $ forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do - (left show <$> SCR.runClientM (getQueryFlag flag) baseUrl manager) `shouldReturn` Right flag + (left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag it "Servant.API.Raw on success" $ \(_, baseUrl) -> do - res <- SCR.runClientM (getRawSuccess HTTP.methodGet) baseUrl manager + res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl) case res of Left e -> assertFailure $ show e Right (code, body, ct, _, response) -> do @@ -294,7 +275,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do C.responseStatus response `shouldBe` HTTP.ok200 it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do - res <- SCR.runClientM (getRawFailure HTTP.methodGet) baseUrl manager + res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl) case res of Right _ -> assertFailure "expected Left, but got Right" Left e -> do @@ -302,7 +283,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do Servant.Client.responseBody e `shouldBe` "rawFailure" it "Returns headers appropriately" $ \(_, baseUrl) -> do - res <- SCR.runClientM getRespHeaders baseUrl manager + res <- runExceptT (getRespHeaders manager baseUrl) case res of Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] @@ -311,7 +292,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> ioProperty $ do - result <- left show <$> SCR.runClientM (getMultiple cap num flag body) baseUrl manager + result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl) return $ result === Right (cap, num, flag, body) @@ -323,9 +304,9 @@ wrappedApiSpec = describe "error status codes" $ do let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do - let getResponse :: SCR.ClientM () + let getResponse :: C.Manager -> BaseUrl -> SCR.ClientM () getResponse = client api - Left FailureResponse{..} <- SCR.runClientM getResponse baseUrl manager + Left FailureResponse{..} <- runExceptT (getResponse manager baseUrl) responseStatus `shouldBe` (HTTP.Status 500 "error message") in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : @@ -340,42 +321,42 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do let (_ :<|> getDeleteEmpty :<|> _) = client api - Left res <- SCR.runClientM getDeleteEmpty baseUrl manager + Left res <- runExceptT (getDeleteEmpty manager baseUrl) case res of FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do let (_ :<|> _ :<|> getCapture :<|> _) = client api - Left res <- SCR.runClientM (getCapture "foo") baseUrl manager + Left res <- runExceptT (getCapture "foo" manager baseUrl) case res of DecodeFailure _ ("application/json") _ -> return () _ -> fail $ "expected DecodeFailure, but got " <> show res it "reports ConnectionError" $ \_ -> do let (getGetWrongHost :<|> _) = client api - Left res <- SCR.runClientM getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "") manager + Left res <- runExceptT (getGetWrongHost manager (BaseUrl Http "127.0.0.1" 19872 "")) case res of ConnectionError _ -> return () _ -> fail $ "expected ConnectionError, but got " <> show res it "reports UnsupportedContentType" $ \(_, baseUrl) -> do let (getGet :<|> _ ) = client api - Left res <- SCR.runClientM getGet baseUrl manager + Left res <- runExceptT (getGet manager baseUrl) case res of UnsupportedContentType ("application/octet-stream") _ -> return () _ -> fail $ "expected UnsupportedContentType, but got " <> show res it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api - Left res <- SCR.runClientM (getBody alice) baseUrl manager + Left res <- runExceptT (getBody alice manager baseUrl) case res of InvalidContentTypeHeader "fooooo" _ -> return () _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a, - HasClient api, Client api ~ SCR.ClientM ()) => + HasClient api, Client api ~ (C.Manager -> BaseUrl -> SCR.ClientM ())) => Proxy api -> WrappedApi basicAuthSpec :: Spec @@ -385,14 +366,14 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "servant" "server" - (left show <$> SCR.runClientM (getBasic basicAuthData) baseUrl manager) `shouldReturn` Right alice + (left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice context "Authentication is rejected when requests are not authenticated properly" $ do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "not" "password" - Left FailureResponse{..} <- SCR.runClientM (getBasic basicAuthData) baseUrl manager + Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl) responseStatus `shouldBe` HTTP.Status 403 "Forbidden" genAuthSpec :: Spec @@ -402,14 +383,14 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do let getProtected = client genAuthAPI let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req) - (left show <$> SCR.runClientM (getProtected authRequest) baseUrl manager) `shouldReturn` Right alice + (left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice context "Authentication is rejected when requests are not authenticated properly" $ do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do let getProtected = client genAuthAPI let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req) - Left FailureResponse{..} <- SCR.runClientM (getProtected authRequest) baseUrl manager + Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl) responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized") -- * utils From a9200cd0501e9359141c2f55536b3d1364a6d476 Mon Sep 17 00:00:00 2001 From: mbg Date: Wed, 30 Mar 2016 22:50:29 +0100 Subject: [PATCH 170/180] Modified the tutorial to reflect the changes to servant-client (explicit parameters) --- doc/tutorial/Client.lhs | 28 +++++++++++++++++----------- 1 file changed, 17 insertions(+), 11 deletions(-) diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index 67f38357..a40ca7c6 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -15,13 +15,13 @@ need to have some language extensions and imports: module Client where +import Control.Monad.Trans.Except (ExceptT, runExceptT) import Data.Aeson import Data.Proxy import GHC.Generics -import Network.HTTP.Client (newManager, defaultManagerSettings) +import Network.HTTP.Client (Manager, newManager, defaultManagerSettings) import Servant.API import Servant.Client -import Servant.Common.Req (ClientM, runClientM) ``` Also, we need examples for some domain specific data types: @@ -71,13 +71,19 @@ What we are going to get with **servant-client** here is 3 functions, one to que ``` haskell position :: Int -- ^ value for "x" -> Int -- ^ value for "y" - -> ClientM Position + -> Manager -- ^ the HTTP client to use + -> BaseUrl -- ^ the URL at which the API can be found + -> ExceptT ServantError IO Position hello :: Maybe String -- ^ an optional value for "name" - -> ClientM HelloMessage + -> Manager -- ^ the HTTP client to use + -> BaseUrl -- ^ the URL at which the API can be found + -> ExceptT ServantError IO HelloMessage marketing :: ClientInfo -- ^ value for the request body - -> ClientM Email + -> Manager -- ^ the HTTP client to use + -> BaseUrl -- ^ the URL at which the API can be found + -> ExceptT ServantError IO Email ``` Each function makes available as an argument any value that the response may @@ -114,17 +120,17 @@ data BaseUrl = BaseUrl That's it. Let's now write some code that uses our client functions. ``` haskell -queries :: ClientM (Position, HelloMessage, Email) -queries = do - pos <- position 10 10 - message <- hello (Just "servant") - em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) +queries :: Manager -> BaseUrl -> ExceptT ServantError IO (Position, HelloMessage, Email) +queries manager baseurl = do + pos <- position 10 10 manager baseurl + message <- hello (Just "servant") manager baseurl + em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) manager baseurl return (pos, message, em) run :: IO () run = do manager <- newManager defaultManagerSettings - res <- runClientM queries (BaseUrl Http "localhost" 8081 "") manager + res <- runExceptT (queries manager (BaseUrl Http "localhost" 8081 "")) case res of Left err -> putStrLn $ "Error: " ++ show err Right (pos, message, em) -> do From 6fd1e21580b0679ca19e5e3f7130e3f0c3deb4b8 Mon Sep 17 00:00:00 2001 From: mbg Date: Wed, 30 Mar 2016 22:51:08 +0100 Subject: [PATCH 171/180] Updated changelog to reflect that client no longer requires BaseUrl and Manager arguments --- servant-client/CHANGELOG.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index 0cddd5ea..cb2b720d 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -1,3 +1,6 @@ + +* `client` no longer takes `BaseUrl` and `Manager` arguments. Instead, each function returned by `client` requires these two arguments. + 0.5 ---- From 1920694f6254a335c67cf8effae2b09a536baada Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sun, 27 Mar 2016 17:16:28 +0800 Subject: [PATCH 172/180] cabal: decrease upper bound for base to disallow ghc-8 --- servant/servant.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant/servant.cabal b/servant/servant.cabal index 849e3d05..a08b20d4 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -46,7 +46,7 @@ library Servant.API.WithNamedContext Servant.Utils.Links build-depends: - base >=4.7 && <5 + base >= 4.7 && < 4.9 , base-compat >= 0.9 , aeson >= 0.7 , attoparsec >= 0.12 From 4f558971d1f3364c947d7417461c73d920e32d63 Mon Sep 17 00:00:00 2001 From: Alexander Kjeldaas Date: Fri, 1 Apr 2016 22:56:19 +0200 Subject: [PATCH 173/180] Removed FromText references from docs. --- doc/tutorial/ApiType.lhs | 2 +- servant-client/src/Servant/Client.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/tutorial/ApiType.lhs b/doc/tutorial/ApiType.lhs index a2282e19..54022bb8 100644 --- a/doc/tutorial/ApiType.lhs +++ b/doc/tutorial/ApiType.lhs @@ -135,7 +135,7 @@ data Capture (s :: Symbol) a ``` In some web frameworks, you use regexes for captures. We use a -[`FromText`](https://hackage.haskell.org/package/servant/docs/Servant-Common-Text.html#t:FromText) +[`FromHttpApiData`](https://hackage.haskell.org/package/http-api-data/docs/Web-HttpApiData.html#t:FromHttpApiData) class, which the captured value must be an instance of. Examples: diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 9c2fcfbc..cb6837ce 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -173,7 +173,7 @@ instance OVERLAPPING_ -- Example: -- -- > newtype Referer = Referer { referrer :: Text } --- > deriving (Eq, Show, Generic, FromText, ToHttpApiData) +-- > deriving (Eq, Show, Generic, ToHttpApiData) -- > -- > -- GET /view-my-referer -- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer From b72c271c2c908e23c67257e1580e167463dce6af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Sat, 2 Apr 2016 15:03:00 +0800 Subject: [PATCH 174/180] remove ToText from docs --- servant-server/src/Servant/Server/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 93b0a2ff..1733f246 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -222,7 +222,7 @@ instance OVERLAPPING_ -- Example: -- -- > newtype Referer = Referer Text --- > deriving (Eq, Show, FromHttpApiData, ToText) +-- > deriving (Eq, Show, FromHttpApiData) -- > -- > -- GET /view-my-referer -- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer From 7ec8eae2e7ecd128bf9c9d6a18bebe109b92c06e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 1 Apr 2016 19:51:50 +0800 Subject: [PATCH 175/180] fixed release readme and bumper script --- scripts/README.md | 2 +- scripts/bump-versions.sh | 7 ++----- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/scripts/README.md b/scripts/README.md index fe006cd0..1f3eae98 100644 --- a/scripts/README.md +++ b/scripts/README.md @@ -3,6 +3,6 @@ The release process works roughly like this: ``` bash ./scripts/bump-versions.sh git commit -./scripts/upload.sh +./scripts/upload.hs git tag && git push --tags ``` diff --git a/scripts/bump-versions.sh b/scripts/bump-versions.sh index 2e39cea3..751f0d77 100755 --- a/scripts/bump-versions.sh +++ b/scripts/bump-versions.sh @@ -56,10 +56,7 @@ done if $DRY_RUN ; then echo "Would have bumped position ${POSITION} on these packages:" - ( cd "$ROOT" && bumper --dry-run -"$POSITION" $(join , "${SOURCES[@]}") ) + ( cd "$ROOT" && bumper --dry-run -"$POSITION" $(join , $SOURCES) ) else - ( cd "$ROOT" && bumper -"$POSITION" $(join , "${SOURCES[@]}") ) + ( cd "$ROOT" && bumper -"$POSITION" $(join , $SOURCES) ) fi - -# Trailing newline, bumper does not ship with its own. -echo From 2367ee9965c4ec137994ff35c0ff1e59fbefe104 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 1 Apr 2016 19:52:43 +0800 Subject: [PATCH 176/180] put 0.6 into changelogs --- servant-client/CHANGELOG.md | 4 +++- servant-server/CHANGELOG.md | 4 ++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index cb2b720d..ada41eb0 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -1,8 +1,10 @@ +0.6 +--- * `client` no longer takes `BaseUrl` and `Manager` arguments. Instead, each function returned by `client` requires these two arguments. 0.5 ----- +--- * Use the `text` package instead of `String`. * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index cd8dc540..8b1c25e2 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,5 +1,5 @@ -on master ---------- +0.6 +--- * Query parameters that can't be parsed result in a `400` (was `404`). From 94982c15dc6077919b0922eddfbd8cc5835dbbab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 1 Apr 2016 20:47:24 +0800 Subject: [PATCH 177/180] move travis script into a file --- .travis.yml | 2 +- travis.sh | 13 +++++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) create mode 100755 travis.sh diff --git a/.travis.yml b/.travis.yml index 9cddf7ab..929b0b13 100644 --- a/.travis.yml +++ b/.travis.yml @@ -25,7 +25,7 @@ install: - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config script: - - for package in $(cat sources.txt); do (echo testing $package && cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done + - ./travis.sh cache: directories: diff --git a/travis.sh b/travis.sh new file mode 100755 index 00000000..ac028050 --- /dev/null +++ b/travis.sh @@ -0,0 +1,13 @@ +#!/usr/bin/env bash + +set -o errexit + +for package in $(cat sources.txt) ; do + echo testing $package + pushd $package + tinc + cabal configure --enable-tests --disable-optimization + cabal build + cabal test + popd +done From 1fe37d5170df2076342fcafd2a4ed9bbc5817fbb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 1 Apr 2016 20:48:03 +0800 Subject: [PATCH 178/180] move doc/tutorial out of sources.txt --- scripts/bump-versions.sh | 4 ++-- sources.txt | 1 - travis.sh | 2 +- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/scripts/bump-versions.sh b/scripts/bump-versions.sh index 751f0d77..aaa3d0c2 100755 --- a/scripts/bump-versions.sh +++ b/scripts/bump-versions.sh @@ -56,7 +56,7 @@ done if $DRY_RUN ; then echo "Would have bumped position ${POSITION} on these packages:" - ( cd "$ROOT" && bumper --dry-run -"$POSITION" $(join , $SOURCES) ) + ( cd "$ROOT" && bumper --dry-run -"$POSITION" $(join , $SOURCES tutorial) ) else - ( cd "$ROOT" && bumper -"$POSITION" $(join , $SOURCES) ) + ( cd "$ROOT" && bumper -"$POSITION" $(join , $SOURCES tutorial) ) fi diff --git a/sources.txt b/sources.txt index 2b2ca454..2d3f8107 100644 --- a/sources.txt +++ b/sources.txt @@ -8,4 +8,3 @@ servant-server servant-blaze servant-lucid servant-mock -doc/tutorial diff --git a/travis.sh b/travis.sh index ac028050..60734911 100755 --- a/travis.sh +++ b/travis.sh @@ -2,7 +2,7 @@ set -o errexit -for package in $(cat sources.txt) ; do +for package in $(cat sources.txt) doc/tutorial ; do echo testing $package pushd $package tinc From 14a8139cbef04bf5ae71e28f9ce4c48980383980 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 1 Apr 2016 21:19:05 +0800 Subject: [PATCH 179/180] version bump --- doc/tutorial/tutorial.cabal | 12 ++++++------ servant-blaze/servant-blaze.cabal | 4 ++-- servant-cassava/servant-cassava.cabal | 4 ++-- servant-client/servant-client.cabal | 8 ++++---- servant-docs/servant-docs.cabal | 4 ++-- servant-foreign/servant-foreign.cabal | 4 ++-- servant-js/servant-js.cabal | 8 ++++---- servant-lucid/servant-lucid.cabal | 4 ++-- servant-mock/servant-mock.cabal | 2 +- servant-server/servant-server.cabal | 4 ++-- servant/servant.cabal | 2 +- 11 files changed, 28 insertions(+), 28 deletions(-) diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 940fce18..e475ffaf 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -1,5 +1,5 @@ name: tutorial -version: 0.5 +version: 0.6 synopsis: The servant tutorial homepage: http://haskell-servant.github.io/ license: BSD3 @@ -25,11 +25,11 @@ library , directory , blaze-markup , containers - , servant == 0.5.* - , servant-server == 0.5.* - , servant-client == 0.5.* - , servant-docs == 0.5.* - , servant-js == 0.5.* + , servant == 0.6.* + , servant-server == 0.6.* + , servant-client == 0.6.* + , servant-docs == 0.6.* + , servant-js == 0.6.* , warp , http-media , lucid diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal index cc36a2de..f51c49cf 100644 --- a/servant-blaze/servant-blaze.cabal +++ b/servant-blaze/servant-blaze.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: servant-blaze -version: 0.5 +version: 0.6 synopsis: Blaze-html support for servant -- description: homepage: http://haskell-servant.github.io/ @@ -25,7 +25,7 @@ library -- other-modules: -- other-extensions: build-depends: base >=4.7 && <5 - , servant == 0.5.* + , servant == 0.6.* , http-media , blaze-html hs-source-dirs: src diff --git a/servant-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal index e7563eab..ccb37b07 100644 --- a/servant-cassava/servant-cassava.cabal +++ b/servant-cassava/servant-cassava.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: servant-cassava -version: 0.5 +version: 0.6 synopsis: Servant CSV content-type for cassava -- description: homepage: http://haskell-servant.github.io/ @@ -22,7 +22,7 @@ library -- other-extensions: build-depends: base >=4.6 && <5 , cassava >0.4 && <0.5 - , servant ==0.5.* + , servant == 0.6.* , http-media , vector hs-source-dirs: src diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 6fbb6642..044511c6 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -1,5 +1,5 @@ name: servant-client -version: 0.5 +version: 0.6 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that @@ -45,7 +45,7 @@ library , http-types , network-uri >= 2.6 , safe - , servant == 0.5.* + , servant == 0.6.* , string-conversions , text , transformers @@ -79,9 +79,9 @@ test-suite spec , HUnit , network >= 2.6 , QuickCheck >= 2.7 - , servant == 0.5.* + , servant == 0.6.* , servant-client - , servant-server == 0.5.* + , servant-server == 0.6.* , text , wai , warp diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index c95624f2..878aa802 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -1,5 +1,5 @@ name: servant-docs -version: 0.5 +version: 0.6 synopsis: generate API docs for your servant webservice description: Library for generating API docs from a servant API definition. @@ -42,7 +42,7 @@ library , http-media >= 0.6 , http-types >= 0.7 , lens - , servant == 0.5.* + , servant == 0.6.* , string-conversions , text , unordered-containers diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 9a101256..45673dbc 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -1,5 +1,5 @@ name: servant-foreign -version: 0.5 +version: 0.6 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 @@ -31,7 +31,7 @@ library , Servant.Foreign.Inflections build-depends: base == 4.* , lens == 4.* - , servant == 0.5.* + , servant == 0.6.* , text >= 1.2 && < 1.3 , http-types hs-source-dirs: src diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index adbed88d..660efbec 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -1,5 +1,5 @@ name: servant-js -version: 0.5 +version: 0.6 synopsis: Automatically derive javascript functions to query servant webservices. description: Automatically derive javascript functions to query servant webservices. @@ -45,7 +45,7 @@ library , base-compat >= 0.9 , charset >= 0.3 , lens >= 4 - , servant-foreign == 0.5.* + , servant-foreign == 0.6.* , text >= 1.2 && < 1.3 hs-source-dirs: src @@ -67,8 +67,8 @@ executable counter , aeson >= 0.7 && < 0.12 , filepath >= 1 , lens >= 4 - , servant == 0.5.* - , servant-server == 0.5.* + , servant == 0.6.* + , servant-server == 0.6.* , servant-js , stm , transformers diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal index 008650bb..325cbb73 100644 --- a/servant-lucid/servant-lucid.cabal +++ b/servant-lucid/servant-lucid.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: servant-lucid -version: 0.5 +version: 0.6 synopsis: Servant support for lucid -- description: homepage: http://haskell-servant.github.io/ @@ -27,7 +27,7 @@ library build-depends: base >=4.7 && <5 , http-media , lucid - , servant == 0.5.* + , servant == 0.6.* hs-source-dirs: src default-language: Haskell2010 include-dirs: include diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index aa9b2bef..3806b79d 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -1,5 +1,5 @@ name: servant-mock -version: 0.5 +version: 0.6 synopsis: Derive a mock server for free from your servant API types description: Derive a mock server for free from your servant API types diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 77302d63..5ba00c65 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -1,5 +1,5 @@ name: servant-server -version: 0.5 +version: 0.6 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them @@ -60,7 +60,7 @@ library , mmorph >= 1 , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4 - , servant == 0.5.* + , servant == 0.6.* , split >= 0.2 && < 0.3 , string-conversions >= 0.3 && < 0.5 , system-filepath >= 0.4 && < 0.5 diff --git a/servant/servant.cabal b/servant/servant.cabal index a08b20d4..51e1ce3b 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -1,5 +1,5 @@ name: servant -version: 0.5 +version: 0.6 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them From 933a2c4445150da454591a58835fcc2f7e0d7a51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Tue, 5 Apr 2016 17:51:25 +0800 Subject: [PATCH 180/180] re-export `ClientM` from `Servant.Client`. --- servant-client/src/Servant/Client.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index cb6837ce..ee27846c 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -19,6 +19,7 @@ module Servant.Client , AuthenticateReq(..) , client , HasClient(..) + , ClientM , mkAuthenticateReq , ServantError(..) , module Servant.Common.BaseUrl