├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── example-servant-persistent.cabal ├── src ├── Api.hs ├── App.hs ├── Main.hs └── Models.hs ├── stack.yaml └── test ├── AppSpec.hs └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | /.stack-work/ 2 | /sqlite.db 3 | /sqlite.db-shm 4 | /sqlite.db-wal 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | 3 | addons: 4 | apt: 5 | packages: 6 | - libgmp-dev 7 | 8 | install: 9 | # stack 10 | - mkdir -p ~/.local/bin 11 | - export PATH=~/.local/bin:$PATH 12 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 13 | - stack --version 14 | 15 | script: 16 | - stack setup --no-terminal 17 | - stack build --ghc-options=-Werror --no-terminal 18 | - stack test --ghc-options=-Werror --no-terminal 19 | 20 | cache: 21 | directories: 22 | - $HOME/.stack 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, James M.C. Haver II 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of James M.C. Haver II nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This project is a small example for how to set up a web-server with 2 | [servant-server](http://haskell-servant.readthedocs.io/) that uses 3 | [persistent](https://www.stackage.org/package/persistent) for saving data to a 4 | database. 5 | 6 | You can build and run the project with [stack](http://haskellstack.org/), e.g.: 7 | 8 | ```shell 9 | stack build 10 | stack exec example-servant-persistent 11 | ``` 12 | 13 | Then you can query the server from a separate shell: 14 | 15 | ```shell 16 | curl -H 'Content-type: application/json' localhost:3000/user --data '{"name": "Alice", "age": 42}' 17 | curl -H 'Content-type: application/json' localhost:3000/user/Alice 18 | ``` 19 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example-servant-persistent.cabal: -------------------------------------------------------------------------------- 1 | name: example-servant-persistent 2 | version: 0.1.0.0 3 | synopsis: example with persistent and servant 4 | description: Simple example to illustrate how to use persistent and servant in combination. 5 | license: BSD3 6 | license-file: LICENSE 7 | author: James M.C. Haver II, Sönke Hahn 8 | maintainer: mchaver@gmail.com, SoenkeHahn@gmail.com 9 | category: Web 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable example-servant-persistent 14 | main-is: Main.hs 15 | other-modules: Api 16 | , App 17 | , Models 18 | build-depends: base >=4.8 && <4.11 19 | , aeson 20 | , monad-logger 21 | , persistent 22 | , persistent-template 23 | , persistent-sqlite 24 | , servant 25 | , servant-server 26 | , string-conversions 27 | , text 28 | , transformers 29 | , wai 30 | , warp 31 | hs-source-dirs: src 32 | default-language: Haskell2010 33 | 34 | test-suite spec 35 | type: exitcode-stdio-1.0 36 | main-is: Spec.hs 37 | hs-source-dirs: test 38 | , src 39 | other-modules: Api 40 | , App 41 | , Models 42 | , AppSpec 43 | build-depends: base >=4.8 && <4.11 44 | , hspec 45 | , aeson 46 | , persistent 47 | , monad-logger 48 | , persistent-template 49 | , persistent-sqlite 50 | , transformers 51 | , wai 52 | , servant 53 | , servant-client 54 | , servant-server 55 | , string-conversions 56 | , warp 57 | , http-client 58 | , text 59 | , mockery 60 | default-language: Haskell2010 61 | -------------------------------------------------------------------------------- /src/Api.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | module Api where 8 | 9 | import Data.Proxy 10 | import Data.Text 11 | 12 | import Database.Persist 13 | 14 | import Models 15 | 16 | import Servant.API 17 | 18 | 19 | 20 | type Api = 21 | "user" :> ReqBody '[JSON] User :> Post '[JSON] (Maybe (Key User)) 22 | :<|> "user" :> Capture "name" Text :> Get '[JSON] (Maybe User) 23 | 24 | api :: Proxy Api 25 | api = Proxy 26 | -------------------------------------------------------------------------------- /src/App.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module App where 9 | 10 | import Control.Monad.IO.Class (liftIO) 11 | import Control.Monad.Logger (runStderrLoggingT) 12 | import Database.Persist.Sqlite ( ConnectionPool, createSqlitePool 13 | , runSqlPool, runSqlPersistMPool 14 | , runMigration, selectFirst, (==.) 15 | , insert, entityVal) 16 | import Data.String.Conversions (cs) 17 | import Data.Text (Text) 18 | import Network.Wai.Handler.Warp as Warp 19 | 20 | import Servant 21 | 22 | import Api 23 | import Models 24 | 25 | server :: ConnectionPool -> Server Api 26 | server pool = 27 | userAddH :<|> userGetH 28 | where 29 | userAddH newUser = liftIO $ userAdd newUser 30 | userGetH name = liftIO $ userGet name 31 | 32 | userAdd :: User -> IO (Maybe (Key User)) 33 | userAdd newUser = flip runSqlPersistMPool pool $ do 34 | exists <- selectFirst [UserName ==. (userName newUser)] [] 35 | case exists of 36 | Nothing -> Just <$> insert newUser 37 | Just _ -> return Nothing 38 | 39 | userGet :: Text -> IO (Maybe User) 40 | userGet name = flip runSqlPersistMPool pool $ do 41 | mUser <- selectFirst [UserName ==. name] [] 42 | return $ entityVal <$> mUser 43 | 44 | app :: ConnectionPool -> Application 45 | app pool = serve api $ server pool 46 | 47 | mkApp :: FilePath -> IO Application 48 | mkApp sqliteFile = do 49 | pool <- runStderrLoggingT $ do 50 | createSqlitePool (cs sqliteFile) 5 51 | 52 | runSqlPool (runMigration migrateAll) pool 53 | return $ app pool 54 | 55 | run :: FilePath -> IO () 56 | run sqliteFile = 57 | Warp.run 3000 =<< mkApp sqliteFile 58 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import App 5 | 6 | main :: IO () 7 | main = run "sqlite.db" 8 | -------------------------------------------------------------------------------- /src/Models.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | 11 | module Models where 12 | 13 | import Data.Aeson 14 | import Data.Text 15 | 16 | import Database.Persist.TH 17 | 18 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 19 | User 20 | name Text 21 | age Int 22 | UniqueName name 23 | deriving Eq Read Show 24 | |] 25 | 26 | instance FromJSON User where 27 | parseJSON = withObject "User" $ \ v -> 28 | User <$> v .: "name" 29 | <*> v .: "age" 30 | 31 | instance ToJSON User where 32 | toJSON (User name age) = 33 | object [ "name" .= name 34 | , "age" .= age ] 35 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.0 2 | packages: 3 | - '.' 4 | -------------------------------------------------------------------------------- /test/AppSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module AppSpec where 4 | 5 | import Api 6 | import App 7 | 8 | import Control.Exception (throwIO, ErrorCall(..)) 9 | import Control.Monad.Trans.Except 10 | 11 | import Data.Text 12 | 13 | import Models 14 | 15 | import Network.HTTP.Client 16 | import Network.Wai.Handler.Warp 17 | 18 | import Servant.API 19 | import Servant.Client 20 | 21 | import Test.Hspec 22 | import Test.Mockery.Directory 23 | 24 | userAdd :: User -> ClientM (Maybe (Key User)) 25 | userGet :: Text -> ClientM (Maybe User) 26 | userAdd :<|> userGet = client api 27 | 28 | spec :: Spec 29 | spec = do 30 | around withApp $ do 31 | describe "/user GET" $ do 32 | it "returns Nothing for non-existing users" $ \ port -> do 33 | try port (userGet "foo") `shouldReturn` Nothing 34 | 35 | describe "/user POST" $ do 36 | it "allows to add a user" $ \ port -> do 37 | let user = User "Alice" 1 38 | id <- try port (userAdd user) 39 | try port (userGet "Alice") `shouldReturn` Just user 40 | 41 | it "allows to add two users" $ \ port -> do 42 | let a = User "Alice" 1 43 | let b = User "Bob" 2 44 | id <- try port (userAdd a) 45 | id <- try port (userAdd b) 46 | try port (userGet "Bob") `shouldReturn` Just b 47 | 48 | it "returns Nothing when adding the same user twice" $ \ port -> do 49 | let a = User "Alice" 1 50 | id <- try port (userAdd a) 51 | try port (userAdd a) `shouldReturn` Nothing 52 | 53 | withApp :: (Int -> IO a) -> IO a 54 | withApp action = 55 | inTempDirectory $ do 56 | app <- mkApp "sqlite.db" 57 | testWithApplication (return app) action 58 | 59 | try :: Int -> ClientM a -> IO a 60 | try port action = do 61 | manager <- newManager defaultManagerSettings 62 | let baseUrl = BaseUrl Http "localhost" port "" 63 | result <- runClientM action (ClientEnv manager baseUrl) 64 | case result of 65 | Left err -> throwIO $ ErrorCall $ show err 66 | Right a -> return a 67 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------