├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── default.nix ├── example └── Site.hs ├── resources ├── auth │ └── devel.cfg └── db │ └── devel.cfg ├── snaplet-postgresql-simple.cabal └── src └── Snap └── Snaplet ├── Auth └── Backends │ └── PostgresqlSimple.hs ├── PostgresqlSimple.hs └── PostgresqlSimple └── Internal.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | dist/ 3 | dist-newstyle/ 4 | *.swp 5 | .cabal-sandbox/ 6 | cabal.sandbox.config 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci 'snaplet-postgresql-simple.cabal' '--output' '.travis.yml' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.10.3 12 | # 13 | version: ~> 1.0 14 | language: c 15 | os: linux 16 | dist: xenial 17 | git: 18 | # whether to recursively clone submodules 19 | submodules: false 20 | cache: 21 | directories: 22 | - $HOME/.cabal/packages 23 | - $HOME/.cabal/store 24 | - $HOME/.hlint 25 | before_cache: 26 | - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log 27 | # remove files that are regenerated by 'cabal update' 28 | - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* 29 | - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json 30 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache 31 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar 32 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx 33 | - rm -rfv $CABALHOME/packages/head.hackage 34 | jobs: 35 | include: 36 | - compiler: ghc-8.10.2 37 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.2","cabal-install-3.2"]}} 38 | os: linux 39 | - compiler: ghc-8.8.3 40 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2"]}} 41 | os: linux 42 | - compiler: ghc-8.6.4 43 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.4","cabal-install-3.2"]}} 44 | os: linux 45 | - compiler: ghc-8.4.3 46 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.3","cabal-install-3.2"]}} 47 | os: linux 48 | - compiler: ghc-8.2.2 49 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.2"]}} 50 | os: linux 51 | - compiler: ghc-8.0.2 52 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.2"]}} 53 | os: linux 54 | - compiler: ghc-7.10.3 55 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.10.3","cabal-install-3.2"]}} 56 | os: linux 57 | - compiler: ghc-7.8.4 58 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.8.4","cabal-install-3.2"]}} 59 | os: linux 60 | before_install: 61 | - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') 62 | - WITHCOMPILER="-w $HC" 63 | - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') 64 | - HCPKG="$HC-pkg" 65 | - unset CC 66 | - CABAL=/opt/ghc/bin/cabal 67 | - CABALHOME=$HOME/.cabal 68 | - export PATH="$CABALHOME/bin:$PATH" 69 | - TOP=$(pwd) 70 | - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" 71 | - echo $HCNUMVER 72 | - CABAL="$CABAL -vnormal+nowrap" 73 | - set -o pipefail 74 | - TEST=--enable-tests 75 | - BENCH=--enable-benchmarks 76 | - HEADHACKAGE=false 77 | - rm -f $CABALHOME/config 78 | - | 79 | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config 80 | echo "remote-build-reporting: anonymous" >> $CABALHOME/config 81 | echo "write-ghc-environment-files: always" >> $CABALHOME/config 82 | echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config 83 | echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config 84 | echo "world-file: $CABALHOME/world" >> $CABALHOME/config 85 | echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config 86 | echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config 87 | echo "installdir: $CABALHOME/bin" >> $CABALHOME/config 88 | echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config 89 | echo "store-dir: $CABALHOME/store" >> $CABALHOME/config 90 | echo "install-dirs user" >> $CABALHOME/config 91 | echo " prefix: $CABALHOME" >> $CABALHOME/config 92 | echo "repository hackage.haskell.org" >> $CABALHOME/config 93 | echo " url: http://hackage.haskell.org/" >> $CABALHOME/config 94 | install: 95 | - ${CABAL} --version 96 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 97 | - | 98 | echo "program-default-options" >> $CABALHOME/config 99 | echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config 100 | - cat $CABALHOME/config 101 | - rm -fv cabal.project cabal.project.local cabal.project.freeze 102 | - travis_retry ${CABAL} v2-update -v 103 | # Generate cabal.project 104 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 105 | - touch cabal.project 106 | - | 107 | echo "packages: ." >> cabal.project 108 | - if [ $HCNUMVER -ge 80200 ] ; then echo 'package snaplet-postgresql-simple' >> cabal.project ; fi 109 | - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" 110 | - | 111 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(snaplet-postgresql-simple)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 112 | - cat cabal.project || true 113 | - cat cabal.project.local || true 114 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 115 | - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} 116 | - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 117 | - rm cabal.project.freeze 118 | - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all 119 | - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all 120 | script: 121 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 122 | # Packaging... 123 | - ${CABAL} v2-sdist all 124 | # Unpacking... 125 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 126 | - cd ${DISTDIR} || false 127 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; 128 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; 129 | - PKGDIR_snaplet_postgresql_simple="$(find . -maxdepth 1 -type d -regex '.*/snaplet-postgresql-simple-[0-9.]*')" 130 | # Generate cabal.project 131 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 132 | - touch cabal.project 133 | - | 134 | echo "packages: ${PKGDIR_snaplet_postgresql_simple}" >> cabal.project 135 | - if [ $HCNUMVER -ge 80200 ] ; then echo 'package snaplet-postgresql-simple' >> cabal.project ; fi 136 | - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" 137 | - | 138 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(snaplet-postgresql-simple)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 139 | - cat cabal.project || true 140 | - cat cabal.project.local || true 141 | # Building... 142 | # this builds all libraries and executables (without tests/benchmarks) 143 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 144 | # Building with tests and benchmarks... 145 | # build & run tests, build benchmarks 146 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all 147 | # cabal check... 148 | - (cd ${PKGDIR_snaplet_postgresql_simple} && ${CABAL} -vnormal check) 149 | # haddock... 150 | - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all 151 | # Building without installed constraints for packages in global-db... 152 | - rm -f cabal.project.local 153 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 154 | 155 | # REGENDATA ("0.10.3",["snaplet-postgresql-simple.cabal","--output",".travis.yml"]) 156 | # EOF 157 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 1.2.0.0 2 | 3 | * Removed ListT instance for HasPostgres, otherwise no other breaking changes 4 | 5 | # 0.6.1 6 | 7 | * Add HasPostgres passthrough inst 8 | 9 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Doug Beardsley 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | Redistributions in binary form must reproduce the above copyright notice, this 11 | list of conditions and the following disclaimer in the documentation and/or 12 | other materials provided with the distribution. 13 | 14 | Neither the name of the authors nor the names of its contributors may be used 15 | to endorse or promote products derived from this software without specific 16 | prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | snaplet-postgresql-simple 2 | ========================= 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/snaplet-postgresql-simple.svg)](https://hackage.haskell.org/package/snaplet-postgresql-simple) 5 | [![Build Status](https://travis-ci.org/mightybyte/snaplet-postgresql-simple.svg?branch=master)](https://travis-ci.org/mightybyte/snaplet-postgresql-simple) 6 | 7 | Quick and easy postgresql support for snap applications. 8 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./snaplet-postgresql-simple.cabal 2 | 3 | source-repository-package 4 | type: git 5 | location: https://github.com/uffizio/snap.git 6 | tag: master 7 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | # To pin to a specific version of nixpkgs, you can substitute with: 2 | # `(builtins.fetchTarball "https://github.com/NixOS/nixpkgs/archive/.tar.gz")` 3 | { compiler ? "ghc841" 4 | , pkgs ? import (builtins.fetchTarball "https://github.com/NixOS/nixpkgs/archive/d3f070fa995756ef5fdf866324f86cfa0472a5d3.tar.gz") {} }: 5 | pkgs.haskell.packages.${compiler}.developPackage { 6 | root = ./.; 7 | overrides = self: super: with pkgs.haskell.lib; { 8 | # Don't run a package's test suite 9 | heist = dontCheck (doJailbreak super.heist); 10 | threads = dontCheck (doJailbreak super.threads); 11 | postgresql-simple = dontCheck (doJailbreak super.postgresql-simple); 12 | 13 | # Don't enforce package's version constraints 14 | # bar = pkgs.haskell.lib.doJailbreak pkgs.haskellPackages.bar; 15 | # 16 | # To discover more functions that can be used to modify haskell 17 | # packages, run "nix-repl", type "pkgs.haskell.lib.", then hit 18 | # to get a tab-completed list of functions. 19 | }; 20 | source-overrides = { 21 | # Use a specific hackage version 22 | # postgresql-simple = "0.5.4.0"; 23 | # snap = "1.1.1.0"; 24 | 25 | # Use a particular commit from github 26 | heist = pkgs.fetchFromGitHub 27 | { owner = "snapframework"; 28 | repo = "heist"; 29 | rev = "3ccbec548830abce7ed7eba42c1c294b02b6cd52"; 30 | sha256 = "14sd4d4an7fj8yb4mr8cdallsv69x5jb1hd330sg10ahi1ryzspr"; 31 | }; 32 | io-streams-haproxy = pkgs.fetchFromGitHub 33 | { owner = "snapframework"; 34 | repo = "io-streams-haproxy"; 35 | rev = "a273d8873aadb3e84723be04df4de03fa3b27588"; 36 | sha256 = "0b8k29i23101mzakbfx1qvc760ihiv2igsfi0nyr4lq11qbc80ps"; 37 | }; 38 | map-syntax = pkgs.fetchFromGitHub 39 | { owner = "mightybyte"; 40 | repo = "map-syntax"; 41 | rev = "acebcf0a83ee639e1a0c49850b9c85821d53f621"; 42 | sha256 = "076knpvls1489gish9z30lhb21vqx44k366vc2i3kdql815v1vqv"; 43 | }; 44 | postgresql-libpq = pkgs.fetchFromGitHub 45 | { owner = "lpsmith"; 46 | repo = "postgresql-libpq"; 47 | rev = "2a401d5047ecbe89a200a9fdd421f8b51e4237d3"; 48 | sha256 = "11hxcdshic61w61xljpc4ls49d0ibyknbl0fripwxls456yawffm"; 49 | }; 50 | postgresql-simple = pkgs.fetchFromGitHub 51 | { owner = "hackage-trustees"; 52 | repo = "postgresql-simple"; 53 | rev = "0ff20911d647a27e9bd9d31bc06a5c62d882321c"; 54 | sha256 = "0kln85b6brllf5mb5mkyid18ps354ycksjqlcghxw2dbx470sz5h"; 55 | }; 56 | snap = pkgs.fetchFromGitHub 57 | { owner = "snapframework"; 58 | repo = "snap"; 59 | rev = "2fa933b52d7d126b59d89eddeed0e8a9d58d1d61"; 60 | sha256 = "002byv0iqmxj60c1q8ybnipvaqsjy7j7hv8rd7drdbc2cz422wlh"; 61 | }; 62 | snap-server = pkgs.fetchFromGitHub 63 | { owner = "snapframework"; 64 | repo = "snap-server"; 65 | rev = "deac24c293b910f253c273258484928891d2152e"; 66 | sha256 = "1bgknkiv6l2k4skja5q8nprdc1csawz85rjmvvzvmb23zr5gza8k"; 67 | }; 68 | }; 69 | } 70 | -------------------------------------------------------------------------------- /example/Site.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Main where 8 | 9 | ------------------------------------------------------------------------------ 10 | import Control.Applicative 11 | import Control.Monad.Trans 12 | import Control.Monad.Reader 13 | import Control.Monad.State 14 | import Data.ByteString (ByteString) 15 | import Control.Lens 16 | import Data.Maybe 17 | import qualified Data.Text as T 18 | import qualified Data.Text.Encoding as T 19 | import Data.Time.Clock 20 | import qualified Database.PostgreSQL.Simple as P 21 | import Snap 22 | import Snap.Snaplet.Auth 23 | import Snap.Snaplet.Auth.Backends.PostgresqlSimple 24 | import Snap.Snaplet.Heist 25 | import Snap.Snaplet.PostgresqlSimple 26 | import Snap.Snaplet.Session 27 | import Snap.Snaplet.Session.Backends.CookieSession 28 | import Snap.Util.FileServe 29 | import Heist 30 | import Text.XmlHtml hiding (render) 31 | 32 | 33 | ------------------------------------------------------------------------------ 34 | data App = App 35 | { _sess :: Snaplet SessionManager 36 | , _db :: Snaplet Postgres 37 | , _auth :: Snaplet (AuthManager App) 38 | } 39 | 40 | makeLenses ''App 41 | 42 | instance HasPostgres (Handler b App) where 43 | getPostgresState = with db get 44 | setLocalPostgresState s = local (set (db . snapletValue) s) 45 | 46 | ------------------------------------------------------------------------------ 47 | -- | The application's routes. 48 | routes :: [(ByteString, Handler App App ())] 49 | routes = [ ("/", writeText "hello") 50 | , ("foo", fooHandler) 51 | , ("add/:uname", addHandler) 52 | , ("find/:email", findHandler) 53 | ] 54 | 55 | fooHandler = do 56 | results <- query_ "select * from snap_auth_user" 57 | liftIO $ print (results :: [AuthUser]) 58 | 59 | addHandler = do 60 | mname <- getParam "uname" 61 | email <- getParam "email" 62 | let name = maybe "guest" T.decodeUtf8 mname 63 | u <- with auth $ do 64 | createUser name "" >>= \u -> case u of 65 | Left _ -> return u 66 | Right u' -> saveUser (u' {userEmail = T.decodeUtf8 <$> email}) 67 | liftIO $ print u 68 | 69 | findHandler = do 70 | email <- getParam "email" 71 | env <- with auth get 72 | liftIO $ lookupByEmail env (maybe "" T.decodeUtf8 email) >>= print 73 | 74 | ------------------------------------------------------------------------------ 75 | -- | The application initializer. 76 | app :: SnapletInit App App 77 | app = makeSnaplet "app" "An snaplet example application." Nothing $ do 78 | s <- nestSnaplet "" sess $ 79 | initCookieSessionManager "site_key.txt" "_cookie" Nothing Nothing 80 | d <- nestSnaplet "db" db pgsInit 81 | a <- nestSnaplet "auth" auth $ initPostgresAuth sess d 82 | addRoutes routes 83 | return $ App s d a 84 | 85 | 86 | main :: IO () 87 | main = serveSnaplet defaultConfig app 88 | 89 | -------------------------------------------------------------------------------- /resources/auth/devel.cfg: -------------------------------------------------------------------------------- 1 | # Currently this option is not enforced. See current auth documentation for 2 | # more information. 3 | minPasswordLen = 8 4 | 5 | # Name of the cookie to use for remembering the logged in user. 6 | rememberCookie = "_remember" 7 | 8 | # Number of seconds of inactivity before the user is logged out. If ommitted, 9 | # the user will remain logged in until the end of the session. 10 | rememberPeriod = 1209600 # 2 weeks 11 | 12 | # Lockout strategy. The first value is the max number of invalid login 13 | # attempts before lockout. The second value is how long the locked lasts. If 14 | # ommitted, then incorrect passwords will never result in lockout. 15 | # lockout = [5, 86400] 16 | 17 | # File where the auth encryption key is stored. 18 | siteKey = "site_key.txt" 19 | 20 | # Name of the table where the user data is stored. 21 | authTable = "snap_auth_user" 22 | -------------------------------------------------------------------------------- /resources/db/devel.cfg: -------------------------------------------------------------------------------- 1 | host = "localhost" 2 | port = 5432 3 | user = "postgres" 4 | pass = "" 5 | db = "testdb" 6 | 7 | # Number of distinct connection pools to maintain. The smallest acceptable 8 | # value is 1. 9 | numStripes = 1 10 | 11 | # Number of seconds an unused resource is kept open. The smallest acceptable 12 | # value is 0.5 seconds. 13 | idleTime = 5 14 | 15 | # Maximum number of resources to keep open per stripe. The smallest 16 | # acceptable value is 1. 17 | maxResourcesPerStripe = 20 18 | -------------------------------------------------------------------------------- /snaplet-postgresql-simple.cabal: -------------------------------------------------------------------------------- 1 | name: snaplet-postgresql-simple 2 | version: 1.2.0.0 3 | synopsis: postgresql-simple snaplet for the Snap Framework 4 | description: This snaplet contains support for using the Postgresql 5 | database with a Snap Framework application via the 6 | postgresql-simple package. It also includes an 7 | authentication backend. 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Doug Beardsley 11 | maintainer: mightybyte@gmail.com 12 | build-type: Simple 13 | cabal-version: >= 1.10 14 | homepage: https://github.com/mightybyte/snaplet-postgresql-simple 15 | category: Web, Snap 16 | 17 | tested-with: 18 | GHC == 7.8.4, 19 | GHC == 7.10.3, 20 | GHC == 8.0.2, 21 | GHC == 8.2.2, 22 | GHC == 8.4.3, 23 | GHC == 8.6.4, 24 | GHC == 8.8.3, 25 | GHC == 8.10.2 26 | 27 | extra-source-files: 28 | LICENSE 29 | README.md 30 | 31 | data-files: 32 | resources/db/devel.cfg 33 | resources/auth/devel.cfg 34 | 35 | source-repository head 36 | type: git 37 | location: https://github.com/mightybyte/snaplet-postgresql-simple.git 38 | 39 | 40 | flag Example 41 | description: Enable example 42 | default: False 43 | 44 | Library 45 | hs-source-dirs: src 46 | 47 | exposed-modules: 48 | Snap.Snaplet.PostgresqlSimple 49 | Snap.Snaplet.Auth.Backends.PostgresqlSimple 50 | 51 | other-modules: 52 | Snap.Snaplet.PostgresqlSimple.Internal 53 | Paths_snaplet_postgresql_simple 54 | 55 | build-depends: 56 | base >= 4 && < 4.15, 57 | bytestring >= 0.9.1 && < 0.11, 58 | clientsession >= 0.7.2 && < 0.10, 59 | configurator >= 0.2 && < 0.4, 60 | lens >= 3.7.6 && < 4.20, 61 | lifted-base >= 0.2 && < 0.3, 62 | monad-control >= 1.0 && < 1.1, 63 | mtl >= 2 && < 2.3, 64 | postgresql-simple >= 0.3 && < 0.7, 65 | resource-pool >= 0.2 && < 0.3, 66 | snap >= 1.0 && < 1.2, 67 | text >= 0.11 && < 1.3, 68 | transformers >= 0.2 && < 0.6, 69 | transformers-base >= 0.4 && < 0.5, 70 | unordered-containers >= 0.2 && < 0.3 71 | 72 | 73 | ghc-options: -Wall -fwarn-tabs -funbox-strict-fields 74 | -fno-warn-orphans -fno-warn-unused-do-bind 75 | 76 | default-language: Haskell2010 77 | 78 | executable Example 79 | if flag(Example) 80 | buildable: True 81 | else 82 | buildable: False 83 | build-depends: base, 84 | aeson, 85 | bytestring, 86 | heist, 87 | lens, 88 | postgresql-simple, 89 | mtl, 90 | snap, 91 | snap-core, 92 | snaplet-postgresql-simple, 93 | text, 94 | time, 95 | xmlhtml 96 | default-language: Haskell2010 97 | hs-source-dirs: example 98 | main-is: Site.hs 99 | -------------------------------------------------------------------------------- /src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | {-| 7 | 8 | This module allows you to use the auth snaplet with your user database stored 9 | in a PostgreSQL database. When you run your application with this snaplet, a 10 | config file will be copied into the the @snaplets/postgresql-auth@ directory. 11 | This file contains all of the configurable options for the snaplet and allows 12 | you to change them without recompiling your application. 13 | 14 | To use this snaplet in your application enable the session, postgres, and auth 15 | snaplets as follows: 16 | 17 | > data App = App 18 | > { ... -- your own application state here 19 | > , _sess :: Snaplet SessionManager 20 | > , _db :: Snaplet Postgres 21 | > , _auth :: Snaplet (A.AuthManager App) 22 | > } 23 | 24 | Then in your initializer you'll have something like this: 25 | 26 | > d <- nestSnaplet "db" db pgsInit 27 | > a <- nestSnaplet "auth" auth $ initPostgresAuth sess d 28 | 29 | If you have not already created the database table for users, it will 30 | automatically be created for you the first time you run your application. 31 | 32 | -} 33 | 34 | module Snap.Snaplet.Auth.Backends.PostgresqlSimple 35 | ( initPostgresAuth 36 | ) where 37 | 38 | ------------------------------------------------------------------------------ 39 | import Control.Applicative 40 | import qualified Control.Exception as E 41 | import Control.Lens ((^#)) 42 | import Control.Monad (liftM, void, when) 43 | import Control.Monad.Trans (liftIO) 44 | import qualified Data.Configurator as C 45 | import qualified Data.HashMap.Lazy as HM 46 | import Data.Maybe (fromMaybe, listToMaybe) 47 | import Data.Text (Text) 48 | import qualified Data.Text as T 49 | import qualified Data.Text.Encoding as T 50 | import qualified Database.PostgreSQL.Simple as P 51 | import Database.PostgreSQL.Simple.FromField (FromField, fromField) 52 | import qualified Database.PostgreSQL.Simple.ToField as P 53 | import Database.PostgreSQL.Simple.Types (Query (Query)) 54 | import Paths_snaplet_postgresql_simple 55 | import Prelude 56 | import Snap (Snaplet, SnapletInit, 57 | SnapletLens, 58 | getSnapletUserConfig, 59 | makeSnaplet, 60 | snapletValue) 61 | import qualified Snap.Snaplet.Auth as A 62 | import Snap.Snaplet.PostgresqlSimple (FromRow, Only, ToRow, 63 | field, fromRow) 64 | import Snap.Snaplet.PostgresqlSimple.Internal (Postgres, 65 | withConnection) 66 | import Snap.Snaplet.Session (SessionManager, mkRNG) 67 | import Web.ClientSession (getKey) 68 | ------------------------------------------------------------------------------ 69 | 70 | 71 | data PostgresAuthManager = PostgresAuthManager 72 | { pamTable :: AuthTable 73 | , pamConn :: Postgres 74 | } 75 | 76 | 77 | ------------------------------------------------------------------------------ 78 | -- | Initializer for the postgres backend to the auth snaplet. 79 | -- 80 | initPostgresAuth 81 | :: SnapletLens b SessionManager -- ^ Lens to the session snaplet 82 | -> Snaplet Postgres -- ^ The postgres snaplet 83 | -> SnapletInit b (A.AuthManager b) 84 | initPostgresAuth sess db = makeSnaplet "postgresql-auth" desc datadir $ do 85 | config <- getSnapletUserConfig 86 | authTable <- liftIO $ C.lookupDefault "snap_auth_user" config "authTable" 87 | authSettings <- A.authSettingsFromConfig 88 | key <- liftIO $ getKey (A.asSiteKey authSettings) 89 | let tableDesc = defAuthTable { tblName = authTable } 90 | let manager = PostgresAuthManager tableDesc $ db ^# snapletValue 91 | liftIO $ createTableIfMissing manager 92 | rng <- liftIO mkRNG 93 | return A.AuthManager 94 | { backend = manager 95 | , session = sess 96 | , activeUser = Nothing 97 | , minPasswdLen = A.asMinPasswdLen authSettings 98 | , rememberCookieName = A.asRememberCookieName authSettings 99 | , rememberCookieDomain = Nothing 100 | , rememberPeriod = A.asRememberPeriod authSettings 101 | , siteKey = key 102 | , lockout = A.asLockout authSettings 103 | , randomNumberGenerator = rng 104 | } 105 | where 106 | desc = "A PostgreSQL backend for user authentication" 107 | datadir = Just $ liftM (++"/resources/auth") getDataDir 108 | 109 | 110 | ------------------------------------------------------------------------------ 111 | -- | Create the user table if it doesn't exist. 112 | createTableIfMissing :: PostgresAuthManager -> IO () 113 | createTableIfMissing PostgresAuthManager{..} = do 114 | withConnection pamConn $ \conn -> do 115 | res <- P.query_ conn $ Query $ T.encodeUtf8 $ 116 | "select relname from pg_class where relname='" 117 | `T.append` schemaless (tblName pamTable) `T.append` "'" 118 | when (null (res :: [Only T.Text])) $ 119 | void (P.execute_ conn (Query $ T.encodeUtf8 q)) 120 | return () 121 | where 122 | schemaless = T.reverse . T.takeWhile (/='.') . T.reverse 123 | q = T.concat 124 | [ "CREATE TABLE \"" 125 | , tblName pamTable 126 | , "\" (" 127 | , T.intercalate "," (map (fDesc . ($pamTable) . fst) colDef) 128 | , "); " 129 | , "CREATE INDEX email_idx ON \"" 130 | , tblName pamTable 131 | , "\" (email);" 132 | ] 133 | 134 | buildUid :: Int -> A.UserId 135 | buildUid = A.UserId . T.pack . show 136 | 137 | 138 | instance FromField A.UserId where 139 | fromField f v = buildUid <$> fromField f v 140 | 141 | instance FromField A.Password where 142 | fromField f v = A.Encrypted <$> fromField f v 143 | 144 | instance FromRow A.AuthUser where 145 | fromRow = 146 | A.AuthUser 147 | <$> _userId 148 | <*> _userLogin 149 | <*> _userEmail 150 | <*> _userPassword 151 | <*> _userActivatedAt 152 | <*> _userSuspendedAt 153 | <*> _userRememberToken 154 | <*> _userLoginCount 155 | <*> _userFailedLoginCount 156 | <*> _userLockedOutUntil 157 | <*> _userCurrentLoginAt 158 | <*> _userLastLoginAt 159 | <*> _userCurrentLoginIp 160 | <*> _userLastLoginIp 161 | <*> _userCreatedAt 162 | <*> _userUpdatedAt 163 | <*> _userResetToken 164 | <*> _userResetRequestedAt 165 | <*> _userRoles 166 | <*> _userMeta 167 | where 168 | !_userId = field 169 | !_userLogin = field 170 | !_userEmail = field 171 | !_userPassword = field 172 | !_userActivatedAt = field 173 | !_userSuspendedAt = field 174 | !_userRememberToken = field 175 | !_userLoginCount = field 176 | !_userFailedLoginCount = field 177 | !_userLockedOutUntil = field 178 | !_userCurrentLoginAt = field 179 | !_userLastLoginAt = field 180 | !_userCurrentLoginIp = field 181 | !_userLastLoginIp = field 182 | !_userCreatedAt = field 183 | !_userUpdatedAt = field 184 | !_userResetToken = field 185 | !_userResetRequestedAt = field 186 | !_userRoles = pure [] 187 | !_userMeta = pure HM.empty 188 | 189 | 190 | querySingle :: (ToRow q, FromRow a) 191 | => Postgres -> Query -> q -> IO (Maybe a) 192 | querySingle pc q ps = withConnection pc $ \conn -> return . listToMaybe =<< 193 | P.query conn q ps 194 | 195 | authExecute :: ToRow q 196 | => Postgres -> Query -> q -> IO () 197 | authExecute pc q ps = do 198 | withConnection pc $ \conn -> P.execute conn q ps 199 | return () 200 | 201 | instance P.ToField A.Password where 202 | toField (A.ClearText bs) = P.toField bs 203 | toField (A.Encrypted bs) = P.toField bs 204 | 205 | 206 | -- | Datatype containing the names of the columns for the authentication table. 207 | data AuthTable 208 | = AuthTable 209 | { tblName :: Text 210 | , colId :: (Text, Text) 211 | , colLogin :: (Text, Text) 212 | , colEmail :: (Text, Text) 213 | , colPassword :: (Text, Text) 214 | , colActivatedAt :: (Text, Text) 215 | , colSuspendedAt :: (Text, Text) 216 | , colRememberToken :: (Text, Text) 217 | , colLoginCount :: (Text, Text) 218 | , colFailedLoginCount :: (Text, Text) 219 | , colLockedOutUntil :: (Text, Text) 220 | , colCurrentLoginAt :: (Text, Text) 221 | , colLastLoginAt :: (Text, Text) 222 | , colCurrentLoginIp :: (Text, Text) 223 | , colLastLoginIp :: (Text, Text) 224 | , colCreatedAt :: (Text, Text) 225 | , colUpdatedAt :: (Text, Text) 226 | , colResetToken :: (Text, Text) 227 | , colResetRequestedAt :: (Text, Text) 228 | , rolesTable :: Text 229 | } 230 | 231 | -- | Default authentication table layout 232 | defAuthTable :: AuthTable 233 | defAuthTable 234 | = AuthTable 235 | { tblName = "snap_auth_user" 236 | , colId = ("uid", "SERIAL PRIMARY KEY") 237 | , colLogin = ("login", "text UNIQUE NOT NULL") 238 | , colEmail = ("email", "text") 239 | , colPassword = ("password", "text") 240 | , colActivatedAt = ("activated_at", "timestamptz") 241 | , colSuspendedAt = ("suspended_at", "timestamptz") 242 | , colRememberToken = ("remember_token", "text") 243 | , colLoginCount = ("login_count", "integer NOT NULL") 244 | , colFailedLoginCount = ("failed_login_count", "integer NOT NULL") 245 | , colLockedOutUntil = ("locked_out_until", "timestamptz") 246 | , colCurrentLoginAt = ("current_login_at", "timestamptz") 247 | , colLastLoginAt = ("last_login_at", "timestamptz") 248 | , colCurrentLoginIp = ("current_login_ip", "text") 249 | , colLastLoginIp = ("last_login_ip", "text") 250 | , colCreatedAt = ("created_at", "timestamptz") 251 | , colUpdatedAt = ("updated_at", "timestamptz") 252 | , colResetToken = ("reset_token", "text") 253 | , colResetRequestedAt = ("reset_requested_at", "timestamptz") 254 | , rolesTable = "user_roles" 255 | } 256 | 257 | fDesc :: (Text, Text) -> Text 258 | fDesc f = fst f `T.append` " " `T.append` snd f 259 | 260 | -- | List of deconstructors so it's easier to extract column names from an 261 | -- 'AuthTable'. 262 | colDef :: [(AuthTable -> (Text, Text), A.AuthUser -> P.Action)] 263 | colDef = 264 | [ (colId , P.toField . fmap A.unUid . A.userId) 265 | , (colLogin , P.toField . A.userLogin) 266 | , (colEmail , P.toField . A.userEmail) 267 | , (colPassword , P.toField . A.userPassword) 268 | , (colActivatedAt , P.toField . A.userActivatedAt) 269 | , (colSuspendedAt , P.toField . A.userSuspendedAt) 270 | , (colRememberToken , P.toField . A.userRememberToken) 271 | , (colLoginCount , P.toField . A.userLoginCount) 272 | , (colFailedLoginCount, P.toField . A.userFailedLoginCount) 273 | , (colLockedOutUntil , P.toField . A.userLockedOutUntil) 274 | , (colCurrentLoginAt , P.toField . A.userCurrentLoginAt) 275 | , (colLastLoginAt , P.toField . A.userLastLoginAt) 276 | , (colCurrentLoginIp , P.toField . A.userCurrentLoginIp) 277 | , (colLastLoginIp , P.toField . A.userLastLoginIp) 278 | , (colCreatedAt , P.toField . A.userCreatedAt) 279 | , (colUpdatedAt , P.toField . A.userUpdatedAt) 280 | , (colResetToken , P.toField . A.userResetToken) 281 | , (colResetRequestedAt, P.toField . A.userResetRequestedAt) 282 | ] 283 | 284 | saveQuery :: AuthTable -> A.AuthUser -> (Text, [P.Action]) 285 | saveQuery atable u@A.AuthUser{..} = maybe insertQuery updateQuery userId 286 | where 287 | insertQuery = (T.concat [ "INSERT INTO " 288 | , tblName atable 289 | , " (" 290 | , T.intercalate "," cols 291 | , ") VALUES (" 292 | , T.intercalate "," vals 293 | , ") RETURNING " 294 | , T.intercalate "," (map (fst . ($atable) . fst) colDef) 295 | ] 296 | , params) 297 | qval f = fst (f atable) `T.append` " = ?" 298 | updateQuery uid = 299 | (T.concat [ "UPDATE " 300 | , tblName atable 301 | , " SET " 302 | , T.intercalate "," (map (qval . fst) $ tail colDef) 303 | , " WHERE " 304 | , fst (colId atable) 305 | , " = ? RETURNING " 306 | , T.intercalate "," (map (fst . ($atable) . fst) colDef) 307 | ] 308 | , params ++ [P.toField $ A.unUid uid]) 309 | cols = map (fst . ($atable) . fst) $ tail colDef 310 | vals = map (const "?") cols 311 | params = map (($u) . snd) $ tail colDef 312 | 313 | 314 | onFailure :: Monad m => E.SomeException -> m (Either A.AuthFailure a) 315 | onFailure e = return $ Left $ A.AuthError $ show e 316 | 317 | ------------------------------------------------------------------------------ 318 | -- | 319 | instance A.IAuthBackend PostgresAuthManager where 320 | save PostgresAuthManager{..} u@A.AuthUser{..} = do 321 | let (qstr, params) = saveQuery pamTable u 322 | let q = Query $ T.encodeUtf8 qstr 323 | let action = withConnection pamConn $ \conn -> do 324 | res <- P.query conn q params 325 | return $ Right $ fromMaybe u $ listToMaybe res 326 | E.catch action onFailure 327 | 328 | 329 | lookupByUserId PostgresAuthManager{..} uid = do 330 | let q = Query $ T.encodeUtf8 $ T.concat 331 | [ "select ", T.intercalate "," cols, " from " 332 | , tblName pamTable 333 | , " where " 334 | , fst (colId pamTable) 335 | , " = ?" 336 | ] 337 | querySingle pamConn q [A.unUid uid] 338 | where cols = map (fst . ($pamTable) . fst) colDef 339 | 340 | lookupByLogin PostgresAuthManager{..} login = do 341 | let q = Query $ T.encodeUtf8 $ T.concat 342 | [ "select ", T.intercalate "," cols, " from " 343 | , tblName pamTable 344 | , " where " 345 | , fst (colLogin pamTable) 346 | , " = ?" 347 | ] 348 | querySingle pamConn q [login] 349 | where cols = map (fst . ($pamTable) . fst) colDef 350 | 351 | #if MIN_VERSION_snap(1,1,0) 352 | lookupByEmail PostgresAuthManager{..} email = do 353 | let q = Query $ T.encodeUtf8 $ T.concat 354 | [ "select ", T.intercalate "," cols, " from " 355 | , tblName pamTable 356 | , " where " 357 | , fst (colEmail pamTable) 358 | , " = ?" 359 | ] 360 | querySingle pamConn q [email] 361 | where cols = map (fst . ($pamTable) . fst) colDef 362 | #endif 363 | 364 | lookupByRememberToken PostgresAuthManager{..} token = do 365 | let q = Query $ T.encodeUtf8 $ T.concat 366 | [ "select ", T.intercalate "," cols, " from " 367 | , tblName pamTable 368 | , " where " 369 | , fst (colRememberToken pamTable) 370 | , " = ?" 371 | ] 372 | querySingle pamConn q [token] 373 | where cols = map (fst . ($pamTable) . fst) colDef 374 | 375 | destroy PostgresAuthManager{..} A.AuthUser{..} = do 376 | let q = Query $ T.encodeUtf8 $ T.concat 377 | [ "delete from " 378 | , tblName pamTable 379 | , " where " 380 | , fst (colLogin pamTable) 381 | , " = ?" 382 | ] 383 | authExecute pamConn q [userLogin] 384 | 385 | -------------------------------------------------------------------------------- /src/Snap/Snaplet/PostgresqlSimple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | 8 | {-| 9 | 10 | This snaplet makes it simple to use a PostgreSQL database from your Snap 11 | application and is based on the excellent postgresql-simple library 12 | () by Leon Smith 13 | (adapted from Bryan O\'Sullivan\'s mysql-simple). Now, adding a database 14 | to your web app takes just two simple steps. 15 | 16 | First, include this snaplet in your application's state. 17 | 18 | > data App = App 19 | > { ... -- Other state needed in your app 20 | > , _db :: Snaplet Postgres 21 | > } 22 | 23 | Next, call the pgsInit from your application's initializer. 24 | 25 | > appInit = makeSnaplet ... $ do 26 | > ... 27 | > d <- nestSnaplet "db" db pgsInit 28 | > return $ App ... d 29 | 30 | Now you can use any of the postgresql-simple wrapper functions defined in this 31 | module anywhere in your application handlers. For instance: 32 | 33 | > postHandler :: Handler App App () 34 | > postHandler = do 35 | > posts <- with db $ query_ "select * from blog_post" 36 | > ... 37 | 38 | Optionally, if you find yourself doing many database queries, you can eliminate some of the boilerplate by defining a HasPostgres instance for your application. 39 | 40 | > instance HasPostgres (Handler b App) where 41 | > getPostgresState = with db get 42 | > setLocalPostgresState s = local (set (db . snapletValue) s) 43 | 44 | With this code, our postHandler example no longer requires the 'with' function: 45 | 46 | > postHandler :: Handler App App () 47 | > postHandler = do 48 | > posts <- query_ "select * from blog_post" 49 | > ... 50 | 51 | If you have code that runs multiple queries but you want to make sure that you only use one database connection then you can use the withPG function, like so: 52 | 53 | > postHandler :: Handler App App () 54 | > postHandler = withPG $ do 55 | > posts <- query_ "select * from blog_post" 56 | > links <- query_ "select * from links" 57 | > ... 58 | 59 | The first time you run an application with the postgresql-simple snaplet, a 60 | configuration file @devel.cfg@ is created in the @snaplets/postgresql-simple@ 61 | directory underneath your project root. It specifies how to connect to your 62 | PostgreSQL server and what user, password, and database to use. Edit this 63 | file and modify the values appropriately and you'll be off and running. 64 | 65 | If you want to have out-of-the-box authentication, look at the documentation 66 | for the "Snap.Snaplet.Auth.Backends.PostgresqlSimple" module. 67 | 68 | -} 69 | 70 | module Snap.Snaplet.PostgresqlSimple ( 71 | -- * The Snaplet 72 | Postgres(..) 73 | , HasPostgres(..) 74 | , PGSConfig(..) 75 | , pgsDefaultConfig 76 | , mkPGSConfig 77 | , pgsInit 78 | , pgsInit' 79 | , getConnectionString 80 | , withPG 81 | , P.Connection 82 | , liftPG 83 | , liftPG' 84 | 85 | -- * Wrappers and re-exports 86 | , query 87 | , query_ 88 | , fold 89 | , foldWithOptions 90 | , fold_ 91 | , foldWithOptions_ 92 | , forEach 93 | , forEach_ 94 | , execute 95 | , execute_ 96 | , executeMany 97 | , returning 98 | , withTransaction 99 | , withTransactionLevel 100 | , withTransactionMode 101 | , withTransactionEither 102 | , withTransactionModeEither 103 | , formatMany 104 | , formatQuery 105 | 106 | -- Re-exported from postgresql-simple 107 | , P.Query 108 | , P.In(..) 109 | , P.Binary(..) 110 | , P.Only(..) 111 | , P.SqlError(..) 112 | , P.FormatError(..) 113 | , P.QueryError(..) 114 | , P.ResultError(..) 115 | , P.TransactionMode(..) 116 | , P.IsolationLevel(..) 117 | , P.ReadWriteMode(..) 118 | , P.begin 119 | , P.beginLevel 120 | , P.beginMode 121 | , P.rollback 122 | , P.commit 123 | , (P.:.)(..) 124 | , ToRow(..) 125 | , FromRow(..) 126 | 127 | , P.defaultConnectInfo 128 | , P.defaultTransactionMode 129 | , P.defaultIsolationLevel 130 | , P.defaultReadWriteMode 131 | , field 132 | 133 | ) where 134 | 135 | import qualified Control.Exception as E 136 | import Control.Lens (set, (^#)) 137 | import Control.Monad (liftM) 138 | import Control.Monad.IO.Class (MonadIO, liftIO) 139 | import Control.Monad.Reader (ReaderT, ask, asks, 140 | local) 141 | import Control.Monad.State (get) 142 | import Control.Monad.Trans.Control (MonadBaseControl, 143 | liftBaseWith, restoreM) 144 | import Data.ByteString (ByteString) 145 | import qualified Data.Configurator as C 146 | import qualified Data.Configurator.Types as C 147 | import Data.Int (Int64) 148 | import Data.Monoid (Monoid (..), (<>)) 149 | import Data.Pool (createPool) 150 | import Data.Ratio (denominator, numerator) 151 | import qualified Data.Text as T 152 | import qualified Data.Text.Encoding as T 153 | import qualified Data.Text.Lazy as TL 154 | import qualified Data.Text.Lazy.Builder as TB 155 | import qualified Data.Text.Lazy.Builder.Int as TB 156 | import qualified Data.Text.Lazy.Builder.RealFloat as TB 157 | import qualified Database.PostgreSQL.Simple as P 158 | import Database.PostgreSQL.Simple.FromRow 159 | import Database.PostgreSQL.Simple.ToRow 160 | import qualified Database.PostgreSQL.Simple.Transaction as P 161 | import Paths_snaplet_postgresql_simple 162 | import Prelude hiding ((++)) 163 | import qualified Snap as Snap 164 | import Snap.Snaplet.PostgresqlSimple.Internal 165 | 166 | ------------------------------------------------------------------------------ 167 | -- | Default instance 168 | instance HasPostgres (Snap.Handler b Postgres) where 169 | getPostgresState = get 170 | setLocalPostgresState s = local (const s) 171 | 172 | 173 | ------------------------------------------------------------------------------ 174 | -- | A convenience instance to make it easier to use this snaplet in the 175 | -- Initializer monad like this: 176 | -- 177 | -- > d <- nestSnaplet "db" db pgsInit 178 | -- > count <- liftIO $ runReaderT (execute "INSERT ..." params) d 179 | instance {-# OVERLAPPING #-} (MonadIO m, MonadBaseControl IO m) 180 | => HasPostgres (ReaderT (Snap.Snaplet Postgres) m) where 181 | getPostgresState = asks (^# Snap.snapletValue) 182 | setLocalPostgresState s = local (set Snap.snapletValue s) 183 | 184 | ------------------------------------------------------------------------------ 185 | -- | A convenience instance to make it easier to use functions written for 186 | -- this snaplet in non-snaplet contexts. 187 | instance {-# OVERLAPPING #-} (MonadIO m, MonadBaseControl IO m) 188 | => HasPostgres (ReaderT Postgres m) where 189 | getPostgresState = ask 190 | setLocalPostgresState s = local (const s) 191 | 192 | 193 | ------------------------------------------------------------------------------ 194 | -- | Produce a connection string from a config 195 | getConnectionString :: C.Config -> IO ByteString 196 | getConnectionString config = do 197 | let params = 198 | [ ["host"] 199 | , ["hostaddr"] 200 | , ["port"] 201 | , ["dbname","db"] 202 | , ["user"] 203 | , ["password","pass"] 204 | , ["connection_timeout"] 205 | , ["client_encoding"] 206 | , ["options"] 207 | , ["application_name"] 208 | , ["fallback_application_name"] 209 | , ["keepalives"] 210 | , ["keepalives_idle"] 211 | , ["keepalives_interval"] 212 | , ["keepalives_count"] 213 | , ["sslmode"] 214 | , ["sslcompression"] 215 | , ["sslcert"] 216 | , ["sslkey"] 217 | , ["sslrootcert"] 218 | , ["sslcrl"] 219 | , ["requirepeer"] 220 | , ["krbsrvname"] 221 | , ["gsslib"] 222 | , ["service"] 223 | ] 224 | connstr <- fmap mconcat $ mapM showParam params 225 | extra <- fmap TB.fromText $ C.lookupDefault "" config "connectionString" 226 | return $! T.encodeUtf8 (TL.toStrict (TB.toLazyText (connstr <> extra))) 227 | where 228 | qt = TB.singleton '\'' 229 | bs = TB.singleton '\\' 230 | sp = TB.singleton ' ' 231 | eq = TB.singleton '=' 232 | 233 | lookupConfig = foldr (\name names -> do 234 | mval <- C.lookup config name 235 | case mval of 236 | Nothing -> names 237 | Just _ -> return mval) 238 | (return Nothing) 239 | 240 | showParam [] = undefined 241 | showParam names@(name:_) = do 242 | mval :: Maybe C.Value <- lookupConfig names 243 | let key = TB.fromText name <> eq 244 | case mval of 245 | Nothing -> return mempty 246 | Just (C.Bool x) -> return (key <> showBool x <> sp) 247 | Just (C.String x) -> return (key <> showText x <> sp) 248 | Just (C.Number x) -> return (key <> showNum x <> sp) 249 | Just (C.List _) -> return mempty 250 | 251 | showBool x = TB.decimal (fromEnum x) 252 | 253 | nd ratio = (numerator ratio, denominator ratio) 254 | 255 | showNum (nd -> (n,1)) = TB.decimal n 256 | showNum x = TB.formatRealFloat TB.Fixed Nothing 257 | ( fromIntegral (numerator x) 258 | / fromIntegral (denominator x) :: Double ) 259 | 260 | showText x = qt <> loop x 261 | where 262 | loop (T.break escapeNeeded -> (a,b)) 263 | = TB.fromText a <> 264 | case T.uncons b of 265 | Nothing -> qt 266 | Just (c,b') -> escapeChar c <> loop b' 267 | 268 | escapeNeeded c = c == '\'' || c == '\\' 269 | 270 | escapeChar c = case c of 271 | '\'' -> bs <> qt 272 | '\\' -> bs <> bs 273 | _ -> TB.singleton c 274 | 275 | 276 | description :: T.Text 277 | description = "PostgreSQL abstraction" 278 | 279 | 280 | datadir :: Maybe (IO FilePath) 281 | datadir = Just $ liftM (<>"/resources/db") getDataDir 282 | 283 | 284 | ------------------------------------------------------------------------------ 285 | -- | Initialize the snaplet 286 | pgsInit :: Snap.SnapletInit b Postgres 287 | pgsInit = Snap.makeSnaplet "postgresql-simple" description datadir $ do 288 | config <- mkPGSConfig =<< Snap.getSnapletUserConfig 289 | initHelper config 290 | 291 | 292 | ------------------------------------------------------------------------------ 293 | -- | Initialize the snaplet using a specific configuration. 294 | pgsInit' :: PGSConfig -> Snap.SnapletInit b Postgres 295 | pgsInit' config = Snap.makeSnaplet "postgresql-simple" description Nothing $ 296 | initHelper config 297 | 298 | 299 | ------------------------------------------------------------------------------ 300 | -- | Builds a PGSConfig object from a configurator Config object. This 301 | -- function uses getConnectionString to construct the connection string. The 302 | -- rest of the PGSConfig fields are obtained from \"numStripes\", 303 | -- \"idleTime\", and \"maxResourcesPerStripe\". 304 | mkPGSConfig :: MonadIO m => C.Config -> m PGSConfig 305 | mkPGSConfig config = liftIO $ do 306 | connstr <- getConnectionString config 307 | stripes <- C.lookupDefault 1 config "numStripes" 308 | idle <- C.lookupDefault 5 config "idleTime" 309 | resources <- C.lookupDefault 20 config "maxResourcesPerStripe" 310 | return $ PGSConfig connstr stripes idle resources 311 | 312 | 313 | initHelper :: MonadIO m => PGSConfig -> m Postgres 314 | initHelper PGSConfig{..} = do 315 | pool <- liftIO $ createPool (P.connectPostgreSQL pgsConnStr) P.close 316 | pgsNumStripes (realToFrac pgsIdleTime) 317 | pgsResources 318 | return $ PostgresPool pool 319 | 320 | 321 | ------------------------------------------------------------------------------ 322 | -- | See 'P.query' 323 | query :: (HasPostgres m, ToRow q, FromRow r) 324 | => P.Query -> q -> m [r] 325 | query q params = liftPG' (\c -> P.query c q params) 326 | 327 | 328 | ------------------------------------------------------------------------------ 329 | -- | See 'P.query_' 330 | query_ :: (HasPostgres m, FromRow r) => P.Query -> m [r] 331 | query_ q = liftPG' (`P.query_` q) 332 | 333 | 334 | ------------------------------------------------------------------------------ 335 | -- | See 'P.returning' 336 | returning :: (HasPostgres m, ToRow q, FromRow r) 337 | => P.Query -> [q] -> m [r] 338 | returning q params = liftPG' (\c -> P.returning c q params) 339 | 340 | 341 | ------------------------------------------------------------------------------ 342 | -- | 343 | fold :: (HasPostgres m, 344 | FromRow row, 345 | ToRow params) 346 | => P.Query -> params -> b -> (b -> row -> IO b) -> m b 347 | fold template qs a f = liftPG' (\c -> P.fold c template qs a f) 348 | 349 | 350 | ------------------------------------------------------------------------------ 351 | -- | 352 | foldWithOptions :: (HasPostgres m, 353 | FromRow row, 354 | ToRow params) 355 | => P.FoldOptions 356 | -> P.Query 357 | -> params 358 | -> b 359 | -> (b -> row -> IO b) 360 | -> m b 361 | foldWithOptions opts template qs a f = 362 | liftPG' (\c -> P.foldWithOptions opts c template qs a f) 363 | 364 | 365 | ------------------------------------------------------------------------------ 366 | -- | 367 | fold_ :: (HasPostgres m, 368 | FromRow row) 369 | => P.Query -> b -> (b -> row -> IO b) -> m b 370 | fold_ template a f = liftPG' (\c -> P.fold_ c template a f) 371 | 372 | 373 | ------------------------------------------------------------------------------ 374 | -- | 375 | foldWithOptions_ :: (HasPostgres m, 376 | FromRow row) 377 | => P.FoldOptions 378 | -> P.Query 379 | -> b 380 | -> (b -> row -> IO b) 381 | -> m b 382 | foldWithOptions_ opts template a f = 383 | liftPG' (\c -> P.foldWithOptions_ opts c template a f) 384 | 385 | 386 | ------------------------------------------------------------------------------ 387 | -- | 388 | forEach :: (HasPostgres m, 389 | FromRow r, 390 | ToRow q) 391 | => P.Query -> q -> (r -> IO ()) -> m () 392 | forEach template qs f = liftPG' (\c -> P.forEach c template qs f) 393 | 394 | 395 | ------------------------------------------------------------------------------ 396 | -- | 397 | forEach_ :: (HasPostgres m, 398 | FromRow r) 399 | => P.Query -> (r -> IO ()) -> m () 400 | forEach_ template f = liftPG' (\c -> P.forEach_ c template f) 401 | 402 | 403 | ------------------------------------------------------------------------------ 404 | -- | 405 | execute :: (HasPostgres m, ToRow q) 406 | => P.Query -> q -> m Int64 407 | execute template qs = liftPG' (\c -> P.execute c template qs) 408 | 409 | 410 | ------------------------------------------------------------------------------ 411 | -- | 412 | execute_ :: (HasPostgres m) 413 | => P.Query -> m Int64 414 | execute_ template = liftPG' (`P.execute_` template) 415 | 416 | 417 | ------------------------------------------------------------------------------ 418 | -- | 419 | executeMany :: (HasPostgres m, ToRow q) 420 | => P.Query -> [q] -> m Int64 421 | executeMany template qs = liftPG' (\c -> P.executeMany c template qs) 422 | 423 | 424 | ------------------------------------------------------------------------------ 425 | -- | Be careful that you do not call Snap's `finishWith` function anywhere 426 | -- inside the function that you pass to `withTransaction`. Doing so has been 427 | -- known to cause DB connection leaks. 428 | withTransaction :: (HasPostgres m) 429 | => m a -> m a 430 | withTransaction = withTransactionMode P.defaultTransactionMode 431 | 432 | 433 | ------------------------------------------------------------------------------ 434 | -- | Be careful that you do not call Snap's `finishWith` function anywhere 435 | -- inside the function that you pass to `withTransactionLevel`. Doing so has 436 | -- been known to cause DB connection leaks. 437 | withTransactionLevel :: (HasPostgres m) 438 | => P.IsolationLevel -> m a -> m a 439 | withTransactionLevel lvl = 440 | withTransactionMode P.defaultTransactionMode { P.isolationLevel = lvl } 441 | 442 | 443 | ------------------------------------------------------------------------------ 444 | -- | Be careful that you do not call Snap's `finishWith` function anywhere 445 | -- inside the function that you pass to `withTransactionMode`. Doing so has 446 | -- been known to cause DB connection leaks. 447 | withTransactionMode :: (HasPostgres m) 448 | => P.TransactionMode -> m a -> m a 449 | withTransactionMode mode act = withPG $ do 450 | pg <- getPostgresState 451 | r <- liftBaseWith $ \run -> E.mask 452 | $ \unmask -> withConnection pg 453 | $ \con -> do 454 | P.beginMode mode con 455 | r <- unmask (run act) `E.onException` P.rollback con 456 | P.commit con 457 | return r 458 | restoreM r 459 | 460 | ------------------------------------------------------------------------------ 461 | -- | Be careful that you do not call Snap's `finishWith` function anywhere 462 | -- inside the function that you pass to `withTransactionMode`. Doing so has 463 | -- been known to cause DB connection leaks. 464 | withTransactionEither :: (HasPostgres m) 465 | => m (Either a b) -> m (Either a b) 466 | withTransactionEither = withTransactionModeEither P.defaultTransactionMode 467 | 468 | ------------------------------------------------------------------------------ 469 | -- | Be careful that you do not call Snap's `finishWith` function anywhere 470 | -- inside the function that you pass to `withTransactionMode`. Doing so has 471 | -- been known to cause DB connection leaks. 472 | withTransactionModeEither :: (HasPostgres m) 473 | => P.TransactionMode -> m (Either a b) -> m (Either a b) 474 | withTransactionModeEither mode act = withPG $ do 475 | pg <- getPostgresState 476 | r <- liftBaseWith $ \run -> E.mask 477 | $ \unmask -> withConnection pg 478 | $ \con -> do 479 | P.beginMode mode con 480 | r <- unmask (run act) `E.onException` P.rollback con 481 | either (const $ P.rollback con) (const $ P.commit con) $ restoreM r 482 | return r 483 | restoreM r 484 | 485 | formatMany :: (ToRow q, HasPostgres m) 486 | => P.Query -> [q] -> m ByteString 487 | formatMany q qs = liftPG' (\c -> P.formatMany c q qs) 488 | 489 | 490 | formatQuery :: (ToRow q, HasPostgres m) 491 | => P.Query -> q -> m ByteString 492 | formatQuery q qs = liftPG' (\c -> P.formatQuery c q qs) 493 | -------------------------------------------------------------------------------- /src/Snap/Snaplet/PostgresqlSimple/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Snap.Snaplet.PostgresqlSimple.Internal where 7 | 8 | import Control.Monad.IO.Class (MonadIO, liftIO) 9 | import Control.Monad.Trans (lift) 10 | import Control.Monad.Trans.Control (MonadBaseControl (..), 11 | control) 12 | import Control.Monad.Trans.Identity (IdentityT (IdentityT)) 13 | import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) 14 | import Control.Monad.Trans.Reader (ReaderT (ReaderT)) 15 | import qualified Control.Monad.Trans.RWS.Lazy as LRWS 16 | import qualified Control.Monad.Trans.RWS.Strict as SRWS 17 | import qualified Control.Monad.Trans.State.Lazy as LS 18 | import qualified Control.Monad.Trans.State.Strict as SS 19 | import qualified Control.Monad.Trans.Writer.Lazy as LW 20 | import qualified Control.Monad.Trans.Writer.Strict as SW 21 | import Data.ByteString (ByteString) 22 | import Data.Monoid (Monoid) 23 | import Data.Pool (Pool, withResource) 24 | import qualified Database.PostgreSQL.Simple as P 25 | 26 | ------------------------------------------------------------------------------ 27 | -- | The state for the postgresql-simple snaplet. To use it in your app 28 | -- include this in your application state and use pgsInit to initialize it. 29 | data Postgres = PostgresPool (Pool P.Connection) 30 | | PostgresConn P.Connection 31 | 32 | 33 | ------------------------------------------------------------------------------ 34 | -- | Instantiate this typeclass on 'Handler b YourAppState' so this snaplet 35 | -- can find the connection source. If you need to have multiple instances of 36 | -- the postgres snaplet in your application, then don't provide this instance 37 | -- and leverage the default instance by using \"@with dbLens@\" in front of calls 38 | -- to snaplet-postgresql-simple functions. 39 | class (MonadIO m, MonadBaseControl IO m) => HasPostgres m where 40 | getPostgresState :: m Postgres 41 | setLocalPostgresState :: Postgres -> m a -> m a 42 | 43 | 44 | instance HasPostgres m => HasPostgres (IdentityT m) where 45 | getPostgresState = lift getPostgresState 46 | setLocalPostgresState pg (IdentityT m) = IdentityT $ 47 | setLocalPostgresState pg m 48 | 49 | 50 | instance HasPostgres m => HasPostgres (MaybeT m) where 51 | getPostgresState = lift getPostgresState 52 | setLocalPostgresState pg (MaybeT m) = MaybeT $ 53 | setLocalPostgresState pg m 54 | 55 | 56 | instance {-#OVERLAPPABLE #-} HasPostgres m => HasPostgres (ReaderT r m) where 57 | getPostgresState = lift getPostgresState 58 | setLocalPostgresState pg (ReaderT m) = ReaderT $ \e -> 59 | setLocalPostgresState pg (m e) 60 | 61 | 62 | instance (Monoid w, HasPostgres m) => HasPostgres (LW.WriterT w m) where 63 | getPostgresState = lift getPostgresState 64 | setLocalPostgresState pg (LW.WriterT m) = LW.WriterT $ 65 | setLocalPostgresState pg m 66 | 67 | 68 | instance (Monoid w, HasPostgres m) => HasPostgres (SW.WriterT w m) where 69 | getPostgresState = lift getPostgresState 70 | setLocalPostgresState pg (SW.WriterT m) = SW.WriterT $ 71 | setLocalPostgresState pg m 72 | 73 | 74 | instance HasPostgres m => HasPostgres (LS.StateT w m) where 75 | getPostgresState = lift getPostgresState 76 | setLocalPostgresState pg (LS.StateT m) = LS.StateT $ \s -> 77 | setLocalPostgresState pg (m s) 78 | 79 | 80 | instance HasPostgres m => HasPostgres (SS.StateT w m) where 81 | getPostgresState = lift getPostgresState 82 | setLocalPostgresState pg (SS.StateT m) = SS.StateT $ \s -> 83 | setLocalPostgresState pg (m s) 84 | 85 | 86 | instance (Monoid w, HasPostgres m) => HasPostgres (LRWS.RWST r w s m) where 87 | getPostgresState = lift getPostgresState 88 | setLocalPostgresState pg (LRWS.RWST m) = LRWS.RWST $ \e s -> 89 | setLocalPostgresState pg (m e s) 90 | 91 | 92 | instance (Monoid w, HasPostgres m) => HasPostgres (SRWS.RWST r w s m) where 93 | getPostgresState = lift getPostgresState 94 | setLocalPostgresState pg (SRWS.RWST m) = SRWS.RWST $ \e s -> 95 | setLocalPostgresState pg (m e s) 96 | 97 | 98 | ------------------------------------------------------------------------------ 99 | -- | Data type holding all the snaplet's config information. 100 | data PGSConfig = PGSConfig 101 | { pgsConnStr :: ByteString 102 | -- ^ A libpq connection string. 103 | , pgsNumStripes :: Int 104 | -- ^ The number of distinct sub-pools to maintain. The smallest 105 | -- acceptable value is 1. 106 | , pgsIdleTime :: Double 107 | -- ^ Amount of time for which an unused resource is kept open. The 108 | -- smallest acceptable value is 0.5 seconds. 109 | , pgsResources :: Int 110 | -- ^ Maximum number of resources to keep open per stripe. The smallest 111 | -- acceptable value is 1. 112 | } 113 | 114 | 115 | ------------------------------------------------------------------------------ 116 | -- | Returns a config object with default values and the specified connection 117 | -- string. 118 | pgsDefaultConfig :: ByteString 119 | -- ^ A connection string such as \"host=localhost 120 | -- port=5432 dbname=mydb\" 121 | -> PGSConfig 122 | pgsDefaultConfig connstr = PGSConfig connstr 1 5 20 123 | 124 | 125 | 126 | ------------------------------------------------------------------------------ 127 | -- | Function that reserves a single connection for the duration of the given 128 | -- action. Nested calls to withPG will only reserve one connection. For example, 129 | -- the following code calls withPG twice in a nested way yet only results in a single 130 | -- connection being reserved: 131 | -- 132 | -- > myHandler = withPG $ do 133 | -- > queryTheDatabase 134 | -- > commonDatabaseMethod 135 | -- > 136 | -- > commonDatabaseMethod = withPG $ do 137 | -- > moreDatabaseActions 138 | -- > evenMoreDatabaseActions 139 | -- 140 | -- This is useful in a practical setting because you may often find yourself in a situation 141 | -- where you have common code (that requires a database connection) that you wish to call from 142 | -- other blocks of code that may require a database connection and you still want to make sure 143 | -- that you are only using one connection through all of your nested methods. 144 | withPG :: (HasPostgres m) 145 | => m b -> m b 146 | withPG f = do 147 | s <- getPostgresState 148 | case s of 149 | (PostgresPool p) -> withResource p (\c -> setLocalPostgresState (PostgresConn c) f) 150 | (PostgresConn _) -> f 151 | 152 | 153 | ------------------------------------------------------------------------------ 154 | -- | Convenience function for executing a function that needs a database 155 | -- connection. 156 | liftPG :: (HasPostgres m) => (P.Connection -> m a) -> m a 157 | liftPG act = do 158 | pg <- getPostgresState 159 | control $ \run -> 160 | withConnection pg $ \con -> run (act con) 161 | 162 | 163 | -- | Convenience function for executing a function that needs a database 164 | -- connection specialized to IO. 165 | liftPG' :: (HasPostgres m) => (P.Connection -> IO b) -> m b 166 | liftPG' f = do 167 | s <- getPostgresState 168 | withConnection s f 169 | 170 | 171 | ------------------------------------------------------------------------------ 172 | -- | Convenience function for executing a function that needs a database 173 | -- connection. 174 | withConnection :: MonadIO m => Postgres -> (P.Connection -> IO b) -> m b 175 | withConnection (PostgresPool p) f = liftIO (withResource p f) 176 | withConnection (PostgresConn c) f = liftIO (f c) 177 | --------------------------------------------------------------------------------