From 88f8d3b0d13061d218442633bb92707d1ee839b5 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 4 Jul 2018 22:59:43 +0300 Subject: [PATCH] Merge servant-generic --- cabal.project | 1 + doc/cookbook/generic/Generic.lhs | 106 +++++++++++++ doc/cookbook/generic/generic.cabal | 25 +++ doc/tutorial/tutorial.cabal | 4 +- servant-client-core/CHANGELOG.md | 8 + servant-client-core/servant-client-core.cabal | 5 +- .../src/Servant/Client/Generic.hs | 51 ++++++ servant-server/CHANGELOG.md | 10 ++ servant-server/servant-server.cabal | 5 +- servant-server/src/Servant/Server/Generic.hs | 52 +++++++ servant/CHANGELOG.md | 13 ++ servant/servant.cabal | 3 +- servant/src/Servant/API/Generic.hs | 146 ++++++++++++++++++ servant/src/Servant/Links.hs | 86 +++++++++++ 14 files changed, 508 insertions(+), 7 deletions(-) create mode 100644 doc/cookbook/generic/Generic.lhs create mode 100644 doc/cookbook/generic/generic.cabal create mode 100644 servant-client-core/src/Servant/Client/Generic.hs create mode 100644 servant-server/src/Servant/Server/Generic.hs create mode 100644 servant/src/Servant/API/Generic.hs diff --git a/cabal.project b/cabal.project index e9f1c0ca..50be543b 100644 --- a/cabal.project +++ b/cabal.project @@ -12,6 +12,7 @@ packages: servant/ doc/cookbook/db-postgres-pool doc/cookbook/db-sqlite-simple doc/cookbook/file-upload + doc/cookbook/generic doc/cookbook/https doc/cookbook/jwt-and-basic-auth doc/cookbook/pagination diff --git a/doc/cookbook/generic/Generic.lhs b/doc/cookbook/generic/Generic.lhs new file mode 100644 index 00000000..5c1ada3f --- /dev/null +++ b/doc/cookbook/generic/Generic.lhs @@ -0,0 +1,106 @@ +# Using generics + +```haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +module Main (main, api, getLink, routesLinks, cliGet) where + +import Control.Exception (throwIO) +import Data.Proxy (Proxy (..)) +import Network.Wai.Handler.Warp (run) +import System.Environment (getArgs) + +import Servant +import Servant.Client + +import Servant.API.Generic +import Servant.Client.Generic +import Servant.Server.Generic +``` + +The usage is simple, if you only need a collection of routes. +First you define a record with field types prefixed by a parameter `route`: + +```haskell +data Routes route = Routes + { _get :: route :- Capture "id" Int :> Get '[JSON] String + , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool + } + deriving (Generic) +``` + +Then we'll use this data type to define API, links, server and client. + +## API + +You can get a `Proxy` of the API using `genericApi`: + +```haskell +api :: Proxy (ToServantApi Routes) +api = genericApi (Proxy :: Proxy Routes) +``` + +It's recommented to use `genericApi` function, as then you'll get +better error message, for example if you forget to `derive Generic`. + +## Links + +The clear advantage of record-based generics approach, is that +we can get safe links very conviently. We don't need to define endpoint types, +as field accessors work as proxies: + +```haskell +getLink :: Int -> Link +getLink = fieldLink _get +``` + +We can also get all links at once, as a record: + +```haskell +routesLinks :: Routes (AsLink Link) +routesLinks = allFieldLinks +``` + +## Client + +Even more power starts to show when we generate a record of client functions. +Here we use `genericClientHoist` function, which let us simultaneously +hoist the monad, in this case from `ClientM` to `IO`. + +```haskell +cliRoutes :: Routes (AsClientT IO) +cliRoutes = genericClientHoist + (\x -> runClientM x env >>= either throwIO return) + where + env = error "undefined environment" + +cliGet :: Int -> IO String +cliGet = _get cliRoutes +``` + +## Server + +Finally, probably the most handy usage: we can convert record of handlers into +the server implementation: + +```haskell +record :: Routes AsServer +record = Routes + { _get = return . show + , _put = return . odd + } + +app :: Application +app = genericServe record + +main :: IO () +main = do + args <- getArgs + case args of + ("run":_) -> do + putStrLn "Starting cookbook-generic at http://localhost:8000" + run 8000 app + _ -> putStrLn "To run, pass 'run' argument: cabal new-run cookbook-generic run" +``` diff --git a/doc/cookbook/generic/generic.cabal b/doc/cookbook/generic/generic.cabal new file mode 100644 index 00000000..0db6db1d --- /dev/null +++ b/doc/cookbook/generic/generic.cabal @@ -0,0 +1,25 @@ +name: cookbook-generic +version: 0.1 +synopsis: Using custom monad to pass a state between handlers +homepage: http://haskell-servant.readthedocs.org/ +license: BSD3 +license-file: ../../../servant/LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 + +executable cookbook-using-custom-monad + main-is: Generic.lhs + build-depends: base == 4.* + , servant + , servant-client + , servant-client-core + , servant-server + , base-compat + , warp >= 3.2 + , transformers >= 0.3 + default-language: Haskell2010 + ghc-options: -Wall -pgmL markdown-unlit + build-tool-depends: markdown-unlit:markdown-unlit >= 0.4 diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 9c928c11..fb82085c 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -75,8 +75,8 @@ library , time >= 1.4.2 && < 1.9 -- For legacy tools, we need to specify build-depends too - build-depends: markdown-unlit >= 0.4.1 && <0.5 - build-tool-depends: markdown-unlit:markdown-unlit >= 0.4.1 && <0.5 + build-depends: markdown-unlit >= 0.5.0 && <0.6 + build-tool-depends: markdown-unlit:markdown-unlit >= 0.5.0 && <0.6 test-suite spec type: exitcode-stdio-1.0 diff --git a/servant-client-core/CHANGELOG.md b/servant-client-core/CHANGELOG.md index aa2c454a..89043507 100644 --- a/servant-client-core/CHANGELOG.md +++ b/servant-client-core/CHANGELOG.md @@ -1,6 +1,14 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.14.1 +------ + +- Merge in `servant-generic` (by [Patrick Chilton](https://github.com/chpatrick)) + into `servant` (`Servant.API.Generic`), + `servant-client-code` (`Servant.Client.Generic`) + and `servant-server` (`Servant.Server.Generic`). + 0.14 ---- diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 5b2197c1..e731cd7a 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -1,5 +1,5 @@ name: servant-client-core -version: 0.14 +version: 0.14.1 synopsis: Core functionality and class for client function generation for servant APIs description: This library provides backend-agnostic generation of client functions. For @@ -33,6 +33,7 @@ library exposed-modules: Servant.Client.Core Servant.Client.Free + Servant.Client.Generic Servant.Client.Core.Reexport Servant.Client.Core.Internal.Auth Servant.Client.Core.Internal.BaseUrl @@ -60,7 +61,7 @@ library -- Servant dependencies build-depends: - servant == 0.14.* + servant >= 0.14.1 && <0.15 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. diff --git a/servant-client-core/src/Servant/Client/Generic.hs b/servant-client-core/src/Servant/Client/Generic.hs new file mode 100644 index 00000000..1e7c11c3 --- /dev/null +++ b/servant-client-core/src/Servant/Client/Generic.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Servant.Client.Generic ( + AsClientT, + genericClient, + genericClientHoist, + ) where + +import Data.Proxy + (Proxy (..)) + +import Servant.API.Generic +import Servant.Client.Core + +-- | A type that specifies that an API reocrd contains a client implementation. +data AsClientT (m :: * -> *) +instance GenericMode (AsClientT m) where + type AsClientT m :- api = Client m api + +-- | Generate a record of client functions. +genericClient + :: forall routes m. + ( HasClient m (ToServantApi routes) + , GenericServant routes (AsClientT m) + , Client m (ToServantApi routes) ~ ToServant routes (AsClientT m) + ) + => routes (AsClientT m) +genericClient + = fromServant + $ clientIn (Proxy :: Proxy (ToServantApi routes)) (Proxy :: Proxy m) + +-- | 'genericClient' but with 'hoistClientMonad' in between. +genericClientHoist + :: forall routes m n. + ( HasClient m (ToServantApi routes) + , GenericServant routes (AsClientT n) + , Client n (ToServantApi routes) ~ ToServant routes (AsClientT n) + ) + => (forall x. m x -> n x) -- ^ natural transformation + -> routes (AsClientT n) +genericClientHoist nt + = fromServant + $ hoistClientMonad m api nt + $ clientIn api m + where + m = Proxy :: Proxy m + api = Proxy :: Proxy (ToServantApi routes) diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 9d3408df..a3fb8f94 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,6 +1,16 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.14.1 +------ + +- Merge in `servant-generic` (by [Patrick Chilton](https://github.com/chpatrick)) + into `servant` (`Servant.API.Generic`), + `servant-client-code` (`Servant.Client.Generic`) + and `servant-server` (`Servant.Server.Generic`). + +- *servant-server* Deprecate `Servant.Utils.StaticUtils`, use `Servant.Server.StaticUtils`. + 0.14 ---- diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 0b17243c..6b0bee2e 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -1,5 +1,5 @@ name: servant-server -version: 0.14 +version: 0.14.1 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them @@ -47,6 +47,7 @@ library Servant Servant.Server Servant.Server.Experimental.Auth + Servant.Server.Generic Servant.Server.Internal Servant.Server.Internal.BasicAuth Servant.Server.Internal.Context @@ -79,7 +80,7 @@ library -- Servant dependencies build-depends: - servant == 0.14.* + servant >= 0.14.1 && <0.15 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. diff --git a/servant-server/src/Servant/Server/Generic.hs b/servant-server/src/Servant/Server/Generic.hs new file mode 100644 index 00000000..f9ea9abd --- /dev/null +++ b/servant-server/src/Servant/Server/Generic.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | @since 0.14.1 +module Servant.Server.Generic ( + AsServerT, + AsServer, + genericServe, + genericServer, + genericServerT, + ) where + +import Data.Proxy + (Proxy (..)) + +import Servant.API.Generic +import Servant.Server + +-- | A type that specifies that an API record contains a server implementation. +data AsServerT (m :: * -> *) +instance GenericMode (AsServerT m) where + type AsServerT m :- api = ServerT api m + +type AsServer = AsServerT Handler + +-- | Transform record of routes into a WAI 'Application'. +genericServe + :: forall routes. + ( HasServer (ToServantApi routes) '[] + , GenericServant routes AsServer + , Server (ToServantApi routes) ~ ToServant routes AsServer + ) + => routes AsServer -> Application +genericServe = serve (Proxy :: Proxy (ToServantApi routes)) . genericServer + +-- | Transform record of endpoints into a 'Server'. +genericServer + :: GenericServant routes AsServer + => routes AsServer + -> ToServant routes AsServer +genericServer = toServant + +genericServerT + :: GenericServant routes (AsServerT m) + => routes (AsServerT m) + -> ToServant routes (AsServerT m) +genericServerT = toServant diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index 79ceeb97..e7da769f 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,5 +1,18 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.14.1 +------ + +- Merge in (and slightly refactor) `servant-generic` + (by [Patrick Chilton](https://github.com/chpatrick)) + into `servant` (`Servant.API.Generic`), + `servant-client-code` (`Servant.Client.Generic`) + and `servant-server` (`Servant.Server.Generic`). + +- Deprecate `Servant.Utils.Links`, use `Servant.Links`. + +- *servant-server* Deprecate `Servant.Utils.StaticUtils`, use `Servant.Server.StaticUtils`. + 0.14 ---- diff --git a/servant/servant.cabal b/servant/servant.cabal index 3b48fa98..778207dc 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -1,5 +1,5 @@ name: servant -version: 0.14 +version: 0.14.1 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them @@ -46,6 +46,7 @@ library Servant.API.Description Servant.API.Empty Servant.API.Experimental.Auth + Servant.API.Generic Servant.API.Header Servant.API.HttpVersion Servant.API.Internal.Test.ComprehensiveAPI diff --git a/servant/src/Servant/API/Generic.hs b/servant/src/Servant/API/Generic.hs new file mode 100644 index 00000000..b887c09e --- /dev/null +++ b/servant/src/Servant/API/Generic.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- | Define servant servers from record types. Generics for the win. +-- +-- The usage is simple, if you only need a collection of routes. First you +-- define a record with field types prefixed by a parameter `route`: +-- +-- @ +-- data Routes route = Routes +-- { _get :: route :- Capture "id" Int :> Get '[JSON] String +-- , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool +-- } +-- deriving ('Generic') +-- @ +-- +-- You can get a 'Proxy' of the server using +-- +-- @ +-- api :: Proxy (ToServantApi Routes) +-- api = genericApi (Proxy :: Proxy Routes) +-- @ +-- +-- Using 'genericApi' is better as it checks that instances exists, +-- i.e. you get better error messages than simply using 'Proxy' value. +-- +-- __Note:__ in 0.14 series this module isn't re-exported from 'Servant.API'. +-- +-- "Servant.API.Generic" is based on @servant-generic@ package by +-- [Patrick Chilton](https://github.com/chpatrick) +-- +-- @since 0.14.1 +module Servant.API.Generic ( + GenericMode (..), + GenericServant, + ToServant, + toServant, + fromServant, + -- * AsApi + AsApi, + ToServantApi, + genericApi, + -- * Utility + GServantProduct, + -- * re-exports + Generic (Rep), + ) where + +-- Based on servant-generic licensed under MIT License +-- +-- Copyright (c) 2017 Patrick Chilton +-- +-- Permission is hereby granted, free of charge, to any person obtaining a copy +-- of this software and associated documentation files (the "Software"), to deal +-- in the Software without restriction, including without limitation the rights +-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be included in all +-- copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +-- SOFTWARE. + +import Data.Proxy + (Proxy (..)) +import GHC.Generics + ((:*:) (..), Generic (..), K1 (..), M1 (..)) + +import Servant.API.Alternative + +-- | A constraint alias, for work with 'mode' and 'routes'. +type GenericServant routes mode = (GenericMode mode, Generic (routes mode), GServantProduct (Rep (routes mode))) + +-- | A class with a type family that applies an appropriate type family to the @api@ +-- parameter. For example, 'AsApi' will leave @api@ untouched, while +-- @'AsServerT' m@ will produce @'ServerT' api m@. +class GenericMode mode where + type mode :- api :: * + +infixl 0 :- + +-- | Turns a generic product type into a tree of `:<|>` combinators. +type ToServant routes mode = GToServant (Rep (routes mode)) + +type ToServantApi routes = ToServant routes AsApi + +-- | See `ToServant`, but at value-level. +toServant + :: GenericServant routes mode + => routes mode -> ToServant routes mode +toServant = gtoServant . from + +-- | Inverse of `toServant`. +-- +-- This can be used to turn 'generated' values such as client functions into records. +-- +-- You may need to provide a type signature for the /output/ type (your record type). +fromServant + :: GenericServant routes mode + => ToServant routes mode -> routes mode +fromServant = to . gfromServant + +-- | A type that specifies that an API record contains an API definition. Only useful at type-level. +data AsApi +instance GenericMode AsApi where + type AsApi :- api = api + +-- | Get a 'Proxy' of an API type. +genericApi + :: GenericServant routes AsApi + => Proxy routes + -> Proxy (ToServantApi routes) +genericApi _ = Proxy + +------------------------------------------------------------------------------- +-- Class +------------------------------------------------------------------------------- + + +class GServantProduct f where + type GToServant f + gtoServant :: f p -> GToServant f + gfromServant :: GToServant f -> f p + +instance GServantProduct f => GServantProduct (M1 i c f) where + type GToServant (M1 i c f) = GToServant f + gtoServant = gtoServant . unM1 + gfromServant = M1 . gfromServant + +instance (GServantProduct l, GServantProduct r) => GServantProduct (l :*: r) where + type GToServant (l :*: r) = GToServant l :<|> GToServant r + gtoServant (l :*: r) = gtoServant l :<|> gtoServant r + gfromServant (l :<|> r) = gfromServant l :*: gfromServant r + +instance GServantProduct (K1 i c) where + type GToServant (K1 i c) = c + gtoServant = unK1 + gfromServant = K1 diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index 7e2e539f..812e22f3 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -91,6 +91,8 @@ -- This error is essentially saying that the type family couldn't find -- bad_link under api after trying the open (but empty) type family -- `IsElem'` as a last resort. +-- +-- @since 0.14.1 module Servant.Links ( module Servant.API.TypeLevel, @@ -102,6 +104,12 @@ module Servant.Links ( , allLinks , allLinks' , URI(..) + -- * Generics + , AsLink + , fieldLink + , fieldLink' + , allFieldLinks + , allFieldLinks' -- * Adding custom types , HasLink(..) , Link @@ -144,6 +152,7 @@ import Servant.API.Empty (EmptyAPI (..)) import Servant.API.Experimental.Auth (AuthProtect) +import Servant.API.Generic import Servant.API.Header (Header') import Servant.API.HttpVersion @@ -334,6 +343,83 @@ allLinks' -> MkLink api a allLinks' toA api = toLink toA api (Link mempty mempty) +------------------------------------------------------------------------------- +-- Generics +------------------------------------------------------------------------------- + +-- | Given an API record field, create a link for that route. Only the field's +-- type is used. +-- +-- @ +-- data Record route = Record +-- { _get :: route :- Capture "id" Int :> Get '[JSON] String +-- , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool +-- } +-- deriving ('Generic') +-- +-- getLink :: Int -> Link +-- getLink = 'fieldLink' _get +-- @ +-- +-- @since 0.14.1 +fieldLink + :: ( IsElem endpoint (ToServantApi routes), HasLink endpoint + , GenericServant routes AsApi + ) + => (routes AsApi -> endpoint) + -> MkLink endpoint Link +fieldLink = fieldLink' id + +-- | More general version of 'fieldLink' +-- +-- @since 0.14.1 +fieldLink' + :: forall routes endpoint a. + ( IsElem endpoint (ToServantApi routes), HasLink endpoint + , GenericServant routes AsApi + ) + => (Link -> a) + -> (routes AsApi -> endpoint) + -> MkLink endpoint a +fieldLink' toA _ = safeLink' toA (genericApi (Proxy :: Proxy routes)) (Proxy :: Proxy endpoint) + +-- | A type that specifies that an API record contains a set of links. +-- +-- @since 0.14.1 +data AsLink (a :: *) +instance GenericMode (AsLink a) where + type (AsLink a) :- api = MkLink api a + +-- | Get all links as a record. +-- +-- @since 0.14.1 +allFieldLinks + :: ( HasLink (ToServantApi routes) + , GenericServant routes (AsLink Link) + , ToServant routes (AsLink Link) ~ MkLink (ToServantApi routes) Link + ) + => routes (AsLink Link) +allFieldLinks = allFieldLinks' id + +-- | More general version of 'allFieldLinks'. +-- +-- @since 0.14.1 +allFieldLinks' + :: forall routes a. + ( HasLink (ToServantApi routes) + , GenericServant routes (AsLink a) + , ToServant routes (AsLink a) ~ MkLink (ToServantApi routes) a + ) + => (Link -> a) + -> routes (AsLink a) +allFieldLinks' toA + = fromServant + $ allLinks' toA (Proxy :: Proxy (ToServantApi routes)) + +------------------------------------------------------------------------------- +-- HasLink +------------------------------------------------------------------------------- + -- | Construct a toLink for an endpoint. class HasLink endpoint where type MkLink endpoint (a :: *)