Merge pull request #163 from haskell-servant/servant-mock

new package: servant-mock, to generate mock servers from API types

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.

servant-mock/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

servant-mock/example/main.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+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)

servant-mock/servant-mock.cabal

@@ -0,0 +1,46 @@
+name:                servant-mock
+version:             0.4
+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

servant-mock/src/Servant/Mock.hs

@@ -0,0 +1,189 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-- |
+-- Module     : Servant.Mock
+-- Copyright  : 2015 Alp Mestanogullari
+-- License    : BSD3
+--
+-- Maintainer  : Alp Mestanogullari <alpmestan@gmail.com>
+-- 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 = fmap 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
+
+

sources.txt

@@ -6,3 +6,4 @@ servant-server
 servant-examples
 servant-blaze
 servant-lucid
+servant-mock