Merge servant-generic

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

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"
+```

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

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-depends: markdown-unlit >= 0.5.0 && <0.6
-  build-tool-depends: markdown-unlit:markdown-unlit >= 0.4.1 && <0.5
+  build-tool-depends: markdown-unlit:markdown-unlit >= 0.5.0 && <0.6
 
 test-suite spec
   type: exitcode-stdio-1.0

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
 ----
 

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.

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)

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
 ----
 

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.

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

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
 ----
 

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

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

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 :: *)