diff --git a/servant-mock/LICENSE b/servant-mock/LICENSE new file mode 100644 index 00000000..f2e47b91 --- /dev/null +++ b/servant-mock/LICENSE @@ -0,0 +1,30 @@ +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-mock/Setup.hs b/servant-mock/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/servant-mock/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-mock/default.nix b/servant-mock/default.nix new file mode 100644 index 00000000..670e066e --- /dev/null +++ b/servant-mock/default.nix @@ -0,0 +1,17 @@ +{ mkDerivation, aeson, base, bytestring, http-types, QuickCheck +, servant, servant-server, stdenv, transformers, wai, warp +}: +mkDerivation { + pname = "servant-mock"; + version = "0.5"; + src = ./.; + isLibrary = true; + isExecutable = true; + buildDepends = [ + aeson base bytestring http-types QuickCheck servant servant-server + transformers wai warp + ]; + homepage = "http://github.com/haskell-servant/servant"; + description = "Derive a mock server for free from your servant API types"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/servant-mock/example/main.hs b/servant-mock/example/main.hs new file mode 100644 index 00000000..51ba7329 --- /dev/null +++ b/servant-mock/example/main.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeOperators #-} +import Data.Aeson +import GHC.Generics +import Network.Wai.Handler.Warp +import Servant +import Servant.Mock +import Test.QuickCheck.Arbitrary + +newtype User = User { username :: String } + deriving (Eq, Show, Arbitrary, Generic) + +instance ToJSON User + +type API = "user" :> Get '[JSON] User + +api :: Proxy API +api = Proxy + +main :: IO () +main = run 8080 (serve api $ mock api) diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal new file mode 100644 index 00000000..d6f9067e --- /dev/null +++ b/servant-mock/servant-mock.cabal @@ -0,0 +1,46 @@ +name: servant-mock +version: 0.5 +synopsis: Derive a mock server for free from your servant API types +description: + Derive a mock server for free from your servant API types + . + See the @Servant.Mock@ module for the documentation and an example. +homepage: http://github.com/haskell-servant/servant +license: BSD3 +license-file: LICENSE +author: Alp Mestanogullari +maintainer: alpmestan@gmail.com +copyright: 2015 Alp Mestanogullari +category: Web +build-type: Simple +cabal-version: >=1.10 + +flag example + description: Build the example too + manual: True + default: False + +library + exposed-modules: + Servant.Mock + build-depends: + base >=4.7 && <5, + bytestring >= 0.10 && <0.11, + http-types >= 0.8 && <0.9, + servant >= 0.4, + servant-server >= 0.4, + transformers >= 0.3 && <0.5, + QuickCheck >= 2.8 && <2.9, + wai >= 3.0 && <3.1 + hs-source-dirs: src + default-language: Haskell2010 + +executable mock-app + main-is: main.hs + hs-source-dirs: example + default-language: Haskell2010 + build-depends: aeson, base, servant-mock, servant-server, QuickCheck, warp + if flag(example) + buildable: True + else + buildable: False diff --git a/servant-mock/shell.nix b/servant-mock/shell.nix new file mode 100644 index 00000000..cd9721d7 --- /dev/null +++ b/servant-mock/shell.nix @@ -0,0 +1,18 @@ +let + pkgs = import {}; + + haskellPackages = pkgs.haskellPackages.override { + overrides = self: super: { + servant = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.appendConfigureFlag (self.callPackage ../servant {}) "--ghc-options=-Werror"); + servant-client = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.appendConfigureFlag (self.callPackage ../servant-client {}) "--ghc-options=-Werror"); + servant-docs = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.appendConfigureFlag (self.callPackage ../servant-docs {}) "--ghc-options=-Werror"); + servant-js = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.appendConfigureFlag (self.callPackage ../servant-js {}) "--ghc-options=-Werror"); + servant-server = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.appendConfigureFlag (self.callPackage ../servant-server {}) "--ghc-options=-Werror"); + servant-examples = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.appendConfigureFlag (self.callPackage ../servant-examples {}) "--ghc-options=-Werror"); + servant-blaze = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.appendConfigureFlag (self.callPackage ../servant-blaze {}) "--ghc-options=-Werror"); + servant-lucid = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.appendConfigureFlag (self.callPackage ../servant-lucid {}) "--ghc-options=-Werror"); + servant-mock = pkgs.haskell.lib.appendConfigureFlag (self.callPackage ./. {}) "--ghc-options=-Werror"; + }; + }; + +in haskellPackages.servant-mock.env diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs new file mode 100644 index 00000000..ddc836da --- /dev/null +++ b/servant-mock/src/Servant/Mock.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Servant.Mock +-- Copyright : 2015 Alp Mestanogullari +-- License : BSD3 +-- +-- Maintainer : Alp Mestanogullari +-- Stability : experimental +-- Portability : portable +-- +-- Automatically derive a mock webserver that implements some API type, +-- just from the said API type's definition. +-- +-- Using this module couldn't be simpler. Given some API type, like: +-- +-- > type API = "user" :> Get '[JSON] User +-- +-- that describes your web application, all you have to do is define +-- a 'Proxy' to it: +-- +-- > myAPI :: Proxy API +-- > myAPI = Proxy +-- +-- and call 'mock', which has the following type: +-- +-- @ +-- 'mock' :: 'HasMock' api => 'Proxy' api -> 'Server' api +-- @ +-- +-- What this says is, given some API type @api@ that it knows it can +-- "mock", 'mock' hands you an implementation of the API type. It does so +-- by having each request handler generate a random value of the +-- appropriate type (@User@ in our case). All you need for this to work is +-- to provide 'Arbitrary' instances for the data types returned as response +-- bodies, hence appearing next to 'Delete', 'Get', 'Patch', 'Post' and 'Put'. +-- +-- To put this all to work and run the mock server, just call 'serve' on the +-- result of 'mock' to get an 'Application' that you can then run with warp. +-- +-- @ +-- main :: IO () +-- main = Network.Wai.Handler.Warp.run 8080 $ +-- 'serve' myAPI ('mock' myAPI) +-- @ +module Servant.Mock ( HasMock(..) ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Monad.IO.Class +import Data.ByteString.Lazy.Char8 (pack) +import Data.Proxy +import GHC.TypeLits +import Network.HTTP.Types.Status +import Network.Wai +import Servant +import Servant.API.ContentTypes +import Test.QuickCheck.Arbitrary (Arbitrary (..), vector) +import Test.QuickCheck.Gen (Gen, generate) + +-- | 'HasMock' defines an interpretation of API types +-- 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 + -- | Calling this method creates request handlers of + -- the right type to implement the API described by + -- @api@ that just generate random response values of + -- the right type. E.g: + -- + -- @ + -- type API = "user" :> Get '[JSON] User + -- :<|> "book" :> Get '[JSON] Book + -- + -- api :: Proxy API + -- api = Proxy + -- + -- -- let's say we will start with the frontend, + -- -- and hence need a placeholder server + -- server :: Server API + -- server = mock api + -- @ + -- + -- What happens here is that @'Server' API@ + -- actually "means" 2 request handlers, of the following types: + -- + -- @ + -- getUser :: EitherT ServantErr IO User + -- getBook :: EitherT ServantErr IO 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 + +instance (HasMock a, HasMock b) => HasMock (a :<|> b) where + mock _ = mock (Proxy :: Proxy a) :<|> mock (Proxy :: Proxy b) + +instance (KnownSymbol path, HasMock rest) => HasMock (path :> rest) where + mock _ = mock (Proxy :: Proxy rest) + +instance (KnownSymbol s, FromText a, HasMock rest) => HasMock (Capture s a :> rest) where + mock _ = \_ -> mock (Proxy :: Proxy rest) + +instance (AllCTUnrender ctypes a, HasMock rest) => HasMock (ReqBody ctypes a :> rest) where + mock _ = \_ -> mock (Proxy :: Proxy rest) + +instance HasMock rest => HasMock (RemoteHost :> rest) where + mock _ = \_ -> mock (Proxy :: Proxy rest) + +instance HasMock rest => HasMock (IsSecure :> rest) where + mock _ = \_ -> mock (Proxy :: Proxy rest) + +instance HasMock rest => HasMock (Vault :> rest) where + mock _ = \_ -> mock (Proxy :: Proxy rest) + +instance HasMock rest => HasMock (HttpVersion :> rest) where + mock _ = \_ -> mock (Proxy :: Proxy rest) + +instance (KnownSymbol s, FromText a, HasMock rest) + => HasMock (QueryParam s a :> rest) where + mock _ = \_ -> mock (Proxy :: Proxy rest) + +instance (KnownSymbol s, FromText a, HasMock rest) + => HasMock (QueryParams s a :> rest) where + mock _ = \_ -> mock (Proxy :: Proxy rest) + +instance (KnownSymbol s, HasMock rest) => HasMock (QueryFlag s :> rest) where + mock _ = \_ -> mock (Proxy :: Proxy rest) + +instance (KnownSymbol s, FromText a, HasMock rest) + => HasMock (MatrixParam s a :> rest) where + mock _ = \_ -> mock (Proxy :: Proxy rest) + +instance (KnownSymbol s, FromText a, HasMock rest) + => HasMock (MatrixParams s a :> rest) where + mock _ = \_ -> mock (Proxy :: Proxy rest) + +instance (KnownSymbol s, HasMock rest) => HasMock (MatrixFlag s :> rest) where + mock _ = \_ -> mock (Proxy :: Proxy rest) + +instance (KnownSymbol h, FromText a, HasMock rest) => HasMock (Header h a :> rest) where + mock _ = \_ -> mock (Proxy :: Proxy rest) + +instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Delete ctypes a) where + mock _ = mockArbitrary + +instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Get ctypes a) where + mock _ = mockArbitrary + +instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Patch ctypes a) where + mock _ = mockArbitrary + +instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Post ctypes a) where + mock _ = mockArbitrary + +instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Put ctypes a) where + mock _ = mockArbitrary + +instance HasMock Raw where + mock _ = \req respond -> do + bdy <- genBody + respond $ responseLBS status200 [] bdy + + where genBody = pack <$> generate (vector 100 :: Gen [Char]) + +mockArbitrary :: (MonadIO m, Arbitrary a) => m a +mockArbitrary = liftIO (generate arbitrary) + +-- utility instance +instance (Arbitrary (HList ls), Arbitrary a) + => Arbitrary (Headers ls a) where + arbitrary = Headers <$> arbitrary <*> arbitrary + +instance Arbitrary (HList '[]) where + arbitrary = pure HNil + +instance (Arbitrary a, Arbitrary (HList hs)) + => Arbitrary (HList (Header h a ': hs)) where + arbitrary = HCons <$> fmap Header arbitrary <*> arbitrary + +