├── .editorconfig ├── .gitignore ├── .hlint.yaml ├── .stylish-haskell.yaml ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── app └── Main.hs ├── assets ├── api.js └── index.html ├── config └── keter.yml ├── deploy.sh ├── servant-persistent.cabal ├── src ├── Api.hs ├── Api │ └── User.hs ├── Config.hs ├── DevelMain.hs ├── Init.hs ├── Logger.hs └── Models.hs ├── stack.yaml ├── stack.yaml.lock ├── stylish-haskell.sh └── test ├── ApiSpec.hs ├── Spec.hs └── UserDbSpec.hs /.editorconfig: -------------------------------------------------------------------------------- 1 | [*.hs] 2 | indent_style = space 3 | indent_size = 4 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | dist 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .virtualenv 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | dist 19 | cabal-dev 20 | *.o 21 | *.hi 22 | *.chi 23 | *.chs.h 24 | *.dyn_o 25 | *.dyn_hi 26 | .virtualenv 27 | .hpc 28 | .hsenv 29 | .cabal-sandbox/ 30 | cabal.sandbox.config 31 | *.prof 32 | *.aux 33 | *.hp 34 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | ########################## 4 | 5 | # This file contains a template configuration file, which is typically 6 | # placed as .hlint.yaml in the root of your project 7 | 8 | 9 | # Specify additional command line arguments 10 | # 11 | # - arguments: [--color, --cpp-simple, -XQuasiQuotes] 12 | 13 | 14 | # Control which extensions/flags/modules/functions can be used 15 | # 16 | # - extensions: 17 | # - default: false # all extension are banned by default 18 | # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used 19 | # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module 20 | # 21 | # - flags: 22 | # - {name: -w, within: []} # -w is allowed nowhere 23 | # 24 | # - modules: 25 | # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' 26 | # - {name: Control.Arrow, within: []} # Certain modules are banned entirely 27 | # 28 | # - functions: 29 | # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules 30 | 31 | 32 | # Add custom hints for this project 33 | # 34 | # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" 35 | # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} 36 | 37 | 38 | # Turn on hints that are off by default 39 | # 40 | # Ban "module X(module X) where", to require a real export list 41 | # - warn: {name: Use explicit module export list} 42 | # 43 | # Replace a $ b $ c with a . b $ c 44 | # - group: {name: dollar, enabled: true} 45 | # 46 | # Generalise map to fmap, ++ to <> 47 | # - group: {name: generalise, enabled: true} 48 | 49 | 50 | # Ignore some builtin hints 51 | # - ignore: {name: Use let} 52 | # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules 53 | 54 | 55 | # Define some custom infix operators 56 | # - fixity: infixr 3 ~^#^~ 57 | 58 | 59 | # To generate a suitable file for HLint do: 60 | # $ hlint --default > .hlint.yaml 61 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - imports: 3 | align: none 4 | list_align: with_module_name 5 | pad_module_names: false 6 | long_list_align: new_line_multiline 7 | empty_list_align: inherit 8 | list_padding: 7 # length "import " 9 | separate_lists: false 10 | space_surround: false 11 | - language_pragmas: 12 | style: vertical 13 | align: false 14 | remove_redundant: true 15 | - simple_align: 16 | cases: false 17 | top_level_patterns: false 18 | records: false 19 | - trailing_whitespace: {} 20 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # thanks to http://stackoverflow.com/a/24600210/3780203 5 | # Handle git submodules yourself 6 | git: 7 | submodules: false 8 | 9 | # Choose a lightweight base image; we provide our own build tools. 10 | language: c 11 | 12 | # GHC depends on GMP. You can add other dependencies here as well. 13 | addons: 14 | apt: 15 | packages: 16 | - libgmp-dev 17 | 18 | # The different configurations we want to test. You could also do things like 19 | # change flags or use --stack-yaml to point to a different file. 20 | env: 21 | - ARGS="" 22 | 23 | before_install: 24 | # Download and unpack the stack executable 25 | - mkdir -p ~/.local/bin 26 | - export PATH=$HOME/.local/bin:$PATH 27 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 28 | - stack install stylish-haskell --resolver nightly-2020-03-14 29 | 30 | services: 31 | - postgresql 32 | 33 | before_script: 34 | - psql -c 'create database test;' -U postgres 35 | - psql -c 'create role test LOGIN CREATEDB;' -U postgres 36 | - psql -c 'create database "perservant-test";' -U test 37 | 38 | # This line does all of the work: installs GHC if necessary, build the library, 39 | # executables, and test suites, and runs the test suites. --no-terminal works 40 | # around some quirks in Travis's terminal implementation. 41 | script: 42 | - make imports 43 | - git diff --exit-code 44 | - stack --no-terminal --install-ghc test 45 | 46 | # Caching so the next build will be fast too. 47 | cache: 48 | directories: 49 | - $HOME/.stack 50 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Matt Parsons 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | help: ## Print documentation 2 | @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' 3 | 4 | ghcid-devel: ## Run the server in fast development mode. See DevelMain for details. 5 | ghcid \ 6 | --command "stack ghci servant-persistent" \ 7 | --test DevelMain.update \ 8 | --warnings \ 9 | --restart ./servant-persistent.cabal \ 10 | --restart ./stack.yaml 11 | 12 | imports: ## Format all the imports that have changed since the master branch. 13 | ./stylish-haskell.sh 14 | 15 | .PHONY: ghcid-devel help imports 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # servant-persistent 2 | 3 | [![Build Status](https://travis-ci.org/parsonsmatt/servant-persistent.svg?branch=master)](https://travis-ci.org/parsonsmatt/servant-persistent) 4 | 5 | [Servant](https://haskell-servant.github.io/) is an awesome Haskell library for writing web APIs. It uses the type system in a way that can only be described as magic to generate type safe routes as well as clients. 6 | 7 | [Persistent](http://www.yesodweb.com/book/persistent) is another awesome Haskell library for querying databases. It manages migrations, your schema, and querying to make data transactions mostly painless. 8 | 9 | For some reason, no one had created an example on how to use these guys together. I put together this minimal example to show an example implementation, along with some resource management and basic error handling. 10 | 11 | I wrote a [blog post](http://www.parsonsmatt.org/2016/07/08/servant-persistent_updated.html) that goes into a bit more detail. 12 | 13 | ## Requirements: 14 | 15 | ### Haskell 16 | 17 | You can use [stack](https://github.com/commercialhaskell/stack) to get started: 18 | 19 | 1. `stack build` 20 | 2. `stack exec perservant` 21 | 22 | Alternatively, cabal can be used: 23 | 24 | 1. `cabal sandbox init` 25 | 2. `cabal install --dependencies-only && cabal configure && cabal build` 26 | 3. `cabal run` 27 | 28 | ### Database: 29 | 30 | You will need PostgreSQL installed and listening on port 5432. The default configuration uses a database name `perservant` with username/password test:test. 31 | 32 | These steps work on Ubuntu: 33 | 34 | ```haskell 35 | $ apt install postgres libpq-dev 36 | $ sudo -u postgres createuser -se test 37 | $ sudo -u postgres psql -c "alter role test with password 'test'" 38 | $ sudo -u postgres psql -c "create database perservant" 39 | ``` 40 | 41 | These following steps worked on Arch Linux: 42 | 43 | ``` 44 | # install postgres 45 | $ sudo pacman -S postgres 46 | 47 | # The installation process should have created the postgres system user for us. 48 | # Become that user in order to initialize the DB. This is required before 49 | # running the postgres service. 50 | $ sudo -i -u postgres 51 | 52 | # As the postgres user, initialize the database. 53 | [postgres]$ initdb --locale en_US.UTF-8 -E UTF8 -D '/var/lib/postgres/data' 54 | # Exit to go back to your normal user. 55 | [postgres]$ exit 56 | 57 | # As your normal user start the postgres service. 58 | $ sudo systemctl start postgres.service 59 | 60 | # When that starts successfully, then we need to become the postgres system 61 | # user again to create the "test" user and perservant database. 62 | $ sudo -i -u postgres 63 | [postgres]$ createuser --interactive 64 | Enter name of role to add: test 65 | Shall the new role be a superuser? (y/n) y 66 | [postgres]$ createdb perservant -U test 67 | # Exit to go back to your normal user. 68 | [postgres]$ exit 69 | 70 | # As your normal user you can log in and play around with the DB: 71 | $ psql -d perservant -U test 72 | psql (9.4.4) 73 | Type "help" for help. 74 | 75 | perservant=# 76 | ``` 77 | 78 | ## The API: 79 | 80 | - GET `/users` returns a list of all users in the database 81 | - GET `/users/:name` returns the first user whose name is `:name`, and returns 404 if the user doesn't show up. 82 | - POST `/users` with JSON like `{ "name": "String", "email": "String" }` to create a User. 83 | 84 | ### Playing with the API from the command line 85 | 86 | Once the compiled `perservant` binary is running, you can use `curl` like below to play with the API from the command line. 87 | 88 | ``` 89 | # create a new user 90 | $ curl --verbose --request POST --header "Content-Type: application/json" \ 91 | --data '{"name": "foo", "email": "foo@foo.com"}' \ 92 | http://localhost:8081/users 93 | 94 | # get all users in database 95 | $ curl --verbose --request GET --header "Content-Type: application/json" \ 96 | http://localhost:8081/users 97 | 98 | # get certain user in database 99 | $ curl --verbose --request GET --header "Content-Type: application/json" \ 100 | http://localhost:8081/users/foo 101 | ``` 102 | 103 | ## src/Main.hs 104 | 105 | `main` starts off by pulling some settings from the environment, creating a connection pool, running the migrations, and finally running the app. 106 | 107 | ## src/Api.hs 108 | 109 | This source contains the actual API definition. 110 | 111 | ## src/Config.hs 112 | 113 | Contains the `runDb`, `makePool`, and `Config` definitions. 114 | 115 | ## src/Models.hs 116 | 117 | Contains fairly typical Persistent schema definitions. 118 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Init (runAppDevel) 4 | 5 | -- | The 'main' function gathers the required environment information and 6 | -- initializes the application. 7 | main :: IO () 8 | main = runAppDevel 9 | -------------------------------------------------------------------------------- /assets/api.js: -------------------------------------------------------------------------------- 1 | 2 | var getUsers = function(onSuccess, onError) { 3 | var xhr = new XMLHttpRequest(); 4 | xhr.open('GET', '/users', true); 5 | xhr.setRequestHeader('Accept', 'application/json'); 6 | xhr.onreadystatechange = function () { 7 | var res = null; 8 | if (xhr.readyState === 4) { 9 | if (xhr.status === 204 || xhr.status === 205) { 10 | onSuccess(); 11 | } else if (xhr.status >= 200 && xhr.status < 300) { 12 | try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); } 13 | if (res) onSuccess(res); 14 | } else { 15 | try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); } 16 | if (res) onError(res); 17 | } 18 | } 19 | }; 20 | xhr.send(null); 21 | }; 22 | 23 | var getUsersByName = function(name, onSuccess, onError) { 24 | var xhr = new XMLHttpRequest(); 25 | xhr.open('GET', '/users/' + encodeURIComponent(name) + '', true); 26 | xhr.setRequestHeader('Accept', 'application/json'); 27 | xhr.onreadystatechange = function () { 28 | var res = null; 29 | if (xhr.readyState === 4) { 30 | if (xhr.status === 204 || xhr.status === 205) { 31 | onSuccess(); 32 | } else if (xhr.status >= 200 && xhr.status < 300) { 33 | try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); } 34 | if (res) onSuccess(res); 35 | } else { 36 | try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); } 37 | if (res) onError(res); 38 | } 39 | } 40 | }; 41 | xhr.send(null); 42 | }; 43 | 44 | var postUsers = function(body, onSuccess, onError) { 45 | var xhr = new XMLHttpRequest(); 46 | xhr.open('POST', '/users', true); 47 | xhr.setRequestHeader('Accept', 'application/json'); 48 | xhr.setRequestHeader('Content-Type', 'application/json'); 49 | xhr.onreadystatechange = function () { 50 | var res = null; 51 | if (xhr.readyState === 4) { 52 | if (xhr.status === 204 || xhr.status === 205) { 53 | onSuccess(); 54 | } else if (xhr.status >= 200 && xhr.status < 300) { 55 | try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); } 56 | if (res) onSuccess(res); 57 | } else { 58 | try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); } 59 | if (res) onError(res); 60 | } 61 | } 62 | }; 63 | xhr.send(JSON.stringify(body)); 64 | }; 65 | 66 | var getMetrics = function(onSuccess, onError) { 67 | var xhr = new XMLHttpRequest(); 68 | xhr.open('GET', '/metrics', true); 69 | xhr.setRequestHeader('Accept', 'application/json'); 70 | xhr.onreadystatechange = function () { 71 | var res = null; 72 | if (xhr.readyState === 4) { 73 | if (xhr.status === 204 || xhr.status === 205) { 74 | onSuccess(); 75 | } else if (xhr.status >= 200 && xhr.status < 300) { 76 | try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); } 77 | if (res) onSuccess(res); 78 | } else { 79 | try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); } 80 | if (res) onError(res); 81 | } 82 | } 83 | }; 84 | xhr.send(null); 85 | }; 86 | -------------------------------------------------------------------------------- /assets/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | perservant 5 | 6 | 7 | 8 |

