diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for servant-generate + +## 0.1 -- 2018-03-22 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,8 @@ +# servant-generate + +Utilities for generating "default" server implementations for +servant APIs. This is a generalisation of +[servant-mock](https://hackage.haskell.org/package/servant-mock). + +See the documentation in `Servant.Server.Generate` for examples +and more. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-generate.cabal b/servant-generate.cabal new file mode 100644 --- /dev/null +++ b/servant-generate.cabal @@ -0,0 +1,31 @@ +name: servant-generate +version: 0.1 +synopsis: Utilities for generating mock server implementations +description: Utilities for generating mock server implementations + . + See the documentation of the @Servant.Server.Generate@ module. +homepage: https://github.com/alpmestan/servant-generate +bug-reports: https://github.com/alpmestan/servant-generate +license: BSD3 +license-file: LICENSE +author: Alp Mestanogullari +maintainer: alpmestan@gmail.com +copyright: 2018 Alp Mestanogullari +category: Web +build-type: Simple +extra-source-files: ChangeLog.md, README.md +cabal-version: >=1.10 +tested-with: GHC == 8.0.2, GHC == 8.2.2 + +source-repository head + type: git + location: https://github.com/alpmestan/servant-generate.git + +library + exposed-modules: Servant.Server.Generate + build-depends: base >=4.7 && <5, + servant >= 0.13 && <0.14, + servant-server >= 0.13 && <0.14 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Servant/Server/Generate.hs b/src/Servant/Server/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Generate.hs @@ -0,0 +1,254 @@ +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Servant.Server.Generate + ( -- * Using this library + -- $using + + -- * The 'GenerateServer' class + GenerateServer(..) + , -- * Utilities + unconstrained, constrained + , handlers + , Flatten, NonEmpty + ) where + +import Data.Proxy +import GHC.Exts +import GHC.TypeLits +import Servant.API +import Servant.API.Internal.Test.ComprehensiveAPI +import Servant.Server + +-- | A class that'll define the generated server using the supplied +-- constraints and some function that takes a response type (through a 'Proxy') +-- and returns a computation in an arbitrary monad that returns a value of +-- the aforementionned response type. +-- +-- What does this all mean? +-- +-- Well, for example, we can use an empty list of +-- constraints (see 'unconstrained') and just systematically call 'throwError' +-- in all endpoints. The monad in that case would be 'Handler', and the result of +-- calling 'generateServer' on any API type would be a server implementation for that +-- API that just errors out in each handler. +-- +-- Another example would be to use a constraint list of just one class (with +-- 'constrained'), say `Arbitrary`, and pass a function to `generateServer` that +-- simply generates a random value in IO (something like +-- @\_ -> liftIO $ generate (arbitrary :: Gen a)@). The result of calling this on a +-- given API type would be a server implementation that can live in any `MonadIO m`, +-- where for each endpoint we simply generate a random response (of the right type!). +class GenerateServer (api :: *) (constraints :: [* -> Constraint]) where + -- | Given: + -- + -- * a particular API type @api@, + -- + -- * some constraint(s) that all response types in the API must satisfy, + -- + -- * a \"monad-like\" type constructor @m@, of kind @* -> *@, + -- + -- * a function that, when given (a 'Proxy' to) any response type @a@ that + -- implements the aforementionned constraints, can produce a value of + -- that type in @m@, + -- + -- 'generateServer' gives you back an implementation of the given API + -- in with handlers returning responses in @m@, that is, a value of type + -- @'ServerT' api m@. + -- + -- When @m@ is just 'Handler', you can directly 'serve' that implementation. + -- If you're working with another monad, you need to use 'hoistServer' on the + -- result of 'generateServer' before you can 'serve' it. + generateServer :: forall (m :: * -> *). + Proxy api + -> Proxy constraints + -> Proxy m + -> (forall a. Flatten constraints a => Proxy a -> m a) + -> ServerT api m + +instance (GenerateServer a c, GenerateServer b c) => GenerateServer (a :<|> b) c where + generateServer _ c m f = generateServer (Proxy @ a) c m f + :<|> generateServer (Proxy @ b) c m f + +instance (KnownSymbol path, GenerateServer api c) => GenerateServer (path :> api) c where + generateServer _ c m f = generateServer (Proxy @ api) c m f + +instance GenerateServer api c => GenerateServer (Summary s :> api) c where + generateServer _ c m f = generateServer (Proxy @ api) c m f + +instance GenerateServer api c => GenerateServer (Description s :> api) c where + generateServer _ c m f = generateServer (Proxy @ api) c m f + +instance GenerateServer EmptyAPI c where + generateServer _ _ _ _ = emptyServer + +instance (KnownSymbol s, GenerateServer api c) => GenerateServer (Capture' mods s a :> api) c where + generateServer _ c m f = \_ -> generateServer (Proxy @ api) c m f + +instance (KnownSymbol s, GenerateServer api c) => GenerateServer (CaptureAll s a :> api) c where + generateServer _ c m f = \_ -> generateServer (Proxy @ api) c m f + +instance GenerateServer api c => GenerateServer (ReqBody' mods cts a :> api) c where + generateServer _ c m f = \_ -> generateServer (Proxy @ api) c m f + +instance GenerateServer api c => GenerateServer (RemoteHost :> api) c where + generateServer _ c m f = \_ -> generateServer (Proxy @ api) c m f + +instance GenerateServer api c => GenerateServer (IsSecure :> api) c where + generateServer _ c m f = \_ -> generateServer (Proxy @ api) c m f + +instance GenerateServer api c => GenerateServer (Vault :> api) c where + generateServer _ c m f = \_ -> generateServer (Proxy @ api) c m f + +instance GenerateServer api c => GenerateServer (HttpVersion :> api) c where + generateServer _ c m f = \_ -> generateServer (Proxy @ api) c m f + +instance (KnownSymbol s, GenerateServer api c) => GenerateServer (QueryParam' mods s a :> api) c where + generateServer _ c m f = \_ -> generateServer (Proxy @ api) c m f + +instance (KnownSymbol s, GenerateServer api c) => GenerateServer (QueryFlag s :> api) c where + generateServer _ c m f = \_ -> generateServer (Proxy @ api) c m f + +instance (KnownSymbol s, GenerateServer api c) => GenerateServer (QueryParams s a :> api) c where + generateServer _ c m f = \_ -> generateServer (Proxy @ api) c m f + +instance (KnownSymbol h, GenerateServer api c) => GenerateServer (Header' mods h a :> api) c where + generateServer _ c m f = \_ -> generateServer (Proxy @ api) c m f + +instance GenerateServer api c => GenerateServer (WithNamedContext name subContext api) c where + generateServer _ c m f = generateServer (Proxy @ api) c m f + +-- | Requires all constraints in @cs@ to be satisfied by @a@. +instance (KnownNat status, Flatten cs a) => GenerateServer (Verb (method :: StdMethod) (status :: Nat) (cts :: [*]) (a :: *)) cs where + generateServer _ _ _ f = f (Proxy @ a) + +type family Flatten (cs :: [* -> Constraint]) (a :: *) :: Constraint where + Flatten '[] a = () + Flatten (c ': cs) a = (c a, Flatten cs a) + +-- * Utilities for specifying the arguments to 'generateServer' + +-- | Meant to be used as the second argument to 'generateServer' when your +-- implementation function doesn't need any typeclass constraint and can +-- just work with any response type. +unconstrained :: Proxy ('[] :: [* -> Constraint]) +unconstrained = Proxy + +type family NonEmpty (cs :: [* -> Constraint]) :: Constraint where + NonEmpty '[] = TypeError ('Text "empty list of constraints used with 'constrained'") + NonEmpty cs = () + +-- | Meant to be used as the second argument to 'generateServer' when your +-- implementation function requires one or more constraints on the /all/ +-- the response types of your API, e.g @'constrained' \@ '[Show, Random, Monoid]@. +constrained + :: forall (cs :: [* -> Constraint]). NonEmpty cs => Proxy cs +constrained = Proxy + +-- | Meant to be used as the third argument to 'generateServer'. It's a simple +-- more readable wrapper around 'Proxy'. Use a type application to specify +-- the monad, e.g @'handlers' \@ 'AppMonad'@. +handlers :: forall (m :: * -> *). Proxy m +handlers = Proxy + +-- do we have all instances? + +class A a where + getA :: Proxy a -> a + +instance A NoContent where + getA _ = NoContent + +instance A Int where + getA _ = 0 + +instance A a => A (Headers '[] a) where + getA _ = Headers (getA (Proxy :: Proxy a)) HNil + +instance (A t, A (Headers hs a)) + => A (Headers (Header h t ': hs) a) where + getA _ = case getA (Proxy @ (Headers hs a)) of + Headers a hs -> Headers a $ + (Header $ getA (Proxy @ t)) `HCons` hs + +s :: Server ComprehensiveAPIWithoutRaw +s = generateServer + (Proxy @ ComprehensiveAPIWithoutRaw) + (constrained @ '[A]) + (handlers @ Handler) + (return . getA) + +-- $using +-- Let's imagine we're working with the following +-- simple API and we would like to spin up a "silly" +-- server implementation that returns responses of the +-- right type (or errors out) for each endpoint. +-- +-- > type API = Get '[JSON] () +-- > :<|> "int" :> Get '[JSON] Int +-- > +-- > api :: Proxy API +-- > api = Proxy +-- +-- First, let's see how we can get a server implementation +-- where all the handlers throw a 404 error. +-- +-- > -- x :: Handler () :<|> Handler Int +-- > -- inferred just fine +-- > x = generateServer api unconstrained (handlers @ Handler) (\_ -> throwError err404) +-- +-- We could more generally take the monad as argument, simply +-- requiring that it is a @'MonadError' 'ServantErr'@, for +-- example. +-- +-- > -- x' :: MonadError ServantErr m => Proxy m -> m () :<|> m Int +-- > -- inferred just fine +-- > x' mon = generateServer api unconstrained mon (\_ -> throwError err404) +-- +-- Now, let's see an example where we need one constraint to be +-- satisfied for all response types present in the API. +-- +-- > -- we will require all response types to provide +-- > -- an instance of this typeclass. +-- > class Default a where +-- > def :: Proxy a -> a +-- > +-- > instance Default () where +-- > def _ = () +-- > +-- > instance Default Int where +-- > def _ = 0 +-- > +-- > -- y :: forall m. Applicative m => Proxy m -> m () :<|> m Int +-- > -- inferred just fine +-- > y mon = generateServer api (constrained @ '[Default]) mon $ \pa -> pure (def pa) +-- +-- Finally, let's see an example where we require all response +-- types of an API to have instances for several type classes. +-- +-- > -- we will require instances of Tweak in addition to +-- > -- Default. +-- > class Tweak a where +-- > tweak :: a -> a +-- > +-- > instance Tweak () where +-- > tweak () = () +-- > +-- > instance Tweak Int where +-- > tweak n = n^2 +-- > +-- > -- z :: forall m. Monad m => Proxy m -> m () :<|> m Int +-- > z mon = generateServer api (constrained @ '[Default, Tweak]) mon $ \pa -> +-- > return $ tweak (def pa) +-- > +-- > -- instantiated at a particular monad, say Handler: +-- > z' = z (handlers @ Handler)