From 8780bf78cb66965d7ddddda78c6dc800b6bed72c Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Wed, 2 Dec 2015 16:37:12 +1100 Subject: [PATCH 01/18] Add `CaptureTimes` and `QueryParamTime(s)` to `servant`. --- servant/servant.cabal | 1 + servant/src/Servant/API.hs | 5 +++++ servant/src/Servant/API/Times.hs | 30 ++++++++++++++++++++++++++++++ 3 files changed, 36 insertions(+) create mode 100644 servant/src/Servant/API/Times.hs diff --git a/servant/servant.cabal b/servant/servant.cabal index 854e499b..8cac1e7e 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -42,6 +42,7 @@ library Servant.API.ReqBody Servant.API.ResponseHeaders Servant.API.Sub + Servant.API.Times Servant.API.Vault Servant.Utils.Links build-depends: diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 2e6abb2a..635c8b1d 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -23,6 +23,10 @@ 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.Times, + -- | Capturing dates and times in URLs and params with specified formats. + + -- * Actual endpoints, distinguished by HTTP method module Servant.API.Get, @@ -83,6 +87,7 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader), HList (..), Headers (..), getHeadersHList, getResponse) import Servant.API.Sub ((:>)) +import Servant.API.Times (CaptureTime, QueryParamTime, QueryParamTimes) import Servant.API.Vault (Vault) import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', diff --git a/servant/src/Servant/API/Times.hs b/servant/src/Servant/API/Times.hs new file mode 100644 index 00000000..77979f8c --- /dev/null +++ b/servant/src/Servant/API/Times.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Servant.API.Times where + +import Data.Typeable (Typeable) +import GHC.TypeLits (Symbol) + + +-- | Capture a value from the request path under a certain type @a@. +-- +-- Example: +-- >>> -- GET /books/:isbn +-- >>> type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book +data CaptureTime (sym :: Symbol) (format :: Symbol) a + deriving (Typeable) + + +data QueryParamTime (sym :: Symbol) (format :: Symbol) a + deriving (Typeable) + + +data QueryParamTimes (sym :: Symbol) (format :: Symbol) a + deriving (Typeable) + From 3a4e4139b5990d39ef82e04702df43ea284e2b79 Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Wed, 2 Dec 2015 16:38:56 +1100 Subject: [PATCH 02/18] Add implementations for HasServer for Servant.API.Times. --- servant-server/servant-server.cabal | 2 + servant-server/src/Servant/Server/Internal.hs | 111 ++++++++++++++++++ 2 files changed, 113 insertions(+) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 8d6beac4..ec6b13ae 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -65,6 +65,7 @@ library , wai >= 3.0 && < 3.1 , wai-app-static >= 3.0 && < 3.2 , warp >= 3.0 && < 3.2 + , time >= 1.5 && < 1.6 hs-source-dirs: src default-language: Haskell2010 @@ -121,6 +122,7 @@ test-suite spec , wai , wai-extra , warp + , time test-suite doctests build-depends: base diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 4200d052..4b1c04a6 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -30,6 +30,7 @@ import Data.Maybe (fromMaybe, mapMaybe) import Data.String (fromString) import Data.String.Conversions (ConvertibleStrings, cs, (<>)) import Data.Text (Text) +import qualified Data.Text as T import Data.Typeable import GHC.TypeLits (KnownSymbol, symbolVal) import Network.HTTP.Types hiding (Header, ResponseHeaders) @@ -40,6 +41,9 @@ import Network.Wai (Application, lazyRequestBody, isSecure, vault, httpVersion, Response, Request, pathInfo) import Servant.API ((:<|>) (..), (:>), Capture, + CaptureTime, + QueryParamTime, + QueryParamTimes, Delete, Get, Header, IsSecure(..), Patch, Post, Put, QueryFlag, QueryParam, QueryParams, @@ -59,6 +63,8 @@ import Servant.Server.Internal.ServantErr import Web.HttpApiData (FromHttpApiData) import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe) +import Data.Time.Format + class HasServer layout where type ServerT layout (m :: * -> *) :: * @@ -124,6 +130,43 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout) where captureProxy = Proxy :: Proxy (Capture capture a) +-- | If you use 'CaptureTime' 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 'CaptureTime'. +-- This lets servant worry about getting it from the URL and turning +-- it into a value of the type you specify if the string matches the fiven format. +-- +-- Example: +-- +-- > type MyApi = "calevents" :> CaptureTime "date" "%Y-%m-%d" Day :> Get '[JSON] [Event] +-- > +-- > server :: Server MyApi +-- > server = getCalendarEvents +-- > where getCalendarEvents :: Day -> ExceptT ServantErr IO [Event] +-- > getCalendarEvents day = ... +instance (KnownSymbol capture, KnownSymbol format, HasServer sublayout, ParseTime t) + => HasServer (CaptureTime capture format t :> sublayout) where + + type ServerT (CaptureTime capture format t :> sublayout) m = + t -> ServerT sublayout m + + route Proxy d = + DynamicRouter $ \ first -> + route (Proxy :: Proxy sublayout) + (addCapture d $ case captureDate formatProxy first of + Nothing -> return $ Fail err404 + Just (t :: t) -> return $ Route t + ) + + where formatProxy = Proxy :: Proxy format + +captureDate :: (ParseTime t, KnownSymbol format) + => Proxy format -> Text -> Maybe t +captureDate p t = parseTime defaultTimeLocale formatStr (T.unpack t) + where formatStr = symbolVal p + + + allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead @@ -488,6 +531,40 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) in route (Proxy :: Proxy sublayout) (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) +-- | 'QueryParamTime' allows you to accept dates and times in query params. +-- The format argument specifies the format understood by 'Data.Time.Format'. +-- +-- Servant takes care of parsing the +-- +-- Example: +-- +-- > type MyApi = "timeseries" +-- > :> QueryParamTime "start" "%Y-%m-%d" Day +-- > :> QueryParamTime "end" "%Y-%m-%d" Day +-- > :> Get '[JSON] [Double] +-- > +-- > server :: Server MyApi +-- > server = getDataBetween +-- > where getDataBetween :: Maybe Day -> Maybe Day -> ExceptT ServantErr IO [Double] +-- > getDataBetween mstart mend = ...return data between optional start and end dates... +instance (KnownSymbol sym, KnownSymbol format, HasServer sublayout, ParseTime t) + => HasServer (QueryParamTime sym format t :> sublayout) where + + type ServerT (QueryParamTime sym format t :> sublayout) m = + Maybe t -> ServerT sublayout m + + route Proxy subserver = WithRequest $ \ request -> + let querytext = parseQueryText $ rawQueryString request + param = + case lookup paramname querytext of + Nothing -> Nothing -- param absent from the query string + Just Nothing -> Nothing -- param present with no value -> Nothing + Just (Just v) -> captureDate formatProxy v -- if present, we try to convert to + -- the right type + in route (Proxy :: Proxy sublayout) (passToServer subserver param) + where paramname = cs $ symbolVal (Proxy :: Proxy sym) + formatProxy = Proxy :: Proxy format + -- | If you use @'QueryParams' "authors" 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 @['Text']@. @@ -526,6 +603,40 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) convert Nothing = Nothing convert (Just v) = parseQueryParamMaybe v +-- | As with 'QueryParams', 'QueryParamTimes, this allows you to capture 0 +-- or more dates/times matching a given format. The format must be one +-- which works with `Data.Time.Format'. +-- +-- Example: +-- +-- > type MyApi = "chckavailability" +-- > :> QueryParamTimes "start" "%Y-%m-%d" Day +-- > :> Get '[JSON] [Event] +-- > +-- > server :: Server MyApi +-- > server = getEventsForDays +-- > where getEventsForDays :: [Day] -> ExceptT ServantErr IO [Event] +-- > getEventsForDays days = ... return all the events on the specified days ... +instance (KnownSymbol sym, KnownSymbol format, HasServer sublayout, ParseTime t) + => HasServer (QueryParamTimes sym format t :> sublayout) where + + type ServerT (QueryParamTimes sym format t :> sublayout) m = + [t] -> ServerT sublayout m + + route Proxy 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) + where paramname = cs $ symbolVal (Proxy :: Proxy sym) + looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") + convert Nothing = Nothing + convert (Just v) = captureDate formatProxy v + formatProxy = Proxy :: Proxy format + -- | If you use @'QueryFlag' "published"@ 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 'Bool'. From 4f2a3d4afd816f9b799b3c140f677b45288d74aa Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Wed, 2 Dec 2015 17:50:09 +1100 Subject: [PATCH 03/18] Update docspec stuff for Servant.API.Times --- servant/src/Servant/API/Times.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/servant/src/Servant/API/Times.hs b/servant/src/Servant/API/Times.hs index 77979f8c..a3a15b1f 100644 --- a/servant/src/Servant/API/Times.hs +++ b/servant/src/Servant/API/Times.hs @@ -12,11 +12,12 @@ import Data.Typeable (Typeable) import GHC.TypeLits (Symbol) --- | Capture a value from the request path under a certain type @a@. +-- | Capture data/time value from a path in the `format', as understood +-- by 'Data.Time.Format. -- -- Example: --- >>> -- GET /books/:isbn --- >>> type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book +-- >>> -- GET /events/:date +-- >>> type MyApi = "events" :> CaptureTime "date" "%Y-%m-%d" Day :> Get '[JSON] Book data CaptureTime (sym :: Symbol) (format :: Symbol) a deriving (Typeable) @@ -28,3 +29,10 @@ data QueryParamTime (sym :: Symbol) (format :: Symbol) a data QueryParamTimes (sym :: Symbol) (format :: Symbol) a deriving (Typeable) +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> import Data.Time.Calendar +-- >>> data Book +-- >>> instance ToJSON Book where { toJSON = undefined } From 7174e1e1fd4408f370abe4e6c955ce7dc13ee764 Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Wed, 2 Dec 2015 17:50:41 +1100 Subject: [PATCH 04/18] Add tests for CaptureTime. --- servant-server/test/Servant/ServerSpec.hs | 32 ++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index e017d399..b45eb6b3 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -34,6 +34,7 @@ import Network.Wai.Internal (Response(ResponseBuilder)) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody) import Servant.API ((:<|>) (..), (:>), Capture, Delete, + CaptureTime, Get, Header (..), Headers, HttpVersion, IsSecure (..), JSON, Patch, PlainText, Post, Put, @@ -50,7 +51,8 @@ import Servant.Server.Internal.Router (tweakResponse, runRouter, Router, Router'(LeafRouter)) - +import Data.Time.Calendar +import Data.ByteString.Lazy (ByteString) -- * test data types data Person = Person { @@ -86,6 +88,7 @@ tweety = Animal "Bird" 2 spec :: Spec spec = do captureSpec + captureDateSpec getSpec headSpec postSpec @@ -128,6 +131,33 @@ captureSpec = do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) +type CaptureTimeApi = CaptureTime "date" "%Y-%m-%d" Day :> Get '[PlainText] String +captureTimeApi :: Proxy CaptureTimeApi +captureTimeApi = Proxy +captureTimesServer :: Day -> ExceptT ServantErr IO String +captureTimesServer = return . show + + +captureDateSpec :: Spec +captureDateSpec = do + describe "Servant.API.Times(CaptureTime)" $ do + with (return (serve captureTimeApi captureTimesServer)) $ do + + it "can capture parts of the 'pathInfo'" $ do + response <- get "/2015-12-02" + liftIO $ simpleBody response `shouldBe` (fromString . show $ fromGregorian 2015 12 2 :: ByteString) + + it "returns 404 if the decoding fails" $ do + get "/notAnInt" `shouldRespondWith` 404 + + with (return (serve + (Proxy :: Proxy (CaptureTime "date" "%Y-%m-%d" Day :> Raw)) + (\ day request_ respond -> + respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do + it "strips the captured path snippet from pathInfo" $ do + get "/2015-12-02/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) + + type GetApi = Get '[JSON] Person :<|> "empty" :> Get '[] () From 74ebec91764b57f8eb0b716fb7c1753649587986 Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Thu, 3 Dec 2015 14:31:44 +1100 Subject: [PATCH 05/18] Reimplement time handling using a new type which carries a format string in its type. --- servant/servant.cabal | 1 + servant/src/Servant/API.hs | 2 +- servant/src/Servant/API/Times.hs | 83 ++++++++++++++++++++++++++------ 3 files changed, 71 insertions(+), 15 deletions(-) diff --git a/servant/servant.cabal b/servant/servant.cabal index 8cac1e7e..2a8f747f 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -59,6 +59,7 @@ library , string-conversions >= 0.3 && < 0.5 , network-uri >= 2.6 , vault >= 0.3 && <0.4 + , time >= 1.5 && < 1.6 hs-source-dirs: src default-language: Haskell2010 other-extensions: CPP diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 635c8b1d..695471b0 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -87,7 +87,7 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader), HList (..), Headers (..), getHeadersHList, getResponse) import Servant.API.Sub ((:>)) -import Servant.API.Times (CaptureTime, QueryParamTime, QueryParamTimes) +import Servant.API.Times (FTime(..), toProxy, getFormat, renderTime, parseTime) import Servant.API.Vault (Vault) import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', diff --git a/servant/src/Servant/API/Times.hs b/servant/src/Servant/API/Times.hs index a3a15b1f..64ebe14b 100644 --- a/servant/src/Servant/API/Times.hs +++ b/servant/src/Servant/API/Times.hs @@ -6,33 +6,88 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} -module Servant.API.Times where +module Servant.API.Times + ( FTime(..) + , toProxy + , getFormat + , renderTime + , parseTime + ) where import Data.Typeable (Typeable) -import GHC.TypeLits (Symbol) +import GHC.TypeLits -- (Symbol) +import Web.HttpApiData +import qualified Data.Time.Format as T +import Data.Text (pack, Text) +import Data.Proxy +import Control.Monad ((>=>)) +import Control.Arrow (first) - --- | Capture data/time value from a path in the `format', as understood --- by 'Data.Time.Format. +-- | A wrapper around a time type which can be parsed/rendered to with `format', +-- as specified in 'Data.Time.Format'. -- -- Example: -- >>> -- GET /events/:date --- >>> type MyApi = "events" :> CaptureTime "date" "%Y-%m-%d" Day :> Get '[JSON] Book -data CaptureTime (sym :: Symbol) (format :: Symbol) a - deriving (Typeable) +-- >>> type MyApi = "events" :> Capture "date" (FTime "%Y-%m-%d" Day) :> Get '[JSON] [Event] +newtype FTime (format :: Symbol) t = FTime {getFTime :: t} + deriving (Typeable, Eq, Ord) + +instance (KnownSymbol format, T.FormatTime t) => Show (FTime format t) where + showsPrec i t = showParen (i > 1) (\str -> renderTime t ++ str) + +instance (KnownSymbol format, T.ParseTime t) => Read (FTime format t) where + readsPrec i str = res + where + res = fmap (first FTime) + (readParen (i > 1) + (T.readSTime False T.defaultTimeLocale fmt) + str + ) + + toFTimeTy :: [(FTime format t, String)] -> FTime format t + toFTimeTy _ = undefined + + fmt = getFormat (toFTimeTy res) -data QueryParamTime (sym :: Symbol) (format :: Symbol) a - deriving (Typeable) + +instance (KnownSymbol format, T.FormatTime t) => ToHttpApiData (FTime format t) where + toUrlPiece = toUrlPiece . renderTime + toHeader = toHeader . renderTime + toQueryParam = toQueryParam . renderTime -data QueryParamTimes (sym :: Symbol) (format :: Symbol) a - deriving (Typeable) +instance (KnownSymbol format, T.ParseTime t) => FromHttpApiData (FTime format t) where + parseUrlPiece = parseUrlPiece >=> parseTime + parseHeader = parseHeader >=> parseTime + parseQueryParam = parseQueryParam >=> parseTime + + +toProxy :: FTime format t -> Proxy format +toProxy _ = Proxy + +getFormat :: KnownSymbol format => FTime format t -> String +getFormat t = symbolVal (toProxy t) + +renderTime :: (KnownSymbol format, T.FormatTime t) => FTime format t -> String +renderTime tt@(FTime t) = T.formatTime T.defaultTimeLocale (getFormat tt) t + +parseTime :: (KnownSymbol format, T.ParseTime t) => String -> Either Text (FTime format t) +parseTime str = res + where + res = case T.parseTimeM False T.defaultTimeLocale fmt str of + Nothing -> Left . pack $ "Could not parse time string \"" ++ str ++ "\" with format \"" ++ fmt ++ "\"" + Just t -> Right (FTime t) + + fmt = getFormat (toFTimeTy res) + + toFTimeTy :: Either Text (FTime format t) -> FTime format a + toFTimeTy _ = undefined -- $setup -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text -- >>> import Data.Time.Calendar --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } +-- >>> data Event +-- >>> instance ToJSON Event where { toJSON = undefined } From 1c9c948faf0ca1494a3f83d8c1ed5721c29f802e Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Thu, 3 Dec 2015 14:32:52 +1100 Subject: [PATCH 06/18] Remove implementations for HasServer for now nonexistent types, add tests for capturing times. --- servant-server/src/Servant/Server/Internal.hs | 109 ------------------ servant-server/test/Servant/ServerSpec.hs | 46 +++++--- 2 files changed, 32 insertions(+), 123 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 4b1c04a6..bc8b0732 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -30,7 +30,6 @@ import Data.Maybe (fromMaybe, mapMaybe) import Data.String (fromString) import Data.String.Conversions (ConvertibleStrings, cs, (<>)) import Data.Text (Text) -import qualified Data.Text as T import Data.Typeable import GHC.TypeLits (KnownSymbol, symbolVal) import Network.HTTP.Types hiding (Header, ResponseHeaders) @@ -41,9 +40,6 @@ import Network.Wai (Application, lazyRequestBody, isSecure, vault, httpVersion, Response, Request, pathInfo) import Servant.API ((:<|>) (..), (:>), Capture, - CaptureTime, - QueryParamTime, - QueryParamTimes, Delete, Get, Header, IsSecure(..), Patch, Post, Put, QueryFlag, QueryParam, QueryParams, @@ -63,7 +59,6 @@ import Servant.Server.Internal.ServantErr import Web.HttpApiData (FromHttpApiData) import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe) -import Data.Time.Format class HasServer layout where type ServerT layout (m :: * -> *) :: * @@ -130,42 +125,6 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout) where captureProxy = Proxy :: Proxy (Capture capture a) --- | If you use 'CaptureTime' 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 'CaptureTime'. --- This lets servant worry about getting it from the URL and turning --- it into a value of the type you specify if the string matches the fiven format. --- --- Example: --- --- > type MyApi = "calevents" :> CaptureTime "date" "%Y-%m-%d" Day :> Get '[JSON] [Event] --- > --- > server :: Server MyApi --- > server = getCalendarEvents --- > where getCalendarEvents :: Day -> ExceptT ServantErr IO [Event] --- > getCalendarEvents day = ... -instance (KnownSymbol capture, KnownSymbol format, HasServer sublayout, ParseTime t) - => HasServer (CaptureTime capture format t :> sublayout) where - - type ServerT (CaptureTime capture format t :> sublayout) m = - t -> ServerT sublayout m - - route Proxy d = - DynamicRouter $ \ first -> - route (Proxy :: Proxy sublayout) - (addCapture d $ case captureDate formatProxy first of - Nothing -> return $ Fail err404 - Just (t :: t) -> return $ Route t - ) - - where formatProxy = Proxy :: Proxy format - -captureDate :: (ParseTime t, KnownSymbol format) - => Proxy format -> Text -> Maybe t -captureDate p t = parseTime defaultTimeLocale formatStr (T.unpack t) - where formatStr = symbolVal p - - allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead @@ -531,40 +490,6 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) in route (Proxy :: Proxy sublayout) (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) --- | 'QueryParamTime' allows you to accept dates and times in query params. --- The format argument specifies the format understood by 'Data.Time.Format'. --- --- Servant takes care of parsing the --- --- Example: --- --- > type MyApi = "timeseries" --- > :> QueryParamTime "start" "%Y-%m-%d" Day --- > :> QueryParamTime "end" "%Y-%m-%d" Day --- > :> Get '[JSON] [Double] --- > --- > server :: Server MyApi --- > server = getDataBetween --- > where getDataBetween :: Maybe Day -> Maybe Day -> ExceptT ServantErr IO [Double] --- > getDataBetween mstart mend = ...return data between optional start and end dates... -instance (KnownSymbol sym, KnownSymbol format, HasServer sublayout, ParseTime t) - => HasServer (QueryParamTime sym format t :> sublayout) where - - type ServerT (QueryParamTime sym format t :> sublayout) m = - Maybe t -> ServerT sublayout m - - route Proxy subserver = WithRequest $ \ request -> - let querytext = parseQueryText $ rawQueryString request - param = - case lookup paramname querytext of - Nothing -> Nothing -- param absent from the query string - Just Nothing -> Nothing -- param present with no value -> Nothing - Just (Just v) -> captureDate formatProxy v -- if present, we try to convert to - -- the right type - in route (Proxy :: Proxy sublayout) (passToServer subserver param) - where paramname = cs $ symbolVal (Proxy :: Proxy sym) - formatProxy = Proxy :: Proxy format - -- | If you use @'QueryParams' "authors" 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 @['Text']@. @@ -603,40 +528,6 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) convert Nothing = Nothing convert (Just v) = parseQueryParamMaybe v --- | As with 'QueryParams', 'QueryParamTimes, this allows you to capture 0 --- or more dates/times matching a given format. The format must be one --- which works with `Data.Time.Format'. --- --- Example: --- --- > type MyApi = "chckavailability" --- > :> QueryParamTimes "start" "%Y-%m-%d" Day --- > :> Get '[JSON] [Event] --- > --- > server :: Server MyApi --- > server = getEventsForDays --- > where getEventsForDays :: [Day] -> ExceptT ServantErr IO [Event] --- > getEventsForDays days = ... return all the events on the specified days ... -instance (KnownSymbol sym, KnownSymbol format, HasServer sublayout, ParseTime t) - => HasServer (QueryParamTimes sym format t :> sublayout) where - - type ServerT (QueryParamTimes sym format t :> sublayout) m = - [t] -> ServerT sublayout m - - route Proxy 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) - where paramname = cs $ symbolVal (Proxy :: Proxy sym) - looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") - convert Nothing = Nothing - convert (Just v) = captureDate formatProxy v - formatProxy = Proxy :: Proxy format - -- | If you use @'QueryFlag' "published"@ 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 'Bool'. diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index b45eb6b3..92ad631a 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -34,7 +34,7 @@ import Network.Wai.Internal (Response(ResponseBuilder)) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody) import Servant.API ((:<|>) (..), (:>), Capture, Delete, - CaptureTime, + FTime(..), Get, Header (..), Headers, HttpVersion, IsSecure (..), JSON, Patch, PlainText, Post, Put, @@ -50,8 +50,10 @@ import Servant.Server.Internal.RoutingApplication (toApplication, Rout import Servant.Server.Internal.Router (tweakResponse, runRouter, Router, Router'(LeafRouter)) - -import Data.Time.Calendar +import Data.Time.Calendar (Day, fromGregorian) +import Data.Time.LocalTime (LocalTime(..), hoursToTimeZone, + localTimeToUTC, makeTimeOfDayValid) +import Data.Time.Clock (UTCTime) import Data.ByteString.Lazy (ByteString) -- * test data types @@ -88,7 +90,7 @@ tweety = Animal "Bird" 2 spec :: Spec spec = do captureSpec - captureDateSpec + captureTimeSpec getSpec headSpec postSpec @@ -131,31 +133,47 @@ captureSpec = do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) -type CaptureTimeApi = CaptureTime "date" "%Y-%m-%d" Day :> Get '[PlainText] String +type CaptureTimeApi = (Capture "date" (FTime "%Y-%m-%d" Day) :> Get '[PlainText] String) + :<|> + ("datetime" :> Capture "datetime" (FTime "%Y-%m-%d %H:%M:%S%Z" UTCTime) :> Get '[PlainText] String) captureTimeApi :: Proxy CaptureTimeApi captureTimeApi = Proxy -captureTimesServer :: Day -> ExceptT ServantErr IO String -captureTimesServer = return . show +captureDateServer :: FTime "%Y-%m-%d" Day -> ExceptT ServantErr IO String +captureDateServer = return . show +captureDateTimeServer :: FTime "%Y-%m-%d %H:%M:%S%Z" UTCTime -> ExceptT ServantErr IO String +captureDateTimeServer = return . show -captureDateSpec :: Spec -captureDateSpec = do + +captureTimeSpec :: Spec +captureTimeSpec = do describe "Servant.API.Times(CaptureTime)" $ do - with (return (serve captureTimeApi captureTimesServer)) $ do + with (return (serve captureTimeApi (captureDateServer :<|> captureDateTimeServer))) $ do - it "can capture parts of the 'pathInfo'" $ do + it "can capture parts of the 'pathInfo' (date only)" $ do response <- get "/2015-12-02" liftIO $ simpleBody response `shouldBe` (fromString . show $ fromGregorian 2015 12 2 :: ByteString) + it "can capture parts of the 'pathInfo' (date and time with a space)" $ do + let day = fromGregorian 2015 12 2 + Just time = makeTimeOfDayValid 12 34 56 + tz = hoursToTimeZone 10 + utcT = localTimeToUTC tz (LocalTime day time) + ftime :: FTime "%Y-%m-%d %H:%M:%S%Z" UTCTime + ftime = FTime utcT + response <- get "/datetime/2015-12-02%2012:34:56+1000" + liftIO $ simpleBody response `shouldBe` (fromString . show $ ftime) + + it "returns 404 if the decoding fails" $ do get "/notAnInt" `shouldRespondWith` 404 with (return (serve - (Proxy :: Proxy (CaptureTime "date" "%Y-%m-%d" Day :> Raw)) - (\ day request_ respond -> + (Proxy :: Proxy (Capture "datetime" (FTime "%Y-%m-%d %H:%M:%S%Z" UTCTime) :> Raw)) + (\ (FTime day )request_ respond -> respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do - get "/2015-12-02/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) + get "/2015-12-02%2012:34:56+1000/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) From 070fe268319a1d09056a411f064bb06f60f8509a Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Mon, 7 Dec 2015 13:05:55 +1100 Subject: [PATCH 07/18] Refactor time format used in FTime tests. --- servant-server/test/Servant/ServerSpec.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 92ad631a..1ebaadd2 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -133,14 +133,16 @@ captureSpec = do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) +type TimeFormatWSpace = "%Y-%m-%d %H:%M:%S%Z" + type CaptureTimeApi = (Capture "date" (FTime "%Y-%m-%d" Day) :> Get '[PlainText] String) :<|> - ("datetime" :> Capture "datetime" (FTime "%Y-%m-%d %H:%M:%S%Z" UTCTime) :> Get '[PlainText] String) + ("datetime" :> Capture "datetime" (FTime TimeFormatWSpace UTCTime) :> Get '[PlainText] String) captureTimeApi :: Proxy CaptureTimeApi captureTimeApi = Proxy captureDateServer :: FTime "%Y-%m-%d" Day -> ExceptT ServantErr IO String captureDateServer = return . show -captureDateTimeServer :: FTime "%Y-%m-%d %H:%M:%S%Z" UTCTime -> ExceptT ServantErr IO String +captureDateTimeServer :: FTime TimeFormatWSpace UTCTime -> ExceptT ServantErr IO String captureDateTimeServer = return . show @@ -159,7 +161,7 @@ captureTimeSpec = do Just time = makeTimeOfDayValid 12 34 56 tz = hoursToTimeZone 10 utcT = localTimeToUTC tz (LocalTime day time) - ftime :: FTime "%Y-%m-%d %H:%M:%S%Z" UTCTime + ftime :: FTime TimeFormatWSpace UTCTime ftime = FTime utcT response <- get "/datetime/2015-12-02%2012:34:56+1000" liftIO $ simpleBody response `shouldBe` (fromString . show $ ftime) @@ -169,7 +171,7 @@ captureTimeSpec = do get "/notAnInt" `shouldRespondWith` 404 with (return (serve - (Proxy :: Proxy (Capture "datetime" (FTime "%Y-%m-%d %H:%M:%S%Z" UTCTime) :> Raw)) + (Proxy :: Proxy (Capture "datetime" (FTime TimeFormatWSpace UTCTime) :> Raw)) (\ (FTime day )request_ respond -> respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do From a73a4fca93d715c91c0a58fd1dde7af26e040d8d Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Mon, 11 Jan 2016 16:45:34 +1100 Subject: [PATCH 08/18] Fix API changes in `time` package between 7.8/7.10 --- servant-server/servant-server.cabal | 2 +- servant/servant.cabal | 6 +++++- servant/src/Servant/API/Times.hs | 12 ++++++++++++ 3 files changed, 18 insertions(+), 2 deletions(-) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index d9270546..b572635d 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -65,7 +65,7 @@ library , wai >= 3.0 && < 3.1 , wai-app-static >= 3.0 && < 3.2 , warp >= 3.0 && < 3.2 - , time >= 1.5 && < 1.6 + , time >= 1.4 && < 1.6 hs-source-dirs: src default-language: Haskell2010 diff --git a/servant/servant.cabal b/servant/servant.cabal index c3e6595d..263ac232 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -59,7 +59,11 @@ library , string-conversions >= 0.3 && < 0.5 , network-uri >= 2.6 , vault >= 0.3 && <0.4 - , time >= 1.5 && < 1.6 + if impl(ghc < 7.10) + build-depends: old-locale >= 1.0 && < 1.1 + , time >= 1.4 && < 1.5 + else + build-depends: time >= 1.5 && < 1.6 hs-source-dirs: src default-language: Haskell2010 other-extensions: CPP diff --git a/servant/src/Servant/API/Times.hs b/servant/src/Servant/API/Times.hs index 64ebe14b..96523bfc 100644 --- a/servant/src/Servant/API/Times.hs +++ b/servant/src/Servant/API/Times.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} @@ -18,6 +19,9 @@ import Data.Typeable (Typeable) import GHC.TypeLits -- (Symbol) import Web.HttpApiData import qualified Data.Time.Format as T +#if !MIN_VERSION_time(1,5,0) +import System.Locale as T +#endif import Data.Text (pack, Text) import Data.Proxy import Control.Monad ((>=>)) @@ -40,7 +44,11 @@ instance (KnownSymbol format, T.ParseTime t) => Read (FTime format t) where where res = fmap (first FTime) (readParen (i > 1) +#if !MIN_VERSION_time(1,5,0) + (T.readsTime T.defaultTimeLocale fmt) +#else (T.readSTime False T.defaultTimeLocale fmt) +#endif str ) @@ -75,7 +83,11 @@ renderTime tt@(FTime t) = T.formatTime T.defaultTimeLocale (getFormat tt) t parseTime :: (KnownSymbol format, T.ParseTime t) => String -> Either Text (FTime format t) parseTime str = res where +#if !MIN_VERSION_time(1,5,0) + res = case T.parseTime T.defaultTimeLocale fmt str of +#else res = case T.parseTimeM False T.defaultTimeLocale fmt str of +#endif Nothing -> Left . pack $ "Could not parse time string \"" ++ str ++ "\" with format \"" ++ fmt ++ "\"" Just t -> Right (FTime t) From 6462804f527394c6e0cd4ecb5cd0975972ccb158 Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Fri, 2 Sep 2016 12:53:04 +1000 Subject: [PATCH 09/18] Merge branch 'master' of https://github.com/haskell-servant/servant into servant-dates # Conflicts: # servant-server/servant-server.cabal # servant-server/src/Servant/Server/Internal.hs # servant-server/test/Servant/ServerSpec.hs # servant/servant.cabal # servant/src/Servant/API.hs --- .ghci | 1 - .gitignore | 4 + .travis.yml | 25 +- CONTRIBUTING.md | 9 +- README.md | 3 +- doc/Makefile | 216 ++++ doc/building-the-docs | 8 + doc/conf.py | 294 +++++ doc/examples.md | 37 + doc/index.rst | 23 + doc/introduction.rst | 40 + doc/links.rst | 34 + doc/requirements.txt | 25 + doc/tutorial/.ghci | 1 + doc/tutorial/ApiType.lhs | 347 +++++ doc/tutorial/Authentication.lhs | 427 +++++++ doc/tutorial/Client.lhs | 150 +++ doc/tutorial/Docs.lhs | 234 ++++ doc/tutorial/Javascript.lhs | 518 ++++++++ {servant-cassava => doc/tutorial}/LICENSE | 4 +- doc/tutorial/Server.lhs | 1111 +++++++++++++++++ {servant-cassava => doc/tutorial}/Setup.hs | 0 doc/tutorial/index.rst | 18 + .../t9 => doc/tutorial/static}/index.html | 6 +- .../tutorial/t9 => doc/tutorial/static}/ui.js | 1 - doc/tutorial/test/JavascriptSpec.hs | 35 + doc/tutorial/test/Spec.hs | 1 + doc/tutorial/tinc.yaml | 13 + doc/tutorial/tutorial.cabal | 62 + scripts/README.md | 8 + scripts/bump-versions.sh | 7 +- scripts/ci-cron.sh | 20 + scripts/test-stack.sh | 11 + scripts/upload.hs | 14 + scripts/upload.sh | 52 - servant-blaze/LICENSE | 30 - servant-blaze/Setup.hs | 2 - servant-blaze/include/overlapping-compat.h | 8 - servant-blaze/servant-blaze.cabal | 33 - servant-blaze/src/Servant/HTML/Blaze.hs | 35 - servant-blaze/tinc.yaml | 3 - servant-cassava/include/overlapping-compat.h | 8 - servant-cassava/servant-cassava.cabal | 30 - servant-cassava/src/Servant/CSV/Cassava.hs | 115 -- servant-cassava/tinc.yaml | 3 - servant-client/CHANGELOG.md | 20 +- servant-client/LICENSE | 2 +- servant-client/README.md | 7 +- servant-client/servant-client.cabal | 63 +- servant-client/src/Servant/Client.hs | 274 ++-- .../src/Servant/Client/Experimental/Auth.hs | 36 + .../src/Servant/Common/BasicAuth.hs | 21 + servant-client/src/Servant/Common/Req.hs | 58 +- servant-client/test/Servant/ClientSpec.hs | 252 ++-- servant-docs/.ghci | 1 + servant-docs/CHANGELOG.md | 13 +- servant-docs/LICENSE | 2 +- servant-docs/example/greet.hs | 4 +- servant-docs/servant-docs.cabal | 15 +- servant-docs/src/Servant/Docs/Internal.hs | 166 ++- .../src/Servant/Docs/Internal/Pretty.hs | 4 +- servant-docs/test/Servant/DocsSpec.hs | 33 +- servant-examples/LICENSE | 30 - servant-examples/Setup.hs | 2 - .../auth-combinator/auth-combinator.hs | 80 -- servant-examples/hackage/hackage.hs | 90 -- servant-examples/include/overlapping-compat.h | 8 - servant-examples/servant-examples.cabal | 130 -- 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 --- .../socket-io-chat/socket-io-chat.hs | 54 - servant-examples/tinc.yaml | 15 - 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/T8.hs | 49 - servant-examples/tutorial/T9.hs | 105 -- servant-examples/tutorial/t8-main.hs | 4 - servant-examples/tutorial/tutorial.hs | 39 - .../wai-middleware/wai-middleware.hs | 51 - servant-foreign/CHANGELOG.md | 8 +- servant-foreign/LICENSE | 2 +- servant-foreign/servant-foreign.cabal | 47 +- servant-foreign/src/Servant/Foreign.hs | 61 +- .../src/Servant/Foreign/Inflections.hs | 45 + .../src/Servant/Foreign/Internal.hs | 473 ++++--- servant-foreign/test/Servant/ForeignSpec.hs | 163 +-- servant-js/CHANGELOG.md | 4 +- servant-js/LICENSE | 2 +- servant-js/examples/counter.hs | 3 +- servant-js/servant-js.cabal | 23 +- servant-js/src/Servant/JS.hs | 14 +- servant-js/src/Servant/JS/Angular.hs | 22 +- servant-js/src/Servant/JS/Axios.hs | 20 +- servant-js/src/Servant/JS/Internal.hs | 71 +- servant-js/src/Servant/JS/JQuery.hs | 21 +- servant-js/src/Servant/JS/Vanilla.hs | 20 +- servant-js/test/Servant/JSSpec.hs | 24 +- .../test/Servant/JSSpec/CustomHeaders.hs | 35 +- servant-lucid/LICENSE | 30 - servant-lucid/Setup.hs | 2 - servant-lucid/include/overlapping-compat.h | 8 - servant-lucid/servant-lucid.cabal | 33 - servant-lucid/src/Servant/HTML/Lucid.hs | 36 - servant-lucid/tinc.yaml | 3 - servant-mock/.ghci | 1 + servant-mock/LICENSE | 2 +- servant-mock/example/main.hs | 5 +- servant-mock/servant-mock.cabal | 45 +- servant-mock/src/Servant/Mock.hs | 108 +- servant-mock/test/Servant/MockSpec.hs | 85 ++ servant-mock/test/Spec.hs | 1 + servant-server/CHANGELOG.md | 44 +- servant-server/LICENSE | 2 +- servant-server/README.md | 3 +- servant-server/example/greet.hs | 6 +- servant-server/servant-server.cabal | 61 +- servant-server/src/Servant.hs | 2 + servant-server/src/Servant/Server.hs | 103 +- .../src/Servant/Server/Experimental/Auth.hs | 68 + servant-server/src/Servant/Server/Internal.hs | 348 ++++-- .../src/Servant/Server/Internal/BasicAuth.hs | 70 ++ .../src/Servant/Server/Internal/Context.hs | 104 ++ .../src/Servant/Server/Internal/Router.hs | 241 +++- .../Server/Internal/RoutingApplication.hs | 290 +++-- .../src/Servant/Server/Internal/ServantErr.hs | 220 +++- ...terSpec.hs => ArbitraryMonadServerSpec.hs} | 7 +- .../test/Servant/Server/ErrorSpec.hs | 99 +- .../Servant/Server/Internal/ContextSpec.hs | 62 + .../test/Servant/Server/RouterSpec.hs | 294 +++++ .../test/Servant/Server/StreamingSpec.hs | 108 ++ .../test/Servant/Server/UsingContextSpec.hs | 124 ++ .../UsingContextSpec/TestCombinators.hs | 71 ++ servant-server/test/Servant/ServerSpec.hs | 308 +++-- servant/.ghci | 1 + servant/CHANGELOG.md | 21 +- servant/LICENSE | 2 +- servant/servant.cabal | 58 +- servant/src/Servant/API.hs | 19 +- servant/src/Servant/API/Alternative.hs | 10 +- servant/src/Servant/API/BasicAuth.hs | 30 + servant/src/Servant/API/Capture.hs | 15 +- servant/src/Servant/API/ContentTypes.hs | 15 +- servant/src/Servant/API/Experimental/Auth.hs | 13 + servant/src/Servant/API/Header.hs | 6 +- .../API/Internal/Test/ComprehensiveAPI.hs | 43 + servant/src/Servant/API/Raw.hs | 2 +- servant/src/Servant/API/ResponseHeaders.hs | 21 +- servant/src/Servant/API/Vault.hs | 4 +- servant/src/Servant/API/Verbs.hs | 67 +- servant/src/Servant/API/WithNamedContext.hs | 21 + .../src/Servant/Utils}/Enter.hs | 11 +- servant/src/Servant/Utils/Links.hs | 60 +- servant/test/Servant/API/ContentTypesSpec.hs | 10 +- servant/test/Servant/Utils/LinksSpec.hs | 49 +- sources.txt | 6 +- stack-ghc-7.8.4.yaml | 35 +- stack-ghc-8.0.1.yaml | 11 + stack.yaml | 13 +- 166 files changed, 7694 insertions(+), 3519 deletions(-) delete mode 100644 .ghci create mode 100644 doc/Makefile create mode 100644 doc/building-the-docs create mode 100644 doc/conf.py create mode 100644 doc/examples.md create mode 100644 doc/index.rst create mode 100644 doc/introduction.rst create mode 100644 doc/links.rst create mode 100644 doc/requirements.txt create mode 100644 doc/tutorial/.ghci create mode 100644 doc/tutorial/ApiType.lhs create mode 100644 doc/tutorial/Authentication.lhs create mode 100644 doc/tutorial/Client.lhs create mode 100644 doc/tutorial/Docs.lhs create mode 100644 doc/tutorial/Javascript.lhs rename {servant-cassava => doc/tutorial}/LICENSE (92%) create mode 100644 doc/tutorial/Server.lhs rename {servant-cassava => doc/tutorial}/Setup.hs (100%) create mode 100644 doc/tutorial/index.rst rename {servant-examples/tutorial/t9 => doc/tutorial/static}/index.html (88%) rename {servant-examples/tutorial/t9 => doc/tutorial/static}/ui.js (99%) create mode 100644 doc/tutorial/test/JavascriptSpec.hs create mode 100644 doc/tutorial/test/Spec.hs create mode 100644 doc/tutorial/tinc.yaml create mode 100644 doc/tutorial/tutorial.cabal create mode 100644 scripts/README.md create mode 100755 scripts/ci-cron.sh create mode 100755 scripts/test-stack.sh create mode 100755 scripts/upload.hs delete mode 100755 scripts/upload.sh delete mode 100644 servant-blaze/LICENSE delete mode 100644 servant-blaze/Setup.hs delete mode 100644 servant-blaze/include/overlapping-compat.h delete mode 100644 servant-blaze/servant-blaze.cabal delete mode 100644 servant-blaze/src/Servant/HTML/Blaze.hs delete mode 100644 servant-blaze/tinc.yaml delete mode 100644 servant-cassava/include/overlapping-compat.h delete mode 100644 servant-cassava/servant-cassava.cabal delete mode 100644 servant-cassava/src/Servant/CSV/Cassava.hs delete mode 100644 servant-cassava/tinc.yaml create mode 100644 servant-client/src/Servant/Client/Experimental/Auth.hs create mode 100644 servant-client/src/Servant/Common/BasicAuth.hs create mode 100644 servant-docs/.ghci delete mode 100644 servant-examples/LICENSE delete mode 100644 servant-examples/Setup.hs delete mode 100644 servant-examples/auth-combinator/auth-combinator.hs delete mode 100644 servant-examples/hackage/hackage.hs delete mode 100644 servant-examples/include/overlapping-compat.h delete mode 100644 servant-examples/servant-examples.cabal 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/socket-io-chat/socket-io-chat.hs delete mode 100644 servant-examples/tinc.yaml 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/T8.hs delete mode 100644 servant-examples/tutorial/T9.hs delete mode 100644 servant-examples/tutorial/t8-main.hs delete mode 100644 servant-examples/tutorial/tutorial.hs delete mode 100644 servant-examples/wai-middleware/wai-middleware.hs create mode 100644 servant-foreign/src/Servant/Foreign/Inflections.hs delete mode 100644 servant-lucid/LICENSE delete mode 100644 servant-lucid/Setup.hs delete mode 100644 servant-lucid/include/overlapping-compat.h delete mode 100644 servant-lucid/servant-lucid.cabal delete mode 100644 servant-lucid/src/Servant/HTML/Lucid.hs delete mode 100644 servant-lucid/tinc.yaml create mode 100644 servant-mock/.ghci create mode 100644 servant-mock/test/Servant/MockSpec.hs create mode 100644 servant-mock/test/Spec.hs create mode 100644 servant-server/src/Servant/Server/Experimental/Auth.hs create mode 100644 servant-server/src/Servant/Server/Internal/BasicAuth.hs create mode 100644 servant-server/src/Servant/Server/Internal/Context.hs rename servant-server/test/Servant/{Server/Internal/EnterSpec.hs => ArbitraryMonadServerSpec.hs} (89%) create mode 100644 servant-server/test/Servant/Server/Internal/ContextSpec.hs create mode 100644 servant-server/test/Servant/Server/RouterSpec.hs create mode 100644 servant-server/test/Servant/Server/StreamingSpec.hs create mode 100644 servant-server/test/Servant/Server/UsingContextSpec.hs create mode 100644 servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs create mode 100644 servant/.ghci create mode 100644 servant/src/Servant/API/BasicAuth.hs create mode 100644 servant/src/Servant/API/Experimental/Auth.hs create mode 100644 servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs create mode 100644 servant/src/Servant/API/WithNamedContext.hs rename {servant-server/src/Servant/Server/Internal => servant/src/Servant/Utils}/Enter.hs (94%) create mode 100644 stack-ghc-8.0.1.yaml diff --git a/.ghci b/.ghci deleted file mode 100644 index 93d9b991..00000000 --- a/.ghci +++ /dev/null @@ -1 +0,0 @@ -:set -itest -isrc -packagehspec2 diff --git a/.gitignore b/.gitignore index 2b2f3487..163de4bd 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,7 @@ Setup .stack-work shell.nix default.nix +doc/_build +doc/venv +doc/tutorial/static/api.js +doc/tutorial/static/jq.js diff --git a/.travis.yml b/.travis.yml index 62501f7a..1a006a6b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,30 +3,27 @@ sudo: false language: c env: - - GHCVER=7.8.4 - - GHCVER=7.10.2 + - STACK_YAML=stack-ghc-7.8.4.yaml + - STACK_YAML=stack.yaml + - STACK_YAML=stack-ghc-8.0.1.yaml addons: apt: - sources: - - hvr-ghc packages: - - ghc-7.8.4 - - ghc-7.10.2 - - cabal-install-1.22 - libgmp-dev install: - - (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc) - - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH - - ghc --version - - cabal --version - - travis_retry cabal update - - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config + - mkdir -p ~/.local/bin + - export PATH=$HOME/.local/bin:$PATH + - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' + - stack --version + - stack setup --no-terminal + - (cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc) script: - - for package in $(cat sources.txt); do (cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done + - if [ "$TRAVIS_EVENT_TYPE" = "cron" ] ; then ./scripts/ci-cron.sh ; else stack test --ghc-options=-Werror --no-terminal ; fi cache: directories: - $HOME/.tinc/cache + - $HOME/.stack diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 335f6094..c4eb4705 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 @@ -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. diff --git a/README.md b/README.md index 3cf786ea..9d3631a7 100644 --- a/README.md +++ b/README.md @@ -4,11 +4,12 @@ ## Getting Started -We have a [tutorial](http://haskell-servant.github.io/tutorial) that +We have a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) that introduces the core features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples. +The central documentation can be found [here](http://haskell-servant.readthedocs.org/). Other blog posts, videos and slides can be found on the [website](http://haskell-servant.github.io/). diff --git a/doc/Makefile b/doc/Makefile new file mode 100644 index 00000000..95957c1a --- /dev/null +++ b/doc/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/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 . diff --git a/doc/conf.py b/doc/conf.py new file mode 100644 index 00000000..1c7aba02 --- /dev/null +++ b/doc/conf.py @@ -0,0 +1,294 @@ +# -*- 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', '.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 = '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', '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' + +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 = [] + +# 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/doc/examples.md b/doc/examples.md new file mode 100644 index 00000000..47e73aa1 --- /dev/null +++ b/doc/examples.md @@ -0,0 +1,37 @@ +# Example Projects + +- **[example-servant-minimal](https://github.com/haskell-servant/example-servant-minimal)**: + + A minimal example for a web server written using **servant-server**, + including a test-suite using [**hspec**](http://hspec.github.io/) and + **servant-client**. + + +- **[stack-templates](https://github.com/commercialhaskell/stack-templates)** + + Repository for templates for haskell projects, including some templates using + **servant**. These templates can be used with `stack new`. + +- **[custom-monad](https://github.com/themoritz/diener)**: + + A custom monad that can replace `IO` in servant applications. It adds among + other things logging functionality and a reader monad (for database connections). + A full usage example of servant/diener is also provided. + + +- **[example-servant-elm](https://github.com/haskell-servant/example-servant-elm)**: + + An example for a project consisting of + + - a backend web server written using **servant-server**, + - a frontend written in [elm](http://elm-lang.org/) using + [servant-elm](https://github.com/mattjbray/servant-elm) to generate client + functions in elm for the API, + - test-suites for both the backend and the frontend. + + +- **[example-servant-persistent](https://github.com/haskell-servant/example-servant-persistent)**: + + An example for a web server written with **servant-server** and + [persistent](https://www.stackage.org/package/persistent) for writing data + into a database. diff --git a/doc/index.rst b/doc/index.rst new file mode 100644 index 00000000..e14fded0 --- /dev/null +++ b/doc/index.rst @@ -0,0 +1,23 @@ +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 +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, +- generate documentation for your web applications +- and more... + +All in a type-safe manner. + +.. toctree:: + :maxdepth: 2 + + introduction.rst + tutorial/index.rst + examples.md + links.rst diff --git a/doc/introduction.rst b/doc/introduction.rst new file mode 100644 index 00000000..77ef306b --- /dev/null +++ b/doc/introduction.rst @@ -0,0 +1,40 @@ +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*. diff --git a/doc/links.rst b/doc/links.rst new file mode 100644 index 00000000..5f14c527 --- /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/requirements.txt b/doc/requirements.txt new file mode 100644 index 00000000..93ddeccc --- /dev/null +++ b/doc/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.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.6 +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/doc/tutorial/.ghci b/doc/tutorial/.ghci new file mode 100644 index 00000000..d8e88521 --- /dev/null +++ b/doc/tutorial/.ghci @@ -0,0 +1 @@ +:set -pgmL markdown-unlit -Wall -Werror -fno-warn-missing-methods -fno-warn-name-shadowing -itest diff --git a/doc/tutorial/ApiType.lhs b/doc/tutorial/ApiType.lhs new file mode 100644 index 00000000..096903e8 --- /dev/null +++ b/doc/tutorial/ApiType.lhs @@ -0,0 +1,347 @@ +# 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: + +``` haskell +{-# 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 more. + +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] + +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. + +Tip: If your endpoint responds to `/` (the root path), just omit any combinators +that introduce path segments. E.g. the following api has only one endpoint on `/`: + +``` haskell +type RootEndpoint = + Get '[JSON] User +``` + +We can also describe APIs with multiple endpoints by using the `:<|>` +combinators. Here's an example: + +``` 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 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. + +``` 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` + +The `Get` combinator is defined in terms of the more general `Verb`: +``` haskell ignore +data Verb method (statusCode :: Nat) (contentType :: [*]) a +type Get = Verb 'GET 200 +``` + +There are other predefined type synonyms for other common HTTP methods, +such as e.g.: +``` haskell ignore +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 +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] + :<|> "admins" :> Get '[JSON] [User] +``` + +### `Capture` + +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 "name of the variable" and a type, which indicates the type we want to +decode the "captured value" to. + +``` haskell ignore +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 +[`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: + +``` 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 :> 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` says that the response will always be empty. + +### `QueryParam`, `QueryParams`, `QueryFlag` + +`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 +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 ignore +data QueryParam (sym :: Symbol) a +data QueryParams (sym :: Symbol) a +data QueryFlag (sym :: Symbol) +``` + +Examples: + +``` haskell +type UserAPI6 = "users" :> QueryParam "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 ignore +data ReqBody (contentTypes :: [*]) a +``` + +Examples: + +``` 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 + +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 ignore +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. + +``` haskell +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: + +``` haskell +type UserAPI9 = "users" :> Get '[JSON, PlainText, FormUrlEncoded, OctetStream] [User] +``` + +(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](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` types and can be used by simply wrapping the "return type" of an endpoint +with it. + +``` haskell ignore +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: + +``` haskell +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 Authentication 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 +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] + -- 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 +``` + +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`. diff --git a/doc/tutorial/Authentication.lhs b/doc/tutorial/Authentication.lhs new file mode 100644 index 00000000..5b1c8d19 --- /dev/null +++ b/doc/tutorial/Authentication.lhs @@ -0,0 +1,427 @@ +# 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.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.Auth (AuthProtect) +import Servant (throwError) +import Servant.Server (BasicAuthCheck (BasicAuthCheck), + BasicAuthResult( Authorized + , Unauthorized + ), + Context ((:.), EmptyContext), + err401, err403, errBody, Server, + serveWithContext, Handler) +import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, + mkAuthHandler) +import Servant.Server.Experimental.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 -> Handler 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 -> Handler 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 -> Handler 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 -> Handler` 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. +basicAuthServerContext :: Context (BasicAuthCheck User ': '[]) +basicAuthServerContext = 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. +basicAuthServer :: Server BasicAPI +basicAuthServer = + 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 + basicAuthServerContext + basicAuthServer + ) + +{- 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 -> Handler 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 Account = Account { unAccount :: Text } + +-- | A (pure) database mapping keys to users. +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 Account. +-- This is our bespoke (and bad) authentication logic. +lookupAccount :: ByteString -> Handler Account +lookupAccount key = case Map.lookup key database of + Nothing -> throwError (err403 { errBody = "Invalid Cookie" }) + Just usr -> return usr +``` + +For generalized authentication, servant exposes the `AuthHandler` type, +which is used to wrap the `Request -> Handler user` logic. Let's +create a value of type `AuthHandler Request Account` using the above `lookupAccount` +method: + +```haskell +-- | The auth handler wraps a function from Request -> Handler 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 -> throwError (err401 { errBody = "Missing auth header" }) + Just authCookieKey -> lookupAccount 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 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 +`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") = Account +``` + +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. +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 'Account' as an +-- argument. We dont' worry about the authentication instrumentation here, +-- that is taken care of by supplying context +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)! + +```haskell +-- | run our server +genAuthMain :: IO () +genAuthMain = run 8080 (serveWithContext genAuthAPI genAuthServerContext genAuthServer) + +{- 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 -> Handler 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/Client.lhs b/doc/tutorial/Client.lhs new file mode 100644 index 00000000..a40ca7c6 --- /dev/null +++ b/doc/tutorial/Client.lhs @@ -0,0 +1,150 @@ +# 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. + +**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 +need to have some language extensions and imports: + +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} + +module Client where + +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Data.Aeson +import Data.Proxy +import GHC.Generics +import Network.HTTP.Client (Manager, newManager, defaultManagerSettings) +import Servant.API +import Servant.Client +``` + +Also, we need examples for some domain specific data types: + +``` 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: + +``` 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: + +``` haskell +position :: Int -- ^ value for "x" + -> Int -- ^ value for "y" + -> 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" + -> 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 + -> 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 +depend on, as evidenced in the API type. How do we get these functions? By calling +the function `client`. It takes one argument: + +- a `Proxy` to your API, + +``` haskell +api :: Proxy API +api = Proxy + +position :<|> hello :<|> marketing = client api +``` + +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 +-- | 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. + +``` haskell +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 <- runExceptT (queries manager (BaseUrl Http "localhost" 8081 "")) + case res of + Left err -> putStrLn $ "Error: " ++ show err + Right (pos, message, em) -> do + print pos + print message + print em +``` + +Here's the output of the above code running against the appropriate server: + +``` bash +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/doc/tutorial/Docs.lhs b/doc/tutorial/Docs.lhs new file mode 100644 index 00000000..fa7b0c43 --- /dev/null +++ b/doc/tutorial/Docs.lhs @@ -0,0 +1,234 @@ +# 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: + +``` 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](Server.html)): + +``` 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: + +``` 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. + +``` 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 where + toSamples _ = singleSample (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 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 where + toSamples _ = singleSample 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. + +With all of this, we can derive docs for our API. + +``` 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. + +**servant**'s markdown pretty printer is a function named `markdown`. + +``` haskell ignore +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. + +``` 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. + +``` 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 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. diff --git a/doc/tutorial/Javascript.lhs b/doc/tutorial/Javascript.lhs new file mode 100644 index 00000000..2d9ab6bd --- /dev/null +++ b/doc/tutorial/Javascript.lhs @@ -0,0 +1,518 @@ +# 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. + +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: + +``` 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 as T (Text) +import Data.Text.IO as T (writeFile, readFile) +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 +``` + +Now let's have the API type(s) and the accompanying datatypes. + +``` 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. + +``` 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. + +``` 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`. + +``` 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. + +``` haskell +api :: Proxy API +api = Proxy + +api' :: Proxy API' +api' = Proxy + +server :: Server API +server = randomPoint + :<|> searchBook + +server' :: Server API' +server' = server + :<|> 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. + +Very similarly to how one can derive haskell functions, we can derive the +javascript with just a simple function call to `jsForAPI` from +`Servant.JS`. + +``` haskell +apiJS1 :: Text +apiJS1 = jsForAPI api jquery +``` + +This `Text` contains 2 Javascript functions, 'getPoint' and 'getBooks': + +``` javascript + +var getPoint = function(onSuccess, onError) +{ + $.ajax( + { url: '/point' + , success: onSuccess + , error: onError + , type: 'GET' + }); +} + +var getBooks = function(q, onSuccess, onError) +{ + $.ajax( + { url: '/books' + '?q=' + encodeURIComponent(q) + , success: onSuccess + , error: onError + , type: 'GET' + }); +} +``` + +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 "static/api.js" apiJS1 + jq <- T.readFile =<< Language.Javascript.JQuery.file + T.writeFile "static/jq.js" jq +``` + +(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. + +## Customizations + +Instead of calling `jquery`, you can call its variant `jqueryWith`. +Here are the type definitions + +```haskell ignore +jquery :: JavaScriptGenerator +jqueryWith :: CommonGeneratorOptions -> JavaScriptGenerator +``` + +The `CommonGeneratorOptions` will let you define different behaviors to +change how functions are generated. Here is the definition of currently +available options: + +```haskell ignore +data CommonGeneratorOptions = CommonGeneratorOptions + { + -- | function generating function names + functionNameBuilder :: FunctionName -> Text + -- | name used when a user want to send the request body (to let you redefine it) + , requestBody :: Text + -- | name of the callback parameter when the request was successful + , successCallback :: Text + -- | name of the callback parameter when the request reported an error + , errorCallback :: Text + -- | namespace on which we define the js function (empty mean local var) + , moduleName :: Text + -- | a prefix that should be prepended to the URL in the generated JS + , urlPrefix :: Text + } +``` + +This pattern is available with all supported backends, and default values are provided. + +## Vanilla support + +If you don't use JQuery for your application, you can reduce your +dependencies to simply use the `XMLHttpRequest` object from the standard API. + +Use the same code as before but simply replace the previous `apiJS` with +the following one: + +``` haskell +apiJS2 :: Text +apiJS2 = jsForAPI api vanillaJS +``` + +The rest is *completely* unchanged. + +The output file is a bit different, but it has the same parameters, + +``` javascript + + +var getPoint = function(onSuccess, onError) +{ + 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); +} + +var getBooks = function(q, onSuccess, onError) +{ + 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); +} + + +``` + +And that's all, your web service can of course be accessible from those +two clients at the same time! + +## Axios support + +### Simple usage + +If you use Axios library for your application, we support that too! + +Use the same code as before but simply replace the previous `apiJS` with +the following one: + +``` haskell +apiJS3 :: Text +apiJS3 = jsForAPI api $ axios defAxiosOptions +``` + +The rest is *completely* unchanged. + +The output file is a bit different, + +``` javascript + + +var getPoint = function() +{ + return axios({ url: '/point' + , method: 'get' + }); +} + + + +var getBooks = function(q) +{ + return axios({ url: '/books' + '?q=' + encodeURIComponent(q) + , method: 'get' + }); +} + +``` + +**Caution:** In order to support the promise style of the API, there are no onSuccess +nor onError callback functions. + +### Defining Axios configuration + +Axios lets you define a 'configuration' to determine the behavior of the +program when the AJAX request is sent. + +We mapped this into a configuration + +``` haskell +data AxiosOptions = AxiosOptions + { -- | indicates whether or not cross-site Access-Control requests + -- should be made using credentials + withCredentials :: !Bool + -- | the name of the cookie to use as a value for xsrf token + , xsrfCookieName :: !(Maybe Text) + -- | the name of the header to use as a value for xsrf token + , xsrfHeaderName :: !(Maybe Text) + } +``` + +## Angular support + +### Simple usage + +You can apply the same procedure as with `vanillaJS` and `jquery`, and +generate top level functions. + +The difference is that `angular` Generator always takes an argument. + +``` haskell +apiJS4 :: Text +apiJS4 = jsForAPI api $ angular defAngularOptions +``` + +The generated code will be a bit different than previous generators. An extra +argument `$http` will be added to let Angular magical Dependency Injector +operate. + +**Caution:** In order to support the promise style of the API, there are no onSuccess +nor onError callback functions. + +``` javascript + + +var getPoint = function($http) +{ + return $http( + { url: '/point' + , method: 'GET' + }); +} + + + +var getBooks = function($http, q) +{ + return $http( + { url: '/books' + '?q=' + encodeURIComponent(q) + , method: 'GET' + }); +} + +``` + +You can then build your controllers easily + +``` javascript + +app.controller("MyController", function($http) { + this.getPoint = getPoint($http) + .success(/* Do something */) + .error(/* Report error */); + + this.getPoint = getBooks($http, q) + .success(/* Do something */) + .error(/* Report error */); +}); +``` + +### Service generator + +You can also generate automatically a service to wrap the whole API as +a single Angular service: + +``` javascript +app.service('MyService', function($http) { + return ({ + postCounter: function() + { + return $http( + { url: '/counter' + , method: 'POST' + }); + }, + getCounter: function() + { + return $http( + { url: '/books' + '?q=' + encodeURIComponent(q), true); + , method: 'GET' + }); + } + }); +}); +``` + +To do so, you just have to use an alternate generator. + +``` haskell +apiJS5 :: Text +apiJS5 = jsForAPI api $ angularService defAngularOptions +``` + +Again, it is possible to customize some portions with the options. + +``` haskell +data AngularOptions = AngularOptions + { -- | When generating code with wrapInService, name of the service to generate, default is 'app' + serviceName :: Text + , -- | beginning of the service definition + prologue :: Text -> Text -> Text + , -- | end of the service definition + epilogue :: Text + } +``` + +# Custom function name builder + +Servant comes with three name builders included: + +- camelCase (the default) +- concatCase +- snakeCase + +Keeping the JQuery as an example, let's see the impact: + +``` haskell +apiJS6 :: Text +apiJS6 = jsForAPI api $ jqueryWith defCommonGeneratorOptions { functionNameBuilder= snakeCase } +``` + +This `Text` contains 2 Javascript functions: + +``` javascript + + +var get_point = function(onSuccess, onError) +{ + $.ajax( + { url: '/point' + , success: onSuccess + , error: onError + , type: 'GET' + }); +} + +var get_books = function(q, onSuccess, onError) +{ + $.ajax( + { url: '/books' + '?q=' + encodeURIComponent(q) + , success: onSuccess + , error: onError + , type: 'GET' + }); +} + +``` + diff --git a/servant-cassava/LICENSE b/doc/tutorial/LICENSE similarity index 92% rename from servant-cassava/LICENSE rename to doc/tutorial/LICENSE index 0b0a2174..fc4415bd 100644 --- a/servant-cassava/LICENSE +++ b/doc/tutorial/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Julian K. Arni +Copyright (c) 2016, Servant Contributors All rights reserved. @@ -13,7 +13,7 @@ modification, are permitted provided that the following conditions are met: disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Julian K. Arni nor the names of other + * 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. diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs new file mode 100644 index 00000000..11fdf3c0 --- /dev/null +++ b/doc/tutorial/Server.lhs @@ -0,0 +1,1111 @@ +# Serving an API + +Enough chit-chat about type-level combinators and representing an API as a +type. Can we have a webservice already? + +## A first example + +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 +need to have some language extensions and imports: + +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Server where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Except +import Control.Monad.Reader +import Data.Aeson.Compat +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 +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 +``` + +**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. + +``` haskell +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. + +``` 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. + +``` 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. + +``` haskell ignore +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 `Handler` 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 `Handler [User]`. Well, +we have a monad, let's just `return` our list: + +``` 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): + +``` 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. + +``` 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 +*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: + +``` 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. + +``` haskell +type UserAPI2 = "users" :> Get '[JSON] [User] + :<|> "albert" :> Get '[JSON] User + :<|> "isaac" :> Get '[JSON] User +``` + +And let's adapt our code a bit. + +``` 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 in in the API type. + +``` haskell +server2 :: Server UserAPI2 +server2 = return users2 + :<|> return albert + :<|> return 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 + +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`. + +``` 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 + { xCoord :: Int + , yCoord :: 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: + +``` haskell +server3 :: Server API +server3 = position + :<|> hello + :<|> marketing + + where position :: Int -> Int -> Handler Position + position x y = return (Position x y) + + hello :: Maybe String -> Handler HelloMessage + hello mname = return . HelloMessage $ case mname of + Nothing -> "Hello, anonymous coward" + Just n -> "Hello, " ++ n + + marketing :: ClientInfo -> Handler 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. Here's the example in action: + +``` bash +$ curl http://localhost:8081/position/1/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 '{"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"} +``` + +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 `Handler `. + > - `Capture "something" a` becomes an argument 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 +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". 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 FromHttpApiData a where + {-# MINIMAL parseUrlPiece | parseQueryParam #-} + -- | Parse URL path piece. + parseUrlPiece :: Text -> Either Text a + parseUrlPiece = parseQueryParam + + -- | Parse HTTP header value. + parseHeader :: ByteString -> Either Text a + parseHeader = parseUrlPiece . decodeUtf8 + + -- | Parse query param value. + parseQueryParam :: Text -> Either Text a + parseQueryParam = parseUrlPiece +``` + +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 +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](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` (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 +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` (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 +the `MediaType` is to write an instance for the `Accept` class: + +``` haskell ignore +-- 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 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 + -- 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 ignore +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 ignore +class Accept ctype => MimeUnrender ctype a where + 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. + +``` 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. + +``` haskell ignore +instance FromJSON a => MimeUnrender JSON a where + mimeUnrender _ = eitherDecodeLenient +``` + +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 +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!). We're first going to look at **lucid**: + +``` 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 +**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 +us specify additional information about a content-type, like the charset here. + +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`. + +``` 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** everything works very similarly: + +``` 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 +`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 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] +``` + +where `Person` is defined as follows: + +``` 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. + +``` 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: + +``` haskell +people :: [Person] +people = + [ Person "Isaac" "Newton" + , Person "Albert" "Einstein" + ] + +personAPI :: Proxy PersonAPI +personAPI = Proxy + +server4 :: Server PersonAPI +server4 = return people + +app2 :: Application +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 +``` + +## The `Handler` monad + +At the heart of the handlers is the monad they run in, namely `ExceptT ServantErr IO` +([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)), which is aliased as `Handler`. +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 (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`. + +Let's recall some definitions. + +``` haskell ignore +-- from the 'mtl' package at +newtype ExceptT e m a = ExceptT (m (Either e a)) +``` + +In short, this means that a handler of type `Handler 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 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 + +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 +``` + +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 + +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 `throwError` function mentioned above +and provide it with the appropriate value of type `ServantErr`, which is +defined as: + +``` haskell ignore +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: + +``` haskell +failingHandler :: Handler () +failingHandler = throwError 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: + +``` haskell +server6 :: Server IOAPI1 +server6 = do + exists <- liftIO (doesFileExist "myfile.txt") + if exists + then liftIO (readFile "myfile.txt") >>= return . FileContent + else throwError custom404Err + + where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." } +``` + +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. + +$ 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/docs/Servant-API-ResponseHeaders.html). +Note that this changes the type of your API, as we can see in the following example: + +``` haskell +type MyHandler = Get '[JSON] (Headers '[Header "X-An-Int" Int] User) + +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 + +**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 ignore +-- exported by Servant and Servant.Server +serveDirectory :: FilePath -> Server Raw +``` + +`serveDirectory`'s argument must be a path to a valid directory. + +Here's an example API that will serve some static files: + +``` haskell +type StaticAPI = "static" :> Raw +``` + +And the server: + +``` haskell +staticAPI :: Proxy StaticAPI +staticAPI = Proxy +``` + +``` haskell +server7 :: Server StaticAPI +server7 = serveDirectory "static-files" + +app3 :: Application +app3 = serve staticAPI server7 +``` + +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 + *static-files/* directory of the path you run the program from. + +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 + +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 + Capture "userid" Int :> Get '[JSON] User + + :<|> -- delete the user with given userid. empty response + Capture "userid" Int :> DeleteNoContent '[JSON] NoContent +``` + +We can instead factor out the `userid`: + +``` haskell +type UserAPI4 = Capture "userid" Int :> + ( Get '[JSON] User + :<|> DeleteNoContent '[JSON] NoContent + ) +``` + +However, you have to be aware that this has an effect on the type of the +corresponding `Server`: + +``` haskell ignore +Server UserAPI3 = (Int -> Handler User) + :<|> (Int -> Handler NoContent) + +Server UserAPI4 = Int -> ( Handler User + :<|> Handler NoContent + ) +``` + +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: + +``` haskell +server8 :: Server UserAPI3 +server8 = getUser :<|> deleteUser + + where getUser :: Int -> Handler User + getUser _userid = error "..." + + deleteUser :: Int -> Handler NoContent + 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 -> Handler User + getUser = error "..." + + deleteUser :: Int -> Handler NoContent + 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`. + +``` 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 + :<|> PostNoContent '[JSON] NoContent -- 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 :> PostNoContent '[JSON] NoContent -- 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. + +``` haskell +type UsersAPI = + Get '[JSON] [User] -- list users + :<|> ReqBody '[JSON] User :> PostNoContent '[JSON] NoContent -- add a user + :<|> Capture "userid" Int :> + ( Get '[JSON] User -- view a user + :<|> ReqBody '[JSON] User :> PutNoContent '[JSON] NoContent -- update a user + :<|> DeleteNoContent '[JSON] NoContent -- delete a user + ) + +usersServer :: Server UsersAPI +usersServer = getUsers :<|> newUser :<|> userOperations + + where getUsers :: Handler [User] + getUsers = error "..." + + newUser :: User -> Handler NoContent + newUser = error "..." + + userOperations userid = + viewUser userid :<|> updateUser userid :<|> deleteUser userid + + where + viewUser :: Int -> Handler User + viewUser = error "..." + + updateUser :: Int -> User -> Handler NoContent + updateUser = error "..." + + deleteUser :: Int -> Handler NoContent + deleteUser = error "..." +``` + +``` haskell +type ProductsAPI = + Get '[JSON] [Product] -- list products + :<|> ReqBody '[JSON] Product :> PostNoContent '[JSON] NoContent -- add a product + :<|> Capture "productid" Int :> + ( Get '[JSON] Product -- view a product + :<|> ReqBody '[JSON] Product :> PutNoContent '[JSON] NoContent -- update a product + :<|> DeleteNoContent '[JSON] NoContent -- delete a product + ) + +data Product = Product { productId :: Int } + +productsServer :: Server ProductsAPI +productsServer = getProducts :<|> newProduct :<|> productOperations + + where getProducts :: Handler [Product] + getProducts = error "..." + + newProduct :: Product -> Handler NoContent + newProduct = error "..." + + productOperations productid = + viewProduct productid :<|> updateProduct productid :<|> deleteProduct productid + + where + viewProduct :: Int -> Handler Product + viewProduct = error "..." + + updateProduct :: Int -> Product -> Handler NoContent + updateProduct = error "..." + + deleteProduct :: Int -> Handler NoContent + 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: + +``` 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 :> PostNoContent '[JSON] NoContent -- add an 'a' + :<|> Capture "id" i :> + ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i' + :<|> ReqBody '[JSON] a :> PutNoContent '[JSON] NoContent -- update an 'a' + :<|> DeleteNoContent '[JSON] NoContent -- delete an 'a' + ) + +-- Build the appropriate 'Server' +-- given the handlers of the right type. +serverFor :: Handler [a] -- handler for listing of 'a's + -> (a -> Handler NoContent) -- handler for adding an 'a' + -> (i -> Handler a) -- handler for viewing an 'a' given its identifier of type 'i' + -> (i -> a -> Handler NoContent) -- updating an 'a' with given id + -> (i -> Handler NoContent) -- 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 `Handler`? Well, actually, there's more to that. `Server` is actually a +simple type synonym. + +``` haskell ignore +type Server api = ServerT api Handler +``` + +`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 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 +`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 ignore +newtype m :~> n = Nat { unNat :: forall a. m a -> n a} +``` + +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 `Handler`, say the `Reader String` monad, the first thing you have to +prepare is a function: + +``` haskell ignore +readerToHandler :: Reader String :~> Handler +``` + +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 +readerToHandler' :: forall a. Reader String a -> Handler a +readerToHandler' r = return (runReader r "hi") + +readerToHandler :: Reader String :~> Handler +readerToHandler = Nat readerToHandler' +``` + +We can write some simple webservice with the handlers running in `Reader String`. + +``` 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 `Handler`. But there's a simple solution to this. + +### Enter `enter` + +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 +readerToHandler` on our handlers. + +``` haskell +readerServer :: Server ReaderAPI +readerServer = enter readerToHandler readerServerT + +app4 :: Application +app4 = serve readerAPI readerServer +``` + +This is the webservice in action: + +``` bash +$ curl http://localhost:8081/a +1797 +$ 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**. diff --git a/servant-cassava/Setup.hs b/doc/tutorial/Setup.hs similarity index 100% rename from servant-cassava/Setup.hs rename to doc/tutorial/Setup.hs diff --git a/doc/tutorial/index.rst b/doc/tutorial/index.rst new file mode 100644 index 00000000..c3516671 --- /dev/null +++ b/doc/tutorial/index.rst @@ -0,0 +1,18 @@ +Tutorial +======== + +This is an introductory tutorial to **servant**. + +(Any comments, issues or feedback about the tutorial can be submitted +to `servant's issue tracker `_.) + + +.. toctree:: + :maxdepth: 1 + + ApiType.lhs + Server.lhs + Client.lhs + Javascript.lhs + Docs.lhs + Authentication.lhs diff --git a/servant-examples/tutorial/t9/index.html b/doc/tutorial/static/index.html similarity index 88% rename from servant-examples/tutorial/t9/index.html rename to doc/tutorial/static/index.html index 7ec49c70..bfc55b59 100644 --- a/servant-examples/tutorial/t9/index.html +++ b/doc/tutorial/static/index.html @@ -3,11 +3,11 @@ - Tutorial - 9 - servant-jquery + servant-js Example

Books

- +

Results for ""

    @@ -23,4 +23,4 @@ - \ No newline at end of file + diff --git a/servant-examples/tutorial/t9/ui.js b/doc/tutorial/static/ui.js similarity index 99% rename from servant-examples/tutorial/t9/ui.js rename to doc/tutorial/static/ui.js index 7148827a..8bcae8d8 100644 --- a/servant-examples/tutorial/t9/ui.js +++ b/doc/tutorial/static/ui.js @@ -58,4 +58,3 @@ function refresh() } window.setInterval(refresh, 200); - diff --git a/doc/tutorial/test/JavascriptSpec.hs b/doc/tutorial/test/JavascriptSpec.hs new file mode 100644 index 00000000..7dfd4cec --- /dev/null +++ b/doc/tutorial/test/JavascriptSpec.hs @@ -0,0 +1,35 @@ +{-# 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 apiJS1 `shouldSatisfy` (`isInfixOf` code) + cs apiJS3 `shouldSatisfy` (`isInfixOf` code) + cs apiJS4 `shouldSatisfy` (`isInfixOf` code) + cs apiJS6 `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 apiJS1)) + + 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/tinc.yaml b/doc/tutorial/tinc.yaml new file mode 100644 index 00000000..f52bab2d --- /dev/null +++ b/doc/tutorial/tinc.yaml @@ -0,0 +1,13 @@ +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-docs + path: ../../servant-docs + - name: servant-foreign + path: ../../servant-foreign diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal new file mode 100644 index 00000000..3b90c0dc --- /dev/null +++ b/doc/tutorial/tutorial.cabal @@ -0,0 +1,62 @@ +name: tutorial +version: 0.8 +synopsis: The servant tutorial +homepage: http://haskell-servant.readthedocs.org/ +license: BSD3 +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: ApiType + , Authentication + , Client + , Docs + , Javascript + , Server + build-depends: base == 4.* + , base-compat + , text + , aeson + , aeson-compat + , blaze-html + , directory + , blaze-markup + , containers + , servant == 0.8.* + , servant-server == 0.8.* + , servant-client == 0.8.* + , servant-docs == 0.8.* + , servant-js == 0.8.* + , warp + , http-media + , lucid + , time + , string-conversions + , bytestring + , attoparsec + , mtl + , random + , js-jquery + , wai + , http-types + , transformers + , markdown-unlit >= 0.4 + , http-client + default-language: Haskell2010 + ghc-options: -Wall -pgmL markdown-unlit + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + other-modules: JavascriptSpec + build-depends: base == 4.* + , tutorial + , hspec + , hspec-wai + , string-conversions diff --git a/scripts/README.md b/scripts/README.md new file mode 100644 index 00000000..1f3eae98 --- /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.hs +git tag && git push --tags +``` diff --git a/scripts/bump-versions.sh b/scripts/bump-versions.sh index 2e39cea3..aaa3d0c2 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 tutorial) ) else - ( cd "$ROOT" && bumper -"$POSITION" $(join , "${SOURCES[@]}") ) + ( cd "$ROOT" && bumper -"$POSITION" $(join , $SOURCES tutorial) ) fi - -# Trailing newline, bumper does not ship with its own. -echo diff --git a/scripts/ci-cron.sh b/scripts/ci-cron.sh new file mode 100755 index 00000000..27be3e35 --- /dev/null +++ b/scripts/ci-cron.sh @@ -0,0 +1,20 @@ +#!/usr/bin/env bash + +set -o nounset +set -o errexit +set -o verbose + +export PATH=$(stack path --bin-path):$PATH + +stack install cabal-install +cabal update + +for package in $(cat sources.txt) ; do + echo testing $package + pushd $package + tinc + cabal configure --enable-tests --disable-optimization --ghc-options='-Werror' + cabal build + cabal test + popd +done diff --git a/scripts/test-stack.sh b/scripts/test-stack.sh new file mode 100755 index 00000000..b93d6107 --- /dev/null +++ b/scripts/test-stack.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash + +set -o nounset +set -o errexit + +for stack_file in stack*.yaml ; do + echo testing $stack_file... + export STACK_YAML=$stack_file + stack setup + stack test --fast --ghc-options="-Werror" +done diff --git a/scripts/upload.hs b/scripts/upload.hs new file mode 100755 index 00000000..b03f251c --- /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 --no-signature " ++ 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 diff --git a/servant-blaze/LICENSE b/servant-blaze/LICENSE deleted file mode 100644 index 0b0a2174..00000000 --- a/servant-blaze/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2015, Julian K. Arni - -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 Julian K. Arni 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-blaze/Setup.hs b/servant-blaze/Setup.hs deleted file mode 100644 index 44671092..00000000 --- a/servant-blaze/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/servant-blaze/include/overlapping-compat.h b/servant-blaze/include/overlapping-compat.h deleted file mode 100644 index eef9d4ea..00000000 --- a/servant-blaze/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-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal deleted file mode 100644 index cc4ea34d..00000000 --- a/servant-blaze/servant-blaze.cabal +++ /dev/null @@ -1,33 +0,0 @@ --- Initial servant-blaze.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: servant-blaze -version: 0.5 -synopsis: Blaze-html support for servant --- description: -homepage: http://haskell-servant.github.io/ -license: BSD3 -license-file: LICENSE -author: Julian K. Arni -maintainer: jkarni@gmail.com --- copyright: -category: Web -build-type: Simple -extra-source-files: include/*.h -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 - -library - exposed-modules: Servant.HTML.Blaze - -- other-modules: - -- other-extensions: - build-depends: base >=4.7 && <5 - , servant == 0.5.* - , http-media - , 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 deleted file mode 100644 index 822a7ae9..00000000 --- a/servant-blaze/src/Servant/HTML/Blaze.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -#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 --- `HTML` datatype.: --- --- >>> type Eg = Get '[HTML] a --- --- Will then check that @a@ has a `ToMarkup` instance, or is `Html`. -module Servant.HTML.Blaze where - -import Data.Typeable (Typeable) -import qualified Network.HTTP.Media as M -import Servant.API (Accept (..), MimeRender (..)) -import Text.Blaze.Html (Html, ToMarkup, toHtml) -import Text.Blaze.Html.Renderer.Utf8 (renderHtml) - -data HTML deriving Typeable - --- | @text/html;charset=utf-8@ -instance Accept HTML where - contentType _ = "text" M.// "html" M./: ("charset", "utf-8") - -instance OVERLAPPABLE_ ToMarkup a => MimeRender HTML a where - mimeRender _ = renderHtml . toHtml - -instance OVERLAPPING_ MimeRender HTML Html where - mimeRender _ = renderHtml - diff --git a/servant-blaze/tinc.yaml b/servant-blaze/tinc.yaml deleted file mode 100644 index dbf42cc7..00000000 --- a/servant-blaze/tinc.yaml +++ /dev/null @@ -1,3 +0,0 @@ -dependencies: - - name: servant - path: ../servant diff --git a/servant-cassava/include/overlapping-compat.h b/servant-cassava/include/overlapping-compat.h deleted file mode 100644 index eef9d4ea..00000000 --- a/servant-cassava/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-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal deleted file mode 100644 index e2e7c964..00000000 --- a/servant-cassava/servant-cassava.cabal +++ /dev/null @@ -1,30 +0,0 @@ --- Initial servant-cassava.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: servant-cassava -version: 0.4.4.2 -synopsis: Servant CSV content-type for cassava --- description: -homepage: http://haskell-servant.github.io/ -license: BSD3 -license-file: LICENSE -author: Julian K. Arni -maintainer: jkarni@gmail.com --- copyright: --- category: -build-type: Simple -extra-source-files: include/*.h -cabal-version: >=1.10 - -library - exposed-modules: Servant.CSV.Cassava - -- other-modules: - -- other-extensions: - build-depends: base >=4.6 && <5 - , cassava >0.4 && <0.5 - , servant ==0.5.* - , http-media - , vector - hs-source-dirs: src - default-language: Haskell2010 - include-dirs: include diff --git a/servant-cassava/src/Servant/CSV/Cassava.hs b/servant-cassava/src/Servant/CSV/Cassava.hs deleted file mode 100644 index 625007e7..00000000 --- a/servant-cassava/src/Servant/CSV/Cassava.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | A @CSV@ empty datatype with `MimeRender` and `MimeUnrender` instances for --- @cassava@'s encoding and decoding classes. --- --- >>> type Eg = Get '[(CSV', MyEncodeOptions)] [(Int, String)] --- --- Default encoding and decoding options are also provided, along with the --- @CSV@ type synonym that uses them. --- --- >>> type EgDefault = Get '[CSV] [(Int, String)] -module Servant.CSV.Cassava where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import Data.Csv -import Data.Proxy (Proxy (..)) -import Data.Typeable (Typeable) -import Data.Vector (Vector, toList) -import GHC.Generics (Generic) -import qualified Network.HTTP.Media as M -import Servant.API (Accept (..), MimeRender (..), - MimeUnrender (..)) - -data CSV' deriving (Typeable, Generic) - -type CSV = (CSV', DefaultDecodeOpts) - --- | @text/csv;charset=utf-8@ -instance Accept (CSV', a) where - contentType _ = "text" M.// "csv" M./: ("charset", "utf-8") - --- * Encoding - --- ** Instances - --- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining --- the order of headers and fields. -instance ( ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) (Header, [a]) where - mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr vals - where p = Proxy :: Proxy opt - --- | Encode with 'encodeDefaultOrderedByNameWith' -instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) [a] where - mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) - where p = Proxy :: Proxy opt - --- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining --- the order of headers and fields. -instance ( ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) (Header, Vector a) where - mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr (toList vals) - where p = Proxy :: Proxy opt - --- | Encode with 'encodeDefaultOrderedByNameWith' -instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) (Vector a) where - mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) . toList - where p = Proxy :: Proxy opt - --- ** Encode Options - -class EncodeOpts a where - encodeOpts :: Proxy a -> EncodeOptions - -data DefaultEncodeOpts deriving (Typeable, Generic) - -instance EncodeOpts DefaultEncodeOpts where - encodeOpts _ = defaultEncodeOptions - --- * Decoding - --- ** Instances - --- | Decode with 'decodeByNameWith' -instance ( FromNamedRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) (Header, [a]) where - mimeUnrender _ bs = fmap toList <$> decodeByNameWith (decodeOpts p) bs - where p = Proxy :: Proxy opt - --- | Decode with 'decodeWith'. Assumes data has headers, which are stripped. -instance ( FromRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) [a] where - mimeUnrender _ bs = toList <$> decodeWith (decodeOpts p) HasHeader bs - where p = Proxy :: Proxy opt - -instance ( FromNamedRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) (Header, Vector a) where - mimeUnrender _ = decodeByNameWith (decodeOpts p) - where p = Proxy :: Proxy opt - --- | Decode with 'decodeWith'. Assumes data has headers, which are stripped. -instance ( FromRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) (Vector a) where - mimeUnrender _ = decodeWith (decodeOpts p) HasHeader - where p = Proxy :: Proxy opt - --- ** Decode Options - -class DecodeOpts a where - decodeOpts :: Proxy a -> DecodeOptions - -data DefaultDecodeOpts deriving (Typeable, Generic) - -instance DecodeOpts DefaultDecodeOpts where - decodeOpts _ = defaultDecodeOptions diff --git a/servant-cassava/tinc.yaml b/servant-cassava/tinc.yaml deleted file mode 100644 index dbf42cc7..00000000 --- a/servant-cassava/tinc.yaml +++ /dev/null @@ -1,3 +0,0 @@ -dependencies: - - name: servant - path: ../servant diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index 2c9f5279..3627608d 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -1,13 +1,27 @@ -HEAD ----- +0.7.1 +----- + +* Support GHC 8.0 +* `ServantError` has an `Eq` instance now. + +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 * 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. +* 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-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/README.md b/servant-client/README.md index b1ef54b5..a2d40be2 100644 --- a/servant-client/README.md +++ b/servant-client/README.md @@ -13,9 +13,8 @@ type MyApi = "books" :> Get '[JSON] [Book] -- GET /books myApi :: Proxy MyApi myApi = Proxy -getAllBooks :: ExceptT String IO [Book] -postNewBook :: Book -> ExceptT String IO Book +getAllBooks :: Manager -> BaseUrl -> ExceptT String IO [Book] +postNewBook :: Book -> Manager -> BaseUrl -> ExceptT String IO Book -- 'client' allows you to produce operations to query an API from a client. -(getAllBooks :<|> postNewBook) = client myApi host - where host = BaseUrl Http "localhost" 8080 +(getAllBooks :<|> postNewBook) = client myApi ``` diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 087920dc..089e1209 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -1,25 +1,28 @@ name: servant-client -version: 0.5 +version: 0.8 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that let you query each endpoint of a webservice. . - See . + See . . 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 cabal-version: >=1.10 tested-with: GHC >= 7.8 -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues +extra-source-files: + include/*.h + CHANGELOG.md + README.md source-repository head type: git location: http://github.com/haskell-servant/servant.git @@ -27,35 +30,39 @@ source-repository head library exposed-modules: Servant.Client + Servant.Client.Experimental.Auth Servant.Common.BaseUrl + Servant.Common.BasicAuth Servant.Common.Req build-depends: - base >=4.7 && <5 - , aeson - , attoparsec - , bytestring - , exceptions - , http-api-data >= 0.1 && < 0.3 - , http-client - , http-client-tls - , http-media - , http-types - , network-uri >= 2.6 - , safe - , servant == 0.5.* - , string-conversions - , text - , transformers - , transformers-compat + base >= 4.7 && < 4.10 + , aeson >= 0.7 && < 1.1 + , attoparsec >= 0.12 && < 0.14 + , base64-bytestring >= 1.0.0.1 && < 1.1 + , bytestring >= 0.10 && < 0.11 + , exceptions >= 0.8 && < 0.9 + , http-api-data >= 0.1 && < 0.3 + , http-client >= 0.4.18.1 && < 0.6 + , http-client-tls >= 0.2.2 && < 0.4 + , http-media >= 0.6.2 && < 0.7 + , http-types >= 0.8.6 && < 0.10 + , network-uri >= 2.6 && < 2.7 + , safe >= 0.3.9 && < 0.4 + , servant == 0.8.* + , string-conversions >= 0.3 && < 0.5 + , text >= 1.2 && < 1.3 + , transformers >= 0.3 && < 0.6 + , transformers-compat >= 0.4 && < 0.6 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints include-dirs: include test-suite spec type: exitcode-stdio-1.0 - ghc-options: - -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + ghc-options: -Wall default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs @@ -76,9 +83,9 @@ test-suite spec , HUnit , network >= 2.6 , QuickCheck >= 2.7 - , servant == 0.5.* + , servant == 0.8.* , servant-client - , servant-server == 0.5.* + , servant-server == 0.8.* , text , wai , warp diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index e9bab748..18581075 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -15,8 +15,12 @@ -- querying functions for each endpoint just from the type representing your -- API. module Servant.Client - ( client + ( AuthClientData + , AuthenticateReq(..) + , client , HasClient(..) + , ClientM + , mkAuthenticateReq , ServantError(..) , module Servant.Common.BaseUrl ) where @@ -24,19 +28,20 @@ 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 (Manager, Response) import Network.HTTP.Media import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as HTTP import Servant.API +import Servant.Client.Experimental.Auth import Servant.Common.BaseUrl +import Servant.Common.BasicAuth import Servant.Common.Req -- * Accessing APIs as a Client @@ -49,19 +54,18 @@ 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 -client :: HasClient layout => Proxy layout -> BaseUrl -> Manager -> Client layout -client p baseurl = clientWithRoute p defReq baseurl +-- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book] +-- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book +-- > (getAllBooks :<|> postNewBook) = client myApi +client :: HasClient api => Proxy api -> Client api +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 +class HasClient api where + type Client api :: * + clientWithRoute :: Proxy api -> Req -> Client api -- | A client querying function for @a ':<|>' b@ will actually hand you @@ -74,15 +78,14 @@ 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 :: 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 - 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 @@ -100,38 +103,68 @@ 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 -> Manager -> BaseUrl -> 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 +instance (KnownSymbol capture, ToHttpApiData a, HasClient api) + => HasClient (Capture capture a :> api) where - type Client (Capture capture a :> sublayout) = - a -> Client sublayout + type Client (Capture capture a :> api) = + a -> Client api - clientWithRoute Proxy req baseurl manager val = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute Proxy req val = + clientWithRoute (Proxy :: Proxy api) (appendToPath p req) - baseurl - manager where p = unpack (toUrlPiece val) +-- | If you use a 'CaptureAll' in one of your endpoints in your API, +-- the corresponding querying function will automatically take an +-- additional argument of a list of the type specified by your +-- 'CaptureAll'. That function will take care of inserting a textual +-- representation of this value at the right place in the request +-- path. +-- +-- You can control how these values are turned into text by specifying +-- a 'ToHttpApiData' instance of your type. +-- +-- Example: +-- +-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile +-- > +-- > myApi :: Proxy +-- > myApi = Proxy +-- +-- > getSourceFile :: [Text] -> Manager -> BaseUrl -> ClientM SourceFile +-- > getSourceFile = client myApi +-- > -- then you can use "getSourceFile" to query that endpoint +instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) + => HasClient (CaptureAll capture a :> sublayout) where + + type Client (CaptureAll capture a :> sublayout) = + [a] -> Client sublayout + + clientWithRoute Proxy req vals = + clientWithRoute (Proxy :: Proxy sublayout) + (foldl' (flip appendToPath) req ps) + + where ps = map (unpack . toUrlPiece) vals + 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) = 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) = ExceptT ServantError IO NoContent - clientWithRoute Proxy req baseurl manager = - performRequestNoBody method req baseurl manager >> 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_ @@ -139,10 +172,10 @@ instance OVERLAPPING_ ( 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 + = 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 baseurl manager + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req manager baseurl return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } @@ -151,10 +184,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 + = Manager -> BaseUrl -> ClientM (Headers ls NoContent) + clientWithRoute Proxy req manager baseurl = do let method = reflectMethod (Proxy :: Proxy method) - hdrs <- performRequestNoBody method req baseurl manager + hdrs <- performRequestNoBody method req manager baseurl return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo hdrs } @@ -173,7 +206,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 @@ -181,28 +214,36 @@ 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 -> 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 -instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) - => HasClient (Header sym a :> sublayout) where +instance (KnownSymbol sym, ToHttpApiData a, HasClient api) + => HasClient (Header sym a :> api) where - type Client (Header sym a :> sublayout) = - Maybe a -> Client sublayout + type Client (Header sym a :> api) = + Maybe a -> Client api - clientWithRoute Proxy req baseurl manager mval = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute Proxy req mval = + clientWithRoute (Proxy :: Proxy api) (maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval ) - baseurl - manager where hname = symbolVal (Proxy :: Proxy sym) +-- | Using a 'HttpVersion' combinator in your API doesn't affect the client +-- functions. +instance HasClient api + => HasClient (HttpVersion :> api) where + + type Client (HttpVersion :> api) = + Client api + + clientWithRoute Proxy = + clientWithRoute (Proxy :: Proxy api) + -- | 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', @@ -223,27 +264,24 @@ instance (KnownSymbol sym, ToHttpApiData a, 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 -> Manager -> BaseUrl -> 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 -instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) - => HasClient (QueryParam sym a :> sublayout) where +instance (KnownSymbol sym, ToHttpApiData a, HasClient api) + => HasClient (QueryParam sym a :> api) where - type Client (QueryParam sym a :> sublayout) = - Maybe a -> Client sublayout + type Client (QueryParam sym a :> api) = + Maybe a -> Client api -- if mparam = Nothing, we don't add it to the query string - clientWithRoute Proxy req baseurl manager mparam = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute Proxy req mparam = + clientWithRoute (Proxy :: Proxy api) (maybe req (flip (appendToQueryString pname) req . Just) mparamText ) - baseurl - manager where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym) @@ -270,26 +308,24 @@ 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] -> Manager -> BaseUrl -> 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"]' -- > -- to get all books by Asimov and Heinlein -instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) - => HasClient (QueryParams sym a :> sublayout) where +instance (KnownSymbol sym, ToHttpApiData a, HasClient api) + => HasClient (QueryParams sym a :> api) where - type Client (QueryParams sym a :> sublayout) = - [a] -> Client sublayout + type Client (QueryParams sym a :> api) = + [a] -> Client api - clientWithRoute Proxy req baseurl manager paramlist = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute Proxy req paramlist = + clientWithRoute (Proxy :: Proxy api) (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist' ) - baseurl manager where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym) @@ -311,25 +347,23 @@ 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 -> Manager -> BaseUrl -> 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 -instance (KnownSymbol sym, HasClient sublayout) - => HasClient (QueryFlag sym :> sublayout) where +instance (KnownSymbol sym, HasClient api) + => HasClient (QueryFlag sym :> api) where - type Client (QueryFlag sym :> sublayout) = - Bool -> Client sublayout + type Client (QueryFlag sym :> api) = + Bool -> Client api - clientWithRoute Proxy req baseurl manager flag = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute Proxy req flag = + clientWithRoute (Proxy :: Proxy api) (if flag then appendToQueryString paramname Nothing req else req ) - baseurl manager where paramname = cs $ symbolVal (Proxy :: Proxy sym) @@ -337,11 +371,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 -> Manager -> BaseUrl -> 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 @@ -358,53 +393,72 @@ 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 -> Manager -> BaseUrl -> 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 +instance (MimeRender ct a, HasClient api) + => HasClient (ReqBody (ct ': cts) a :> api) where - type Client (ReqBody (ct ': cts) a :> sublayout) = - a -> Client sublayout + type Client (ReqBody (ct ': cts) a :> api) = + a -> Client api - clientWithRoute Proxy req baseurl manager body = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute Proxy req body = + clientWithRoute (Proxy :: Proxy api) (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 +instance (KnownSymbol path, HasClient api) => HasClient (path :> api) where + type Client (path :> api) = Client api - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy sublayout) + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy api) (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 + + 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 (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 val = + clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) {- Note [Non-Empty Content Types] diff --git a/servant-client/src/Servant/Client/Experimental/Auth.hs b/servant-client/src/Servant/Client/Experimental/Auth.hs new file mode 100644 index 00000000..a98d0b41 --- /dev/null +++ b/servant-client/src/Servant/Client/Experimental/Auth.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Authentication for clients + +module Servant.Client.Experimental.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 +-- +-- 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 +mkAuthenticateReq val func = AuthenticateReq (val, func) 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/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 3d72acd9..ea610cce 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -55,6 +55,19 @@ data ServantError } deriving (Show, Typeable) +instance Eq ServantError where + FailureResponse a b c == FailureResponse x y z = + (a, b, c) == (x, y, z) + DecodeFailure a b c == DecodeFailure x y z = + (a, b, c) == (x, y, z) + UnsupportedContentType a b == UnsupportedContentType x y = + (a, b) == (x, y) + InvalidContentTypeHeader a b == InvalidContentTypeHeader x y = + (a, b) == (x, y) + ConnectionError a == ConnectionError x = + show a == show x + _ == _ = False + instance Exception ServantError data Req = Req @@ -90,7 +103,7 @@ setRQBody b t req = req { reqBody = Just (b, t) } reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request reqToRequest req (BaseUrl reqScheme reqHost reqPort path) = - setheaders . setAccept . setrqb . setQS <$> parseUrl url + setheaders . setAccept . setrqb . setQS <$> parseRequest url where url = show $ nullURI { uriScheme = case reqScheme of Http -> "http:" @@ -117,22 +130,34 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) = toProperHeader (name, val) = (fromString name, encodeUtf8 val) +#if !MIN_VERSION_http_client(0,4,30) +-- 'parseRequest' is introduced in http-client-0.4.30 +-- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses +-- +-- See for implementations: +-- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest +-- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest +parseRequest :: MonadThrow m => String -> m Request +parseRequest url = liftM disableStatusCheck (parseUrl url) + where + disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing } +#endif + -- * performing requests displayHttpRequest :: Method -> String displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" +type ClientM = ExceptT ServantError IO -performRequest :: Method -> Req -> BaseUrl -> Manager - -> ExceptT ServantError IO ( Int, ByteString, MediaType - , [HTTP.Header], Response ByteString) -performRequest reqMethod req reqHost manager = do +performRequest :: Method -> Req -> Manager -> BaseUrl + -> ClientM ( Int, ByteString, MediaType + , [HTTP.Header], Response ByteString) +performRequest reqMethod req manager reqHost = do partialRequest <- liftIO $ reqToRequest req reqHost - let request = partialRequest { Client.method = reqMethod - , checkStatus = \ _status _headers _cookies -> Nothing - } + let request = partialRequest { Client.method = reqMethod } eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager case eResponse of @@ -153,23 +178,22 @@ performRequest reqMethod req reqHost manager = do throwE $ 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 -> Manager -> BaseUrl + -> ClientM ([HTTP.Header], result) +performRequestCT ct reqMethod req manager reqHost = do let acceptCT = contentType ct (_status, respBody, respCT, hdrs, _response) <- - performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager + performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of Left err -> throwE $ 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 -> Manager -> BaseUrl + -> ClientM [HTTP.Header] +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 245a7216..da7c763b 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 #-} @@ -11,9 +12,14 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -freduction-depth=100 #-} +#else {-# OPTIONS_GHC -fcontext-stack=100 #-} +#endif {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -26,21 +32,20 @@ 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 (throwE, runExceptT) 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, responseLBS) +import Network.Wai (Request, requestHeaders, responseLBS) import Network.Wai.Handler.Warp import System.IO.Unsafe (unsafePerformIO) import Test.Hspec @@ -49,14 +54,22 @@ import Test.HUnit import Test.QuickCheck 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. +_ = client comprehensiveAPI spec :: Spec spec = describe "Servant.Client" $ do sucessSpec failSpec wrappedApiSpec + basicAuthSpec + genAuthSpec -- * test data types @@ -92,6 +105,7 @@ type Api = "get" :> Get '[JSON] Person :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person + :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person] :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] @@ -109,11 +123,42 @@ type Api = api :: Proxy Api api = Proxy +getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person +getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent +getCapture :: String -> C.Manager -> BaseUrl -> SCR.ClientM Person +getCaptureAll :: [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 + :<|> getCaptureAll + :<|> getBody + :<|> getQueryParam + :<|> getQueryParams + :<|> getQueryFlag + :<|> getRawSuccess + :<|> getRawFailure + :<|> getMultiple + :<|> getRespHeaders + :<|> getDeleteContentType = client api + server :: Application server = serve api ( return alice :<|> return NoContent :<|> (\ name -> return $ Person name 0) + :<|> (\ names -> return (zipWith Person names [0..])) :<|> return :<|> (\ name -> case name of Just "alice" -> return alice @@ -121,8 +166,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 @@ -138,11 +183,57 @@ 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 + +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 + +basicServerContext :: Context '[ BasicAuthCheck () ] +basicServerContext = basicAuthHandler :. EmptyContext + +basicAuthServer :: Application +basicAuthServer = serveWithContext basicAuthAPI basicServerContext (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 + +genAuthServerContext :: Context '[ AuthHandler Request () ] +genAuthServerContext = genAuthHandler :. EmptyContext + +genAuthServer :: Application +genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice)) + {-# NOINLINE manager #-} manager :: C.Manager manager = unsafePerformIO $ C.newManager C.defaultManagerSettings @@ -151,76 +242,68 @@ 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 + (left show <$> runExceptT (getGet manager baseUrl)) `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 + (left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do - let getDeleteContentType = getLast $ client api baseUrl manager - (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right NoContent + (left show <$> runExceptT (getDeleteContentType manager baseUrl)) `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) + (left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0) + + it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do + let expected = [(Person "Paula" 0), (Person "Peta" 1)] + (left show <$> runExceptT (getCaptureAll ["Paula", "Peta"] manager baseUrl)) `shouldReturn` Right expected 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 + (left show <$> runExceptT (getBody p manager baseUrl)) `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")) - responseStatus `shouldBe` Status 400 "bob not found" + 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 - let getQueryParams = getNth (Proxy :: Proxy 5) $ client api baseUrl manager - (left show <$> runExceptT (getQueryParams [])) `shouldReturn` Right [] - (left show <$> runExceptT (getQueryParams ["alice", "bob"])) + (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 - let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api baseUrl manager - (left show <$> runExceptT (getQueryFlag flag)) `shouldReturn` Right flag + (left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `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) + res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl) 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 baseUrl manager - res <- runExceptT (getRawFailure methodGet) + res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl) 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 baseUrl manager - res <- runExceptT getRespHeaders + res <- runExceptT (getRespHeaders manager baseUrl) 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 - in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> + property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> ioProperty $ do - result <- left show <$> runExceptT (getMultiple cap num flag body) + result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl) return $ result === Right (cap, num, flag, body) @@ -232,10 +315,10 @@ 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 - responseStatus `shouldBe` (Status 500 "error message") + let getResponse :: C.Manager -> BaseUrl -> SCR.ClientM () + getResponse = client api + Left FailureResponse{..} <- runExceptT (getResponse manager baseUrl) + responseStatus `shouldBe` (HTTP.Status 500 "error message") in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : @@ -248,45 +331,78 @@ 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 <- runExceptT (getDeleteEmpty manager baseUrl) 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 - let (_ :<|> _ :<|> getCapture :<|> _) = client api baseUrl manager - Left res <- runExceptT (getCapture "foo") + let (_ :<|> _ :<|> getCapture :<|> _) = client api + 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 (BaseUrl Http "127.0.0.1" 19872 "") manager - Left res <- runExceptT getGetWrongHost + let (getGetWrongHost :<|> _) = client api + 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 baseUrl manager - Left res <- runExceptT getGet + let (getGet :<|> _ ) = client api + 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 baseUrl manager - Left res <- runExceptT (getBody alice) + let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api + 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 ~ ExceptT ServantError IO ()) => + WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a, + HasClient api, Client api ~ (C.Manager -> BaseUrl -> SCR.ClientM ())) => 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 + let basicAuthData = BasicAuthData "servant" "server" + (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{..} <- runExceptT (getBasic basicAuthData manager baseUrl) + responseStatus `shouldBe` HTTP.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 + let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req) + (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{..} <- runExceptT (getProtected authRequest manager baseUrl) + responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized") -- * utils @@ -317,25 +433,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 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 diff --git a/servant-docs/CHANGELOG.md b/servant-docs/CHANGELOG.md index a5be837a..dfdb99e5 100644 --- a/servant-docs/CHANGELOG.md +++ b/servant-docs/CHANGELOG.md @@ -1,4 +1,14 @@ -HEAD +0.7.1 +----- + +* Support GHC 8.0 + +0.7 +--- + +* Use `throwError` instead of `throwE` in documentation + +0.5 ---- * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators @@ -9,6 +19,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-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/example/greet.hs b/servant-docs/example/greet.hs index e94e065b..cdfa0b3c 100644 --- a/servant-docs/example/greet.hs +++ b/servant-docs/example/greet.hs @@ -81,7 +81,7 @@ type TestApi = :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] (Headers '[Header "X-Example" Int] Greet) -- DELETE /greet/:greetid - :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] () + :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent testApi :: Proxy TestApi testApi = Proxy @@ -91,7 +91,7 @@ testApi = Proxy -- notes. extra :: ExtraInfo TestApi extra = - extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] ())) $ + extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent)) $ defAction & headers <>~ ["unicorns"] & notes <>~ [ DocNote "Title" ["This is some text"] , DocNote "Second secton" ["And some more"] diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index b1be264d..d325e3d9 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.8 synopsis: generate API docs for your servant webservice description: Library for generating API docs from a servant API definition. @@ -9,14 +9,14 @@ 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 tested-with: GHC >= 7.8 -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: include/*.h @@ -42,7 +42,7 @@ library , http-media >= 0.6 , http-types >= 0.7 , lens - , servant == 0.5.* + , servant == 0.8.* , string-conversions , text , unordered-containers @@ -50,6 +50,8 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints include-dirs: include executable greet-docs @@ -82,4 +84,3 @@ test-suite spec , servant-docs , string-conversions default-language: Haskell2010 - diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 0c3e30ac..7b181822 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -22,11 +22,12 @@ 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) 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) @@ -139,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 @@ -156,7 +163,7 @@ data DocNote = DocNote -- -- These are intended to be built using extraInfo. -- Multiple ExtraInfo may be combined with the monoid instance. -newtype ExtraInfo layout = ExtraInfo (HashMap Endpoint Action) +newtype ExtraInfo api = ExtraInfo (HashMap Endpoint Action) instance Monoid (ExtraInfo a) where mempty = ExtraInfo mempty ExtraInfo a `mappend` ExtraInfo b = @@ -229,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 @@ -246,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'. @@ -267,6 +275,7 @@ defAction = [] [] [] + [] defResponse -- | Create an API that's comprised of a single endpoint. @@ -276,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 @@ -290,11 +300,11 @@ makeLenses ''Action -- default way to create documentation. -- -- prop> docs == docsWithOptions defaultDocOptions -docs :: HasDocs layout => Proxy layout -> API +docs :: HasDocs api => Proxy api -> API docs p = docsWithOptions p defaultDocOptions -- | Generate the docs for a given API that implements 'HasDocs'. -docsWithOptions :: HasDocs layout => Proxy layout -> DocOptions -> API +docsWithOptions :: HasDocs api => Proxy api -> DocOptions -> API docsWithOptions p = docsFor p (defEndpoint, defAction) -- | Closed type family, check if endpoint is exactly within API. @@ -306,7 +316,7 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where IsIn (e :> sa) (e :> sb) = IsIn sa sb IsIn e e = () --- | Create an 'ExtraInfo' that is garunteed to be within the given API layout. +-- | Create an 'ExtraInfo' that is guaranteed to be within the given API layout. -- -- The safety here is to ensure that you only add custom documentation to an -- endpoint that actually exists within your API. @@ -319,8 +329,8 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where -- > , DocNote "Second secton" ["And some more"] -- > ] -extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint) - => Proxy endpoint -> Action -> ExtraInfo layout +extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint) + => Proxy endpoint -> Action -> ExtraInfo api extraInfo p action = let api = docsFor p (defEndpoint, defAction) defaultDocOptions -- Assume one endpoint, HasLink constraint means that we should only ever @@ -339,7 +349,7 @@ extraInfo p action = -- 'extraInfo'. -- -- If you only want to add an introduction, use 'docsWithIntros'. -docsWith :: HasDocs layout => DocOptions -> [DocIntro] -> ExtraInfo layout -> Proxy layout -> API +docsWith :: HasDocs api => DocOptions -> [DocIntro] -> ExtraInfo api -> Proxy api -> API docsWith opts intros (ExtraInfo endpoints) p = docsWithOptions p opts & apiIntros <>~ intros @@ -348,13 +358,13 @@ docsWith opts intros (ExtraInfo endpoints) p = -- | Generate the docs for a given API that implements 'HasDocs' with with any -- number of introduction(s) -docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API +docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API docsWithIntros intros = docsWith defaultDocOptions intros mempty -- | The class that abstracts away the impact of API combinators -- on documentation generation. -class HasDocs layout where - docsFor :: Proxy layout -> (Endpoint, Action) -> DocOptions -> API +class HasDocs api where + docsFor :: Proxy api -> (Endpoint, Action) -> DocOptions -> API -- | The class that lets us display a sample input or output in the supported -- content-types when generating documentation for endpoints that either: @@ -453,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) @@ -503,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 @@ -515,6 +529,7 @@ markdown api = unlines $ str : "" : notesStr (action ^. notes) ++ + authStr (action ^. authInfo) ++ capturesStr (action ^. captures) ++ headersStr (action ^. headers) ++ paramsStr (action ^. params) ++ @@ -522,7 +537,7 @@ markdown api = unlines $ responseStr (action ^. response) ++ [] - where str = "## " ++ show (endpoint^.method) + where str = "## " ++ BSC.unpack (endpoint^.method) ++ " " ++ showPath (endpoint^.path) introsStr :: [DocIntro] -> [String] @@ -547,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 = @@ -646,27 +675,43 @@ markdown api = unlines $ -- | The generated docs for @a ':<|>' b@ just appends the docs -- for @a@ with the docs for @b@. instance OVERLAPPABLE_ - (HasDocs layout1, HasDocs layout2) - => HasDocs (layout1 :<|> layout2) where + (HasDocs a, HasDocs b) + => HasDocs (a :<|> b) where docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action) - where p1 :: Proxy layout1 + where p1 :: Proxy a p1 = Proxy - p2 :: Proxy layout2 + p2 :: Proxy b p2 = Proxy -- | @"books" :> 'Capture' "isbn" Text@ will appear as -- @/books/:isbn@ in the docs. -instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout) - => HasDocs (Capture sym a :> sublayout) where +instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api) + => HasDocs (Capture sym a :> api) where + + docsFor Proxy (endpoint, action) = + docsFor subApiP (endpoint', action') + + where subApiP = Proxy :: Proxy api + captureP = Proxy :: Proxy (Capture sym a) + + action' = over captures (|> toCapture captureP) action + endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint + symP = Proxy :: Proxy sym + + +-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as +-- @/books/:isbn@ in the docs. +instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout) + => HasDocs (CaptureAll sym a :> sublayout) where docsFor Proxy (endpoint, action) = docsFor sublayoutP (endpoint', action') where sublayoutP = Proxy :: Proxy sublayout - captureP = Proxy :: Proxy (Capture sym a) + captureP = Proxy :: Proxy (CaptureAll sym a) action' = over captures (|> toCapture captureP) action endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint @@ -707,34 +752,43 @@ instance OVERLAPPING_ status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a -instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) - => HasDocs (QueryParam sym a :> sublayout) where +instance (KnownSymbol sym, HasDocs api) + => HasDocs (Header sym a :> api) where + docsFor Proxy (endpoint, action) = + docsFor subApiP (endpoint, action') + + where subApiP = Proxy :: Proxy api + action' = over headers (|> headername) action + headername = T.pack $ symbolVal (Proxy :: Proxy sym) + +instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs api) + => HasDocs (QueryParam sym a :> api) where docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') + docsFor subApiP (endpoint, action') - where sublayoutP = Proxy :: Proxy sublayout + where subApiP = Proxy :: Proxy api paramP = Proxy :: Proxy (QueryParam sym a) action' = over params (|> toParam paramP) action -instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout) - => HasDocs (QueryParams sym a :> sublayout) where +instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs api) + => HasDocs (QueryParams sym a :> api) where docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') + docsFor subApiP (endpoint, action') - where sublayoutP = Proxy :: Proxy sublayout + where subApiP = Proxy :: Proxy api paramP = Proxy :: Proxy (QueryParams sym a) action' = over params (|> toParam paramP) action -instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout) - => HasDocs (QueryFlag sym :> sublayout) where +instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api) + => HasDocs (QueryFlag sym :> api) where docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') + docsFor subApiP (endpoint, action') - where sublayoutP = Proxy :: Proxy sublayout + where subApiP = Proxy :: Proxy api paramP = Proxy :: Proxy (QueryFlag sym) action' = over params (|> toParam paramP) action @@ -747,45 +801,55 @@ 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, AllMimeRender (ct ': cts) a, HasDocs sublayout) - => HasDocs (ReqBody (ct ': cts) a :> sublayout) where +instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api) + => HasDocs (ReqBody (ct ': cts) a :> api) where docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint, action') + docsFor subApiP (endpoint, action') - where sublayoutP = Proxy :: Proxy sublayout + where subApiP = Proxy :: Proxy api action' = action & rqbody .~ sampleByteString t p & rqtypes .~ allMime t t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a -instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where +instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where docsFor Proxy (endpoint, action) = - docsFor sublayoutP (endpoint', action) + docsFor subApiP (endpoint', action) - where sublayoutP = Proxy :: Proxy sublayout + where subApiP = Proxy :: Proxy api endpoint' = endpoint & path <>~ [symbolVal pa] pa = Proxy :: Proxy path -instance HasDocs sublayout => HasDocs (RemoteHost :> sublayout) where +instance HasDocs api => HasDocs (RemoteHost :> api) where docsFor Proxy ep = - docsFor (Proxy :: Proxy sublayout) ep + docsFor (Proxy :: Proxy api) ep -instance HasDocs sublayout => HasDocs (IsSecure :> sublayout) where +instance HasDocs api => HasDocs (IsSecure :> api) where docsFor Proxy ep = - docsFor (Proxy :: Proxy sublayout) ep + docsFor (Proxy :: Proxy api) ep -instance HasDocs sublayout => HasDocs (HttpVersion :> sublayout) where +instance HasDocs api => HasDocs (HttpVersion :> api) where docsFor Proxy ep = - docsFor (Proxy :: Proxy sublayout) ep + docsFor (Proxy :: Proxy api) ep -instance HasDocs sublayout => HasDocs (Vault :> sublayout) where +instance HasDocs api => HasDocs (Vault :> api) where docsFor Proxy ep = - docsFor (Proxy :: Proxy sublayout) ep + docsFor (Proxy :: Proxy api) ep + +instance HasDocs api => HasDocs (WithNamedContext name context api) where + docsFor Proxy = docsFor (Proxy :: Proxy api) + +instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where + docsFor Proxy (endpoint, action) = + docsFor (Proxy :: Proxy api) (endpoint, action') + where + authProxy = Proxy :: Proxy (BasicAuth realm usr) + action' = over authInfo (|> toAuthInfo authProxy) action -- ToSample instances for simple types -instance ToSample () +instance ToSample NoContent instance ToSample Bool instance ToSample Ordering diff --git a/servant-docs/src/Servant/Docs/Internal/Pretty.hs b/servant-docs/src/Servant/Docs/Internal/Pretty.hs index 13275467..993526b7 100644 --- a/servant-docs/src/Servant/Docs/Internal/Pretty.hs +++ b/servant-docs/src/Servant/Docs/Internal/Pretty.hs @@ -29,12 +29,12 @@ instance ToJSON a => MimeRender PrettyJSON a where -- @ -- 'docs' ('pretty' ('Proxy' :: 'Proxy' MyAPI)) -- @ -pretty :: Proxy layout -> Proxy (Pretty layout) +pretty :: Proxy api -> Proxy (Pretty api) pretty Proxy = Proxy -- | Replace all JSON content types with PrettyJSON. -- Kind-polymorphic so it can operate on kinds @*@ and @[*]@. -type family Pretty (layout :: k) :: k where +type family Pretty (api :: k) :: k where Pretty (x :<|> y) = Pretty x :<|> Pretty y Pretty (x :> y) = Pretty x :> Pretty y Pretty (Get cs r) = Get (Pretty cs) r diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index d37f78c9..054ea00a 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,27 @@ import GHC.Generics import Test.Hspec import Servant.API +import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Docs.Internal +-- * comprehensive api + +-- This declaration simply checks that all instances are in place. +_ = 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" +instance ToCapture (CaptureAll "foo" Int) where + toCapture = error "unused" + +-- * specs + spec :: Spec spec = describe "Servant.Docs" $ do @@ -63,6 +82,7 @@ spec = describe "Servant.Docs" $ do , ("zwei, kaks, kaks",(TT2,UT2,UT2)) ] + where tests md = do it "mentions supported content-types" $ do @@ -72,15 +92,19 @@ 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." 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 +127,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) diff --git a/servant-examples/LICENSE b/servant-examples/LICENSE deleted file mode 100644 index f2e47b91..00000000 --- a/servant-examples/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2015, Alp Mestanogullari - -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/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs deleted file mode 100644 index ec152782..00000000 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -import Data.Aeson -import Data.ByteString (ByteString) -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 - -type DBLookup = ByteString -> IO Bool - -isGoodCookie :: DBLookup -isGoodCookie = return . (== "good password") - -data AuthProtected - -instance HasServer rest => HasServer (AuthProtected :> rest) where - type ServerT (AuthProtected :> rest) m = ServerT rest m - - route Proxy subserver = WithRequest $ \ request -> - route (Proxy :: Proxy rest) $ 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 - 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 - -newtype PrivateData = PrivateData { ssshhh :: Text } - deriving (Eq, Show, Generic) - -instance ToJSON PrivateData - -newtype PublicData = PublicData { somedata :: Text } - deriving (Eq, Show, Generic) - -instance ToJSON PublicData - -api :: Proxy API -api = Proxy - -server :: Server API -server = return prvdata :<|> return pubdata - - where prvdata = [PrivateData "this is a secret"] - pubdata = [PublicData "this is a public piece of data"] - -main :: IO () -main = run 8080 (serve api server) - -{- Sample session: -$ curl http://localhost:8080/ -[{"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/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/servant-examples.cabal b/servant-examples/servant-examples.cabal deleted file mode 100644 index bd187106..00000000 --- a/servant-examples/servant-examples.cabal +++ /dev/null @@ -1,130 +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: Alp Mestanogullari -maintainer: alpmestan@gmail.com --- copyright: -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 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 - , http-types - , servant == 0.5.* - , servant-server == 0.5.* - , text - , 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/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/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/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 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/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/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/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/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/servant-examples/wai-middleware/wai-middleware.hs b/servant-examples/wai-middleware/wai-middleware.hs deleted file mode 100644 index d625d092..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 -> 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 diff --git a/servant-foreign/CHANGELOG.md b/servant-foreign/CHANGELOG.md index 5d242065..92339e12 100644 --- a/servant-foreign/CHANGELOG.md +++ b/servant-foreign/CHANGELOG.md @@ -1,4 +1,10 @@ -HEAD +0.7.1 +----- + +* Support GHC 8.0 + +0.5 ----- * Use the `text` package instead of `String`. * Extract javascript-oblivious types and helpers to *servant-foreign* +* Typed-languages support 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..ea5b599a 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.8 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 @@ -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 @@ -21,21 +21,41 @@ extra-source-files: include/*.h CHANGELOG.md README.md +bug-reports: http://github.com/haskell-servant/servant/issues source-repository head type: git 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.* + , servant == 0.8.* , text >= 1.2 && < 1.3 , http-types hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints include-dirs: include + default-extensions: CPP + , ConstraintKinds + , DataKinds + , FlexibleContexts + , FlexibleInstances + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , ScopedTypeVariables + , StandaloneDeriving + , TemplateHaskell + , TypeFamilies + , TypeOperators + , UndecidableInstances + , OverloadedStrings + , PolyKinds test-suite spec @@ -44,9 +64,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 5054e69f..e2d212b6 100644 --- a/servant-foreign/src/Servant/Foreign.hs +++ b/servant-foreign/src/Servant/Foreign.hs @@ -1,39 +1,56 @@ -- | 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(..) - , FunctionName - , QueryArg(..) - , HeaderArg(..) - , ArgType(..) - , Req - , captureArg - , defReq - , concatCase - , snakeCase - , camelCase - -- lenses - , argType + , Url(..) + -- aliases + , Path + , Arg(..) + , FunctionName(..) + , PathSegment(..) + -- lenses , argName - , isCapture - , funcName - , path + , argType + , argPath , reqUrl - , reqBody - , reqHeaders , reqMethod + , reqHeaders + , reqBody , reqReturnType - , segment + , reqFuncName + , path , queryStr - , listFromAPI + , queryArgName + , queryArgType + , headerArg + -- prisms + , _PathSegment + , _HeaderArg + , _ReplaceHeaderArg + , _Static + , _Cap + , _Normal + , _Flag + , _List + -- rest of it + , HasForeign(..) + , HasForeignType(..) , GenerateList(..) , NoTypes - -- re-exports + , captureArg + , isCapture + , defReq + , listFromAPI + -- 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 ae199202..59d09436 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -1,119 +1,139 @@ -{-# 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, (%~), (&), (.~), (<>~)) -import qualified Data.Char as C +import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~), + (.~)) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif import Data.Proxy +import Data.String 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 --- | Function name builder that simply concat each part together -concatCase :: FunctionName -> Text -concatCase = concat --- | Function name builder using the snake_case convention. --- each part is separated by a single underscore character. -snakeCase :: FunctionName -> Text -snakeCase = intercalate "_" +newtype FunctionName = FunctionName { unFunctionName :: [Text] } + deriving (Show, Eq, Monoid) --- | 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 +makePrisms ''FunctionName -type ForeignType = Text -type Arg = (Text, ForeignType) +newtype PathSegment = PathSegment { unPathSegment :: Text } + deriving (Show, Eq, IsString, Monoid) -newtype Segment = Segment { _segment :: SegmentType } - deriving (Eq, Show) +makePrisms ''PathSegment -data SegmentType = Static Text -- ^ a static path segment. like "/foo" - | Cap Arg -- ^ a capture. like "/:userid" - deriving (Eq, Show) +data Arg f = Arg + { _argName :: PathSegment + , _argType :: f } -type Path = [Segment] +deriving instance Eq f => Eq (Arg f) +deriving instance Show f => Show (Arg f) -data ArgType = - Normal +makeLenses ''Arg + +argPath :: Getter (Arg f) Text +argPath = argName . _PathSegment + +data SegmentType f + = Static PathSegment + -- ^ a static path segment. like "/foo" + | Cap (Arg f) + -- ^ a capture. like "/:userid" + +deriving instance Eq f => Eq (SegmentType f) +deriving instance Show f => Show (SegmentType f) + +makePrisms ''SegmentType + +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 f -> Bool +isCapture (Segment (Cap _)) = True +isCapture _ = False + +captureArg :: Segment f -> Arg f +captureArg (Segment (Cap s)) = s +captureArg _ = error "captureArg called on non capture" + +type Path f = [Segment f] + +data ArgType + = Normal | Flag | List deriving (Eq, Show) -data QueryArg = QueryArg - { _argName :: Arg - , _argType :: ArgType - } deriving (Eq, Show) +makePrisms ''ArgType -data HeaderArg = HeaderArg - { headerArg :: Arg - } - | ReplaceHeaderArg - { headerArg :: Arg - , headerPattern :: Text - } deriving (Eq, Show) +data QueryArg f = QueryArg + { _queryArgName :: Arg f + , _queryArgType :: ArgType + } - -data Url = Url - { _path :: Path - , _queryStr :: [QueryArg] - } deriving (Eq, Show) - -defUrl :: Url -defUrl = Url [] [] - -type FunctionName = [Text] - -data Req = Req - { _reqUrl :: Url - , _reqMethod :: HTTP.Method - , _reqHeaders :: [HeaderArg] - , _reqBody :: Maybe ForeignType - , _reqReturnType :: ForeignType - , _funcName :: FunctionName - } deriving (Eq, Show) +deriving instance Eq f => Eq (QueryArg f) +deriving instance Show f => Show (QueryArg f) makeLenses ''QueryArg -makeLenses ''Segment + +data HeaderArg f = HeaderArg + { _headerArg :: Arg f } + | ReplaceHeaderArg + { _headerArg :: Arg f + , _headerPattern :: Text + } + +deriving instance Eq f => Eq (HeaderArg f) +deriving instance Show f => Show (HeaderArg f) + +makeLenses ''HeaderArg + +makePrisms ''HeaderArg + +data Url f = Url + { _path :: Path f + , _queryStr :: [QueryArg f] + } + +deriving instance Eq f => Eq (Url f) +deriving instance Show f => Show (Url f) + +defUrl :: Url f +defUrl = Url [] [] + makeLenses ''Url + +data Req f = Req + { _reqUrl :: Url f + , _reqMethod :: HTTP.Method + , _reqHeaders :: [HeaderArg f] + , _reqBody :: Maybe f + , _reqReturnType :: Maybe f + , _reqFuncName :: FunctionName + } + +deriving instance Eq f => Eq (Req f) +deriving instance Show f => Show (Req f) + 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 ftype +defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) -- | To be used exclusively as a "negative" return type/constraint -- by @'Elem`@ type family. @@ -126,194 +146,233 @@ 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 NoContent output type: +-- +-- > getEndpoints :: (HasForeign NoTypes NoContent api, GenerateList Text (Foreign NoContent api)) +-- > => Proxy api -> [Req NoContent] +-- > getEndpoints api = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy NoContent) api -- > -- -class HasForeignType lang a where - typeFor :: Proxy lang -> Proxy a -> ForeignType +class HasForeignType lang ftype a where + typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype data NoTypes -instance HasForeignType NoTypes a where - typeFor _ _ = empty +instance HasForeignType NoTypes NoContent ftype where + typeFor _ _ _ = NoContent -class HasForeign lang (layout :: *) where - type Foreign layout :: * - foreignFor :: Proxy lang -> Proxy layout -> Req -> Foreign layout +class HasForeign lang ftype (api :: *) where + type Foreign ftype api :: * + foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api -instance (HasForeign lang a, HasForeign lang b) - => HasForeign lang (a :<|> b) where - type Foreign (a :<|> b) = Foreign a :<|> Foreign b +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 - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy a) req - :<|> foreignFor lang (Proxy :: Proxy b) req + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy a) req + :<|> foreignFor lang ftype (Proxy :: Proxy b) req -instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) - => HasForeign lang (Capture sym a :> 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]) +instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype api) + => HasForeign lang ftype (Capture sym t :> api) where + type Foreign ftype (Capture sym a :> api) = Foreign ftype api + foreignFor lang Proxy Proxy req = + foreignFor lang Proxy (Proxy :: Proxy api) $ + req & reqUrl . path <>~ [Segment (Cap arg)] + & reqFuncName . _FunctionName %~ (++ ["by", str]) where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy a)) + str = pack . symbolVal $ (Proxy :: Proxy sym) + 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 +instance (KnownSymbol sym, HasForeignType lang ftype [t], HasForeign lang ftype sublayout) + => HasForeign lang ftype (CaptureAll sym t :> sublayout) where + type Foreign ftype (CaptureAll sym t :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - req & funcName %~ (methodLC :) + 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) (Proxy :: Proxy [t]) + arg = Arg + { _argName = PathSegment str + , _argType = ftype } + +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 Proxy req = + req & reqFuncName . _FunctionName %~ (methodLC :) & reqMethod .~ method - & reqReturnType .~ retType + & reqReturnType .~ Just retType where - retType = typeFor lang (Proxy :: Proxy a) - method = reflectMethod (Proxy :: Proxy method) - methodLC = toLower $ decodeUtf8 method + 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 - - foreignFor lang Proxy req = - foreignFor lang subP $ req - & reqHeaders <>~ [HeaderArg arg] +instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype api) + => HasForeign lang ftype (Header sym a :> api) where + type Foreign ftype (Header sym a :> api) = Foreign ftype api + foreignFor lang Proxy Proxy req = + foreignFor lang Proxy 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 = Arg + { _argName = PathSegment hname + , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) } + subP = Proxy :: Proxy api -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 api) + => HasForeign lang ftype (QueryParam sym a :> api) where + type Foreign ftype (QueryParam sym a :> api) = Foreign ftype api - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ + foreignFor lang Proxy Proxy req = + foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $ 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 = Arg + { _argName = PathSegment str + , _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) $ +instance + (KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype api) + => HasForeign lang ftype (QueryParams sym a :> api) where + type Foreign ftype (QueryParams sym a :> api) = Foreign ftype api + foreignFor lang Proxy Proxy req = + foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $ 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 = Arg + { _argName = PathSegment str + , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [a]) } -instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang sublayout) - => HasForeign lang (QueryFlag sym :> sublayout) where - type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout +instance + (KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype api) + => HasForeign lang ftype (QueryFlag sym :> api) where + type Foreign ftype (QueryFlag sym :> api) = Foreign ftype api - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy api) $ 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 = Arg + { _argName = PathSegment str + , _argType = typeFor lang ftype (Proxy :: Proxy Bool) } -instance HasForeign lang Raw where - type Foreign Raw = HTTP.Method -> Req +instance HasForeign lang ftype Raw where + type Foreign ftype Raw = HTTP.Method -> Req ftype - foreignFor _ Proxy req method = - req & funcName %~ ((toLower $ decodeUtf8 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 api) + => HasForeign lang ftype (ReqBody list a :> api) where + type Foreign ftype (ReqBody list a :> api) = Foreign ftype api - 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 api) $ + 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 - - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqUrl.path <>~ [Segment (Static str)] - & funcName %~ (++ [str]) +instance (KnownSymbol path, HasForeign lang ftype api) + => HasForeign lang ftype (path :> api) where + type Foreign ftype (path :> api) = Foreign ftype api + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy api) $ + req & reqUrl . path <>~ [Segment (Static (PathSegment str))] + & reqFuncName . _FunctionName %~ (++ [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 - type Foreign (RemoteHost :> sublayout) = Foreign sublayout +instance HasForeign lang ftype api + => HasForeign lang ftype (RemoteHost :> api) where + type Foreign ftype (RemoteHost :> api) = Foreign ftype api - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) req + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy api) req -instance HasForeign lang sublayout => HasForeign lang (IsSecure :> sublayout) where - type Foreign (IsSecure :> sublayout) = Foreign sublayout +instance HasForeign lang ftype api + => HasForeign lang ftype (IsSecure :> api) where + type Foreign ftype (IsSecure :> api) = Foreign ftype api - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) req + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy api) req -instance HasForeign lang sublayout => HasForeign lang (Vault :> sublayout) where - type Foreign (Vault :> sublayout) = Foreign sublayout +instance HasForeign lang ftype api => HasForeign lang ftype (Vault :> api) where + type Foreign ftype (Vault :> api) = Foreign ftype api - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) req + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy api) req -instance HasForeign lang sublayout => HasForeign lang (HttpVersion :> sublayout) where - type Foreign (HttpVersion :> sublayout) = Foreign sublayout +instance HasForeign lang ftype api => + HasForeign lang ftype (WithNamedContext name context api) where - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) req + type Foreign ftype (WithNamedContext name context api) = Foreign ftype api + + foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api) + +instance HasForeign lang ftype api + => HasForeign lang ftype (HttpVersion :> api) where + type Foreign ftype (HttpVersion :> api) = Foreign ftype api + + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy api) 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] +class GenerateList ftype reqs where + generateList :: reqs -> [Req ftype] -instance GenerateList Req 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)) => Proxy lang -> Proxy api -> [Req] -listFromAPI lang p = generateList (foreignFor lang p defReq) +listFromAPI + :: (HasForeign lang ftype api, GenerateList ftype (Foreign ftype api)) + => Proxy lang + -> Proxy ftype + -> Proxy api + -> [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 06e722cc..966861d5 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 @@ -15,7 +6,6 @@ module Servant.ForeignSpec where import Data.Monoid ((<>)) import Data.Proxy import Servant.Foreign -import Servant.Foreign.Internal import Test.Hspec @@ -27,87 +17,106 @@ 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" -instance HasForeignType LangX Int where - typeFor _ _ = "intX" -instance HasForeignType LangX Bool where - typeFor _ _ = "boolX" -instance OVERLAPPING_ HasForeignType LangX String where - typeFor _ _ = "stringX" -instance OVERLAPPABLE_ HasForeignType LangX a => HasForeignType LangX [a] where - typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a) +instance HasForeignType LangX String NoContent where + typeFor _ _ _ = "voidX" + +instance HasForeignType LangX String Int where + typeFor _ _ _ = "intX" + +instance HasForeignType LangX String Bool where + typeFor _ _ _ = "boolX" + +instance OVERLAPPING_ HasForeignType LangX String String where + typeFor _ _ _ = "stringX" + +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 - :<|> "test" :> QueryParam "param" Int :> ReqBody '[JSON] [String] :> Post '[JSON] () - :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] () - :<|> "test" :> Capture "id" Int :> Delete '[JSON] () + :<|> "test" :> QueryParam "param" Int :> ReqBody '[JSON] [String] :> Post '[JSON] NoContent + :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] NoContent + :<|> "test" :> Capture "id" Int :> Delete '[JSON] NoContent + :<|> "test" :> CaptureAll "ids" Int :> Get '[JSON] [Int] -testApi :: [Req] -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 - it "generates 4 endpoints for TestApi" $ do - length testApi `shouldBe` 4 + it "generates 4 endpoints for TestApi" $ do + length testApi `shouldBe` 5 - let [getReq, postReq, putReq, deleteReq] = testApi + let [getReq, postReq, putReq, deleteReq, captureAllReq] = 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 (Arg "flag" "boolX") Flag ] + , _reqMethod = "GET" + , _reqHeaders = [HeaderArg $ Arg "header" "listX of stringX"] + , _reqBody = Nothing + , _reqReturnType = Just "intX" + , _reqFuncName = FunctionName ["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 (Arg "param" "intX") Normal ] + , _reqMethod = "POST" + , _reqHeaders = [] + , _reqBody = Just "listX of stringX" + , _reqReturnType = Just "voidX" + , _reqFuncName = FunctionName ["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 put request" $ do + shouldBe putReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" ] + -- Shoud this be |intX| or |listX of intX| ? + [ QueryArg (Arg "params" "listX of intX") List ] + , _reqMethod = "PUT" + , _reqHeaders = [] + , _reqBody = Just "stringX" + , _reqReturnType = Just "voidX" + , _reqFuncName = FunctionName ["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 delete request" $ do + shouldBe deleteReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" + , Segment $ Cap (Arg "id" "intX") ] + [] + , _reqMethod = "DELETE" + , _reqHeaders = [] + , _reqBody = Nothing + , _reqReturnType = Just "voidX" + , _reqFuncName = FunctionName ["delete", "test", "by", "id"] + } + it "collects all info for capture all request" $ do + shouldBe captureAllReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" + , Segment $ Cap (Arg "ids" "listX of intX") ] + [] + , _reqMethod = "GET" + , _reqHeaders = [] + , _reqBody = Nothing + , _reqReturnType = Just "listX of intX" + , _reqFuncName = FunctionName ["get", "test", "by", "ids"] + } diff --git a/servant-js/CHANGELOG.md b/servant-js/CHANGELOG.md index 575391d0..770f2a72 100644 --- a/servant-js/CHANGELOG.md +++ b/servant-js/CHANGELOG.md @@ -1,6 +1,8 @@ -HEAD +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 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/examples/counter.hs b/servant-js/examples/counter.hs index 5d2b80d0..4040b053 100644 --- a/servant-js/examples/counter.hs +++ b/servant-js/examples/counter.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} import Control.Concurrent.STM @@ -92,7 +93,7 @@ main = do writeJSForAPI testApi (angular defAngularOptions) (www "angular" "api.js") - writeJSForAPI testApi axios (www "axios" "api.js") + writeJSForAPI testApi (axios defAxiosOptions) (www "axios" "api.js") writeServiceJS (www "angular" "api.service.js") diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index 28005e60..726e0b4e 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.8 synopsis: Automatically derive javascript functions to query servant webservices. description: Automatically derive javascript functions to query servant webservices. @@ -13,13 +13,13 @@ 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 -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: include/*.h @@ -42,9 +42,11 @@ 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.* + , servant-foreign == 0.8.* + , servant == 0.8.* , text >= 1.2 && < 1.3 hs-source-dirs: src @@ -54,7 +56,7 @@ library executable counter main-is: counter.hs - ghc-options: -O2 -Wall + ghc-options: -Wall hs-source-dirs: examples if flag(example) @@ -63,11 +65,11 @@ executable counter buildable: False build-depends: base >= 4.7 && < 5 - , aeson >= 0.7 && < 0.11 + , aeson >= 0.7 && < 1.1 , filepath >= 1 , lens >= 4 - , servant == 0.5.* - , servant-server == 0.5.* + , servant == 0.8.* + , servant-server == 0.8.* , servant-js , stm , transformers @@ -83,6 +85,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/src/Servant/JS.hs b/servant-js/src/Servant/JS.hs index 443b758b..d11c6eb0 100644 --- a/servant-js/src/Servant/JS.hs +++ b/servant-js/src/Servant/JS.hs @@ -112,38 +112,40 @@ module Servant.JS , javascript , NoTypes , GenerateList(..) + , FunctionName(..) ) where import Prelude hiding (writeFile) import Data.Proxy import Data.Text import Data.Text.IO (writeFile) +import Servant.API.ContentTypes import Servant.JS.Angular import Servant.JS.Axios import Servant.JS.Internal import Servant.JS.JQuery import Servant.JS.Vanilla -import Servant.Foreign (GenerateList(..), listFromAPI, NoTypes) +import Servant.Foreign (listFromAPI) -- | 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 NoContent api => Proxy api -> Foreign NoContent api +javascript p = foreignFor (Proxy :: Proxy NoTypes) (Proxy :: Proxy NoContent) 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 NoContent api, GenerateList NoContent (Foreign NoContent 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 NoContent) 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 NoContent api, GenerateList NoContent (Foreign NoContent 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/Angular.hs b/servant-js/src/Servant/JS/Angular.hs index 8530b03f..5c93610d 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 $ queryArgName . argPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . argPath) + ) 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 argPath . 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 . argPath <> + "\": " <> toJSHeader header namespace = if hasService @@ -128,7 +132,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..3b299cd4 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 $ queryArgName . argPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . argPath) + ) hs - captures = map (fst . captureArg) + captures = map (view argPath . 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 . argPath <> + "\": " <> toJSHeader header namespace = if hasNoModule @@ -116,7 +120,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..f04480ea 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,19 @@ module Servant.JS.Internal , reqHeaders , HasForeign(..) , HasForeignType(..) + , GenerateList(..) + , NoTypes + , ArgType(..) , HeaderArg(..) + , QueryArg(..) + , Req(..) + , Segment(..) + , SegmentType(..) + , Url(..) + , Path + , Arg(..) + , FunctionName(..) + , PathSegment(..) , concatCase , snakeCase , camelCase @@ -32,7 +46,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 @@ -40,23 +54,30 @@ import qualified Data.Text as T import Data.Text (Text) import Servant.Foreign -type AjaxReq = Req +type AjaxReq = Req NoContent -- 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 NoContent] -> Text -- | This structure is used by specific implementations to let you -- 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. @@ -115,8 +136,9 @@ toValidFunctionName t = , Set.connectorPunctuation ] -toJSHeader :: HeaderArg -> Text -toJSHeader (HeaderArg n) = toValidFunctionName ("header" <> fst n) +toJSHeader :: HeaderArg f -> Text +toJSHeader (HeaderArg n) + = toValidFunctionName ("header" <> n ^. argName . _PathSegment) toJSHeader (ReplaceHeaderArg n p) | pn `T.isPrefixOf` p = pv <> " + \"" <> rp <> "\"" | pn `T.isSuffixOf` p = "\"" <> rp <> "\" + " <> pv @@ -124,34 +146,35 @@ toJSHeader (ReplaceHeaderArg n p) <> "\"" | otherwise = p where - pv = toValidFunctionName ("header" <> fst n) - pn = "{" <> fst n <> "}" + pv = toValidFunctionName ("header" <> n ^. argName . _PathSegment) + 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 (Static s) = s -segmentTypeToStr (Cap s) = "' + encodeURIComponent(" <> fst s <> ") + '" +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 ^. argType of + case qarg ^. queryArgType of Normal -> name <> "=' + encodeURIComponent(" <> name @@ -161,4 +184,4 @@ paramToStr qarg notTheEnd = <> "[]=' + encodeURIComponent(" <> name <> if notTheEnd then ") + '" else ")" - where name = qarg ^. argName . _1 + 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 71147006..98038f0c 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 $ queryArgName . argPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map (toValidFunctionName + . (<>) "header" + . view (headerArg . argPath) + ) hs ++ [onSuccess, onError] - captures = map (fst . captureArg) + captures = map (view argPath . captureArg) . filter isCapture $ req ^. reqUrl.path @@ -73,15 +77,16 @@ 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 . argPath <> + "\": " <> toJSHeader header 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..216fbc7f 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 $ queryArgName . argPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . argPath) + ) hs ++ [onSuccess, onError] - captures = map (fst . captureArg) + captures = map (view argPath . captureArg) . filter isCapture $ req ^. reqUrl.path @@ -85,15 +88,16 @@ 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 . argPath <> + "\", " <> toJSHeader header <> ");" 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/test/Servant/JSSpec.hs b/servant-js/test/Servant/JSSpec.hs index 23fe4326..7cf56be0 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,20 +6,22 @@ {-# 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 +import Servant.API.ContentTypes import Servant.JS import Servant.JS.Internal import qualified Servant.JS.Angular as NG @@ -29,6 +30,13 @@ import qualified Servant.JS.JQuery as JQ import qualified Servant.JS.Vanilla as JS import Servant.JSSpec.CustomHeaders +-- * comprehensive api + +-- This declaration simply checks that all instances are in place. +_ = jsForAPI comprehensiveAPIWithoutRaw vanillaJS :: Text + +-- * specs + type TestAPI = "simple" :> ReqBody '[JSON,FormUrlEncoded] Text :> Post '[JSON] Bool :<|> "has.extension" :> Get '[FormUrlEncoded,JSON] Bool @@ -98,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 NoContent) (Proxy :: Proxy TestAPI) it "should add withCredentials when needed" $ do let jsText = genJS withCredOpts $ reqList output jsText @@ -122,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 NoContent) (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 150436e3..7d9d39d5 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 #-} @@ -15,6 +16,7 @@ import Data.Monoid import Data.Proxy import Data.Text (pack) import GHC.TypeLits +import Servant.API.ContentTypes import Servant.JS.Internal -- | This is a hypothetical combinator that fetches an Authorization header. @@ -22,36 +24,37 @@ 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 NoContent api) + => HasForeign lang NoContent (Authorization sym a :> api) where + type Foreign NoContent (Authorization sym a :> api) = Foreign NoContent api - foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqHeaders <>~ [ ReplaceHeaderArg ("Authorization", "") $ - tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ] + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy api) $ + req & reqHeaders <>~ + [ ReplaceHeaderArg (Arg "Authorization" NoContent) + $ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ] where tokenType t = t <> " {Authorization}" -- | 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 NoContent api) + => HasForeign lang NoContent (MyLovelyHorse a :> api) where + type Foreign NoContent (MyLovelyHorse a :> api) = Foreign NoContent api - foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqHeaders <>~ [ ReplaceHeaderArg ("X-MyLovelyHorse", "") tpl ] + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy api) $ + req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" NoContent) 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 NoContent api) + => HasForeign lang NoContent (WhatsForDinner a :> api) where + type Foreign NoContent (WhatsForDinner a :> api) = Foreign NoContent api - foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqHeaders <>~ [ ReplaceHeaderArg ("X-WhatsForDinner", "") tpl ] + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy api) $ + req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" NoContent) tpl ] where tpl = "I would like {X-WhatsForDinner} with a cherry on top." diff --git a/servant-lucid/LICENSE b/servant-lucid/LICENSE deleted file mode 100644 index 0b0a2174..00000000 --- a/servant-lucid/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2015, Julian K. Arni - -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 Julian K. Arni 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-lucid/Setup.hs b/servant-lucid/Setup.hs deleted file mode 100644 index 44671092..00000000 --- a/servant-lucid/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/servant-lucid/include/overlapping-compat.h b/servant-lucid/include/overlapping-compat.h deleted file mode 100644 index eef9d4ea..00000000 --- a/servant-lucid/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-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal deleted file mode 100644 index f2be1eb5..00000000 --- a/servant-lucid/servant-lucid.cabal +++ /dev/null @@ -1,33 +0,0 @@ --- Initial servant-lucid.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: servant-lucid -version: 0.5 -synopsis: Servant support for lucid --- description: -homepage: http://haskell-servant.github.io/ -license: BSD3 -license-file: LICENSE -author: Julian K. Arni -maintainer: jkarni@gmail.com --- copyright: -category: Web -build-type: Simple -extra-source-files: include/*.h -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 - -library - exposed-modules: Servant.HTML.Lucid - -- other-modules: - -- other-extensions: - build-depends: base >=4.7 && <5 - , http-media - , lucid - , 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 deleted file mode 100644 index ec62a21c..00000000 --- a/servant-lucid/src/Servant/HTML/Lucid.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -#include "overlapping-compat.h" - --- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s --- `ToHtml` class and `Html` datatype. --- You should only need to import this module for it's instances and the --- `HTML` datatype.: --- --- >>> type Eg = Get '[HTML] a --- --- Will then check that @a@ has a `ToHtml` instance, or is `Html`. -module Servant.HTML.Lucid where - -import Data.Typeable (Typeable) -import Lucid (Html, ToHtml (..), renderBS) -import qualified Network.HTTP.Media as M -import Servant.API (Accept (..), MimeRender (..)) - -data HTML deriving Typeable - --- | @text/html;charset=utf-8@ -instance Accept HTML where - contentType _ = "text" M.// "html" M./: ("charset", "utf-8") - -instance OVERLAPPABLE_ - ToHtml a => MimeRender HTML a where - mimeRender _ = renderBS . toHtml - -instance OVERLAPPING_ - MimeRender HTML (Html a) where - mimeRender _ = renderBS diff --git a/servant-lucid/tinc.yaml b/servant-lucid/tinc.yaml deleted file mode 100644 index dbf42cc7..00000000 --- a/servant-lucid/tinc.yaml +++ /dev/null @@ -1,3 +0,0 @@ -dependencies: - - name: servant - path: ../servant 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 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/example/main.hs b/servant-mock/example/main.hs index 51ba7329..a602dc88 100644 --- a/servant-mock/example/main.hs +++ b/servant-mock/example/main.hs @@ -2,6 +2,9 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + import Data.Aeson import GHC.Generics import Network.Wai.Handler.Warp @@ -20,4 +23,4 @@ api :: Proxy API api = Proxy main :: IO () -main = run 8080 (serve api $ mock api) +main = run 8080 (serve api $ mock api Proxy) diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 7d8589d0..89ff1f6f 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.8 synopsis: Derive a mock server for free from your servant API types description: Derive a mock server for free from your servant API types @@ -8,18 +8,21 @@ 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 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 flag example description: Build the example too - manual: True - default: False + default: True library exposed-modules: @@ -28,14 +31,15 @@ library base >=4.7 && <5, bytestring >= 0.10 && <0.11, http-types >= 0.8 && <0.10, - servant >= 0.4, - servant-server >= 0.4, - transformers >= 0.3 && <0.5, - QuickCheck >= 2.7 && <2.9, + servant == 0.8.*, + servant-server == 0.8.*, + transformers >= 0.3 && <0.6, + QuickCheck >= 2.7 && <2.10, wai >= 3.0 && <3.3 hs-source-dirs: src default-language: Haskell2010 include-dirs: include + ghc-options: -Wall executable mock-app main-is: main.hs @@ -46,3 +50,24 @@ executable mock-app buildable: True else buildable: False + ghc-options: -Wall + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Servant.MockSpec + build-depends: + base, + hspec, + hspec-wai, + QuickCheck, + servant, + servant-server, + servant-mock, + aeson, + bytestring-conversion, + wai diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index e4437fba..0d0f4a48 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -1,11 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + +#include "overlapping-compat.h" + -- | -- Module : Servant.Mock -- Copyright : 2015 Alp Mestanogullari @@ -31,7 +36,7 @@ -- and call 'mock', which has the following type: -- -- @ --- 'mock' :: 'HasMock' api => 'Proxy' api -> 'Server' api +-- 'mock' :: 'HasMock' api context => 'Proxy' api -> 'Proxy' context -> 'Server' api -- @ -- -- What this says is, given some API type @api@ that it knows it can @@ -47,7 +52,7 @@ -- @ -- main :: IO () -- main = Network.Wai.Handler.Warp.run 8080 $ --- 'serve' myAPI ('mock' myAPI) +-- 'serve' myAPI ('mock' myAPI Proxy) -- @ module Servant.Mock ( HasMock(..) ) where @@ -69,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 => HasMock api 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 @@ -85,71 +90,85 @@ class HasServer api => HasMock api where -- -- let's say we will start with the frontend, -- -- and hence need a placeholder server -- server :: Server API - -- server = mock api + -- server = mock api Proxy -- @ -- -- What happens here is that @'Server' API@ -- actually "means" 2 request handlers, of the following types: -- -- @ - -- getUser :: ExceptT ServantErr IO User - -- getBook :: ExceptT ServantErr IO Book + -- getUser :: Handler User + -- getBook :: Handler Book -- @ -- -- 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 context -> Server api -instance (HasMock a, HasMock b) => HasMock (a :<|> b) where - mock _ = mock (Proxy :: Proxy a) :<|> mock (Proxy :: Proxy b) +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) => HasMock (path :> rest) where +instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) context 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 context) => HasMock (Capture s a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (AllCTUnrender ctypes a, HasMock rest) => HasMock (ReqBody ctypes a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (CaptureAll s a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest => HasMock (RemoteHost :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (AllCTUnrender ctypes a, HasMock rest context) => HasMock (ReqBody ctypes a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest => HasMock (IsSecure :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest context => HasMock (RemoteHost :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest => HasMock (Vault :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest context => HasMock (IsSecure :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest => HasMock (HttpVersion :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest context => HasMock (Vault :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol s, FromHttpApiData a, HasMock rest) - => HasMock (QueryParam s a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest context => HasMock (HttpVersion :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -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 context) + => HasMock (QueryParam s a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol s, HasMock rest) => HasMock (QueryFlag s :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) + => HasMock (QueryParams s a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol h, FromHttpApiData a, HasMock rest) => HasMock (Header h a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +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 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) where - mock _ = mockArbitrary + => HasMock (Verb method status ctypes a) context where + mock _ _ = mockArbitrary -instance HasMock Raw where - mock _ = \_req respond -> do +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)) context where + mock _ _ = mockArbitrary + +instance HasMock Raw context where + mock _ _ = \_req respond -> do bdy <- genBody respond $ responseLBS status200 [] bdy where genBody = pack <$> generate (vector 100 :: Gen [Char]) +instance (HasContextEntry context (NamedContext name subContext), HasMock rest subContext) => + HasMock (WithNamedContext name subContext rest) context where + + mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subContext) + mockArbitrary :: (MonadIO m, Arbitrary a) => m a mockArbitrary = liftIO (generate arbitrary) @@ -165,4 +184,5 @@ instance (Arbitrary a, Arbitrary (HList hs)) => Arbitrary (HList (Header h a ': hs)) where arbitrary = HCons <$> fmap Header arbitrary <*> arbitrary - +instance Arbitrary NoContent where + arbitrary = pure NoContent diff --git a/servant-mock/test/Servant/MockSpec.hs b/servant-mock/test/Servant/MockSpec.hs new file mode 100644 index 00000000..7d7b32ac --- /dev/null +++ b/servant-mock/test/Servant/MockSpec.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +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 +import Test.QuickCheck + +import Servant +import Servant.API.Internal.Test.ComprehensiveAPI +import Servant.Mock + +-- This declaration simply checks that all instances are in place. +_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedContext "foo" '[]]) + +data Body + = Body + | ArbitraryBody + 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 + context "Get" $ do + let api :: Proxy (Get '[JSON] Body) + api = Proxy + app = serve api (mock api Proxy) + with (return app) $ do + it "serves arbitrary response bodies" $ 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 (Proxy :: Proxy '[])) + 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-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/CHANGELOG.md b/servant-server/CHANGELOG.md index 5ba871ee..0046372d 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,6 +1,44 @@ -HEAD ----- +0.7.1 +------ +* Remove module `Servant.Server.Internal.Enter` (https://github.com/haskell-servant/servant/pull/478) +* Support GHC 8.0 + +0.7 +--- + +* The `Router` type has been changed. Static router tables should now + be properly shared between requests, drastically increasing the + number of situations where servers will be able to route requests + efficiently. Functions `layout` and `layoutWithContext` have been + added to visualize the router layout for debugging purposes. Test + cases for expected router layouts have been added. +* If an endpoint is discovered to have a non-matching "accept header", + this is now a recoverable rather than a fatal failure, allowing + different endpoints for the same route, but with different content + types to be specified modularly. +* Export `throwError` from module `Servant` +* Add `Handler` type synonym + +0.6.1 +----- + +* If servers use the `BasicAuth` combinator and receive requests with missing or + invalid credentials, the resulting error responses (401 and 403) could be + overwritten by subsequent alternative routes. Now `BasicAuth` uses `FailFatal` + and the error responses can't be overwritten anymore. + +0.6 +--- + +* 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 + 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` @@ -8,6 +46,8 @@ HEAD * Remove `RouteMismatch`. * 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-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/README.md b/servant-server/README.md index 08842f19..b2a9ed00 100644 --- a/servant-server/README.md +++ b/servant-server/README.md @@ -6,5 +6,4 @@ This library lets you *implement* an HTTP server with handlers for each endpoint ## Getting started -We've written a [tutorial](http://haskell-servant.github.io/tutorial/) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples. - +We've written a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples. diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index 3fda367d..662c2c33 100644 --- a/servant-server/example/greet.hs +++ b/servant-server/example/greet.hs @@ -34,7 +34,7 @@ type TestApi = :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet -- DELETE /greet/:greetid - :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] () + :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent testApi :: Proxy TestApi testApi = Proxy @@ -44,7 +44,7 @@ testApi = Proxy -- There's one handler per endpoint, which, just like in the type -- that represents the API, are glued together using :<|>. -- --- Each handler runs in the 'ExceptT ServantErr IO' monad. +-- Each handler runs in the 'Handler' monad. server :: Server TestApi server = helloH :<|> postGreetH :<|> deleteGreetH @@ -54,7 +54,7 @@ server = helloH :<|> postGreetH :<|> deleteGreetH postGreetH greet = return greet - deleteGreetH _ = return () + deleteGreetH _ = return NoContent -- Turn the server into a WAI app. 'serve' is provided by servant, -- more precisely by the Servant.Server module. diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index b2b5a8d4..a5be18e2 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -1,23 +1,23 @@ name: servant-server -version: 0.5 +version: 0.8 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them . - You can learn about the basics in the . + You can learn about the basics in the . . is a runnable example, with comments, that defines a dummy API and implements a webserver that serves this API, using this package. . -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ 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 @@ -36,41 +36,51 @@ library exposed-modules: Servant Servant.Server + Servant.Server.Experimental.Auth Servant.Server.Internal - Servant.Server.Internal.Enter + Servant.Server.Internal.BasicAuth + Servant.Server.Internal.Context Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServantErr Servant.Utils.StaticFiles build-depends: - base >= 4.7 && < 5 - , aeson >= 0.7 && < 0.11 + base >= 4.7 && < 4.10 + , base-compat >= 0.9 && < 0.10 + , aeson >= 0.7 && < 1.1 , attoparsec >= 0.12 && < 0.14 + , base64-bytestring >= 1.0 && < 1.1 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6 , http-api-data >= 0.1 && < 0.3 , http-types >= 0.8 && < 0.10 , network-uri >= 2.6 && < 2.7 - , mtl >= 2 && < 3 - , mmorph >= 1 + , mtl >= 2 && < 2.3 , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4 - , servant == 0.5.* + , servant == 0.8.* , split >= 0.2 && < 0.3 , string-conversions >= 0.3 && < 0.5 , system-filepath >= 0.4 && < 0.5 - , filepath >= 1 + , filepath >= 1 && < 1.5 , text >= 1.2 && < 1.3 - , transformers >= 0.3 && < 0.5 - , transformers-compat>= 0.4 + , transformers >= 0.3 && < 0.6 + , transformers-compat>= 0.4 && < 0.6 , wai >= 3.0 && < 3.3 - , wai-app-static >= 3.0 && < 3.2 + , wai-app-static >= 3.1 && < 3.2 , warp >= 3.0 && < 3.3 - , time >= 1.4 && < 1.6 + , word8 >= 0.1 && < 0.2 + if impl(ghc < 7.10) + build-depends: old-locale >= 1.0 && < 1.1 + , time >= 1.4 && < 1.5 + else + build-depends: time >= 1.5 && < 1.6 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints include-dirs: include executable greet @@ -89,19 +99,25 @@ executable greet test-suite spec type: exitcode-stdio-1.0 - ghc-options: - -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + ghc-options: -Wall default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs other-modules: - Servant.Server.Internal.EnterSpec + Servant.ArbitraryMonadServerSpec + Servant.Server.ErrorSpec + Servant.Server.Internal.ContextSpec + Servant.Server.RouterSpec + Servant.Server.StreamingSpec + Servant.Server.UsingContextSpec + Servant.Server.UsingContextSpec.TestCombinators Servant.ServerSpec Servant.Utils.StaticFilesSpec - Servant.Server.ErrorSpec build-depends: base == 4.* + , base-compat , aeson + , base64-bytestring , bytestring , bytestring-conversion , directory @@ -116,6 +132,7 @@ test-suite spec , servant , servant-server , string-conversions + , should-not-typecheck == 2.1.* , temporary , text , transformers @@ -137,5 +154,5 @@ test-suite doctests main-is: test/Doctests.hs buildable: True default-language: Haskell2010 - ghc-options: -threaded + ghc-options: -Wall -threaded include-dirs: include diff --git a/servant-server/src/Servant.hs b/servant-server/src/Servant.hs index 96fd219f..ed24756d 100644 --- a/servant-server/src/Servant.hs +++ b/servant-server/src/Servant.hs @@ -10,8 +10,10 @@ module Servant ( module Servant.Utils.StaticFiles, -- | Useful re-exports Proxy(..), + throwError ) where +import Control.Monad.Error.Class (throwError) import Data.Proxy import Servant.API import Servant.Server diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index a26941ea..cc29ff84 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -7,6 +9,7 @@ module Servant.Server ( -- * Run a wai application from an API serve + , serveWithContext , -- * Construct a wai Application from an API toApplication @@ -14,6 +17,11 @@ module Servant.Server , -- * Handlers for all standard combinators HasServer(..) , Server + , Handler + + -- * Debugging the server layout + , layout + , layoutWithContext -- * Enter -- $enterDoc @@ -35,6 +43,22 @@ module Servant.Server , generalizeNat , tweakResponse + -- * Context + , Context(..) + , HasContextEntry(getContextEntry) + -- ** NamedContext + , NamedContext(..) + , descendIntoNamedContext + + -- * Basic Authentication + , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck) + , BasicAuthResult(..) + + -- * General Authentication + -- , AuthHandler(unAuthHandler) + -- , AuthServerData + -- , mkAuthHandler + -- * Default error type , ServantErr(..) -- ** 3XX @@ -63,7 +87,7 @@ module Servant.Server , err415 , err416 , err417 - -- * 5XX + -- ** 5XX , err500 , err501 , err502 @@ -71,12 +95,16 @@ module Servant.Server , err504 , err505 + -- * Re-exports + , Application + ) where import Data.Proxy (Proxy) +import Data.Text (Text) import Network.Wai (Application) import Servant.Server.Internal -import Servant.Server.Internal.Enter +import Servant.Utils.Enter -- * Implementing Servers @@ -102,12 +130,73 @@ import Servant.Server.Internal.Enter -- > 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)) - where - d = Delayed r r r (\ _ _ -> Route server) - r = return (Route ()) +serve :: (HasServer api '[]) => Proxy api -> Server api -> Application +serve p = serveWithContext p EmptyContext +serveWithContext :: (HasServer api context) + => Proxy api -> Context context -> Server api -> Application +serveWithContext p context server = + toApplication (runRouter (route p context (emptyDelayed (Route server)))) + +-- | The function 'layout' produces a textual description of the internal +-- router layout for debugging purposes. Note that the router layout is +-- determined just by the API, not by the handlers. +-- +-- Example: +-- +-- For the following API +-- +-- > type API = +-- > "a" :> "d" :> Get '[JSON] NoContent +-- > :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool +-- > :<|> "c" :> Put '[JSON] Bool +-- > :<|> "a" :> "e" :> Get '[JSON] Int +-- > :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool +-- > :<|> Raw +-- +-- we get the following output: +-- +-- > / +-- > ├─ a/ +-- > │ ├─ d/ +-- > │ │ └─• +-- > │ └─ e/ +-- > │ └─• +-- > ├─ b/ +-- > │ └─ / +-- > │ ├─• +-- > │ ┆ +-- > │ └─• +-- > ├─ c/ +-- > │ └─• +-- > ┆ +-- > └─ +-- +-- Explanation of symbols: +-- +-- [@├@] Normal lines reflect static branching via a table. +-- +-- [@a/@] Nodes reflect static path components. +-- +-- [@─•@] Leaves reflect endpoints. +-- +-- [@\/@] This is a delayed capture of a path component. +-- +-- [@\@] This is a part of the API we do not know anything about. +-- +-- [@┆@] Dashed lines suggest a dynamic choice between the part above +-- and below. If there is a success for fatal failure in the first part, +-- that one takes precedence. If both parts fail, the \"better\" error +-- code will be returned. +-- +layout :: (HasServer api '[]) => Proxy api -> Text +layout p = layoutWithContext p EmptyContext + +-- | Variant of 'layout' that takes an additional 'Context'. +layoutWithContext :: (HasServer api context) + => Proxy api -> Context context -> Text +layoutWithContext p context = + routerLayout (route p context (emptyDelayed (FailFatal err501))) -- Documentation 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..fd38ff1e --- /dev/null +++ b/servant-server/src/Servant/Server/Experimental/Auth.hs @@ -0,0 +1,68 @@ +{-# 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 (liftIO) +import Control.Monad.Trans.Except (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.RoutingApplication (addAuthCheck, + delayedFailFatal, + DelayedIO, + withRequest) +import Servant.Server.Internal.ServantErr (Handler) + +-- * 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 -> Handler usr } + deriving (Generic, Typeable) + +-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +mkAuthHandler :: (r -> Handler 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 = + route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck) + where + authHandler :: Request -> Handler (AuthServerData (AuthProtect tag)) + authHandler = unAuthHandler (getContextEntry context) + authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag)) + authCheck = (>>= either delayedFailFatal return) . liftIO . runExceptT . authHandler diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index eeef4cd5..de4a237a 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -1,8 +1,10 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -13,22 +15,20 @@ 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 ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans (liftIO) 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) import Data.String (fromString) import Data.String.Conversions (cs, (<>)) -import Data.Text (Text) import Data.Typeable import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) @@ -36,20 +36,25 @@ import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.Socket (SockAddr) import Network.Wai (Application, Request, Response, httpVersion, isSecure, - lazyRequestBody, pathInfo, + lazyRequestBody, rawQueryString, remoteHost, requestHeaders, requestMethod, responseLBS, vault) +import Prelude () +import Prelude.Compat import Web.HttpApiData (FromHttpApiData) import Web.HttpApiData.Internal (parseHeaderMaybe, parseQueryParamMaybe, - parseUrlPieceMaybe) + parseUrlPieceMaybe, + parseUrlPieces) -import Servant.API ((:<|>) (..), (:>), Capture, - Verb, ReflectMethod(reflectMethod), - IsSecure(..), Header, - QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, Vault) +import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture, + CaptureAll, Verb, + ReflectMethod(reflectMethod), + IsSecure(..), Header, QueryFlag, + QueryParam, QueryParams, Raw, + RemoteHost, ReqBody, Vault, + WithNamedContext) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), @@ -58,18 +63,23 @@ import Servant.API.ContentTypes (AcceptHeader (..), 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 +class HasServer api context where + type ServerT api (m :: * -> *) :: * -class HasServer layout where - type ServerT layout (m :: * -> *) :: * + route :: + Proxy api + -> Context context + -> Delayed env (Server api) + -> Router env - route :: Proxy layout -> Delayed (Server layout) -> Router - -type Server layout = ServerT layout (ExceptT ServantErr IO) +type Server api = ServerT api Handler -- * Instances @@ -84,18 +94,15 @@ 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 context, HasServer b context) => HasServer (a :<|> b) context where type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m - route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server)) - (route pb ((\ (_ :<|> 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 -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'. @@ -111,23 +118,54 @@ captured _ = parseUrlPieceMaybe -- > -- > server :: Server MyApi -- > server = getBook --- > where getBook :: Text -> ExceptT ServantErr IO Book +-- > where getBook :: Text -> Handler Book -- > getBook isbn = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout) - => HasServer (Capture capture a :> sublayout) where +instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) + => HasServer (Capture capture a :> api) context where - type ServerT (Capture capture a :> sublayout) m = - a -> ServerT sublayout m + type ServerT (Capture capture a :> api) m = + a -> ServerT api m - route Proxy d = - DynamicRouter $ \ first -> - route (Proxy :: Proxy sublayout) - (addCapture d $ case captured captureProxy first of - Nothing -> return $ Fail err404 - Just v -> return $ Route v + route Proxy context d = + CaptureRouter $ + route (Proxy :: Proxy api) + context + (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of + Nothing -> delayedFail err400 + Just v -> return v + ) + +-- | If you use 'CaptureAll' in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a +-- function that takes an argument of a list of the type specified by +-- the 'CaptureAll'. This lets servant worry about getting values from +-- the URL and turning them into values of the type you specify. +-- +-- You can control how they'll be converted from 'Text' to your type +-- by simply providing an instance of 'FromHttpApiData' for your type. +-- +-- Example: +-- +-- > type MyApi = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile +-- > +-- > server :: Server MyApi +-- > server = getSourceFile +-- > where getSourceFile :: [Text] -> Handler Book +-- > getSourceFile pathSegments = ... +instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) + => HasServer (CaptureAll capture a :> sublayout) context where + + type ServerT (CaptureAll capture a :> sublayout) m = + [a] -> ServerT sublayout m + + route Proxy context d = + CaptureAllRouter $ + route (Proxy :: Proxy sublayout) + context + (addCapture d $ \ txts -> case parseUrlPieces txts of + Left _ -> delayedFail err400 + Right v -> return v ) - where - captureProxy = Proxy :: Proxy (Capture capture a) allowedMethodHead :: Method -> Request -> Bool @@ -146,67 +184,70 @@ processMethodRouter handleA status method headers request = case handleA of bdy = if allowedMethodHead method request then "" else body hdrs = (hContentType, cs contentT) : (fromMaybe [] headers) -methodCheck :: Method -> Request -> IO (RouteResult ()) +methodCheck :: Method -> Request -> DelayedIO () methodCheck method request - | allowedMethod method request = return $ Route () - | otherwise = return $ Fail err405 + | allowedMethod method request = return () + | otherwise = delayedFail err405 -acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ()) +-- This has switched between using 'Fail' and 'FailFatal' a number of +-- times. If the 'acceptCheck' is run after the body check (which would +-- be morally right), then we have to set this to 'FailFatal', because +-- the body check is not reversible, and therefore backtracking after the +-- body check is no longer an option. However, we now run the accept +-- check before the body check and can therefore afford to make it +-- recoverable. +acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO () acceptCheck proxy accH - | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route () - | otherwise = return $ Fail err406 + | canHandleAcceptH proxy (AcceptHeader accH) = return () + | otherwise = delayedFail err406 methodRouter :: (AllCTRender ctypes a) => Method -> Proxy ctypes -> Status - -> Delayed (ExceptT ServantErr IO a) - -> Router -methodRouter method proxy status action = LeafRouter route' + -> Delayed env (Handler a) + -> Router env +methodRouter method proxy status action = leafRouter route' where - route' request respond - | pathIsEmpty request = + route' env request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH - ) respond $ \ output -> do + ) env request respond $ \ output -> do let handleA = handleAcceptH proxy (AcceptHeader accH) output processMethodRouter handleA status method Nothing request - | otherwise = respond $ Fail err404 methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) => Method -> Proxy ctypes -> Status - -> Delayed (ExceptT ServantErr IO (Headers h v)) - -> Router -methodRouterHeaders method proxy status action = LeafRouter route' + -> Delayed env (Handler (Headers h v)) + -> Router env +methodRouterHeaders method proxy status action = leafRouter route' where - route' request respond - | pathIsEmpty request = + route' env request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH - ) respond $ \ output -> do + ) env request 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 instance OVERLAPPABLE_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status - ) => HasServer (Verb method status ctypes a) where + ) => HasServer (Verb method status ctypes a) context where type ServerT (Verb method status ctypes a) m = m a - 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) 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)) context where type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) - 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) @@ -221,24 +262,24 @@ 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 -- > -- > server :: Server MyApi -- > server = viewReferer --- > where viewReferer :: Referer -> ExceptT ServantErr IO referer +-- > where viewReferer :: Referer -> Handler referer -- > viewReferer referer = return referer -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) - => HasServer (Header sym a :> sublayout) where +instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) + => HasServer (Header sym a :> api) context where - type ServerT (Header sym a :> sublayout) m = - Maybe a -> ServerT sublayout m + type ServerT (Header sym a :> api) m = + Maybe a -> ServerT api m - route Proxy subserver = WithRequest $ \ request -> - let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request) - in route (Proxy :: Proxy sublayout) (passToServer subserver mheader) + route Proxy context subserver = + let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req) + in route (Proxy :: Proxy api) 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, @@ -259,24 +300,24 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) -- > -- > server :: Server MyApi -- > server = getBooksBy --- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book] +-- > where getBooksBy :: Maybe Text -> Handler [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 api context) + => HasServer (QueryParam sym a :> api) context where - type ServerT (QueryParam sym a :> sublayout) m = - Maybe a -> ServerT sublayout m + type ServerT (QueryParam sym a :> api) m = + Maybe a -> ServerT api m - route Proxy subserver = WithRequest $ \ request -> - let querytext = parseQueryText $ rawQueryString request - param = - case lookup paramname querytext of + route Proxy context subserver = + let querytext r = parseQueryText $ rawQueryString r + param r = + case lookup paramname (querytext r) of Nothing -> Nothing -- param absent from the query string 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 api) 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, @@ -296,22 +337,22 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) -- > -- > server :: Server MyApi -- > server = getBooksBy --- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book] +-- > where getBooksBy :: [Text] -> Handler [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 api context) + => HasServer (QueryParams sym a :> api) context where - type ServerT (QueryParams sym a :> sublayout) m = - [a] -> ServerT sublayout m + type ServerT (QueryParams sym a :> api) m = + [a] -> ServerT api m - route Proxy subserver = WithRequest $ \ request -> - let querytext = parseQueryText $ rawQueryString request + route Proxy context subserver = + let querytext r = parseQueryText $ rawQueryString r -- 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) + parameters r = filter looksLikeParam (querytext r) + values r = mapMaybe (convert . snd) (parameters r) + in route (Proxy :: Proxy api) context (passToServer subserver values) where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") convert Nothing = Nothing @@ -327,21 +368,21 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) -- > -- > server :: Server MyApi -- > server = getBooks --- > where getBooks :: Bool -> ExceptT ServantErr IO [Book] +-- > where getBooks :: Bool -> Handler [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 api context) + => HasServer (QueryFlag sym :> api) context where - type ServerT (QueryFlag sym :> sublayout) m = - Bool -> ServerT sublayout m + type ServerT (QueryFlag sym :> api) m = + Bool -> ServerT api m - route Proxy subserver = WithRequest $ \ request -> - let querytext = parseQueryText $ rawQueryString request - param = case lookup paramname querytext of + route Proxy context subserver = + let querytext r = parseQueryText $ rawQueryString r + param r = case lookup paramname (querytext r) 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 api) context (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False @@ -354,12 +395,12 @@ instance (KnownSymbol sym, HasServer sublayout) -- > -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" -instance HasServer Raw where +instance HasServer Raw context where type ServerT Raw m = Application - route Proxy rawApplication = LeafRouter $ \ request respond -> do - r <- runDelayed rawApplication + route Proxy _ rawApplication = RawRouter $ \ env request respond -> do + r <- runDelayed rawApplication env request case r of Route app -> app request (respond . Route) Fail a -> respond $ Fail a @@ -384,18 +425,18 @@ instance HasServer Raw where -- > -- > server :: Server MyApi -- > server = postBook --- > where postBook :: Book -> ExceptT ServantErr IO Book +-- > where postBook :: Book -> Handler Book -- > postBook book = ...insert into your db... -instance ( AllCTUnrender list a, HasServer sublayout - ) => HasServer (ReqBody list a :> sublayout) where +instance ( AllCTUnrender list a, HasServer api context + ) => HasServer (ReqBody list a :> api) context where - type ServerT (ReqBody list a :> sublayout) m = - a -> ServerT sublayout m + type ServerT (ReqBody list a :> api) m = + a -> ServerT api m - route Proxy subserver = WithRequest $ \ request -> - route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request)) + route Proxy context subserver = + route (Proxy :: Proxy api) context (addBodyCheck subserver bodyCheck) where - bodyCheck request = do + bodyCheck = withRequest $ \ request -> do -- See HTTP RFC 2616, section 7.2.1 -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 -- See also "W3C Internet Media Type registration, consistency of use" @@ -403,54 +444,87 @@ instance ( AllCTUnrender list a, HasServer sublayout let contentTypeH = fromMaybe "application/octet-stream" $ lookup hContentType $ requestHeaders request mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) - <$> lazyRequestBody request + <$> liftIO (lazyRequestBody request) case mrqbody of - Nothing -> return $ FailFatal err415 - Just (Left e) -> return $ FailFatal err400 { errBody = cs e } - Just (Right v) -> return $ Route v + Nothing -> delayedFailFatal err415 + Just (Left e) -> delayedFailFatal err400 { errBody = cs e } + Just (Right v) -> return v -- | 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 +-- pass the rest of the request path to @api@. +instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where - type ServerT (path :> sublayout) m = ServerT sublayout m + type ServerT (path :> api) m = ServerT api m - route Proxy subserver = StaticRouter $ - M.singleton (cs (symbolVal proxyPath)) - (route (Proxy :: Proxy sublayout) subserver) + route Proxy context subserver = + pathRouter + (cs (symbolVal proxyPath)) + (route (Proxy :: Proxy api) context subserver) where proxyPath = Proxy :: Proxy path -instance HasServer api => HasServer (RemoteHost :> api) where +instance HasServer api context => HasServer (RemoteHost :> api) context where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ remoteHost req) + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver remoteHost) -instance HasServer api => HasServer (IsSecure :> api) where +instance HasServer api context => HasServer (IsSecure :> api) context where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ secure req) + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver secure) where secure req = if isSecure req then Secure else NotSecure -instance HasServer api => HasServer (Vault :> api) where +instance HasServer api context => HasServer (Vault :> api) context where type ServerT (Vault :> api) m = Vault -> ServerT api m - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ vault req) + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver vault) -instance HasServer api => HasServer (HttpVersion :> api) where +instance HasServer api context => HasServer (HttpVersion :> api) context where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ httpVersion req) + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver httpVersion) -pathIsEmpty :: Request -> Bool -pathIsEmpty = go . pathInfo - where go [] = True - go [""] = True - go _ = False +-- | Basic Authentication +instance ( KnownSymbol realm + , HasServer api context + , HasContextEntry context (BasicAuthCheck usr) + ) + => HasServer (BasicAuth realm usr :> api) context where + + type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m + + route Proxy context subserver = + route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck) + where + realm = BC8.pack $ symbolVal (Proxy :: Proxy realm) + basicAuthContext = getContextEntry context + authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext + +-- * helpers ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP + +-- * General Authentication + + +-- * contexts + +instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) + => HasServer (WithNamedContext name subContext subApi) context where + + type ServerT (WithNamedContext 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/src/Servant/Server/Internal/BasicAuth.hs b/servant-server/src/Servant/Server/Internal/BasicAuth.hs new file mode 100644 index 00000000..1fed931b --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/BasicAuth.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Servant.Server.Internal.BasicAuth where + +import Control.Monad (guard) +import Control.Monad.Trans (liftIO) +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 -> DelayedIO usr +runBasicAuth req realm (BasicAuthCheck ba) = + case decodeBAHdr req of + Nothing -> plzAuthenticate + Just e -> liftIO (ba e) >>= \res -> case res of + BadPassword -> plzAuthenticate + NoSuchUser -> plzAuthenticate + Unauthorized -> delayedFailFatal err403 + Authorized usr -> return usr + where plzAuthenticate = delayedFailFatal err401 { errHeaders = [mkBAChallengerHdr realm] } 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..3dd3a898 --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Context.hs @@ -0,0 +1,104 @@ +{-# 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 + +-- | '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.Utils.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, ()] +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/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index 6f4ebfbb..d01cc67a 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -1,89 +1,206 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where import Data.Map (Map) import qualified Data.Map as M +import Data.Monoid import Data.Text (Text) -import Network.Wai (Request, Response, pathInfo) +import qualified Data.Text as T +import Network.Wai (Response, pathInfo) import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr -type Router = Router' RoutingApplication +type Router env = Router' env RoutingApplication -- | Internal representation of a router. -data Router' a = - WithRequest (Request -> Router) - -- ^ current request is passed to the router - | StaticRouter (Map Text Router) - -- ^ first path component used for lookup and removed afterwards - | DynamicRouter (Text -> Router) - -- ^ first path component used for lookup and removed afterwards - | LeafRouter a - -- ^ to be used for routes that match an empty path - | Choice Router Router +-- +-- The first argument describes an environment type that is +-- expected as extra input by the routers at the leaves. The +-- environment is filled while running the router, with path +-- components that can be used to process captures. +-- +data Router' env a = + StaticRouter (Map Text (Router' env a)) [env -> a] + -- ^ the map contains routers for subpaths (first path component used + -- for lookup and removed afterwards), the list contains handlers + -- for the empty path, to be tried in order + | CaptureRouter (Router' (Text, env) a) + -- ^ first path component is passed to the child router in its + -- environment and removed afterwards + | CaptureAllRouter (Router' ([Text], env) a) + -- ^ all path components are passed to the child router in its + -- environment and are removed afterwards + | RawRouter (env -> a) + -- ^ to be used for routes we do not know anything about + | Choice (Router' env a) (Router' env a) -- ^ left-biased choice between two routers deriving Functor --- | Apply a transformation to the response of a `Router`. -tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router -tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) +-- | Smart constructor for a single static path component. +pathRouter :: Text -> Router' env a -> Router' env a +pathRouter t r = StaticRouter (M.singleton t r) [] + +-- | Smart constructor for a leaf, i.e., a router that expects +-- the empty path. +-- +leafRouter :: (env -> a) -> Router' env a +leafRouter l = StaticRouter M.empty [l] -- | Smart constructor for the choice between routers. -- We currently optimize the following cases: -- --- * Two static routers can be joined by joining their maps. +-- * Two static routers can be joined by joining their maps +-- and concatenating their leaf-lists. -- * Two dynamic routers can be joined by joining their codomains. --- * Two 'WithRequest' routers can be joined by passing them --- the same request and joining their codomains. --- * A 'WithRequest' router can be joined with anything else by --- passing the same request to both but ignoring it in the --- component that does not need it. +-- * Choice nodes can be reordered. -- -choice :: Router -> Router -> Router -choice (StaticRouter table1) (StaticRouter table2) = - StaticRouter (M.unionWith choice table1 table2) -choice (DynamicRouter fun1) (DynamicRouter fun2) = - DynamicRouter (\ first -> choice (fun1 first) (fun2 first)) -choice (WithRequest router1) (WithRequest router2) = - WithRequest (\ request -> choice (router1 request) (router2 request)) -choice (WithRequest router1) router2 = - WithRequest (\ request -> choice (router1 request) router2) -choice router1 (WithRequest router2) = - WithRequest (\ request -> choice router1 (router2 request)) +choice :: Router' env a -> Router' env a -> Router' env a +choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) = + StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2) +choice (CaptureRouter router1) (CaptureRouter router2) = + CaptureRouter (choice router1 router2) +choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3 choice router1 router2 = Choice router1 router2 --- | Interpret a router as an application. -runRouter :: Router -> RoutingApplication -runRouter (WithRequest router) request respond = - runRouter (router request) request respond -runRouter (StaticRouter table) request respond = - case pathInfo request of - first : rest - | Just router <- M.lookup first table - -> let request' = request { pathInfo = rest } - in runRouter router request' respond - _ -> respond $ Fail err404 -runRouter (DynamicRouter fun) request respond = - case pathInfo request of - first : rest - -> let request' = request { pathInfo = rest } - in runRouter (fun first) request' respond - _ -> respond $ Fail err404 -runRouter (LeafRouter app) request respond = app request respond -runRouter (Choice r1 r2) request respond = - runRouter r1 request $ \ mResponse1 -> case mResponse1 of - Fail _ -> runRouter r2 request $ \ mResponse2 -> - respond (highestPri mResponse1 mResponse2) - _ -> respond mResponse1 - where - highestPri (Fail e1) (Fail e2) = - if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2) - then Fail e2 - else Fail e1 - highestPri (Fail _) y = y - highestPri x _ = x +-- | Datatype used for representing and debugging the +-- structure of a router. Abstracts from the handlers +-- at the leaves. +-- +-- Two 'Router's can be structurally compared by computing +-- their 'RouterStructure' using 'routerStructure' and +-- then testing for equality, see 'sameStructure'. +-- +data RouterStructure = + StaticRouterStructure (Map Text RouterStructure) Int + | CaptureRouterStructure RouterStructure + | RawRouterStructure + | ChoiceStructure RouterStructure RouterStructure + deriving (Eq, Show) +-- | Compute the structure of a router. +-- +-- Assumes that the request or text being passed +-- in 'WithRequest' or 'CaptureRouter' does not +-- affect the structure of the underlying tree. +-- +routerStructure :: Router' env a -> RouterStructure +routerStructure (StaticRouter m ls) = + StaticRouterStructure (fmap routerStructure m) (length ls) +routerStructure (CaptureRouter router) = + CaptureRouterStructure $ + routerStructure router +routerStructure (CaptureAllRouter router) = + CaptureRouterStructure $ + routerStructure router +routerStructure (RawRouter _) = + RawRouterStructure +routerStructure (Choice r1 r2) = + ChoiceStructure + (routerStructure r1) + (routerStructure r2) + +-- | Compare the structure of two routers. +-- +sameStructure :: Router' env a -> Router' env b -> Bool +sameStructure r1 r2 = + routerStructure r1 == routerStructure r2 + +-- | Provide a textual representation of the +-- structure of a router. +-- +routerLayout :: Router' env a -> Text +routerLayout router = + T.unlines (["/"] ++ mkRouterLayout False (routerStructure router)) + where + mkRouterLayout :: Bool -> RouterStructure -> [Text] + mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n + mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "" (mkRouterLayout False r) + mkRouterLayout c RawRouterStructure = + if c then ["├─ "] else ["└─ "] + mkRouterLayout c (ChoiceStructure r1 r2) = + mkRouterLayout True r1 ++ ["┆"] ++ mkRouterLayout c r2 + + mkSubTrees :: Bool -> [(Text, RouterStructure)] -> Int -> [Text] + mkSubTrees _ [] 0 = [] + mkSubTrees c [] n = + concat (replicate (n - 1) (mkLeaf True) ++ [mkLeaf c]) + mkSubTrees c [(t, r)] 0 = + mkSubTree c t (mkRouterLayout False r) + mkSubTrees c ((t, r) : trs) n = + mkSubTree True t (mkRouterLayout False r) ++ mkSubTrees c trs n + + mkLeaf :: Bool -> [Text] + mkLeaf True = ["├─•","┆"] + mkLeaf False = ["└─•"] + + mkSubTree :: Bool -> Text -> [Text] -> [Text] + mkSubTree True path children = ("├─ " <> path <> "/") : map ("│ " <>) children + mkSubTree False path children = ("└─ " <> path <> "/") : map (" " <>) children + +-- | Apply a transformation to the response of a `Router`. +tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env -> Router env +tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) + +-- | Interpret a router as an application. +runRouter :: Router () -> RoutingApplication +runRouter r = runRouterEnv r () + +runRouterEnv :: Router env -> env -> RoutingApplication +runRouterEnv router env request respond = + case router of + StaticRouter table ls -> + case pathInfo request of + [] -> runChoice ls env request respond + -- This case is to handle trailing slashes. + [""] -> runChoice ls env request respond + first : rest | Just router' <- M.lookup first table + -> let request' = request { pathInfo = rest } + in runRouterEnv router' env request' respond + _ -> respond $ Fail err404 + CaptureRouter router' -> + case pathInfo request of + [] -> respond $ Fail err404 + -- This case is to handle trailing slashes. + [""] -> respond $ Fail err404 + first : rest + -> let request' = request { pathInfo = rest } + in runRouterEnv router' (first, env) request' respond + CaptureAllRouter router' -> + let segments = pathInfo request + request' = request { pathInfo = [] } + in runRouterEnv router' (segments, env) request' respond + RawRouter app -> + app env request respond + Choice r1 r2 -> + runChoice [runRouterEnv r1, runRouterEnv r2] env request respond + +-- | Try a list of routing applications in order. +-- We stop as soon as one fails fatally or succeeds. +-- If all fail normally, we pick the "best" error. +-- +runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication +runChoice ls = + case ls of + [] -> \ _ _ respond -> respond (Fail err404) + [r] -> r + (r : rs) -> + \ env request respond -> + r env request $ \ response1 -> + case response1 of + Fail _ -> runChoice rs env request $ \ response2 -> + respond $ highestPri response1 response2 + _ -> respond response1 + where + highestPri (Fail e1) (Fail e2) = + if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2) + then Fail e2 + else Fail e1 + highestPri (Fail _) y = y + highestPri x _ = x -- Priority on HTTP codes. -- diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 4b27c688..5f78d0bb 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -4,21 +4,17 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RecordWildCards #-} {-# 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 qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.IORef (newIORef, readIORef, - writeIORef) +import Control.Monad (ap, liftM) +import Control.Monad.Trans (MonadIO(..)) +import Control.Monad.Trans.Except (runExceptT) import Network.Wai (Application, Request, - Response, ResponseReceived, - requestBody, - strictRequestBody) + Response, ResponseReceived) +import Prelude () +import Prelude.Compat import Servant.Server.Internal.ServantErr type RoutingApplication = @@ -33,64 +29,14 @@ 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 routingRespond (FailFatal err) = respond $ responseServantErr err routingRespond (Route v) = respond v --- We currently mix up the order in which we perform checks --- and the priority with which errors are reported. --- --- For example, we perform Capture checks prior to method checks, --- and therefore get 404 before 405. --- --- However, we also perform body checks prior to method checks --- 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. --- --- So in principle, we'd like: --- --- static routes (can cause 404) --- delayed captures (can cause 404) --- methods (can cause 405) --- delayed body (can cause 415, 400) --- accept header (can cause 406) --- --- According to the HTTP decision diagram, the priority order --- between HTTP status codes is as follows: --- - -- | A 'Delayed' is a representation of a handler with scheduled -- delayed checks that can trigger errors. -- @@ -98,10 +44,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 @@ -151,99 +97,181 @@ toApplication ra request respond = do -- 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 env c where + Delayed :: { capturesD :: env -> DelayedIO captures + , methodD :: DelayedIO () + , authD :: DelayedIO auth + , bodyD :: DelayedIO body + , serverD :: captures -> auth -> body -> Request -> RouteResult c + } -> Delayed env c -instance Functor Delayed where - fmap f (Delayed a b c g) = Delayed a b c ((fmap.fmap.fmap) f g) +instance Functor (Delayed env) where + fmap f Delayed{..} = + Delayed + { serverD = \ c a b req -> f <$> serverD c a b req + , .. + } -- Note [Existential Record Update] + +-- | Computations used in a 'Delayed' can depend on the +-- incoming 'Request', may perform 'IO, and result in a +-- 'RouteResult, meaning they can either suceed, fail +-- (with the possibility to recover), or fail fatally. +-- +newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> IO (RouteResult a) } + +instance Functor DelayedIO where + fmap = liftM + +instance Applicative DelayedIO where + pure = return + (<*>) = ap + +instance Monad DelayedIO where + return x = DelayedIO (const $ return (Route x)) + DelayedIO m >>= f = + DelayedIO $ \ req -> do + r <- m req + case r of + Fail e -> return $ Fail e + FailFatal e -> return $ FailFatal e + Route a -> runDelayedIO (f a) req + +instance MonadIO DelayedIO where + liftIO m = DelayedIO (const $ Route <$> m) + +-- | A 'Delayed' without any stored checks. +emptyDelayed :: RouteResult a -> Delayed env a +emptyDelayed result = + Delayed (const r) r r r (\ _ _ _ _ -> result) + where + r = return () + +-- | Fail with the option to recover. +delayedFail :: ServantErr -> DelayedIO a +delayedFail err = DelayedIO (const $ return $ Fail err) + +-- | Fail fatally, i.e., without any option to recover. +delayedFailFatal :: ServantErr -> DelayedIO a +delayedFailFatal err = DelayedIO (const $ return $ FailFatal err) + +-- | Gain access to the incoming request. +withRequest :: (Request -> DelayedIO a) -> DelayedIO a +withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req) -- | 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 env (a -> b) + -> (captured -> DelayedIO a) + -> Delayed (captured, env) b +addCapture Delayed{..} new = + Delayed + { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt + , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req + , .. + } -- 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 env a + -> DelayedIO () + -> Delayed env a +addMethodCheck Delayed{..} new = + Delayed + { methodD = methodD <* new + , .. + } -- Note [Existential Record Update] + +-- | Add an auth check to the end of the auth block. +addAuthCheck :: Delayed env (a -> b) + -> DelayedIO a + -> Delayed env b +addAuthCheck Delayed{..} new = + Delayed + { authD = (,) <$> authD <*> new + , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req + , .. + } -- 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 env (a -> b) + -> DelayedIO a + -> Delayed env b +addBodyCheck Delayed{..} new = + Delayed + { bodyD = (,) <$> bodyD <*> new + , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req + , .. + } -- 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, --- but this will be the case, because the accept header check --- is only scheduled by the method combinators. -addAcceptCheck :: Delayed a - -> IO (RouteResult ()) - -> Delayed a -addAcceptCheck (Delayed captures method body server) new = - Delayed captures method (combineRouteResults const body new) server + +-- | Add an accept header check to the beginning of the body +-- block. There is a tradeoff here. In principle, we'd like +-- to take a bad body (400) response take precedence over a +-- failed accept check (406). BUT to allow streaming the body, +-- we cannot run the body check and then still backtrack. +-- We therefore do the accept check before the body check, +-- when we can still backtrack. There are other solutions to +-- this, but they'd be more complicated (such as delaying the +-- body check further so that it can still be run in a situation +-- where we'd otherwise report 406). +addAcceptCheck :: Delayed env a + -> DelayedIO () + -> Delayed env a +addAcceptCheck Delayed{..} new = + Delayed + { bodyD = new *> bodyD + , .. + } -- Note [Existential Record Update] -- | Many combinators extract information that is passed to -- the handler without the possibility of failure. In such a -- case, 'passToServer' can be used. -passToServer :: Delayed (a -> b) -> a -> Delayed b -passToServer d x = ($ x) <$> d - --- | The combination 'IO . RouteResult' is a monad, but we --- don't explicitly wrap it in a newtype in order to make it --- an instance. This is the '>>=' of that monad. --- --- We stop on the first error. -bindRouteResults :: IO (RouteResult a) -> (a -> IO (RouteResult b)) -> IO (RouteResult b) -bindRouteResults m f = do - r <- m - case r of - Fail e -> return $ Fail e - FailFatal e -> return $ FailFatal e - Route a -> f a - --- | Common special case of 'bindRouteResults', corresponding --- to 'liftM2'. -combineRouteResults :: (a -> b -> c) -> IO (RouteResult a) -> IO (RouteResult b) -> IO (RouteResult c) -combineRouteResults f m1 m2 = - m1 `bindRouteResults` \ a -> - m2 `bindRouteResults` \ b -> - return (Route (f a b)) +passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b +passToServer Delayed{..} x = + Delayed + { serverD = \ c a b req -> ($ x req) <$> serverD c a b req + , .. + } -- Note [Existential Record Update] -- | 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. -runDelayed :: Delayed a +-- +-- This should only be called once per request; otherwise the guarantees about +-- effect and HTTP error ordering break down. +runDelayed :: Delayed env a + -> env + -> Request -> IO (RouteResult a) -runDelayed (Delayed captures method body server) = - captures `bindRouteResults` \ c -> - method `bindRouteResults` \ _ -> - body `bindRouteResults` \ b -> - return (server c b) +runDelayed Delayed{..} env = runDelayedIO $ do + c <- capturesD env + methodD + a <- authD + b <- bodyD + DelayedIO (\ req -> return $ serverD c a b req) -- | Runs a delayed server and the resulting action. -- Takes a continuation that lets us send a response. -- Also takes a continuation for how to turn the -- result of the delayed server into a response. -runAction :: Delayed (ExceptT ServantErr IO a) +runAction :: Delayed env (Handler a) + -> env + -> Request -> (RouteResult Response -> IO r) -> (a -> RouteResult Response) -> IO r -runAction action respond k = runDelayed action >>= go >>= respond +runAction action env req respond k = + runDelayed action env req >>= 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 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. +-} diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs index 6cfa3e90..e1267ce6 100644 --- a/servant-server/src/Servant/Server/Internal/ServantErr.hs +++ b/servant-server/src/Servant/Server/Internal/ServantErr.hs @@ -1,9 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} module Servant.Server.Internal.ServantErr where +import Control.Exception (Exception) +import Control.Monad.Trans.Except (ExceptT) 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,13 +15,24 @@ data ServantErr = ServantErr { errHTTPCode :: Int , errReasonPhrase :: String , errBody :: LBS.ByteString , errHeaders :: [HTTP.Header] - } deriving (Show, Eq, Read) + } deriving (Show, Eq, Read, Typeable) + +instance Exception ServantErr + +type Handler = ExceptT ServantErr IO responseServantErr :: ServantErr -> Response responseServantErr ServantErr{..} = responseLBS status errHeaders errBody where status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase) +-- | 'err300' Multiple Choices +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err300 { errBody = "I can't choose." } +-- err300 :: ServantErr err300 = ServantErr { errHTTPCode = 300 , errReasonPhrase = "Multiple Choices" @@ -25,6 +40,13 @@ err300 = ServantErr { errHTTPCode = 300 , errHeaders = [] } +-- | 'err301' Moved Permanently +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err301 +-- err301 :: ServantErr err301 = ServantErr { errHTTPCode = 301 , errReasonPhrase = "Moved Permanently" @@ -32,6 +54,13 @@ err301 = ServantErr { errHTTPCode = 301 , errHeaders = [] } +-- | 'err302' Found +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err302 +-- err302 :: ServantErr err302 = ServantErr { errHTTPCode = 302 , errReasonPhrase = "Found" @@ -39,6 +68,13 @@ err302 = ServantErr { errHTTPCode = 302 , errHeaders = [] } +-- | 'err303' See Other +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err303 +-- err303 :: ServantErr err303 = ServantErr { errHTTPCode = 303 , errReasonPhrase = "See Other" @@ -46,6 +82,13 @@ err303 = ServantErr { errHTTPCode = 303 , errHeaders = [] } +-- | 'err304' Not Modified +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err304 +-- err304 :: ServantErr err304 = ServantErr { errHTTPCode = 304 , errReasonPhrase = "Not Modified" @@ -53,6 +96,13 @@ err304 = ServantErr { errHTTPCode = 304 , errHeaders = [] } +-- | 'err305' Use Proxy +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err305 +-- err305 :: ServantErr err305 = ServantErr { errHTTPCode = 305 , errReasonPhrase = "Use Proxy" @@ -60,6 +110,13 @@ err305 = ServantErr { errHTTPCode = 305 , errHeaders = [] } +-- | 'err307' Temporary Redirect +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err307 +-- err307 :: ServantErr err307 = ServantErr { errHTTPCode = 307 , errReasonPhrase = "Temporary Redirect" @@ -67,6 +124,13 @@ err307 = ServantErr { errHTTPCode = 307 , errHeaders = [] } +-- | 'err400' Bad Request +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." } +-- err400 :: ServantErr err400 = ServantErr { errHTTPCode = 400 , errReasonPhrase = "Bad Request" @@ -74,6 +138,13 @@ err400 = ServantErr { errHTTPCode = 400 , errHeaders = [] } +-- | 'err401' Unauthorized +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." } +-- err401 :: ServantErr err401 = ServantErr { errHTTPCode = 401 , errReasonPhrase = "Unauthorized" @@ -81,6 +152,13 @@ err401 = ServantErr { errHTTPCode = 401 , errHeaders = [] } +-- | 'err402' Payment Required +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." } +-- err402 :: ServantErr err402 = ServantErr { errHTTPCode = 402 , errReasonPhrase = "Payment Required" @@ -88,6 +166,13 @@ err402 = ServantErr { errHTTPCode = 402 , errHeaders = [] } +-- | 'err403' Forbidden +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err403 { errBody = "Please login first." } +-- err403 :: ServantErr err403 = ServantErr { errHTTPCode = 403 , errReasonPhrase = "Forbidden" @@ -95,6 +180,13 @@ err403 = ServantErr { errHTTPCode = 403 , errHeaders = [] } +-- | 'err404' Not Found +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." } +-- err404 :: ServantErr err404 = ServantErr { errHTTPCode = 404 , errReasonPhrase = "Not Found" @@ -102,6 +194,13 @@ err404 = ServantErr { errHTTPCode = 404 , errHeaders = [] } +-- | 'err405' Method Not Allowed +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." } +-- err405 :: ServantErr err405 = ServantErr { errHTTPCode = 405 , errReasonPhrase = "Method Not Allowed" @@ -109,6 +208,13 @@ err405 = ServantErr { errHTTPCode = 405 , errHeaders = [] } +-- | 'err406' Not Acceptable +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err406 +-- err406 :: ServantErr err406 = ServantErr { errHTTPCode = 406 , errReasonPhrase = "Not Acceptable" @@ -116,6 +222,13 @@ err406 = ServantErr { errHTTPCode = 406 , errHeaders = [] } +-- | 'err407' Proxy Authentication Required +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err407 +-- err407 :: ServantErr err407 = ServantErr { errHTTPCode = 407 , errReasonPhrase = "Proxy Authentication Required" @@ -123,6 +236,13 @@ err407 = ServantErr { errHTTPCode = 407 , errHeaders = [] } +-- | 'err409' Conflict +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" } +-- err409 :: ServantErr err409 = ServantErr { errHTTPCode = 409 , errReasonPhrase = "Conflict" @@ -130,6 +250,13 @@ err409 = ServantErr { errHTTPCode = 409 , errHeaders = [] } +-- | 'err410' Gone +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." } +-- err410 :: ServantErr err410 = ServantErr { errHTTPCode = 410 , errReasonPhrase = "Gone" @@ -137,6 +264,13 @@ err410 = ServantErr { errHTTPCode = 410 , errHeaders = [] } +-- | 'err411' Length Required +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err411 +-- err411 :: ServantErr err411 = ServantErr { errHTTPCode = 411 , errReasonPhrase = "Length Required" @@ -144,6 +278,13 @@ err411 = ServantErr { errHTTPCode = 411 , errHeaders = [] } +-- | 'err412' Precondition Failed +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" } +-- err412 :: ServantErr err412 = ServantErr { errHTTPCode = 412 , errReasonPhrase = "Precondition Failed" @@ -151,6 +292,13 @@ err412 = ServantErr { errHTTPCode = 412 , errHeaders = [] } +-- | 'err413' Request Entity Too Large +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." } +-- err413 :: ServantErr err413 = ServantErr { errHTTPCode = 413 , errReasonPhrase = "Request Entity Too Large" @@ -158,6 +306,13 @@ err413 = ServantErr { errHTTPCode = 413 , errHeaders = [] } +-- | 'err414' Request-URI Too Large +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." } +-- err414 :: ServantErr err414 = ServantErr { errHTTPCode = 414 , errReasonPhrase = "Request-URI Too Large" @@ -165,6 +320,13 @@ err414 = ServantErr { errHTTPCode = 414 , errHeaders = [] } +-- | 'err415' Unsupported Media Type +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" } +-- err415 :: ServantErr err415 = ServantErr { errHTTPCode = 415 , errReasonPhrase = "Unsupported Media Type" @@ -172,6 +334,13 @@ err415 = ServantErr { errHTTPCode = 415 , errHeaders = [] } +-- | 'err416' Request range not satisfiable +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." } +-- err416 :: ServantErr err416 = ServantErr { errHTTPCode = 416 , errReasonPhrase = "Request range not satisfiable" @@ -179,6 +348,13 @@ err416 = ServantErr { errHTTPCode = 416 , errHeaders = [] } +-- | 'err417' Expectation Failed +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." } +-- err417 :: ServantErr err417 = ServantErr { errHTTPCode = 417 , errReasonPhrase = "Expectation Failed" @@ -186,6 +362,13 @@ err417 = ServantErr { errHTTPCode = 417 , errHeaders = [] } +-- | 'err500' Internal Server Error +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" } +-- err500 :: ServantErr err500 = ServantErr { errHTTPCode = 500 , errReasonPhrase = "Internal Server Error" @@ -193,6 +376,13 @@ err500 = ServantErr { errHTTPCode = 500 , errHeaders = [] } +-- | 'err501' Not Implemented +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." } +-- err501 :: ServantErr err501 = ServantErr { errHTTPCode = 501 , errReasonPhrase = "Not Implemented" @@ -200,6 +390,13 @@ err501 = ServantErr { errHTTPCode = 501 , errHeaders = [] } +-- | 'err502' Bad Gateway +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." } +-- err502 :: ServantErr err502 = ServantErr { errHTTPCode = 502 , errReasonPhrase = "Bad Gateway" @@ -207,6 +404,13 @@ err502 = ServantErr { errHTTPCode = 502 , errHeaders = [] } +-- | 'err503' Service Unavailable +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." } +-- err503 :: ServantErr err503 = ServantErr { errHTTPCode = 503 , errReasonPhrase = "Service Unavailable" @@ -214,6 +418,13 @@ err503 = ServantErr { errHTTPCode = 503 , errHeaders = [] } +-- | 'err504' Gateway Time-out +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." } +-- err504 :: ServantErr err504 = ServantErr { errHTTPCode = 504 , errReasonPhrase = "Gateway Time-out" @@ -221,6 +432,13 @@ err504 = ServantErr { errHTTPCode = 504 , errHeaders = [] } +-- | 'err505' HTTP Version not supported +-- +-- Example usage: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." } +-- err505 :: ServantErr err505 = ServantErr { errHTTPCode = 505 , errReasonPhrase = "HTTP Version not supported" diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/ArbitraryMonadServerSpec.hs similarity index 89% rename from servant-server/test/Servant/Server/Internal/EnterSpec.hs rename to servant-server/test/Servant/ArbitraryMonadServerSpec.hs index 8b450377..444d86ec 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/ArbitraryMonadServerSpec.hs @@ -1,11 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} -module Servant.Server.Internal.EnterSpec where +module Servant.ArbitraryMonadServerSpec where import qualified Control.Category as C import Control.Monad.Reader -import Control.Monad.Trans.Except import Data.Proxy import Servant.API import Servant.Server @@ -15,7 +14,7 @@ import Test.Hspec.Wai (get, matchStatus, post, shouldRespondWith, with) spec :: Spec -spec = describe "module Servant.Server.Enter" $ do +spec = describe "Arbitrary monad server" $ do enterSpec type ReaderAPI = "int" :> Get '[JSON] Int @@ -34,7 +33,7 @@ combinedAPI = Proxy readerServer' :: ServerT ReaderAPI (Reader String) readerServer' = return 1797 :<|> ask -fReader :: Reader String :~> ExceptT ServantErr IO +fReader :: Reader String :~> Handler fReader = generalizeNat C.. (runReaderTNat "hi") readerServer :: Server ReaderAPI diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 500a0069..39a71721 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,96 @@ 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 +-- On error priorities: +-- +-- We originally had +-- +-- 404, 405, 401, 415, 400, 406, 402 +-- +-- but we changed this to +-- +-- 404, 405, 401, 406, 415, 400, 402 +-- +-- for servant-0.7. +-- +-- This change is due to the body check being irreversible (to support +-- streaming). Any check done after the body check has to be made fatal, +-- breaking modularity. We've therefore moved the accept check before +-- the body check, to allow it being recoverable and modular, and this +-- goes along with promoting the error priority of 406. errorOrderSpec :: Spec -errorOrderSpec = describe "HTTP error order" - $ with (return $ serve errorOrderApi errorOrderServer) $ do +errorOrderSpec = + describe "HTTP error order" $ + with (return $ serveWithContext errorOrderApi + (errorOrderAuthCheck :. EmptyContext) + errorOrderServer + ) $ do 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") 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 - `shouldRespondWith` 415 + it "has 401 as its third highest priority error (auth)" $ do + request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody + `shouldRespondWith` 401 - it "has 400 as its fourth highest priority error" $ do - request goodMethod goodUrl [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 fourth highest priority error" $ do + request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody `shouldRespondWith` 406 + it "has 415 as its fifth highest priority error" $ do + request goodMethod goodUrl [goodAuth, badContentType, goodAccept] badBody + `shouldRespondWith` 415 + + it "has 400 as its sixth highest priority error" $ do + request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody + `shouldRespondWith` 400 + 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 +175,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 +192,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 $ serveWithContext errorRetryApi + (errorOrderAuthCheck :. EmptyContext) + errorRetryServer + ) $ do let jsonCT = (hContentType, "application/json") jsonAccept = (hAccept, "application/json") @@ -162,7 +211,7 @@ 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 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..887f7269 --- /dev/null +++ b/servant-server/test/Servant/Server/Internal/ContextSpec.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-} +module Servant.Server.Internal.ContextSpec (spec) where + +import Data.Proxy (Proxy (..)) +import Test.Hspec (Spec, describe, it, shouldBe, 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 + it "has a Show instance" $ do + let cxt = 'a' :. True :. EmptyContext + show cxt `shouldBe` "'a' :. True :. EmptyContext" + + context "bracketing" $ do + it "works" $ do + let cxt = 'a' :. True :. EmptyContext + show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)" + + it "works with operators" $ do + let cxt = ((1 :: Integer) :. '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/RouterSpec.hs b/servant-server/test/Servant/Server/RouterSpec.hs new file mode 100644 index 00000000..0356de8b --- /dev/null +++ b/servant-server/test/Servant/Server/RouterSpec.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +module Servant.Server.RouterSpec (spec) where + +import Control.Monad (unless) +import Data.Proxy (Proxy(..)) +import Data.Text (unpack) +import Network.HTTP.Types (Status (..)) +import Network.Wai (responseBuilder) +import Network.Wai.Internal (Response (ResponseBuilder)) +import Test.Hspec +import Test.Hspec.Wai (get, shouldRespondWith, with) +import Servant.API +import Servant.Server +import Servant.Server.Internal + +spec :: Spec +spec = describe "Servant.Server.Internal.Router" $ do + routerSpec + distributivitySpec + +routerSpec :: Spec +routerSpec = do + let app' :: Application + app' = toApplication $ runRouter router' + + router', router :: Router () + router' = tweakResponse (fmap twk) router + router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "") + + twk :: Response -> Response + twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b + twk b = b + + describe "tweakResponse" . with (return app') $ do + it "calls f on route result" $ do + get "" `shouldRespondWith` 202 + +distributivitySpec :: Spec +distributivitySpec = + describe "choice" $ do + it "distributes endpoints through static paths" $ do + endpoint `shouldHaveSameStructureAs` endpointRef + it "distributes nested routes through static paths" $ do + static `shouldHaveSameStructureAs` staticRef + it "distributes nested routes through dynamic paths" $ do + dynamic `shouldHaveSameStructureAs` dynamicRef + it "properly reorders permuted static paths" $ do + permute `shouldHaveSameStructureAs` permuteRef + it "properly reorders permuted static paths in the presence of Raw in end" $ do + permuteRawEnd `shouldHaveSameStructureAs` permuteRawEndRef + it "properly reorders permuted static paths in the presence of Raw in beginning" $ do + permuteRawBegin `shouldHaveSameStructureAs` permuteRawBeginRef + it "properly reorders permuted static paths in the presence of Raw in middle" $ do + permuteRawMiddle `shouldHaveSameStructureAs` permuteRawMiddleRef + it "properly reorders permuted static paths in the presence of a root endpoint in end" $ do + permuteEndEnd `shouldHaveSameStructureAs` permuteEndRef + it "properly reorders permuted static paths in the presence of a root endpoint in beginning" $ do + permuteEndBegin `shouldHaveSameStructureAs` permuteEndRef + it "properly reorders permuted static paths in the presence of a root endpoint in middle" $ do + permuteEndMiddle `shouldHaveSameStructureAs` permuteEndRef + it "properly handles mixing static paths at different levels" $ do + level `shouldHaveSameStructureAs` levelRef + +shouldHaveSameStructureAs :: + (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation +shouldHaveSameStructureAs p1 p2 = + unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $ + expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1)) + +makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router () +makeTrivialRouter p = + route p EmptyContext (emptyDelayed (FailFatal err501)) + +type End = Get '[JSON] NoContent + +-- The latter version looks more efficient, +-- but the former should be compiled to the +-- same layout: + +type Endpoint = "a" :> End :<|> "a" :> End +type EndpointRef = "a" :> (End :<|> End) + +endpoint :: Proxy Endpoint +endpoint = Proxy + +endpointRef :: Proxy EndpointRef +endpointRef = Proxy + +-- Again, the latter version looks more efficient, +-- but the former should be compiled to the same +-- layout: + +type Static = "a" :> "b" :> End :<|> "a" :> "c" :> End +type StaticRef = "a" :> ("b" :> End :<|> "c" :> End) + +static :: Proxy Static +static = Proxy + +staticRef :: Proxy StaticRef +staticRef = Proxy + +-- Even for dynamic path components, we expect the +-- router to simplify the layout, because captures +-- are delayed and only actually performed once +-- reaching an endpoint. So the former version and +-- the latter should be compiled to the same router +-- structure: + +type Dynamic = + "a" :> Capture "foo" Int :> "b" :> End + :<|> "a" :> Capture "bar" Bool :> "c" :> End + :<|> "a" :> Capture "baz" Char :> "d" :> End + +type DynamicRef = + "a" :> Capture "anything" () :> + ("b" :> End :<|> "c" :> End :<|> "d" :> End) + +dynamic :: Proxy Dynamic +dynamic = Proxy + +dynamicRef :: Proxy DynamicRef +dynamicRef = Proxy + +-- A more complicated example of static route reordering. +-- All the permuted paths should be correctly grouped, +-- so both 'Permute' and 'PermuteRef' should compile to +-- the same layout: + +type Permute = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteRef = + "a" :> ( "b" :> "c" :> End + :<|> "c" :> "b" :> End + ) + :<|> "b" :> ( "a" :> "c" :> End + :<|> "c" :> "a" :> End + ) + :<|> "c" :> ( "a" :> "b" :> End + :<|> "b" :> "a" :> End + ) + +permute :: Proxy Permute +permute = Proxy + +permuteRef :: Proxy PermuteRef +permuteRef = Proxy + +-- Adding a 'Raw' in one of the ends should have minimal +-- effect on the grouping. + +type PermuteRawEnd = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + :<|> Raw + +type PermuteRawEndRef = PermuteRef :<|> Raw + +type PermuteRawBegin = + Raw + :<|> "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteRawBeginRef = Raw :<|> PermuteRef + +permuteRawBegin :: Proxy PermuteRawBegin +permuteRawBegin = Proxy + +permuteRawBeginRef :: Proxy PermuteRawBeginRef +permuteRawBeginRef = Proxy + +permuteRawEnd :: Proxy PermuteRawEnd +permuteRawEnd = Proxy + +permuteRawEndRef :: Proxy PermuteRawEndRef +permuteRawEndRef = Proxy + +-- Adding a 'Raw' in the middle will disrupt grouping, +-- because we commute things past a 'Raw'. But the two +-- halves should still be grouped. + +type PermuteRawMiddle = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> Raw + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteRawMiddleRef = + "a" :> ( "b" :> "c" :> End + :<|> "c" :> "b" :> End + ) + :<|> "b" :> "a" :> "c" :> End + :<|> Raw + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> ( "a" :> "b" :> End + :<|> "b" :> "a" :> End + ) + +permuteRawMiddle :: Proxy PermuteRawMiddle +permuteRawMiddle = Proxy + +permuteRawMiddleRef :: Proxy PermuteRawMiddleRef +permuteRawMiddleRef = Proxy + +-- Adding an endpoint at the top-level in various places +-- is also somewhat critical for grouping, but it should +-- not disrupt grouping at all, even if it is placed in +-- the middle. + +type PermuteEndEnd = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + :<|> End + +type PermuteEndBegin = + End + :<|> "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteEndMiddle = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteEndRef = PermuteRef :<|> End + +permuteEndEnd :: Proxy PermuteEndEnd +permuteEndEnd = Proxy + +permuteEndBegin :: Proxy PermuteEndBegin +permuteEndBegin = Proxy + +permuteEndMiddle :: Proxy PermuteEndMiddle +permuteEndMiddle = Proxy + +permuteEndRef :: Proxy PermuteEndRef +permuteEndRef = Proxy + +-- An API with routes on different nesting levels that +-- is composed out of different fragments should still +-- be reordered correctly. + +type LevelFragment1 = + "a" :> "b" :> End + :<|> "a" :> End + +type LevelFragment2 = + "b" :> End + :<|> "a" :> "c" :> End + :<|> End + +type Level = LevelFragment1 :<|> LevelFragment2 + +type LevelRef = + "a" :> ("b" :> End :<|> "c" :> End :<|> End) + :<|> "b" :> End + :<|> End + +level :: Proxy Level +level = Proxy + +levelRef :: Proxy LevelRef +levelRef = Proxy diff --git a/servant-server/test/Servant/Server/StreamingSpec.hs b/servant-server/test/Servant/Server/StreamingSpec.hs new file mode 100644 index 00000000..215664ee --- /dev/null +++ b/servant-server/test/Servant/Server/StreamingSpec.hs @@ -0,0 +1,108 @@ +{-# 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 hiding (Handler) +import Control.Monad.IO.Class +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 -> Handler 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 + } diff --git a/servant-server/test/Servant/Server/UsingContextSpec.hs b/servant-server/test/Servant/Server/UsingContextSpec.hs new file mode 100644 index 00000000..91ab8376 --- /dev/null +++ b/servant-server/test/Servant/Server/UsingContextSpec.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Server.UsingContextSpec where + +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 -> Handler 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..0a718788 --- /dev/null +++ b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs @@ -0,0 +1,71 @@ +{-# 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 + +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 delayed) + where + subProxy :: Proxy subApi + subProxy = Proxy + + inject 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 952c8ca8..746f72c8 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -1,25 +1,24 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} module Servant.ServerSpec where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif import Control.Monad (forM_, when, unless) -import Control.Monad.Trans.Except (ExceptT, throwE) +import Control.Monad.Trans.Except (throwE) import Data.Aeson (FromJSON, ToJSON, decode', encode) +import qualified Data.ByteString.Base64 as Base64 import Data.ByteString.Conversion () import Data.Char (toUpper) +import Data.Monoid import Data.Proxy (Proxy (Proxy)) import Data.String (fromString) import Data.String.Conversions (cs) @@ -29,43 +28,58 @@ import Network.HTTP.Types (Status (..), hAccept, hContentType, methodDelete, methodGet, methodHead, methodPatch, methodPost, methodPut, ok200, + imATeaPot418, parseQuery) -import Network.Wai (Application, Request, pathInfo, +import Network.Wai (Application, Request, requestHeaders, pathInfo, queryString, rawQueryString, - responseBuilder, responseLBS) -import Network.Wai.Internal (Response (ResponseBuilder)) + responseLBS) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody, simpleHeaders, simpleStatus) -import Servant.API ((:<|>) (..), (:>), Capture, Delete, - Get, FTime(..), Header (..), +import Servant.API ((:<|>) (..), (:>), AuthProtect, + BasicAuth, BasicAuthData(BasicAuthData), + Capture, CaptureAll, Delete, Get, Header (..), Headers, HttpVersion, IsSecure (..), JSON, NoContent (..), Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, - StdMethod (..), Verb, addHeader) -import Servant.Server (ServantErr (..), Server, err404, - serve) + StdMethod (..), Verb, addHeader, + FTime(..)) +import Servant.API.Internal.Test.ComprehensiveAPI +import Servant.Server (Server, Handler, err401, err403, + err404, 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.RoutingApplication - (toApplication, RouteResult(..)) -import Servant.Server.Internal.Router - (tweakResponse, runRouter, - Router, Router'(LeafRouter)) +import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck), + BasicAuthResult(Authorized,Unauthorized)) +import Servant.Server.Experimental.Auth + (AuthHandler, AuthServerData, + mkAuthHandler) +import Servant.Server.Internal.Context + (NamedContext(..)) import Data.Time.Calendar (Day, fromGregorian) import Data.Time.LocalTime (LocalTime(..), hoursToTimeZone, localTimeToUTC, makeTimeOfDayValid) import Data.Time.Clock (UTCTime) import Data.ByteString.Lazy (ByteString) +-- * comprehensive api test + +-- This declaration simply checks that all instances are in place. +_ = serveWithContext comprehensiveAPI comprehensiveApiContext + +comprehensiveApiContext :: Context '[NamedContext "foo" '[]] +comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext + +-- * Specs --- *Specs spec :: Spec spec = do verbSpec @@ -77,8 +91,9 @@ spec = do rawSpec alternativeSpec responseHeadersSpec - routerSpec miscCombinatorSpec + basicAuthSpec + genAuthSpec ------------------------------------------------------------------------------ -- * verbSpec {{{ @@ -89,6 +104,9 @@ type VerbApi method status :<|> "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) + :<|> "accept" :> ( Verb method status '[JSON] Person + :<|> Verb method status '[PlainText] String + ) verbSpec :: Spec verbSpec = describe "Servant.API.Verb" $ do @@ -97,6 +115,7 @@ verbSpec = describe "Servant.API.Verb" $ do :<|> return NoContent :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent) + :<|> (return alice :<|> return "B") get200 = Proxy :: Proxy (VerbApi 'GET 200) post210 = Proxy :: Proxy (VerbApi 'POST 210) put203 = Proxy :: Proxy (VerbApi 'PUT 203) @@ -110,49 +129,55 @@ 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 + unless (status `elem` [214, 215] || method == methodHead) $ + it "allows modular specification of supported content types" $ do + response <- THW.request method "/accept" [(hAccept, "text/plain")] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + liftIO $ simpleBody response `shouldBe` "B" + 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")] @@ -171,7 +196,7 @@ verbSpec = describe "Servant.API.Verb" $ do type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal captureApi :: Proxy CaptureApi captureApi = Proxy -captureServer :: Integer -> ExceptT ServantErr IO Animal +captureServer :: Integer -> Handler Animal captureServer legs = case legs of 4 -> return jerry 2 -> return tweety @@ -186,8 +211,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)) @@ -196,6 +221,59 @@ captureSpec = do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) +-- }}} + +------------------------------------------------------------------------------ +-- * captureAllSpec {{{ +------------------------------------------------------------------------------ + +type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal +captureAllApi :: Proxy CaptureAllApi +captureAllApi = Proxy +captureAllServer :: [Integer] -> Handler Animal +captureAllServer legs = case sum legs of + 4 -> return jerry + 2 -> return tweety + 0 -> return beholder + _ -> throwE err404 + +captureAllSpec :: Spec +captureAllSpec = do + describe "Servant.API.CaptureAll" $ do + with (return (serve captureAllApi captureAllServer)) $ do + + it "can capture a single element of the 'pathInfo'" $ do + response <- get "/2" + liftIO $ decode' (simpleBody response) `shouldBe` Just tweety + + it "can capture multiple elements of the 'pathInfo'" $ do + response <- get "/2/2" + liftIO $ decode' (simpleBody response) `shouldBe` Just jerry + + it "can capture arbitrarily many elements of the 'pathInfo'" $ do + response <- get "/1/1/0/1/0/1" + liftIO $ decode' (simpleBody response) `shouldBe` Just jerry + + it "can capture when there are no elements in 'pathInfo'" $ do + response <- get "/" + liftIO $ decode' (simpleBody response) `shouldBe` Just beholder + + it "returns 400 if the decoding fails" $ do + get "/notAnInt" `shouldRespondWith` 400 + + it "returns 400 if the decoding fails, regardless of which element" $ do + get "/1/0/0/notAnInt/3/" `shouldRespondWith` 400 + + it "returns 400 if the decoding fails, even when it's multiple elements" $ do + get "/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400 + + with (return (serve + (Proxy :: Proxy (CaptureAll "segments" String :> Raw)) + (\ _captured request_ respond -> + respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do + it "consumes everything from pathInfo" $ do + get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int]))) + -- }}} ------------------------------------------------------------------------------ -- * timeCaptureSpec {{{ @@ -208,9 +286,9 @@ type CaptureTimeApi = (Capture "date" (FTime "%Y-%m-%d" Day) :> Get '[PlainText] ("datetime" :> Capture "datetime" (FTime TimeFormatWSpace UTCTime) :> Get '[PlainText] String) captureTimeApi :: Proxy CaptureTimeApi captureTimeApi = Proxy -captureDateServer :: FTime "%Y-%m-%d" Day -> ExceptT ServantErr IO String +captureDateServer :: FTime "%Y-%m-%d" Day -> Handler String captureDateServer = return . show -captureDateTimeServer :: FTime TimeFormatWSpace UTCTime -> ExceptT ServantErr IO String +captureDateTimeServer :: FTime TimeFormatWSpace UTCTime -> Handler String captureDateTimeServer = return . show @@ -272,7 +350,7 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize queryParamSpec :: Spec queryParamSpec = do describe "Servant.API.QueryParam" $ do - it "allows to retrieve simple GET parameters" $ + it "allows retrieving simple GET parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do let params1 = "?name=bob" response1 <- Network.Wai.Test.request defaultRequest{ @@ -284,7 +362,7 @@ queryParamSpec = do name = "bob" } - it "allows to retrieve lists in GET parameters" $ + it "allows retrieving lists in GET parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do let params2 = "?names[]=bob&names[]=john" response2 <- Network.Wai.Test.request defaultRequest{ @@ -298,7 +376,7 @@ queryParamSpec = do } - it "allows to retrieve value-less GET parameters" $ + it "allows retrieving value-less GET parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do let params3 = "?capitalize" response3 <- Network.Wai.Test.request defaultRequest{ @@ -348,7 +426,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 @@ -361,7 +439,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 -- }}} @@ -369,29 +447,33 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do -- * headerSpec {{{ ------------------------------------------------------------------------------ -type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] () +type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] NoContent headerApi :: Proxy (HeaderApi a) headerApi = Proxy headerSpec :: Spec headerSpec = describe "Servant.API.Header" $ do - let expectsInt :: Maybe Int -> ExceptT ServantErr IO () - expectsInt (Just x) = when (x /= 5) $ error "Expected 5" + let expectsInt :: Maybe Int -> Handler NoContent + expectsInt (Just x) = do + when (x /= 5) $ error "Expected 5" + return NoContent expectsInt Nothing = error "Expected an int" - let expectsString :: Maybe String -> ExceptT ServantErr IO () - expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you" + let expectsString :: Maybe String -> Handler NoContent + expectsString (Just x) = do + when (x /= "more from you") $ error "Expected more from you" + return NoContent 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 @@ -439,7 +521,7 @@ type AlternativeApi = :<|> "foo" :> Get '[PlainText] T.Text :<|> "bar" :> Post '[JSON] Animal :<|> "bar" :> Put '[JSON] Animal - :<|> "bar" :> Delete '[JSON] () + :<|> "bar" :> Delete '[JSON] NoContent alternativeApi :: Proxy AlternativeApi alternativeApi = Proxy @@ -451,7 +533,7 @@ alternativeServer = :<|> return "a string" :<|> return jerry :<|> return jerry - :<|> return () + :<|> return NoContent alternativeSpec :: Spec alternativeSpec = do @@ -497,43 +579,21 @@ 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 --- }}} ------------------------------------------------------------------------------- --- * routerSpec {{{ ------------------------------------------------------------------------------- -routerSpec :: Spec -routerSpec = do - describe "Servant.Server.Internal.Router" $ do - let app' :: Application - app' = toApplication $ runRouter router' - - router', router :: Router - router' = tweakResponse (twk <$>) router - router = LeafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "") - - twk :: Response -> Response - twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b - twk b = b - - describe "tweakResponse" . with (return app') $ do - it "calls f on route result" $ do - get "" `shouldRespondWith` 202 - -- }}} ------------------------------------------------------------------------------ -- * miscCombinatorSpec {{{ @@ -569,6 +629,97 @@ miscCombinatorSpec = with (return $ serve miscApi miscServ) $ go "/host" "\"0.0.0.0:0\"" where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res + +-- }}} +------------------------------------------------------------------------------ +-- * Basic Authentication {{{ +------------------------------------------------------------------------------ + +type BasicAuthAPI = + BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal + :<|> Raw + +basicAuthApi :: Proxy BasicAuthAPI +basicAuthApi = Proxy + +basicAuthServer :: Server BasicAuthAPI +basicAuthServer = + const (return jerry) :<|> + (\ _ respond -> respond $ responseLBS imATeaPot418 [] "") + +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 + let basicAuthHeaders user password = + [("Authorization", "Basic " <> Base64.encode (user <> ":" <> password))] + it "returns 401 when no credentials given" $ do + get "/basic" `shouldRespondWith` 401 + + it "returns 403 when invalid credentials given" $ do + THW.request methodGet "/basic" (basicAuthHeaders "servant" "wrong") "" + `shouldRespondWith` 403 + + it "returns 200 with the right password" $ do + THW.request methodGet "/basic" (basicAuthHeaders "servant" "server") "" + `shouldRespondWith` 200 + + it "plays nice with subsequent Raw endpoints" $ do + get "/foo" `shouldRespondWith` 418 + +-- }}} +------------------------------------------------------------------------------ +-- * General Authentication {{{ +------------------------------------------------------------------------------ + +type GenAuthAPI = AuthProtect "auth" :> "auth" :> Get '[JSON] Animal + :<|> Raw + +genAuthApi :: Proxy GenAuthAPI +genAuthApi = Proxy + +genAuthServer :: Server GenAuthAPI +genAuthServer = const (return tweety) + :<|> (\ _ respond -> respond $ responseLBS imATeaPot418 [] "") + +type instance AuthServerData (AuthProtect "auth") = () + +genAuthContext :: Context '[AuthHandler Request ()] +genAuthContext = + let authHandler = \req -> case lookup "Auth" (requestHeaders req) of + Just "secret" -> return () + Just _ -> throwE err403 + Nothing -> throwE err401 + in mkAuthHandler authHandler :. EmptyContext + +genAuthSpec :: Spec +genAuthSpec = do + describe "Servant.API.Auth" $ do + with (return (serveWithContext genAuthApi genAuthContext genAuthServer)) $ do + + context "Custom Auth Protection" $ do + it "returns 401 when missing headers" $ do + get "/auth" `shouldRespondWith` 401 + + it "returns 403 on wrong passwords" $ do + THW.request methodGet "/auth" [("Auth","wrong")] "" `shouldRespondWith` 403 + + it "returns 200 with the right header" $ do + THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200 + + it "plays nice with subsequent Raw endpoints" $ do + get "/foo" `shouldRespondWith` 418 + -- }}} ------------------------------------------------------------------------------ -- * Test data types {{{ @@ -600,4 +751,7 @@ jerry = Animal "Mouse" 4 tweety :: Animal tweety = Animal "Bird" 2 + +beholder :: Animal +beholder = Animal "Beholder" 0 -- }}} 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 diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index 7890e0f1..f35679d1 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,6 +1,23 @@ -HEAD +next ---- +* Add `CaptureAll` combinator. Captures all of the remaining segments in a URL. + +0.8 +--- + +* Minor fixes, documentation changes and cabal tweaks + +0.7.1 +----- + +* Add module `Servant.Utils.Enter` (https://github.com/haskell-servant/servant/pull/478) +* Allow to set the same header multiple times in responses. + +0.5 +--- + +* Add `WithNamedConfig` combinator. * Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Fix safeLink, so Header is not in fact required. * Add more instances for (:<|>) @@ -9,6 +26,8 @@ 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 +* Add generalized authentication support 0.4.2 ----- 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 3af6680a..1f1cb007 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -1,24 +1,26 @@ name: servant -version: 0.5 +version: 0.8 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them . - You can learn about the basics in the . + You can learn about the basics in the . . -homepage: http://haskell-servant.github.io/ +homepage: http://haskell-servant.readthedocs.org/ 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 cabal-version: >=1.10 tested-with: GHC >= 7.8 +extra-source-files: + include/*.h + CHANGELOG.md source-repository head type: git location: http://github.com/haskell-servant/servant.git @@ -27,10 +29,13 @@ library exposed-modules: Servant.API Servant.API.Alternative + Servant.API.BasicAuth Servant.API.Capture Servant.API.ContentTypes + Servant.API.Experimental.Auth Servant.API.Header Servant.API.HttpVersion + Servant.API.Internal.Test.ComprehensiveAPI Servant.API.IsSecure Servant.API.QueryParam Servant.API.Raw @@ -41,21 +46,26 @@ library Servant.API.Times Servant.API.Vault Servant.API.Verbs + Servant.API.WithNamedContext Servant.Utils.Links + Servant.Utils.Enter build-depends: - base >=4.7 && <5 - , aeson >= 0.7 - , attoparsec >= 0.12 - , bytestring == 0.10.* - , bytestring-conversion == 0.3.* - , case-insensitive >= 1.2 - , http-api-data >= 0.1 && < 0.3 - , http-media >= 0.4 && < 0.7 - , http-types >= 0.8 && < 0.10 - , text >= 1 && < 2 - , string-conversions >= 0.3 && < 0.5 - , network-uri >= 2.6 - , vault >= 0.3 && <0.4 + base >= 4.7 && < 4.10 + , base-compat >= 0.9 && < 0.10 + , aeson >= 0.7 && < 1.1 + , attoparsec >= 0.12 && < 0.14 + , bytestring >= 0.10 && < 0.11 + , bytestring-conversion >= 0.3 && < 0.4 + , case-insensitive >= 1.2 && < 1.3 + , http-api-data >= 0.1 && < 0.3 + , http-media >= 0.4 && < 0.7 + , http-types >= 0.8 && < 0.10 + , mtl >= 2.0 && < 2.3 + , mmorph >= 1 && < 1.1 + , text >= 1 && < 1.3 + , string-conversions >= 0.3 && < 0.5 + , network-uri >= 2.6 && < 2.7 + , vault >= 0.3 && < 0.4 if impl(ghc < 7.10) build-depends: old-locale >= 1.0 && < 1.1 , time >= 1.4 && < 1.5 @@ -84,12 +94,13 @@ library , TypeSynonymInstances , UndecidableInstances ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wno-redundant-constraints include-dirs: include test-suite spec type: exitcode-stdio-1.0 - ghc-options: - -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + ghc-options: -Wall default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs @@ -99,6 +110,7 @@ test-suite spec Servant.Utils.LinksSpec build-depends: base == 4.* + , base-compat , aeson , attoparsec , bytestring @@ -121,5 +133,5 @@ test-suite doctests main-is: test/Doctests.hs buildable: True default-language: Haskell2010 - ghc-options: -threaded + ghc-options: -Wall -threaded include-dirs: include diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index f71ebe5c..92010db7 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -8,7 +8,7 @@ module Servant.API ( -- * Accessing information from the request module Servant.API.Capture, - -- | Capturing parts of the url path as parsed values: @'Capture'@ + -- | Capturing parts of the url path as parsed values: @'Capture'@ and @'CaptureAll'@ module Servant.API.Header, -- | Retrieving specific headers from the request module Servant.API.HttpVersion, @@ -23,14 +23,17 @@ 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.WithNamedContext, + -- | Access context entries in combinators in servant-server module Servant.API.Times, -- | Capturing dates and times in URLs and params with specified formats. - - -- * 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 @@ -47,18 +50,25 @@ 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 ) where import Servant.API.Alternative ((:<|>) (..)) -import Servant.API.Capture (Capture) +import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..)) +import Servant.API.Capture (Capture, CaptureAll) 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 (..)) @@ -93,6 +103,7 @@ import Servant.API.Verbs (PostCreated, Delete, DeleteAccepte PutNoContent, PutNonAuthoritative, ReflectMethod (reflectMethod), Verb, StdMethod(..)) +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/Alternative.hs b/servant/src/Servant/API/Alternative.hs index 752dcef0..8a8a693f 100644 --- a/servant/src/Servant/API/Alternative.hs +++ b/servant/src/Servant/API/Alternative.hs @@ -1,20 +1,16 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} -#if !MIN_VERSION_base(4,8,0) {-# LANGUAGE DeriveFoldable #-} -#endif {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE TypeOperators #-} {-# 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 () +import Prelude.Compat + -- | Union of two APIs, first takes precedence in case of overlap. -- -- Example: diff --git a/servant/src/Servant/API/BasicAuth.hs b/servant/src/Servant/API/BasicAuth.hs new file mode 100644 index 00000000..307c21aa --- /dev/null +++ b/servant/src/Servant/API/BasicAuth.hs @@ -0,0 +1,30 @@ +{-# 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) (userData :: *) + deriving (Typeable) + +-- | A simple datatype to hold data required to decorate a request +data BasicAuthData = BasicAuthData { basicAuthUsername :: !ByteString + , basicAuthPassword :: !ByteString + } diff --git a/servant/src/Servant/API/Capture.hs b/servant/src/Servant/API/Capture.hs index 9a2e1b61..7ee7972a 100644 --- a/servant/src/Servant/API/Capture.hs +++ b/servant/src/Servant/API/Capture.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Capture (Capture) where +module Servant.API.Capture (Capture, CaptureAll) where import Data.Typeable (Typeable) import GHC.TypeLits (Symbol) @@ -15,9 +15,22 @@ import GHC.TypeLits (Symbol) data Capture (sym :: Symbol) a deriving (Typeable) + +-- | Capture all remaining values from the request path under a certain type +-- @a@. +-- +-- Example: +-- +-- >>> -- GET /src/* +-- >>> type MyAPI = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile +data CaptureAll (sym :: Symbol) a + deriving (Typeable) + -- $setup -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text -- >>> data Book -- >>> instance ToJSON Book where { toJSON = undefined } +-- >>> data SourceFile +-- >>> instance ToJSON SourceFile where { toJSON = undefined } diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index 61bf1ce9..f10e2ba1 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 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,8 @@ import GHC.Generics (Generic) import qualified Network.HTTP.Media as M import Network.URI (escapeURIString, isUnreserved, unEscapeString) +import Prelude () +import Prelude.Compat -- * Provided content types data JSON deriving Typeable @@ -155,7 +154,7 @@ newtype AcceptHeader = AcceptHeader BS.ByteString -- > instance Accept MyContentType where -- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8") -- > --- > instance Show a => MimeRender MyContentType where +-- > instance Show a => MimeRender MyContentType a where -- > mimeRender _ val = pack ("This is MINE! " ++ show val) -- > -- > type MyAPI = "path" :> Get '[MyContentType] Int @@ -170,7 +169,7 @@ class (AllMime list) => AllCTRender (list :: [*]) a where handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) instance OVERLAPPABLE_ - (AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where + (Accept ct, AllMime cts, AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept where pctyps = Proxy :: Proxy (ct ': cts) amrs = allMimeRender pctyps val @@ -320,7 +319,7 @@ instance MimeRender OctetStream BS.ByteString where -- | A type for responses without content-body. data NoContent = NoContent - deriving (Show, Eq, Read) + deriving (Show, Eq, Read, Generic) -------------------------------------------------------------------------- diff --git a/servant/src/Servant/API/Experimental/Auth.hs b/servant/src/Servant/API/Experimental/Auth.hs new file mode 100644 index 00000000..fa79bfc7 --- /dev/null +++ b/servant/src/Servant/API/Experimental/Auth.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +module Servant.API.Experimental.Auth where + +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) diff --git a/servant/src/Servant/API/Header.hs b/servant/src/Servant/API/Header.hs index ac7471c1..2f46f160 100644 --- a/servant/src/Servant/API/Header.hs +++ b/servant/src/Servant/API/Header.hs @@ -3,7 +3,9 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Header where +module Servant.API.Header ( + Header(..), +) where import Data.ByteString (ByteString) import Data.Typeable (Typeable) @@ -25,5 +27,3 @@ data Header (sym :: Symbol) a = Header a -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } 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..e7c15633 --- /dev/null +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -0,0 +1,43 @@ +{-# 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 + +import Servant.API + +type GET = Get '[JSON] NoContent + +type ComprehensiveAPI = + ComprehensiveAPIWithoutRaw :<|> + Raw + +comprehensiveAPI :: Proxy ComprehensiveAPI +comprehensiveAPI = Proxy + +type ComprehensiveAPIWithoutRaw = + 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 :<|> + RemoteHost :> GET :<|> + ReqBody '[JSON] Int :> GET :<|> + Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|> + "foo" :> GET :<|> + Vault :> GET :<|> + Verb 'POST 204 '[JSON] NoContent :<|> + Verb 'POST 204 '[JSON] Int :<|> + WithNamedContext "foo" '[] GET :<|> + CaptureAll "foo" Int :> GET + +comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw +comprehensiveAPIWithoutRaw = Proxy 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 diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index dc73a8e0..cdb7341e 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,8 @@ 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. -- Instead, use 'addHeader'. @@ -69,8 +68,7 @@ class BuildHeadersTo hs where instance OVERLAPPING_ BuildHeadersTo '[] where buildHeadersTo _ = HNil -instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h - , Contains h xs ~ 'False) +instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h ) => BuildHeadersTo ((Header h v) ': xs) where buildHeadersTo headers = let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) @@ -90,7 +88,7 @@ class GetHeaders ls where instance OVERLAPPING_ GetHeaders (HList '[]) where getHeaders _ = [] -instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs)) +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 @@ -101,7 +99,7 @@ instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs)) instance OVERLAPPING_ GetHeaders (Headers '[] a) where getHeaders _ = [] -instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v) +instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v ) => GetHeaders (Headers (Header h v ': rest) a) where getHeaders hs = getHeaders $ getHeadersHList hs @@ -113,20 +111,15 @@ class AddHeader h v orig new addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times -instance OVERLAPPING_ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False) +instance OVERLAPPING_ ( KnownSymbol h, ToByteString v ) => 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 OVERLAPPABLE_ ( KnownSymbol h, ToByteString v - , new ~ (Headers '[Header h v] a)) + , 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 - Contains x ((Header x a) ': xs) = 'True - Contains x ((Header y a) ': xs) = Contains x xs - Contains x '[] = 'False - -- $setup -- >>> import Servant.API -- >>> import Data.Aeson diff --git a/servant/src/Servant/API/Vault.hs b/servant/src/Servant/API/Vault.hs index 7a767b39..7b0a0971 100644 --- a/servant/src/Servant/API/Vault.hs +++ b/servant/src/Servant/API/Vault.hs @@ -9,8 +9,8 @@ import Data.Vault.Lazy (Vault) -- -- | Use 'Vault' in your API types to provide access to the 'Vault' -- of the request, which is a location shared by middlewares and applications --- to store arbitrary data. See 'Vault' for more details on how to actually --- use the vault in your handlers +-- to store arbitrary data. See +-- for more details on how to actually use the vault in your handlers -- -- Example: -- diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs index 4915fdaf..1b898ea6 100644 --- a/servant/src/Servant/API/Verbs.hs +++ b/servant/src/Servant/API/Verbs.hs @@ -14,7 +14,9 @@ import GHC.Generics (Generic) import GHC.TypeLits (Nat) import Network.HTTP.Types.Method (Method, StdMethod (..), methodDelete, methodGet, methodHead, - methodPatch, methodPost, methodPut) + methodPatch, methodPost, methodPut, + methodTrace, methodConnect, + methodOptions) -- | @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 @@ -34,15 +36,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 +60,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 +71,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 +88,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 +107,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 +126,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 +146,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 @@ -167,3 +169,12 @@ instance ReflectMethod 'PATCH where instance ReflectMethod 'HEAD where reflectMethod _ = methodHead + +instance ReflectMethod 'OPTIONS where + reflectMethod _ = methodOptions + +instance ReflectMethod 'TRACE where + reflectMethod _ = methodTrace + +instance ReflectMethod 'CONNECT where + reflectMethod _ = methodConnect 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 diff --git a/servant-server/src/Servant/Server/Internal/Enter.hs b/servant/src/Servant/Utils/Enter.hs similarity index 94% rename from servant-server/src/Servant/Server/Internal/Enter.hs rename to servant/src/Servant/Utils/Enter.hs index 5bcebe9d..12f7a530 100644 --- a/servant-server/src/Servant/Server/Internal/Enter.hs +++ b/servant/src/Servant/Utils/Enter.hs @@ -8,15 +8,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Servant.Server.Internal.Enter where +module Servant.Utils.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 -#endif import Control.Monad.Identity import Control.Monad.Morph import Control.Monad.Reader @@ -25,6 +19,9 @@ 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 class Enter typ arg ret | typ arg -> ret, typ ret -> arg where diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index d83ffc7e..d6b218be 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 #-} @@ -22,7 +21,7 @@ -- >>> -- >>> -- >>> type Hello = "hello" :> Get '[JSON] Int --- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] () +-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent -- >>> type API = Hello :<|> Bye -- >>> let api = Proxy :: Proxy API -- @@ -48,11 +47,11 @@ -- If the API has an endpoint with parameters then we can generate links with -- or without those: -- --- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] ()) +-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent) -- >>> print $ safeLink api with (Just "Hubert") -- bye?name=Hubert -- --- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] ()) +-- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent) -- >>> print $ safeLink api without -- bye -- @@ -70,17 +69,11 @@ -- Attempting to construct a link to an endpoint that does not exist in api -- will result in a type error like this: -- --- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ()) +-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent) -- >>> safeLink api bad_link -- ... --- Could not deduce (Or --- (IsElem' (Verb 'DELETE 200 '[JSON] ()) (Verb 'GET 200 '[JSON] Int)) --- (IsElem' --- ("hello" :> Delete '[JSON] ()) --- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ())))) --- arising from a use of ‘safeLink’ --- In the expression: safeLink api bad_link --- In an equation for ‘it’: it = safeLink api bad_link +-- ...Could not deduce... +-- ... -- -- This error is essentially saying that the type family couldn't find -- bad_link under api after trying the open (but empty) type family @@ -101,24 +94,24 @@ 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 -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid ( Monoid(..), (<>) ) -#else -import Data.Monoid ( (<>) ) -#endif -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 ) +import Servant.API.BasicAuth ( BasicAuth ) +import Servant.API.Capture ( Capture, CaptureAll ) import Servant.API.ReqBody ( ReqBody ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) import Servant.API.Header ( Header ) +import Servant.API.RemoteHost ( RemoteHost ) import Servant.API.Verbs ( Verb ) import Servant.API.Sub ( type (:>) ) import Servant.API.Raw ( Raw ) @@ -170,6 +163,8 @@ type family IsElem endpoint api :: Constraint where IsElem sa (ReqBody y x :> sb) = IsElem sa sb IsElem (Capture z y :> sa) (Capture x y :> sb) = IsElem sa sb + IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb) + = IsElem sa sb 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 @@ -291,10 +286,25 @@ instance (ToHttpApiData v, HasLink sub) toLink (Proxy :: Proxy sub) $ addSegment (escape . Text.unpack $ toUrlPiece v) l +instance (ToHttpApiData v, HasLink sub) + => HasLink (CaptureAll sym v :> sub) where + type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub + toLink _ l vs = + toLink (Proxy :: Proxy sub) $ + foldl' (flip $ addSegment . escape . Text.unpack . toUrlPiece) l vs + instance HasLink sub => HasLink (Header sym a :> sub) where type MkLink (Header sym a :> sub) = MkLink sub toLink _ = toLink (Proxy :: Proxy sub) +instance HasLink sub => HasLink (RemoteHost :> sub) where + type MkLink (RemoteHost :> sub) = MkLink sub + toLink _ = toLink (Proxy :: Proxy sub) + +instance HasLink sub => HasLink (BasicAuth realm a :> sub) where + type MkLink (BasicAuth realm a :> sub) = MkLink sub + toLink _ = toLink (Proxy :: Proxy sub) + -- Verb (terminal) instances instance HasLink (Verb m s ct a) where type MkLink (Verb m s ct a) = URI diff --git a/servant/test/Servant/API/ContentTypesSpec.hs b/servant/test/Servant/API/ContentTypesSpec.hs index 062b6b2b..1a155b5c 100644 --- a/servant/test/Servant/API/ContentTypesSpec.hs +++ b/servant/test/Servant/API/ContentTypesSpec.hs @@ -3,14 +3,14 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.API.ContentTypesSpec where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -import Data.Monoid -#endif +import Prelude () +import Prelude.Compat + import Control.Arrow import Data.Aeson import Data.ByteString.Char8 (ByteString, append, pack) @@ -28,7 +28,7 @@ import GHC.Generics import Network.URL (exportParams, importParams) import Test.Hspec import Test.QuickCheck -import Test.QuickCheck.Instances () +import "quickcheck-instances" Test.QuickCheck.Instances () import Servant.API.ContentTypes diff --git a/servant/test/Servant/Utils/LinksSpec.hs b/servant/test/Servant/Utils/LinksSpec.hs index 07e0b068..2040fc55 100644 --- a/servant/test/Servant/Utils/LinksSpec.hs +++ b/servant/test/Servant/Utils/LinksSpec.hs @@ -12,16 +12,17 @@ import Servant.API type TestApi = -- Capture and query params - "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] () + "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent + :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent -- Flags - :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] () + :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent -- All of the verbs - :<|> "get" :> Get '[JSON] () - :<|> "put" :> Put '[JSON] () - :<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] () - :<|> "delete" :> Header "ponies" String :> Delete '[JSON] () + :<|> "get" :> Get '[JSON] NoContent + :<|> "put" :> Put '[JSON] NoContent + :<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] NoContent + :<|> "delete" :> Header "ponies" String :> Delete '[JSON] NoContent :<|> "raw" :> Raw @@ -38,26 +39,30 @@ shouldBeURI link expected = spec :: Spec spec = describe "Servant.Utils.Links" $ do it "generates correct links for capture query params" $ do - let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] ()) + let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent) apiLink l1 "hi" `shouldBeURI` "hello/hi" let l2 = Proxy :: Proxy ("hello" :> Capture "name" String :> QueryParam "capital" Bool - :> Delete '[JSON] ()) + :> Delete '[JSON] NoContent) apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true" + it "generates correct links for CaptureAll" $ do + apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent)) + ["roads", "lead", "to", "rome"] + `shouldBeURI` "all/roads/lead/to/rome" it "generates correct links for query flags" $ do let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy" - :> QueryFlag "fast" :> Delete '[JSON] ()) + :> QueryFlag "fast" :> Delete '[JSON] NoContent) apiLink l1 True True `shouldBeURI` "balls?bouncy&fast" apiLink l1 False True `shouldBeURI` "balls?fast" it "generates correct links for all of the verbs" $ do - apiLink (Proxy :: Proxy ("get" :> Get '[JSON] ())) `shouldBeURI` "get" - apiLink (Proxy :: Proxy ("put" :> Put '[JSON] ())) `shouldBeURI` "put" - apiLink (Proxy :: Proxy ("post" :> Post '[JSON] ())) `shouldBeURI` "post" - apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] ())) `shouldBeURI` "delete" + apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeURI` "get" + apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeURI` "put" + apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeURI` "post" + apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeURI` "delete" apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw" @@ -67,35 +72,35 @@ spec = describe "Servant.Utils.Links" $ do -- -- >>> apiLink (Proxy :: Proxy WrongPath) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongReturnType) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongContentType) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongMethod) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- >>> apiLink (Proxy :: Proxy NotALink) -- ... --- Could not deduce ... +-- ...Could not deduce... -- ... -- -- sanity check -- >>> apiLink (Proxy :: Proxy AllGood) -- get -type WrongPath = "getTypo" :> Get '[JSON] () +type WrongPath = "getTypo" :> Get '[JSON] NoContent type WrongReturnType = "get" :> Get '[JSON] Bool -type WrongContentType = "get" :> Get '[OctetStream] () -type WrongMethod = "get" :> Post '[JSON] () +type WrongContentType = "get" :> Get '[OctetStream] NoContent +type WrongMethod = "get" :> Post '[JSON] NoContent type NotALink = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool -type AllGood = "get" :> Get '[JSON] () +type AllGood = "get" :> Get '[JSON] NoContent diff --git a/sources.txt b/sources.txt index 24719355..06ff7ed8 100644 --- a/sources.txt +++ b/sources.txt @@ -1,11 +1,7 @@ servant -servant-cassava +servant-server servant-client servant-docs servant-foreign servant-js -servant-server -servant-examples -servant-blaze -servant-lucid servant-mock diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index 9632e808..0fe58482 100644 --- a/stack-ghc-7.8.4.yaml +++ b/stack-ghc-7.8.4.yaml @@ -1,25 +1,28 @@ flags: {} packages: -- servant-examples/ -- servant-docs/ -- servant-blaze/ +- servant/ - servant-client/ -- servant-lucid/ -- servant-mock/ +- servant-docs/ - servant-foreign/ - servant-js/ -- servant/ +- servant-mock/ - servant-server/ extra-deps: -- hspec-2.2.0 -- hspec-core-2.2.0 -- hspec-discover-2.2.0 -- hspec-expectations-0.7.2 -- doctest-0.10.1 -- engine-io-1.2.10 -- engine-io-wai-1.0.3 -- socket-io-1.3.3 -- stm-delay-0.1.1.1 +- base-compat-0.9.1 - control-monad-omega-0.3.1 -- http-api-data-0.1.1.1 +- cryptonite-0.6 +- doctest-0.11.0 +- hspec-2.2.3 +- hspec-core-2.2.3 +- hspec-discover-2.2.3 +- hspec-expectations-0.7.2 +- http-api-data-0.2.2 +- primitive-0.6.1.0 +- servant-0.7.1 +- servant-client-0.7.1 +- servant-docs-0.7.1 +- servant-server-0.7.1 +- should-not-typecheck-2.1.0 +- time-locale-compat-0.1.1.1 +- wai-app-static-3.1.5 resolver: lts-2.22 diff --git a/stack-ghc-8.0.1.yaml b/stack-ghc-8.0.1.yaml new file mode 100644 index 00000000..8861e1a9 --- /dev/null +++ b/stack-ghc-8.0.1.yaml @@ -0,0 +1,11 @@ +resolver: nightly-2016-05-27 +packages: +- servant/ +- servant-client/ +- servant-docs/ +- servant-foreign/ +- servant-js/ +- servant-mock/ +- servant-server/ +extra-deps: [] +flags: {} diff --git a/stack.yaml b/stack.yaml index f370da09..95599455 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,19 +1,12 @@ -flags: - servant-js: - example: false +flags: {} packages: - servant/ -- servant-blaze/ -- servant-cassava/ - servant-client/ - servant-docs/ -- servant-examples/ - servant-foreign/ - servant-js/ -- servant-lucid/ - servant-mock/ - servant-server/ +- doc/tutorial extra-deps: -- engine-io-wai-1.0.2 -- control-monad-omega-0.3.1 -resolver: nightly-2015-10-08 +resolver: lts-6.0 From 523fe563c926f690d240285515c33b7d246ad38a Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Fri, 2 Sep 2016 15:20:27 +1000 Subject: [PATCH 10/18] Remove toProxy from API.Times in API --- servant/src/Servant/API.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 92010db7..1244cb4e 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -83,7 +83,7 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader), HList (..), Headers (..), getHeadersHList, getResponse) import Servant.API.Sub ((:>)) -import Servant.API.Times (FTime(..), toProxy, getFormat, renderTime, parseTime) +import Servant.API.Times (FTime(..), getFormat, renderTime, parseTime) import Servant.API.Vault (Vault) import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted, DeleteNoContent, From 539b8c93fa9401adc85084f6f8d39efc872f894c Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Fri, 2 Sep 2016 15:44:16 +1000 Subject: [PATCH 11/18] Add three ISO8601 compatible formats --- servant/src/Servant/API/Times.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/servant/src/Servant/API/Times.hs b/servant/src/Servant/API/Times.hs index 96523bfc..2f8e508d 100644 --- a/servant/src/Servant/API/Times.hs +++ b/servant/src/Servant/API/Times.hs @@ -13,6 +13,9 @@ module Servant.API.Times , getFormat , renderTime , parseTime + , ISO8601Date + , ISO8601DateTime + , ISO8601DateTimeZ ) where import Data.Typeable (Typeable) @@ -27,6 +30,11 @@ import Data.Proxy import Control.Monad ((>=>)) import Control.Arrow (first) + +type ISO8601Date = "%Y-%m-%d" +type ISO8601DateTime = "%Y-%m-%dT%H:%M:%S" +type ISO8601DateTimeZ = "%Y-%m-%dT%H:%M:%S%z" + -- | A wrapper around a time type which can be parsed/rendered to with `format', -- as specified in 'Data.Time.Format'. -- From bbd6779cc50096c49c188bdc0c319b8d08601d65 Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Fri, 2 Sep 2016 15:44:49 +1000 Subject: [PATCH 12/18] Fix doc formatting and add note about + in URLs --- servant/src/Servant/API/Times.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/servant/src/Servant/API/Times.hs b/servant/src/Servant/API/Times.hs index 2f8e508d..76572928 100644 --- a/servant/src/Servant/API/Times.hs +++ b/servant/src/Servant/API/Times.hs @@ -39,8 +39,12 @@ type ISO8601DateTimeZ = "%Y-%m-%dT%H:%M:%S%z" -- as specified in 'Data.Time.Format'. -- -- Example: +-- -- >>> -- GET /events/:date -- >>> type MyApi = "events" :> Capture "date" (FTime "%Y-%m-%d" Day) :> Get '[JSON] [Event] +-- +-- __Note:__ Time Zones parsed in the @%z@ format (@±HHMM@) need to ensure that the @+@ symbol is +-- url encoded (@%2B@) in requests, as the @+@ symbol is interpreted as a space in query params. newtype FTime (format :: Symbol) t = FTime {getFTime :: t} deriving (Typeable, Eq, Ord) From 1996ec05f7fa9fc3cf1a960aa54a5c489660e609 Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Fri, 2 Sep 2016 15:45:31 +1000 Subject: [PATCH 13/18] Remove use of undefined in Read instance --- servant/src/Servant/API/Times.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/servant/src/Servant/API/Times.hs b/servant/src/Servant/API/Times.hs index 76572928..f2b8166c 100644 --- a/servant/src/Servant/API/Times.hs +++ b/servant/src/Servant/API/Times.hs @@ -54,6 +54,7 @@ instance (KnownSymbol format, T.FormatTime t) => Show (FTime format t) where instance (KnownSymbol format, T.ParseTime t) => Read (FTime format t) where readsPrec i str = res where + fmt = symbolVal (Proxy :: Proxy format) res = fmap (first FTime) (readParen (i > 1) #if !MIN_VERSION_time(1,5,0) @@ -64,12 +65,6 @@ instance (KnownSymbol format, T.ParseTime t) => Read (FTime format t) where str ) - toFTimeTy :: [(FTime format t, String)] -> FTime format t - toFTimeTy _ = undefined - - fmt = getFormat (toFTimeTy res) - - instance (KnownSymbol format, T.FormatTime t) => ToHttpApiData (FTime format t) where toUrlPiece = toUrlPiece . renderTime From f3f61dbbac715ad84b979c76b04c0de708583af6 Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Fri, 2 Sep 2016 15:46:23 +1000 Subject: [PATCH 14/18] Rename toProxy to toFormatProxy --- servant/src/Servant/API/Times.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/servant/src/Servant/API/Times.hs b/servant/src/Servant/API/Times.hs index f2b8166c..a5c120b0 100644 --- a/servant/src/Servant/API/Times.hs +++ b/servant/src/Servant/API/Times.hs @@ -9,7 +9,7 @@ module Servant.API.Times ( FTime(..) - , toProxy + , toFormatProxy , getFormat , renderTime , parseTime @@ -78,11 +78,11 @@ instance (KnownSymbol format, T.ParseTime t) => FromHttpApiData (FTime format t) parseQueryParam = parseQueryParam >=> parseTime -toProxy :: FTime format t -> Proxy format -toProxy _ = Proxy +toFormatProxy :: FTime format t -> Proxy format +toFormatProxy _ = Proxy getFormat :: KnownSymbol format => FTime format t -> String -getFormat t = symbolVal (toProxy t) +getFormat t = symbolVal (toFormatProxy t) renderTime :: (KnownSymbol format, T.FormatTime t) => FTime format t -> String renderTime tt@(FTime t) = T.formatTime T.defaultTimeLocale (getFormat tt) t From 840eae8cfee5af0c2dd2782c46aed69610df4977 Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Fri, 2 Sep 2016 15:57:51 +1000 Subject: [PATCH 15/18] various code clean ups, fixing some issues from @jkarni --- servant-server/test/Servant/ServerSpec.hs | 2 +- servant/src/Servant/API/Times.hs | 28 +++++++++++------------ 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 746f72c8..8bd049e8 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -318,7 +318,7 @@ captureTimeSpec = do with (return (serve (Proxy :: Proxy (Capture "datetime" (FTime TimeFormatWSpace UTCTime) :> Raw)) - (\ (FTime day )request_ respond -> + (\ (FTime _day) request_ respond -> respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do get "/2015-12-02%2012:34:56+1000/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) diff --git a/servant/src/Servant/API/Times.hs b/servant/src/Servant/API/Times.hs index a5c120b0..7a79147b 100644 --- a/servant/src/Servant/API/Times.hs +++ b/servant/src/Servant/API/Times.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} module Servant.API.Times @@ -18,17 +18,17 @@ module Servant.API.Times , ISO8601DateTimeZ ) where -import Data.Typeable (Typeable) -import GHC.TypeLits -- (Symbol) +import Data.Typeable (Typeable) +import GHC.TypeLits (Symbol,KnownSymbol,symbolVal) import Web.HttpApiData import qualified Data.Time.Format as T #if !MIN_VERSION_time(1,5,0) -import System.Locale as T +import qualified System.Locale as T #endif -import Data.Text (pack, Text) +import Data.Text (pack, Text) import Data.Proxy -import Control.Monad ((>=>)) -import Control.Arrow (first) +import Control.Monad ((>=>)) +import Control.Arrow (first) type ISO8601Date = "%Y-%m-%d" @@ -49,7 +49,7 @@ newtype FTime (format :: Symbol) t = FTime {getFTime :: t} deriving (Typeable, Eq, Ord) instance (KnownSymbol format, T.FormatTime t) => Show (FTime format t) where - showsPrec i t = showParen (i > 1) (\str -> renderTime t ++ str) + showsPrec i t = showParen (i > 1) (renderTime t ++) instance (KnownSymbol format, T.ParseTime t) => Read (FTime format t) where readsPrec i str = res From 518a2715bebf766acf63bee61ede22f944b66fd8 Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Fri, 2 Sep 2016 16:14:25 +1000 Subject: [PATCH 16/18] Remove use of CPP inside functions --- servant/src/Servant/API/Times.hs | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/servant/src/Servant/API/Times.hs b/servant/src/Servant/API/Times.hs index 7a79147b..c8bdf01c 100644 --- a/servant/src/Servant/API/Times.hs +++ b/servant/src/Servant/API/Times.hs @@ -52,18 +52,12 @@ instance (KnownSymbol format, T.FormatTime t) => Show (FTime format t) where showsPrec i t = showParen (i > 1) (renderTime t ++) instance (KnownSymbol format, T.ParseTime t) => Read (FTime format t) where - readsPrec i str = res - where - fmt = symbolVal (Proxy :: Proxy format) - res = fmap (first FTime) - (readParen (i > 1) -#if !MIN_VERSION_time(1,5,0) - (T.readsTime T.defaultTimeLocale fmt) -#else - (T.readSTime False T.defaultTimeLocale fmt) -#endif - str - ) + readsPrec i str = res where + fmt = symbolVal (Proxy :: Proxy format) + res = fmap (first FTime) + (readParen (i > 1) + (rtime T.defaultTimeLocale fmt) + str) instance (KnownSymbol format, T.FormatTime t) => ToHttpApiData (FTime format t) where @@ -103,6 +97,17 @@ parseTime str = res toFTimeTy :: Either Text (FTime format t) -> FTime format a toFTimeTy _ = undefined + +ptime :: T.ParseTime t => T.TimeLocale -> String -> String -> Maybe t +rtime :: T.ParseTime t => T.TimeLocale -> String -> ReadS t +#if !MIN_VERSION_time(1,5,0) +ptime = T.parseTime +rtime = T.readsTime +#else +ptime = T.parseTimeM False +rtime = T.readSTime False +#endif + -- $setup -- >>> import Servant.API -- >>> import Data.Aeson From 7293717a0d25681db295f4f97fbaf14a011bc6a5 Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Fri, 2 Sep 2016 16:16:41 +1000 Subject: [PATCH 17/18] Rename {render,parse}Time FTime --- servant/src/Servant/API.hs | 2 +- servant/src/Servant/API/Times.hs | 38 ++++++++++++++------------------ 2 files changed, 18 insertions(+), 22 deletions(-) diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 1244cb4e..bf0e102f 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -83,7 +83,7 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader), HList (..), Headers (..), getHeadersHList, getResponse) import Servant.API.Sub ((:>)) -import Servant.API.Times (FTime(..), getFormat, renderTime, parseTime) +import Servant.API.Times (FTime(..), getFormat, renderFTime, parseFTime) import Servant.API.Vault (Vault) import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted, DeleteNoContent, diff --git a/servant/src/Servant/API/Times.hs b/servant/src/Servant/API/Times.hs index c8bdf01c..58e237c8 100644 --- a/servant/src/Servant/API/Times.hs +++ b/servant/src/Servant/API/Times.hs @@ -11,8 +11,8 @@ module Servant.API.Times ( FTime(..) , toFormatProxy , getFormat - , renderTime - , parseTime + , renderFTime + , parseFTime , ISO8601Date , ISO8601DateTime , ISO8601DateTimeZ @@ -49,7 +49,7 @@ newtype FTime (format :: Symbol) t = FTime {getFTime :: t} deriving (Typeable, Eq, Ord) instance (KnownSymbol format, T.FormatTime t) => Show (FTime format t) where - showsPrec i t = showParen (i > 1) (renderTime t ++) + showsPrec i t = showParen (i > 1) (renderFTime t ++) instance (KnownSymbol format, T.ParseTime t) => Read (FTime format t) where readsPrec i str = res where @@ -61,15 +61,15 @@ instance (KnownSymbol format, T.ParseTime t) => Read (FTime format t) where instance (KnownSymbol format, T.FormatTime t) => ToHttpApiData (FTime format t) where - toUrlPiece = toUrlPiece . renderTime - toHeader = toHeader . renderTime - toQueryParam = toQueryParam . renderTime + toUrlPiece = toUrlPiece . renderFTime + toHeader = toHeader . renderFTime + toQueryParam = toQueryParam . renderFTime instance (KnownSymbol format, T.ParseTime t) => FromHttpApiData (FTime format t) where - parseUrlPiece = parseUrlPiece >=> parseTime - parseHeader = parseHeader >=> parseTime - parseQueryParam = parseQueryParam >=> parseTime + parseUrlPiece = parseUrlPiece >=> parseFTime + parseHeader = parseHeader >=> parseFTime + parseQueryParam = parseQueryParam >=> parseFTime toFormatProxy :: FTime format t -> Proxy format @@ -78,19 +78,15 @@ toFormatProxy _ = Proxy getFormat :: KnownSymbol format => FTime format t -> String getFormat t = symbolVal (toFormatProxy t) -renderTime :: (KnownSymbol format, T.FormatTime t) => FTime format t -> String -renderTime tt@(FTime t) = T.formatTime T.defaultTimeLocale (getFormat tt) t +renderFTime :: (KnownSymbol format, T.FormatTime t) => FTime format t -> String +renderFTime tt@(FTime t) = T.formatTime T.defaultTimeLocale (getFormat tt) t -parseTime :: (KnownSymbol format, T.ParseTime t) => String -> Either Text (FTime format t) -parseTime str = res - where -#if !MIN_VERSION_time(1,5,0) - res = case T.parseTime T.defaultTimeLocale fmt str of -#else - res = case T.parseTimeM False T.defaultTimeLocale fmt str of -#endif - Nothing -> Left . pack $ "Could not parse time string \"" ++ str ++ "\" with format \"" ++ fmt ++ "\"" - Just t -> Right (FTime t) +parseFTime :: (KnownSymbol format, T.ParseTime t) => String -> Either Text (FTime format t) +parseFTime str = res where + res = case ptime T.defaultTimeLocale fmt str of + Nothing -> Left . pack $ "Could not parse time string \"" + ++ str ++ "\" with format \"" ++ fmt ++ "\"" + Just t -> Right (FTime t) fmt = getFormat (toFTimeTy res) From 32fa3490cfccde74e0dfb47bd9adaca5a9c43ab1 Mon Sep 17 00:00:00 2001 From: Alex Mason Date: Fri, 2 Sep 2016 16:17:17 +1000 Subject: [PATCH 18/18] Write better docs (and remove last use if undefined) --- servant/src/Servant/API/Times.hs | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/servant/src/Servant/API/Times.hs b/servant/src/Servant/API/Times.hs index 58e237c8..431414a9 100644 --- a/servant/src/Servant/API/Times.hs +++ b/servant/src/Servant/API/Times.hs @@ -35,8 +35,8 @@ type ISO8601Date = "%Y-%m-%d" type ISO8601DateTime = "%Y-%m-%dT%H:%M:%S" type ISO8601DateTimeZ = "%Y-%m-%dT%H:%M:%S%z" --- | A wrapper around a time type which can be parsed/rendered to with `format', --- as specified in 'Data.Time.Format'. +-- | An `FTime` is a wrapper around a time type which can be +-- parsed/rendered with `format', as specified in "Data.Time.Format". -- -- Example: -- @@ -46,7 +46,7 @@ type ISO8601DateTimeZ = "%Y-%m-%dT%H:%M:%S%z" -- __Note:__ Time Zones parsed in the @%z@ format (@±HHMM@) need to ensure that the @+@ symbol is -- url encoded (@%2B@) in requests, as the @+@ symbol is interpreted as a space in query params. newtype FTime (format :: Symbol) t = FTime {getFTime :: t} - deriving (Typeable, Eq, Ord) + deriving (Typeable, Eq, Ord) instance (KnownSymbol format, T.FormatTime t) => Show (FTime format t) where showsPrec i t = showParen (i > 1) (renderFTime t ++) @@ -75,9 +75,17 @@ instance (KnownSymbol format, T.ParseTime t) => FromHttpApiData (FTime format t) toFormatProxy :: FTime format t -> Proxy format toFormatProxy _ = Proxy +-- | Returns the sttring representation of the type level @format@ string +-- +-- >>> getFormat (undefined :: FTime ISO8601Date UTCTime) +-- "%Y-%m-%d" getFormat :: KnownSymbol format => FTime format t -> String getFormat t = symbolVal (toFormatProxy t) +-- | Renders an @FTime format t@ using the format `format'. +-- +-- >>> renderFTime (FTime (fromGregorian 2016 9 2) :: FTime ISO8601Date Day) +-- "2016-09-02" renderFTime :: (KnownSymbol format, T.FormatTime t) => FTime format t -> String renderFTime tt@(FTime t) = T.formatTime T.defaultTimeLocale (getFormat tt) t @@ -88,10 +96,10 @@ parseFTime str = res where ++ str ++ "\" with format \"" ++ fmt ++ "\"" Just t -> Right (FTime t) - fmt = getFormat (toFTimeTy res) + fmt = symbolVal (toFTimeTy res) - toFTimeTy :: Either Text (FTime format t) -> FTime format a - toFTimeTy _ = undefined + toFTimeTy :: Either Text (FTime format t) -> Proxy format + toFTimeTy _ = Proxy ptime :: T.ParseTime t => T.TimeLocale -> String -> String -> Maybe t @@ -109,5 +117,6 @@ rtime = T.readSTime False -- >>> import Data.Aeson -- >>> import Data.Text -- >>> import Data.Time.Calendar +-- >>> import Data.Time.Clock (UTCTime) -- >>> data Event -- >>> instance ToJSON Event where { toJSON = undefined }