Perservant

9 | 10 | 11 | 12 |
13 | 14 | 17 |
18 |

Pop up a specific user name's email!

19 | 20 | 21 | 69 | 70 | 71 | -------------------------------------------------------------------------------- /config/keter.yml: -------------------------------------------------------------------------------- 1 | exec: ../perservant 2 | host: your.host.name.com 3 | 4 | plugins: 5 | postgres: true 6 | -------------------------------------------------------------------------------- /deploy.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | set -e 4 | echo "Building Perservant..." 5 | stack build 6 | strip `stack exec -- which perservant` 7 | echo "Creating bundle..." 8 | cp `stack exec -- which perservant` perservant 9 | tar -czvf perservant.keter perservant config ql-ui/assets 10 | rm perservant 11 | # scp ./perservant.keter user@host:/opt/keter/incoming/perservant.keter 12 | rm perservant.keter 13 | -------------------------------------------------------------------------------- /servant-persistent.cabal: -------------------------------------------------------------------------------- 1 | name: servant-persistent 2 | version: 0.2.0.0 3 | synopsis: Brief example on using persistent with servant 4 | description: Brief example on using persistent with servant 5 | license: MIT 6 | license-file: LICENSE 7 | author: Matt Parsons 8 | maintainer: parsonsmatt@gmail.com 9 | copyright: 2016 Matt Parsons 10 | category: Web 11 | build-type: Simple 12 | cabal-version: >=1.18 13 | 14 | source-repository head 15 | type: 16 | git 17 | location: 18 | https://www.github.com/parsonsmatt/servant-persistent 19 | 20 | executable perservant 21 | main-is: 22 | Main.hs 23 | build-depends: 24 | base >= 4.9 && < 5.0 25 | , servant-persistent 26 | , persistent-postgresql 27 | , wai 28 | , warp 29 | , monad-logger 30 | , safe 31 | , safe-exceptions 32 | , monad-metrics 33 | , wai-middleware-metrics 34 | , microlens 35 | , ekg 36 | , ekg-core 37 | , say 38 | hs-source-dirs: 39 | app 40 | default-language: 41 | Haskell2010 42 | ghc-options: 43 | -fwarn-unused-imports 44 | 45 | library 46 | default-language: 47 | Haskell2010 48 | hs-source-dirs: 49 | src 50 | exposed-modules: 51 | Config 52 | , Init 53 | , Models 54 | , Api 55 | , Api.User 56 | , Logger 57 | , DevelMain 58 | build-depends: 59 | base >= 4.9 && < 5.0 60 | , aeson 61 | , bytestring 62 | , containers 63 | , ekg 64 | , ekg-core 65 | , fast-logger 66 | , foreign-store 67 | , katip >= 0.5.0.2 && < 0.7 68 | , microlens 69 | , monad-control 70 | , monad-logger 71 | , monad-metrics 72 | , mtl 73 | , persistent 74 | , persistent-postgresql 75 | , persistent-template 76 | , safe 77 | , safe-exceptions 78 | , say 79 | , servant >= 0.13 && < 0.15 80 | , servant-js >= 0.9 && < 0.10 81 | , servant-server >= 0.13 && < 0.15 82 | , text 83 | , transformers 84 | , unordered-containers 85 | , wai 86 | , wai-extra 87 | , wai-middleware-metrics 88 | , warp 89 | , resource-pool 90 | ghc-options: 91 | -fwarn-unused-imports 92 | 93 | test-suite servant-persistent-test 94 | type: 95 | exitcode-stdio-1.0 96 | hs-source-dirs: 97 | test 98 | main-is: 99 | Spec.hs 100 | other-modules: 101 | ApiSpec 102 | UserDbSpec 103 | build-depends: 104 | base 105 | , persistent 106 | , persistent-postgresql 107 | , servant-persistent 108 | , servant >= 0.13 && < 0.14 109 | , servant-server >= 0.13 && < 0.14 110 | , QuickCheck 111 | , hspec 112 | , mtl 113 | , transformers 114 | , text 115 | , monad-metrics 116 | ghc-options: 117 | -threaded -rtsopts -with-rtsopts=-N -fwarn-unused-imports 118 | default-language: 119 | Haskell2010 120 | -------------------------------------------------------------------------------- /src/Api.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | 4 | module Api (app) where 5 | 6 | import Control.Monad.Reader (runReaderT) 7 | import Servant 8 | ( (:<|>)((:<|>)) 9 | , Proxy(Proxy) 10 | , Raw 11 | , Server 12 | , serve 13 | , serveDirectoryFileServer 14 | ) 15 | import Servant.Server 16 | 17 | import Api.User (UserAPI, userApi, userServer) 18 | import Config (AppT(..), Config(..)) 19 | 20 | -- | This is the function we export to run our 'UserAPI'. Given 21 | -- a 'Config', we return a WAI 'Application' which any WAI compliant server 22 | -- can run. 23 | userApp :: Config -> Application 24 | userApp cfg = serve userApi (appToServer cfg) 25 | 26 | -- | This functions tells Servant how to run the 'App' monad with our 27 | -- 'server' function. 28 | appToServer :: Config -> Server UserAPI 29 | appToServer cfg = hoistServer userApi (convertApp cfg) userServer 30 | 31 | -- | This function converts our @'AppT' m@ monad into the @ExceptT ServantErr 32 | -- m@ monad that Servant's 'enter' function needs in order to run the 33 | -- application. 34 | convertApp :: Config -> AppT IO a -> Handler a 35 | convertApp cfg appt = Handler $ runReaderT (runApp appt) cfg 36 | 37 | -- | Since we also want to provide a minimal front end, we need to give 38 | -- Servant a way to serve a directory with HTML and JavaScript. This 39 | -- function creates a WAI application that just serves the files out of the 40 | -- given directory. 41 | files :: Server Raw 42 | files = serveDirectoryFileServer "assets" 43 | 44 | -- | Just like a normal API type, we can use the ':<|>' combinator to unify 45 | -- two different APIs and applications. This is a powerful tool for code 46 | -- reuse and abstraction! We need to put the 'Raw' endpoint last, since it 47 | -- always succeeds. 48 | type AppAPI = UserAPI :<|> Raw 49 | 50 | appApi :: Proxy AppAPI 51 | appApi = Proxy 52 | 53 | -- | Finally, this function takes a configuration and runs our 'UserAPI' 54 | -- alongside the 'Raw' endpoint that serves all of our files. 55 | app :: Config -> Application 56 | app cfg = 57 | serve appApi (appToServer cfg :<|> files) 58 | -------------------------------------------------------------------------------- /src/Api/User.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module Api.User where 6 | 7 | import Control.Monad.Except (MonadIO, liftIO) 8 | import Control.Monad.Logger (logDebugNS) 9 | import qualified Control.Monad.Metrics as Metrics 10 | import Data.Int (Int64) 11 | import Database.Persist.Postgresql 12 | (Entity(..), fromSqlKey, insert, selectFirst, selectList, (==.)) 13 | import Servant 14 | import Servant.JS (vanillaJS, writeJSForAPI) 15 | 16 | import Config (AppT(..)) 17 | import Control.Monad.Metrics (increment, metricsCounters) 18 | import Data.HashMap.Lazy (HashMap) 19 | import Data.IORef (readIORef) 20 | import Data.Text (Text) 21 | import Lens.Micro ((^.)) 22 | import Models (User(User), runDb, userEmail, userName) 23 | import qualified Models as Md 24 | import qualified System.Metrics.Counter as Counter 25 | 26 | type UserAPI = 27 | "users" :> Get '[JSON] [Entity User] 28 | :<|> "users" :> Capture "name" Text :> Get '[JSON] (Entity User) 29 | :<|> "users" :> ReqBody '[JSON] User :> Post '[JSON] Int64 30 | :<|> "metrics" :> Get '[JSON] (HashMap Text Int64) 31 | 32 | userApi :: Proxy UserAPI 33 | userApi = Proxy 34 | 35 | -- | The server that runs the UserAPI 36 | userServer :: MonadIO m => ServerT UserAPI (AppT m) 37 | userServer = allUsers :<|> singleUser :<|> createUser :<|> waiMetrics 38 | 39 | -- | Returns all users in the database. 40 | allUsers :: MonadIO m => AppT m [Entity User] 41 | allUsers = do 42 | increment "allUsers" 43 | logDebugNS "web" "allUsers" 44 | runDb (selectList [] []) 45 | 46 | -- | Returns a user by name or throws a 404 error. 47 | singleUser :: MonadIO m => Text -> AppT m (Entity User) 48 | singleUser str = do 49 | increment "singleUser" 50 | logDebugNS "web" "singleUser" 51 | maybeUser <- runDb (selectFirst [Md.UserName ==. str] []) 52 | case maybeUser of 53 | Nothing -> 54 | throwError err404 55 | Just person -> 56 | return person 57 | 58 | -- | Creates a user in the database. 59 | createUser :: MonadIO m => User -> AppT m Int64 60 | createUser p = do 61 | increment "createUser" 62 | logDebugNS "web" "creating a user" 63 | newUser <- runDb (insert (User (userName p) (userEmail p))) 64 | return $ fromSqlKey newUser 65 | 66 | -- | Return wai metrics as JSON 67 | waiMetrics :: MonadIO m => AppT m (HashMap Text Int64) 68 | waiMetrics = do 69 | increment "metrics" 70 | logDebugNS "web" "metrics" 71 | metr <- Metrics.getMetrics 72 | liftIO $ mapM Counter.read =<< readIORef (metr ^. metricsCounters) 73 | 74 | -- | Generates JavaScript to query the User API. 75 | generateJavaScript :: IO () 76 | generateJavaScript = 77 | writeJSForAPI (Proxy :: Proxy UserAPI) vanillaJS "./assets/api.js" 78 | 79 | -------------------------------------------------------------------------------- /src/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE StrictData, OverloadedStrings #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | 8 | module Config where 9 | 10 | import Control.Concurrent (ThreadId) 11 | import Control.Exception.Safe (throwIO) 12 | import Control.Monad.Except (ExceptT, MonadError) 13 | import Control.Monad.IO.Class 14 | import Control.Monad.Logger (MonadLogger(..)) 15 | import Control.Monad.Metrics (Metrics, MonadMetrics, getMetrics) 16 | import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, asks) 17 | import Control.Monad.Trans.Class 18 | import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) 19 | import qualified Data.ByteString.Char8 as BS 20 | import Data.Monoid ((<>)) 21 | import Database.Persist.Postgresql 22 | (ConnectionPool, ConnectionString, createPostgresqlPool) 23 | import Network.Wai (Middleware) 24 | import Network.Wai.Handler.Warp (Port) 25 | import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev) 26 | import Servant (ServantErr) 27 | import System.Environment (lookupEnv) 28 | 29 | import Logger 30 | 31 | -- | This type represents the effects we want to have for our application. 32 | -- We wrap the standard Servant monad with 'ReaderT Config', which gives us 33 | -- access to the application configuration using the 'MonadReader' 34 | -- interface's 'ask' function. 35 | -- 36 | -- By encapsulating the effects in our newtype, we can add layers to the 37 | -- monad stack without having to modify code that uses the current layout. 38 | newtype AppT m a 39 | = AppT 40 | { runApp :: ReaderT Config (ExceptT ServantErr m) a 41 | } deriving 42 | ( Functor, Applicative, Monad, MonadReader Config, MonadError ServantErr 43 | , MonadIO 44 | ) 45 | 46 | type App = AppT IO 47 | 48 | -- | The Config for our application is (for now) the 'Environment' we're 49 | -- running in and a Persistent 'ConnectionPool'. 50 | data Config 51 | = Config 52 | { configPool :: ConnectionPool 53 | , configEnv :: Environment 54 | , configMetrics :: Metrics 55 | , configEkgServer :: ThreadId 56 | , configLogEnv :: LogEnv 57 | , configPort :: Port 58 | } 59 | 60 | instance Monad m => MonadMetrics (AppT m) where 61 | getMetrics = asks Config.configMetrics 62 | 63 | -- | Katip instance for @AppT m@ 64 | instance MonadIO m => Katip (AppT m) where 65 | getLogEnv = asks configLogEnv 66 | localLogEnv = error "not implemented" 67 | 68 | -- | MonadLogger instance to use within @AppT m@ 69 | instance MonadIO m => MonadLogger (AppT m) where 70 | monadLoggerLog = adapt logMsg 71 | 72 | -- | MonadLogger instance to use in @makePool@ 73 | instance MonadIO m => MonadLogger (KatipT m) where 74 | monadLoggerLog = adapt logMsg 75 | 76 | -- | Right now, we're distinguishing between three environments. We could 77 | -- also add a @Staging@ environment if we needed to. 78 | data Environment 79 | = Development 80 | | Test 81 | | Production 82 | deriving (Eq, Show, Read) 83 | 84 | -- | This returns a 'Middleware' based on the environment that we're in. 85 | setLogger :: Environment -> Middleware 86 | setLogger Test = id 87 | setLogger Development = logStdoutDev 88 | setLogger Production = logStdout 89 | 90 | -- | Web request logger (currently unimplemented and unused). For inspiration 91 | -- see ApacheLogger from wai-logger package. 92 | katipLogger :: LogEnv -> Middleware 93 | katipLogger env app req respond = runKatipT env $ do 94 | -- todo: log proper request data 95 | logMsg "web" InfoS "todo: received some request" 96 | liftIO $ app req respond 97 | 98 | -- | This function creates a 'ConnectionPool' for the given environment. 99 | -- For 'Development' and 'Test' environments, we use a stock and highly 100 | -- insecure connection string. The 'Production' environment acquires the 101 | -- information from environment variables that are set by the keter 102 | -- deployment application. 103 | makePool :: Environment -> LogEnv -> IO ConnectionPool 104 | makePool Test env = 105 | runKatipT env (createPostgresqlPool (connStr "-test") (envPool Test)) 106 | makePool Development env = 107 | runKatipT env $ createPostgresqlPool (connStr "") (envPool Development) 108 | makePool Production env = do 109 | -- This function makes heavy use of the 'MaybeT' monad transformer, which 110 | -- might be confusing if you're not familiar with it. It allows us to 111 | -- combine the effects from 'IO' and the effect of 'Maybe' into a single 112 | -- "big effect", so that when we bind out of @MaybeT IO a@, we get an 113 | -- @a@. If we just had @IO (Maybe a)@, then binding out of the IO would 114 | -- give us a @Maybe a@, which would make the code quite a bit more 115 | -- verbose. 116 | pool <- runMaybeT $ do 117 | let keys = [ "host=" 118 | , "port=" 119 | , "user=" 120 | , "password=" 121 | , "dbname=" 122 | ] 123 | envs = [ "PGHOST" 124 | , "PGPORT" 125 | , "PGUSER" 126 | , "PGPASS" 127 | , "PGDATABASE" 128 | ] 129 | envVars <- traverse (MaybeT . lookupEnv) envs 130 | let prodStr = BS.intercalate " " . zipWith (<>) keys $ BS.pack <$> envVars 131 | lift $ runKatipT env $ createPostgresqlPool prodStr (envPool Production) 132 | case pool of 133 | -- If we don't have a correct database configuration, we can't 134 | -- handle that in the program, so we throw an IO exception. This is 135 | -- one example where using an exception is preferable to 'Maybe' or 136 | -- 'Either'. 137 | Nothing -> throwIO (userError "Database Configuration not present in environment.") 138 | Just a -> return a 139 | 140 | -- | The number of pools to use for a given environment. 141 | envPool :: Environment -> Int 142 | envPool Test = 1 143 | envPool Development = 1 144 | envPool Production = 8 145 | 146 | -- | A basic 'ConnectionString' for local/test development. Pass in either 147 | -- @""@ for 'Development' or @"test"@ for 'Test'. 148 | connStr :: BS.ByteString -> ConnectionString 149 | connStr sfx = "host=localhost dbname=perservant" <> sfx <> " user=test password=test port=5432" 150 | -------------------------------------------------------------------------------- /src/DevelMain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings,TypeApplications #-} 2 | 3 | -- | Running your app inside GHCi. 4 | -- 5 | -- > stack ghci 6 | -- 7 | -- To start your app, run: 8 | -- 9 | -- > :l DevelMain 10 | -- > DevelMain.update 11 | -- 12 | -- You can also call @DevelMain.shutdown@ to stop the app 13 | -- 14 | -- There is more information about this approach, 15 | -- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci 16 | 17 | module DevelMain where 18 | 19 | import Prelude 20 | 21 | import Data.Typeable 22 | import qualified Data.Text as Text 23 | import Data.Text (Text) 24 | import System.IO 25 | import Control.Concurrent 26 | import Control.Exception.Safe 27 | import Control.Monad 28 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 29 | import Foreign.Store (Store(..), lookupStore, readStore, storeAction, withStore) 30 | import GHC.Word (Word32) 31 | import Init (runAppDevel) 32 | import Say 33 | import Data.Monoid 34 | 35 | tshow :: Show a => a -> Text 36 | tshow = Text.pack . show 37 | 38 | -- | Start or restart the server. 39 | -- newStore is from foreign-store. 40 | -- A Store holds onto some data across ghci reloads 41 | update :: IO () 42 | update = do 43 | hSetBuffering stdout NoBuffering 44 | hSetBuffering stderr NoBuffering 45 | mtidStore <- lookupStore tidStoreNum 46 | case mtidStore of 47 | Nothing -> do 48 | say "no server running" 49 | done <- storeAction doneStore newEmptyMVar 50 | tid <- start done 51 | _ <- storeAction (Store tidStoreNum) (newIORef tid) 52 | return () 53 | Just tidStore -> do 54 | say "restarting app..." 55 | restartAppInNewThread tidStore 56 | where 57 | doneStore :: Store (MVar ()) 58 | doneStore = Store 0 59 | 60 | -- shut the server down with killThread and wait for the done signal 61 | restartAppInNewThread :: Store (IORef ThreadId) -> IO () 62 | restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do 63 | say $ "killing thread: " <> tshow tid 64 | killThread tid 65 | say $ "taking mvar" 66 | withStore doneStore takeMVar 67 | readStore doneStore >>= start 68 | 69 | 70 | -- | Start the server in a separate thread. 71 | start :: MVar () -- ^ Written to when the thread is killed. 72 | -> IO ThreadId 73 | start done = 74 | myThreadId <* (do 75 | say "in forkFinally" 76 | runAppDevel `catch` \(SomeException e) -> do 77 | say "!!! exception in runAppDevel !!!" 78 | say $ "X exception type: " <> tshow (typeOf e) 79 | say $ "X exception : " <> tshow e 80 | say "runAppDevel terminated" 81 | ) 82 | `catch` 83 | (\(SomeException err) -> do 84 | say "finally action" 85 | hFlush stdout 86 | hFlush stderr 87 | putMVar done () 88 | say $ "Got Exception: " <> tshow err 89 | throwIO err 90 | ) 91 | `finally` 92 | (do 93 | say "finally action" 94 | hFlush stdout 95 | hFlush stderr 96 | putMVar done () 97 | ) 98 | 99 | -- | kill the server 100 | shutdown :: IO () 101 | shutdown = do 102 | mtidStore <- lookupStore tidStoreNum 103 | case mtidStore of 104 | -- no server running 105 | Nothing -> say "no app running" 106 | Just tidStore -> do 107 | withStore tidStore $ readIORef >=> killThread 108 | say "App is shutdown" 109 | 110 | tidStoreNum :: Word32 111 | tidStoreNum = 1 112 | 113 | modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO () 114 | modifyStoredIORef store f = withStore store $ \ref -> do 115 | v <- readIORef ref 116 | f v >>= writeIORef ref 117 | -------------------------------------------------------------------------------- /src/Init.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, OverloadedStrings #-} 2 | 3 | 4 | module Init where 5 | 6 | import Data.Typeable 7 | import qualified Data.Text as Text 8 | import Data.Text (Text) 9 | import Control.Monad.Logger 10 | import Control.Concurrent (killThread) 11 | import qualified Control.Monad.Metrics as M 12 | import Database.Persist.Postgresql (runSqlPool) 13 | import Lens.Micro ((^.)) 14 | import Network.Wai (Application) 15 | import Network.Wai.Metrics (metrics, registerWaiMetrics) 16 | import System.Environment (lookupEnv) 17 | import System.Remote.Monitoring (forkServer, serverMetricStore, serverThreadId) 18 | import Say 19 | import Data.Monoid 20 | import Control.Exception.Safe 21 | 22 | import Api (app) 23 | import Api.User (generateJavaScript) 24 | import Config (Config(..), Environment(..), makePool, setLogger) 25 | import qualified Data.Pool as Pool 26 | import qualified Katip 27 | import Logger (defaultLogEnv) 28 | import Models (doMigrations) 29 | import Network.Wai.Handler.Warp (run) 30 | import Safe (readMay) 31 | 32 | -- | An action that creates a WAI 'Application' together with its resources, 33 | -- runs it, and tears it down on exit 34 | runAppDevel :: IO () 35 | runAppDevel = do 36 | say "in runAppDevel" 37 | withConfig $ \config -> do 38 | say "acquired config" 39 | cfg <- initialize config 40 | `finally` say "exited: initialize config" 41 | say "post-initialize" 42 | run (configPort config) cfg 43 | `finally` say "server is closed" 44 | 45 | 46 | -- | The 'initialize' function accepts the required environment information, 47 | -- initializes the WAI 'Application' and returns it 48 | initialize :: Config -> IO Application 49 | initialize cfg = do 50 | say "initialize" 51 | waiMetrics <- registerWaiMetrics (configMetrics cfg ^. M.metricsStore) 52 | say "wai metrics" 53 | let logger = setLogger (configEnv cfg) 54 | say "run migrations" 55 | bracket 56 | (say "starting to run migrations") 57 | (\_ -> say "migrations complete") 58 | $ \_ -> do 59 | say "actually running migrations" 60 | runSqlPool doMigrations (configPool cfg) `catch` \(SomeException e) -> do 61 | say $ mconcat 62 | [ "exception in doMigrations, type: " 63 | , tshow (typeOf e) 64 | , ", shown: " 65 | , tshow e 66 | ] 67 | throwIO e 68 | say "okay all done" 69 | 70 | say "generate js" 71 | generateJavaScript 72 | say "making app" 73 | pure . logger . metrics waiMetrics . app $ cfg 74 | 75 | withConfig :: (Config -> IO a) -> IO a 76 | withConfig action = do 77 | say "acquireConfig" 78 | port <- lookupSetting "PORT" 8081 79 | say $ "on port:" <> tshow port 80 | env <- lookupSetting "ENV" Development 81 | say $ "on env: " <> tshow env 82 | bracket defaultLogEnv (\x -> say "closing katip scribes" >> Katip.closeScribes x) $ \logEnv -> do 83 | say $ "got log env" 84 | !pool <- makePool env logEnv `onException` say "exception in makePool" 85 | say $ "got pool " 86 | bracket (forkServer "localhost" 8082) (\x -> say "closing ekg" >> do killThread $ serverThreadId x) $ \ekgServer -> do 87 | say "forked ekg server" 88 | let store = serverMetricStore ekgServer 89 | waiMetrics <- registerWaiMetrics store `onException` say "exception in registerWaiMetrics" 90 | say "registered wai metrics" 91 | metr <- M.initializeWith store 92 | say "got metrics" 93 | action Config 94 | { configPool = pool 95 | , configEnv = env 96 | , configMetrics = metr 97 | , configLogEnv = logEnv 98 | , configPort = port 99 | , configEkgServer = serverThreadId ekgServer 100 | } 101 | 102 | -- | Takes care of cleaning up 'Config' resources 103 | shutdownApp :: Config -> IO () 104 | shutdownApp cfg = do 105 | Katip.closeScribes (configLogEnv cfg) 106 | Pool.destroyAllResources (configPool cfg) 107 | -- Monad.Metrics does not provide a function to destroy metrics store 108 | -- so, it'll hopefully get torn down when async exception gets thrown 109 | -- at metrics server process 110 | killThread (configEkgServer cfg) 111 | pure () 112 | 113 | -- | Looks up a setting in the environment, with a provided default, and 114 | -- 'read's that information into the inferred type. 115 | lookupSetting :: Read a => String -> a -> IO a 116 | lookupSetting env def = do 117 | maybeValue <- lookupEnv env 118 | case maybeValue of 119 | Nothing -> 120 | return def 121 | Just str -> 122 | maybe (handleFailedRead str) return (readMay str) 123 | where 124 | handleFailedRead str = 125 | error $ mconcat 126 | [ "Failed to read [[" 127 | , str 128 | , "]] for environment variable " 129 | , env 130 | ] 131 | 132 | tshow :: Show a => a -> Text 133 | tshow = Text.pack . show 134 | 135 | -------------------------------------------------------------------------------- /src/Logger.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Logger 3 | ( adapt 4 | , defaultLogEnv 5 | , logMsg 6 | , runKatipT 7 | , KatipT(..) 8 | , Katip(..) 9 | , LogEnv 10 | , Severity(..) 11 | ) where 12 | 13 | import Control.Monad.Logger 14 | import qualified Control.Monad.Logger as Logger 15 | import Katip 16 | import qualified System.IO as IO 17 | import qualified System.Log.FastLogger as FastLogger 18 | 19 | defaultLogEnv :: IO LogEnv 20 | defaultLogEnv = do 21 | handleScribe <- mkHandleScribe ColorIfTerminal IO.stdout DebugS V2 22 | env <- initLogEnv "servant-persistent" "production" 23 | registerScribe "stdout" handleScribe defaultScribeSettings env 24 | 25 | fromLevel :: LogLevel -> Severity 26 | fromLevel LevelDebug = DebugS 27 | fromLevel LevelInfo = InfoS 28 | fromLevel LevelWarn = WarningS 29 | fromLevel LevelError = ErrorS 30 | fromLevel (LevelOther _) = NoticeS 31 | 32 | -- | Transforms Katip logMsg into monadLoggerLog to be used inside 33 | -- MonadLogger monad 34 | adapt :: (ToLogStr msg, Applicative m, Katip m) => 35 | (Namespace -> Severity -> Katip.LogStr -> m ()) -> 36 | Loc -> LogSource -> LogLevel -> msg -> m () 37 | adapt f _ src lvl msg = 38 | f ns (fromLevel lvl) $ logStr' msg 39 | where 40 | ns = Namespace [src] 41 | -- not sure how fast this is going to be 42 | logStr' = Katip.logStr . FastLogger.fromLogStr . Logger.toLogStr 43 | -------------------------------------------------------------------------------- /src/Models.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE EmptyDataDecls #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | 14 | module Models where 15 | 16 | import Control.Monad.Reader (MonadIO, MonadReader, asks, liftIO) 17 | import Database.Persist.Sql (SqlPersistT, runMigration, runSqlPool) 18 | import Database.Persist.TH 19 | (mkMigrate, mkPersist, persistLowerCase, share, sqlSettings) 20 | 21 | import Control.Exception.Safe 22 | import Say 23 | import Config (Config, configPool) 24 | import Data.Text (Text) 25 | 26 | share 27 | [ mkPersist sqlSettings 28 | , mkMigrate "migrateAll" 29 | ] [persistLowerCase| 30 | User json 31 | name Text 32 | email Text 33 | deriving Show Eq 34 | |] 35 | 36 | doMigrations :: SqlPersistT IO () 37 | doMigrations = do 38 | liftIO $ say "in doMigrations, running?" 39 | runMigration migrateAll 40 | liftIO $ say "already run" 41 | 42 | runDb :: (MonadReader Config m, MonadIO m) => SqlPersistT IO b -> m b 43 | runDb query = do 44 | pool <- asks configPool 45 | liftIO $ runSqlPool query pool 46 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - katip-0.6.3.0 6 | resolver: lts-12.26 7 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | pantry-tree: 9 | sha256: f0fc7a19f21f364f7b3950a6450dc59c0700aa6a20a8320034f98e17df02aa30 10 | size: 1140 11 | hackage: katip-0.6.3.0@sha256:26948b73c7a9815516f46287eb44835fe452854b6ffd486524e5ed5e909562bf,4272 12 | original: 13 | hackage: katip-0.6.3.0 14 | snapshots: 15 | - completed: 16 | sha256: 95f014df58d0679b1c4a2b7bf2b652b61da8d30de5f571abb0d59015ef678646 17 | size: 509471 18 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/26.yaml 19 | original: lts-12.26 20 | -------------------------------------------------------------------------------- /stylish-haskell.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -Eeux 4 | 5 | # modified files 6 | git diff --name-status origin/master \ 7 | | grep .hs \ 8 | | grep "^M" \ 9 | | cut -f 2 \ 10 | | xargs stylish-haskell --inplace 11 | 12 | # added files 13 | git diff --name-status origin/master \ 14 | | grep .hs \ 15 | | grep "^A" \ 16 | | cut -f 2 \ 17 | | xargs stylish-haskell --inplace 18 | 19 | # renamed files 20 | git diff --name-status origin/master \ 21 | | grep .hs \ 22 | | grep "^R" \ 23 | | cut -f 3 \ 24 | | xargs stylish-haskell --inplace 25 | 26 | -------------------------------------------------------------------------------- /test/ApiSpec.hs: -------------------------------------------------------------------------------- 1 | module ApiSpec where 2 | 3 | import Test.Hspec 4 | import Test.QuickCheck 5 | 6 | spec :: Spec 7 | spec = do 8 | describe "Test suite works" $ do 9 | it "passes" $ do 10 | 5 `shouldBe` (5 :: Int) 11 | it "does properties" $ property $ \x -> 12 | x + 1 > (x :: Int) 13 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/UserDbSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module UserDbSpec where 6 | 7 | import Test.Hspec 8 | 9 | import Control.Exception (throwIO) 10 | import Control.Monad.Except (runExceptT) 11 | import Control.Monad.Reader (runReaderT) 12 | 13 | import Database.Persist.Postgresql (Entity(..), deleteWhere, insert, runSqlPool) 14 | import Database.Persist.Sql (ConnectionPool) 15 | import Database.Persist.Types (Filter) 16 | 17 | import Api.User 18 | import Config (App, AppT(..), Config(..), Environment(..), makePool) 19 | import qualified Data.Text as T 20 | import Logger (defaultLogEnv) 21 | import Models 22 | import Init 23 | 24 | runAppToIO :: Config -> App a -> IO a 25 | runAppToIO config app = do 26 | result <- runExceptT $ runReaderT (runApp app) config 27 | case result of 28 | Left err -> throwIO err 29 | Right a -> return a 30 | 31 | setupTeardown :: (Config -> IO a) -> IO () 32 | setupTeardown runTestsWith = do 33 | cfg <- acquireConfig 34 | env <- defaultLogEnv 35 | pool <- makePool Test env 36 | migrateDb pool 37 | runTestsWith cfg 38 | { configEnv = Test 39 | , configPool = pool 40 | } 41 | cleanDb pool 42 | where 43 | migrateDb :: ConnectionPool -> IO () 44 | migrateDb pool = runSqlPool doMigrations pool 45 | cleanDb :: ConnectionPool -> IO () 46 | cleanDb = deleteAllUsers 47 | deleteAllUsers :: ConnectionPool -> IO () 48 | deleteAllUsers pool = do 49 | flip runSqlPool pool $ do deleteWhere ([] :: [Filter User]) 50 | 51 | -- for more detail, see `src/Config.hs`, but this assumes you have... 52 | -- 1. a Postgres `test` user 53 | -- 2. a `perservant-test` DB 54 | spec :: Spec 55 | spec = 56 | around setupTeardown $ do 57 | describe "User" $ do 58 | it "singleUser fetches User by name" $ \config -> do 59 | let user = User (T.pack "username") (T.pack "email") 60 | dbUser <- 61 | runAppToIO config $ do 62 | runDb $ insert user 63 | Entity _ user <- singleUser (T.pack "username") 64 | return user 65 | dbUser `shouldBe` user 66 | --------------------------------------------------------------------------------