Bump patch version

Upgrade to Hasql 0.7

README.md

@@ -1,21 +1,26 @@
 ![Logo](static/logo.png "Logo")
 
 [![Build Status](https://circleci.com/gh/begriffs/postgrest.png?circle-token=f723c01686abf0364de1e2eaae5aff1f68bd3ff2)](https://circleci.com/gh/begriffs/postgrest/tree/master)
+<a href="https://heroku.com/deploy?template=https://github.com/begriffs/postgrest">
+  <img src="static/heroku.png" alt="Deploy">
+</a>
 
 PostgREST serves a fully RESTful API from any existing PostgreSQL
 database. It provides a cleaner, more standards-compliant, faster
 API than you are likely to write from scratch.
 
-### Demo
+### Demo [postgrest.herokuapp.com](https://postgrest.herokuapp.com) | Watch [Video](https://begriffs.com/posts/2014-12-30-intro-to-postgrest.html)
 
-Try making requests to the live [demo server] with an HTTP client
-such as [postman](http://www.getpostman.com/).
-
-[video placeholder]
+Try making requests to the live demo server with an HTTP client
+such as [postman](http://www.getpostman.com/). The structure of the
+demo database is defined by
+[begriffs/postgrest-example](https://github.com/begriffs/postgrest-example).
+You can use it as inspiration for test-driven server migrations in
+your own projects.
 
 ### Usage
 
-Download [binaries for your platform] and invoke the program like so:
+Download the binary ([OS X](http://bin.begriffs.com/dbapi/osx/postgrest-0.2.5.1.tar.xz) /  [Ubuntu](http://bin.begriffs.com/dbapi/heroku/postgrest-0.2.5.1.tar.xz)) and invoke like so:
 
 ```bash
 postgrest  --db-host localhost  --db-port 5432     \
@@ -25,32 +30,13 @@ postgrest  --db-host localhost  --db-port 5432     \
            --port 3000
 ```
 
-### Security
-
-PostgREST handles authentication (HTTP Basic over SSL) and delegates
-authorization to the role information defined in the database. This
-ensures there is a single declarative source of truth for security.
-When dealing with the database the server assumes the identity of
-the currently authenticated user, and for the duration of the
-connection cannot do anything the user themselves couldn't.
-
-Postgres 9.5 will soon support true [row-level
-security](http://michael.otacoo.com/postgresql-2/postgres-9-5-feature-highlight-row-level-security/).
-In the meantime what isn't yet implemented can be simulated with
-triggers and security-barrier views. Because the possible queries
-to the database are limited to certain templates using
-[leakproof](http://blog.2ndquadrant.com/how-do-postgresql-security_barrier-views-work/)
-functions, the trigger workaround does not compromise row-level
-security.
-
-For example security patterns see the [security
-guide](https://github.com/begriffs/postgrest/wiki/Security-and-Permissions).
-
 ### Performance
 
+TLDR; subsecond response times for up to 2000 requests/sec on Heroku free tier. ([see the load test](https://github.com/begriffs/postgrest/wiki/Performance-and-Scaling))
+
 If you're used to servers written in interpreted languages (or named
 after precious gems), prepare to be pleasantly surprised by PostgREST
-performance. ([see the load test](https://github.com/begriffs/postgrest/wiki/Performance-and-Scaling))
+performance.
 
 Three factors contribute to the speed. First the server is written
 in [Haskell](https://new-www.haskell.org/) using the
@@ -82,6 +68,27 @@ the [performance guide](https://github.com/begriffs/postgrest/wiki/Performance-a
 Other optimizations are possible, and some are outlined in the
 [Future Features](#future-features).
 
+### Security
+
+PostgREST handles authentication (HTTP Basic over SSL) and delegates
+authorization to the role information defined in the database. This
+ensures there is a single declarative source of truth for security.
+When dealing with the database the server assumes the identity of
+the currently authenticated user, and for the duration of the
+connection cannot do anything the user themselves couldn't.
+
+Postgres 9.5 will soon support true [row-level
+security](http://michael.otacoo.com/postgresql-2/postgres-9-5-feature-highlight-row-level-security/).
+In the meantime what isn't yet implemented can be simulated with
+triggers and security-barrier views. Because the possible queries
+to the database are limited to certain templates using
+[leakproof](http://blog.2ndquadrant.com/how-do-postgresql-security_barrier-views-work/)
+functions, the trigger workaround does not compromise row-level
+security.
+
+For example security patterns see the [security
+guide](https://github.com/begriffs/postgrest/wiki/Security-and-Permissions).
+
 ### Versioning
 
 A robust long-lived API needs the freedom to exist in multiple
@@ -135,7 +142,18 @@ and the [guide to routing](https://github.com/begriffs/postgrest/wiki/Routing).
 * Add two-legged auth with OAuth 1.0a(?)
 * ... the other [issues](https://github.com/begriffs/postgrest/issues)
 
+### Guides
+
+* [Routing](https://github.com/begriffs/postgrest/wiki/Routing)
+* [Versioning](https://github.com/begriffs/postgrest/wiki/API-Versioning)
+* [Performance](https://github.com/begriffs/postgrest/wiki/Performance-and-Scaling)
+* [Security](https://github.com/begriffs/postgrest/wiki/Security-and-Permissions)
+
 ### Thanks
 
-Thanks to [Adam Baker](https://github.com/adambaker) for code
-contributions and many fundamental design discussions.
+* [Adam Baker](https://github.com/adambaker) for code
+  contributions and many fundamental design discussions
+* [Nikita Volkov](https://github.com/nikita-volkov) for writing the
+  wonderful [Hasql](https://github.com/nikita-volkov/hasql) library
+  and helping me use it
+* [Mikey Casalaina](https://github.com/casalaina) for the cool logo

app.json

@@ -0,0 +1,46 @@
+{
+  "name": "PostgREST",
+  "description": "RESTful API for any PostgreSQL database.",
+  "logo": "https://halcyon.sh/logo.svg",
+  "repository": "https://github.com/begriffs/postgrest",
+  "env": {
+    "BUILDPACK_URL": {
+      "description": "Heroku buildpack for deploying Haskell applications",
+      "value": "https://github.com/begriffs/postgrest-heroku"
+    },
+    "POSTGREST_VER": {
+      "description": "Version of PostgREST to deploy",
+      "value": "0.2.5.1"
+    },
+    "DB_NAME": {
+      "description": "Database name",
+      "required": true
+    },
+    "AUTH_ROLE": {
+      "description": "Database role to use checking client authentication",
+      "required": true
+    },
+    "AUTH_PASS": {
+      "description": "Authentication password",
+      "required": false
+    },
+    "ANONYMOUS_ROLE": {
+      "description": "Database role for non-authenticated requests",
+      "required": true
+    },
+    "DB_HOST": {
+      "description": "Database server hostname",
+      "required": true
+    },
+    "DB_PORT": {
+      "description": "Database server port",
+      "required": false,
+      "value": "5432"
+    },
+    "DB_POOL": {
+      "description": "Maximum number of connections in database pool",
+      "required": false,
+      "value": "10"
+    }
+  }
+}

postgrest.cabal

@@ -1,9 +1,13 @@
 name:                  postgrest
-version:               0.2.4.9
-synopsis:              The database is your api
+description:           Reads the schema of a PostgreSQL database and creates RESTful routes
+                       for the tables and views, supporting all HTTP verbs that security
+                       permits.
+version:               0.2.5.1
+synopsis:              REST API for any Postgres database
 license:               MIT
 license-file:          LICENSE
 author:                Joe Nelson, Adam Baker
+homepage:              https://github.com/begriffs/postgrest
 maintainer:            cred+github@begriffs.com
 category:              Web
 build-type:            Simple
@@ -11,13 +15,13 @@ cabal-version:         >=1.10
 
 executable postgrest
   main-is:             Main.hs
-  ghc-options:         -Wall -W -Werror -O2
+  ghc-options:         -Wall -W -O2
   default-language:    Haskell2010
-  default-extensions:  OverloadedStrings
+  default-extensions:  OverloadedStrings, ScopedTypeVariables
   other-extensions:    QuasiQuotes
   build-depends:       base >=4.6 && <5
-                     , hasql == 0.4.*, hasql-backend
-                     , hasql-postgres == 0.8.*
+                     , hasql == 0.7.*, hasql-backend
+                     , hasql-postgres == 0.10.*
                      , warp >= 3.0.2, wai >= 3.0.1
                      , wai-extra, wai-cors
                      , wai-middleware-static >= 0.6.0
@@ -26,13 +30,13 @@ executable postgrest
                      , scientific, time
                      , aeson, network >= 2.6
                      , bytestring, text, split, string-conversions
-                     , stringsearch, parsec
+                     , stringsearch
                      , containers, unordered-containers
                      , optparse-applicative >= 0.9.1 && < 0.10
                      , regex-base, regex-tdfa
                      , regex-tdfa-text
                      , Ranged-sets
-                     , transformers
+                     , transformers, MissingH
                      , bcrypt, base64-string
                      , network-uri >= 2.6
                      , resource-pool
@@ -44,7 +48,6 @@ executable postgrest
                      , Config
                      , PgStructure
                      , PgQuery
-                     , PgError
                      , RangeQuery
                      , Middleware
   hs-source-dirs:      src
@@ -52,16 +55,16 @@ executable postgrest
 Test-Suite spec
   Type:                exitcode-stdio-1.0
   Default-Language:    Haskell2010
-  default-extensions:  OverloadedStrings
+  default-extensions:  OverloadedStrings, ScopedTypeVariables
   other-extensions:    QuasiQuotes
   Hs-Source-Dirs:      test, src
   ghc-options:         -Wall -W -Werror
-  Main-Is:             Spec.hs
+  Main-Is:             Main.hs
   Other-Modules:       App, Auth, Config, Spec, SpecHelper
-  Build-Depends:       base, hspec >= 2.0, QuickCheck
+  Build-Depends:       base, hspec >= 2.1.2, QuickCheck
                      , hspec-wai >= 0.5.0, hspec-wai-json
-                     , hasql == 0.4.*, hasql-backend
-                     , hasql-postgres == 0.8.*
+                     , hasql == 0.7.*, hasql-backend
+                     , hasql-postgres == 0.10.*
                      , warp >= 3.0.2, wai >= 3.0.1
                      , HTTP, convertible
                      , case-insensitive
@@ -70,17 +73,15 @@ Test-Suite spec
                      , http-types, scientific, time
                      , bytestring, aeson, network >= 2.6
                      , text, optparse-applicative
-                     , stringsearch, parsec
+                     , stringsearch
                      , unordered-containers
                      , regex-base
                      , string-conversions
                      , http-media, regex-tdfa
                      , regex-tdfa-text
                      , Ranged-sets
-                     , transformers
-                     , bcrypt
-                     , base64-string
-                     , split
+                     , transformers, MissingH, split
+                     , bcrypt, base64-string
                      , network-uri >= 2.6
                      , resource-pool
                      , blaze-builder

src/App.hs

@@ -25,17 +25,17 @@ import Network.Wai
 
 import Data.Aeson
 import Data.Monoid
+import qualified Data.Vector as V
 import qualified Hasql as H
-import qualified Hasql.Postgres as H
+import qualified Hasql.Backend as B
+import qualified Hasql.Postgres as P
 
 import Auth
 import PgQuery
 import RangeQuery
 import PgStructure
-import PgError
-import Text.Parsec hiding (Column)
 
-app :: BL.ByteString -> Request -> H.Tx H.Postgres s Response
+app :: BL.ByteString -> Request -> H.Tx P.Postgres s Response
 app reqBody req =
   case (path, verb) of
     ([], _) -> do
@@ -54,8 +54,7 @@ app reqBody req =
       then return $ responseLBS status416 [] "HTTP Range error"
       else do
         let qt = QualifiedTable schema (cs table)
-        let select = coerce $
-              ("select ",[],mempty) <>
+        let select = B.Stmt "select " V.empty True <>
                   parentheticT (
                     whereT qq $ countRows qt
                   ) <> commaq <> (
@@ -65,7 +64,7 @@ app reqBody req =
                   . whereT qq
                   $ selectStar qt
                 )
-        row <- H.single select
+        row <- H.maybeEx select
         let (tableTotal, queryTotal, body) =
               fromMaybe (0, 0, Just "" :: Maybe Text) row
             from = fromMaybe 0 $ rangeOffset <$> range
@@ -102,9 +101,8 @@ app reqBody req =
     ([table], "POST") ->
       handleJsonObj reqBody $ \obj -> do
         let qt = QualifiedTable schema (cs table)
-            query = coerce $
-              insertInto qt (map cs $ keys obj) (elems obj)
-        row <- H.single query
+            query = insertInto qt (map cs $ keys obj) (elems obj)
+        row <- H.maybeEx query
         let (Identity insertedJson) = fromMaybe (Identity "{}" :: Identity Text) row
             Just inserted = decode (cs insertedJson) :: Maybe Object
 
@@ -134,7 +132,7 @@ app reqBody req =
             if S.fromList tableCols == S.fromList cols
               then do
                 let vals = elems obj
-                H.unit . coerce $ iffNotT
+                H.unitEx $ iffNotT
                         (whereT qq $ update qt cols vals)
                         (insertSelect qt cols vals)
                 return $ responseLBS status204 [ jsonH ] ""
@@ -147,12 +145,23 @@ app reqBody req =
     ([table], "PATCH") ->
       handleJsonObj reqBody $ \obj -> do
         let qt = QualifiedTable schema (cs table)
-        H.unit
-          $ coerce
+        H.unitEx
           $ whereT qq
           $ update qt (map cs $ keys obj) (elems obj)
         return $ responseLBS status204 [ jsonH ] ""
 
+    ([table], "DELETE") -> do
+      let qt = QualifiedTable schema (cs table)
+      let del = countT
+            . returningStarT
+            . whereT qq
+            $ deleteFrom qt
+      row <- H.maybeEx del
+      let (Identity deletedCount) = fromMaybe (Identity 0 :: Identity Int) row
+      return $ if deletedCount == 0
+         then responseLBS status404 [] ""
+         else responseLBS status204 [("Content-Range", "*/"<> cs (show deletedCount))] ""
+
     (_, _) ->
       return $ responseLBS status404 [] ""
 
@@ -164,38 +173,12 @@ app reqBody req =
     schema = requestedSchema hdrs
     range  = rangeRequested hdrs
     allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
-    coerce (q, args, All b) = (q, args, b)
 
+sqlError :: t
+sqlError = undefined
 
-isSqlError :: H.Error -> Maybe H.Error
-isSqlError = Just
-
-sqlError :: H.Error -> Response
-sqlError err =
-  let inside = case err of
-        H.CantConnect _ ->
-          "Message: \"Cannot connect to postgres server\""
-        H.ConnectionLost t -> t
-        H.ErroneousResult t -> t
-        H.UnexpectedResult t -> t
-        H.UnparsableTemplate t -> t
-        H.UnparsableRow t -> t
-        H.NotInTransaction -> "An operation which requires a"
-          <> "database transaction was executed without one" in
-  either
-    (\hint ->
-      responseLBS status500
-      [(hContentType, "application/json")]
-      (cs . encode . object $ [
-          ("message", String $
-            "Failed to parse exception:" <> inside)
-        , ("hint", String . cs . show $ hint)]))
-    (\msg ->
-      responseLBS (httpStatus msg)
-      [(hContentType, "application/json")]
-      (encode msg))
-    (parse message "" inside)
-
+isSqlError :: t
+isSqlError = undefined
 
 rangeStatus :: Int -> Int -> Int -> Status
 rangeStatus from to total
@@ -226,8 +209,8 @@ requestedSchema hdrs =
 jsonH :: Header
 jsonH = (hContentType, "application/json")
 
-handleJsonObj :: BL.ByteString -> (Object -> H.Tx H.Postgres s Response)
-              -> H.Tx H.Postgres s Response
+handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response)
+              -> H.Tx P.Postgres s Response
 handleJsonObj reqBody handler = do
   let p = eitherDecode reqBody
   case p of
@@ -243,6 +226,7 @@ handleJsonObj reqBody handler = do
         jErr = encode . object $
           [("message", String "Expecting a JSON object")]
 
+
 data TableOptions = TableOptions {
   tblOptcolumns :: [Column]
 , tblOptpkey :: [Text]

src/Auth.hs

@@ -7,8 +7,10 @@ import Control.Applicative ( (<*>), (<$>) )
 import Crypto.BCrypt
 import Data.Text
 import Data.Monoid
+import qualified Data.Vector as V
 import qualified Hasql as H
-import qualified Hasql.Postgres as H
+import qualified Hasql.Backend as B
+import qualified Hasql.Postgres as P
 import Data.String.Conversions (cs)
 import PgQuery (pgFmtLit)
 
@@ -45,22 +47,22 @@ data LoginAttempt =
 checkPass :: Text -> Text -> Bool
 checkPass = (. cs) . validatePassword . cs
 
-setRole :: Text -> H.Tx H.Postgres s ()
-setRole role = H.unit ("set role " <> cs (pgFmtLit role), [], True)
+setRole :: Text -> H.Tx P.Postgres s ()
+setRole role = H.unitEx $ B.Stmt ("set role " <> cs (pgFmtLit role)) V.empty True
 
-resetRole :: H.Tx H.Postgres s ()
-resetRole = H.unit [H.q|reset role|]
+resetRole :: H.Tx P.Postgres s ()
+resetRole = H.unitEx [H.stmt|reset role|]
 
-addUser :: Text -> Text -> Text -> H.Tx H.Postgres s ()
+addUser :: Text -> Text -> Text -> H.Tx P.Postgres s ()
 addUser identity pass role = do
   let Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
-  H.unit $
-    [H.q|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|]
+  H.unitEx $
+    [H.stmt|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|]
       identity (cs hashed :: Text) role
 
-signInRole :: Text -> Text -> H.Tx H.Postgres s LoginAttempt
+signInRole :: Text -> Text -> H.Tx P.Postgres s LoginAttempt
 signInRole user pass = do
-  u <- H.single $ [H.q|select pass, rolname from postgrest.auth where id = ?|] user
+  u <- H.maybeEx $ [H.stmt|select pass, rolname from postgrest.auth where id = ?|] user
   return $ maybe LoginFailed (\r ->
       let (hashed, role) = r in
       if checkPass hashed pass

src/Error.hs

@@ -0,0 +1,71 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+
+module Error (PgError, errResponse) where
+
+import qualified Hasql as H
+import qualified Hasql.Postgres as P
+import qualified Network.HTTP.Types.Status as HT
+import qualified Data.Aeson as JSON
+import qualified Data.Text as T
+import Data.Aeson ((.=))
+import Data.String.Conversions (cs)
+import Data.String.Utils(replace)
+import Network.Wai(Response, responseLBS)
+import Network.HTTP.Types.Header
+
+type PgError = H.SessionError P.Postgres
+
+errResponse :: PgError -> Response
+errResponse e = responseLBS (httpStatus e)
+  [(hContentType, "application/json")] (JSON.encode e)
+
+instance JSON.ToJSON PgError where
+  toJSON (H.TxError (P.ErroneousResult c m d h)) = JSON.object [
+    "code" .= (cs c::T.Text),
+    "message" .= (cs m::T.Text),
+    "details" .= (fmap cs d::Maybe T.Text),
+    "hint" .= (fmap cs h::Maybe T.Text)]
+  toJSON (H.TxError (P.NoResult d)) = JSON.object [
+    "message" .= ("No response from server"::T.Text),
+    "details" .= (fmap cs d::Maybe T.Text)]
+  toJSON (H.TxError (P.UnexpectedResult m)) = JSON.object ["message" .= m]
+  toJSON (H.TxError P.NotInTransaction) = JSON.object [
+    "message" .= ("Not in transaction"::T.Text)]
+  toJSON (H.CxError (P.CantConnect d)) = JSON.object [
+    "message" .= ("Can't connect to the database"::T.Text),
+    "details" .= (fmap cs d::Maybe T.Text)]
+  toJSON (H.CxError (P.UnsupportedVersion v)) = JSON.object [
+    "message" .= ("Postgres version "++version++" is not supported") ]
+      where version = replace "0" "." (show v)
+  toJSON (H.ResultError m) = JSON.object ["message" .= m]
+
+httpStatus :: PgError -> HT.Status
+httpStatus (H.TxError (P.ErroneousResult codeBS _ _ _)) =
+  let code = cs codeBS in
+  case code of
+    '0':'8':_ -> HT.status503 -- pg connection err
+    '0':'9':_ -> HT.status500 -- triggered action exception
+    '0':'L':_ -> HT.status403 -- invalid grantor
+    '0':'P':_ -> HT.status403 -- invalid role specification
+    '2':'5':_ -> HT.status500 -- invalid tx state
+    '2':'8':_ -> HT.status403 -- invalid auth specification
+    '2':'D':_ -> HT.status500 -- invalid tx termination
+    '3':'8':_ -> HT.status500 -- external routine exception
+    '3':'9':_ -> HT.status500 -- external routine invocation
+    '3':'B':_ -> HT.status500 -- savepoint exception
+    '4':'0':_ -> HT.status500 -- tx rollback
+    '5':'3':_ -> HT.status503 -- insufficient resources
+    '5':'4':_ -> HT.status413 -- too complex
+    '5':'5':_ -> HT.status500 -- obj not on prereq state
+    '5':'7':_ -> HT.status500 -- operator intervention
+    '5':'8':_ -> HT.status500 -- system error
+    'F':'0':_ -> HT.status500 -- conf file error
+    'H':'V':_ -> HT.status500 -- foreign data wrapper error
+    'P':'0':_ -> HT.status500 -- PL/pgSQL Error
+    'X':'X':_ -> HT.status500 -- internal Error
+    "42P01" -> HT.status404 -- undefined table
+    "42501" -> HT.status404 -- insufficient privilege
+    _ -> HT.status400
+httpStatus (H.TxError (P.NoResult _)) = HT.status503
+httpStatus _ = HT.status500

src/Main.hs

@@ -4,10 +4,10 @@ import Paths_postgrest (version)
 
 import App
 import Middleware
+import Error(errResponse)
 
 import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
-import Control.Exception
 import Data.String.Conversions (cs)
 import Network.Wai (strictRequestBody)
 import Network.Wai.Middleware.Cors (cors)
@@ -17,7 +17,7 @@ import Network.Wai.Middleware.Static (staticPolicy, only)
 import Data.List (intercalate)
 import Data.Version (versionBranch)
 import qualified Hasql as H
-import qualified Hasql.Postgres as H
+import qualified Hasql.Postgres as P
 import Options.Applicative hiding (columns)
 
 import Config (AppConfig(..), argParser, corsPolicy)
@@ -32,16 +32,12 @@ main = do
   Prelude.putStrLn $ "Listening on port " ++
     (show $ configPort conf :: String)
 
-  let pgSettings = H.ParamSettings (cs $ configDbHost conf)
+  let pgSettings = P.ParamSettings (cs $ configDbHost conf)
                      (fromIntegral $ configDbPort conf)
                      (cs $ configDbUser conf)
                      (cs $ configDbPass conf)
                      (cs $ configDbName conf)
-
-  sessSettings <- maybe (fail "Improper session settings") return $
-                    H.sessionSettings (fromIntegral $ configPool conf) 30
-
-  let appSettings = setPort port
+      appSettings = setPort port
                   . setServerName (cs $ "postgrest/" <> prettyVersion)
                   $ defaultSettings
       middle =
@@ -51,13 +47,16 @@ main = do
       anonRole = cs $ configAnonRole conf
       currRole = cs $ configDbUser conf
 
-  H.session pgSettings sessSettings $ H.sessionUnlifter >>= \unlift ->
-    liftIO $ runSettings appSettings $ middle $ \req respond -> do
-      body <- strictRequestBody req
-      respond =<< catchJust isSqlError
-        (unlift $ H.tx Nothing
-                $ authenticated currRole anonRole (app body) req)
-        (return . sqlError)
+  poolSettings <- maybe (fail "Improper session settings") return $
+                H.poolSettings (fromIntegral $ configPool conf) 30
+  pool :: H.Pool P.Postgres
+          <- H.acquirePool pgSettings poolSettings
+
+  runSettings appSettings $ middle $ \req respond -> do
+    body <- strictRequestBody req
+    resOrError <- liftIO $ H.session pool $ H.tx Nothing $
+      authenticated currRole anonRole (app body) req
+    either (respond . errResponse) respond resOrError
 
   where
     describe = progDesc "create a REST API to an existing Postgres database"

src/Middleware.hs

@@ -9,7 +9,7 @@ import Data.Text
 -- import Data.Pool(withResource, Pool)
 
 import qualified Hasql as H
-import qualified Hasql.Postgres as H
+import qualified Hasql.Postgres as P
 import Data.String.Conversions(cs)
 
 import Network.HTTP.Types.Header (hLocation, hAuthorization)
@@ -23,8 +23,8 @@ import Auth (LoginAttempt(..), signInRole, setRole, resetRole)
 import Codec.Binary.Base64.String (decode)
 
 authenticated :: forall s. Text -> Text ->
-                 (Request -> H.Tx H.Postgres s Response) ->
-                 Request -> H.Tx H.Postgres s Response
+                 (Request -> H.Tx P.Postgres s Response) ->
+                 Request -> H.Tx P.Postgres s Response
 authenticated currentRole anon app req = do
   attempt <- httpRequesterRole (requestHeaders req)
   case attempt of
@@ -36,7 +36,7 @@ authenticated currentRole anon app req = do
     NoCredentials ->     if anon /= currentRole then runInRole anon else app req
 
  where
-   httpRequesterRole :: RequestHeaders -> H.Tx H.Postgres s LoginAttempt
+   httpRequesterRole :: RequestHeaders -> H.Tx P.Postgres s LoginAttempt
    httpRequesterRole hdrs = do
     let auth = fromMaybe "" $ lookup hAuthorization hdrs
     case split (==' ') (cs auth) of
@@ -46,7 +46,7 @@ authenticated currentRole anon app req = do
           _ -> return MalformedAuth
       _ -> return NoCredentials
 
-   runInRole :: Text -> H.Tx H.Postgres s Response
+   runInRole :: Text -> H.Tx P.Postgres s Response
    runInRole r = do
      setRole r
      res <- app req

src/PgError.hs

@@ -1,86 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module PgError (Message(..), message, httpStatus) where
-
-import Text.Parsec
-import Text.Parsec.Text
-import qualified Data.Map as M
-import Text.Regex.TDFA.Text ()
-import Data.Text hiding (drop, concat, head)
-import Data.Aeson
-import Data.Maybe
-import Control.Monad (void)
-
-import Data.String.Conversions (cs)
-import Data.CaseInsensitive (CI, mk)
-
-import Network.HTTP.Types.Status
-
-data Message = Message {
-    msgStatus :: Maybe Text
-  , msgCode   :: Text
-  , msgText   :: Maybe Text
-  , msgHint   :: Maybe Text
-} deriving (Show, Eq)
-
-message :: Parser Message
-message = do
-  ps <- sepBy valPair (char ';')
-  let m = M.fromList ps
-  return $ Message
-    (M.lookup "status" m)
-    (fromMaybe "" $ M.lookup "code" m)
-    (M.lookup "message" m)
-    (M.lookup "hint" m)
-
-valPair :: Parser (CI Text, Text)
-valPair = do
-  _ <- spaces
-  name <- many1 letter
-  _ <- char ':'
-  spaces
-  _ <- many $ char '"'
-  val <- manyTill anyChar $
-    try
-      (void $ many (char '"') >> (
-        (void . lookAhead $ (char ';'))
-        <|> ((optional $ char '.') >> eof)
-      ))
-  return (mk (cs name), cs val)
-
-
-instance ToJSON Message where
-  toJSON t = object [
-      "message" .= msgText t
-    , "code"    .= msgCode t
-    , "status"  .= msgStatus t
-    , "hint"    .= msgHint t
-    ]
-
-httpStatus :: Message -> Status
-httpStatus m =
-  let code = cs $ msgCode m :: String in
-  case code of
-    '0' : '8' : _ -> status503 -- pg connection err
-    '0' : '9' : _ -> status500 -- triggered action exception
-    '0' : 'L' : _ -> status403 -- invalid grantor
-    '0' : 'P' : _ -> status403 -- invalid role specification
-    '2' : '5' : _ -> status500 -- invalid tx state
-    '2' : '8' : _ -> status403 -- invalid auth specification
-    '2' : 'D' : _ -> status500 -- invalid tx termination
-    '3' : '8' : _ -> status500 -- external routine exception
-    '3' : '9' : _ -> status500 -- external routine invocation
-    '3' : 'B' : _ -> status500 -- savepoint exception
-    '4' : '0' : _ -> status500 -- tx rollback
-    '5' : '3' : _ -> status503 -- insufficient resources
-    '5' : '4' : _ -> status413 -- too complex
-    '5' : '5' : _ -> status500 -- obj not on prereq state
-    '5' : '7' : _ -> status500 -- operator intervention
-    '5' : '8' : _ -> status500 -- system error
-    'F' : '0' : _ -> status500 -- conf file error
-    'H' : 'V' : _ -> status500 -- foreign data wrapper error
-    'P' : '0' : _ -> status500 -- PL/pgSQL Error
-    'X' : 'X' : _ -> status500 -- internal Error
-    "42P01" -> status404 -- undefined table
-    "42501" -> status404 -- insufficient privilege
-    _ -> status400

src/PgQuery.hs

@@ -1,17 +1,21 @@
 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module PgQuery where
 
 import RangeQuery
 
-import qualified Hasql.Postgres as H
-import qualified Hasql.Backend as H
+import qualified Hasql as H
+import qualified Hasql.Postgres as P
+import qualified Hasql.Backend as B
 
-import Data.Text hiding (map)
+import Data.Text hiding (map, empty)
 import Text.Regex.TDFA ( (=~) )
 import Text.Regex.TDFA.Text ()
 import qualified Network.HTTP.Types.URI as Net
 import qualified Data.ByteString.Char8 as BS
 import Data.Monoid
+import Data.Vector (empty)
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Functor ( (<$>) )
 import Control.Monad (join)
@@ -20,9 +24,12 @@ import qualified Data.Aeson as JSON
 import qualified Data.List as L
 import Data.Scientific (isInteger, formatScientific, FPFormat(..))
 
-type DynamicSQL = (BS.ByteString, [H.StatementArgument H.Postgres], All)
-
-type StatementT = DynamicSQL -> DynamicSQL
+type PStmt = H.Stmt P.Postgres
+instance Monoid PStmt where
+  mappend (B.Stmt query params prep) (B.Stmt query' params' prep') =
+    B.Stmt (query <> query') (params <> params') (prep && prep')
+  mempty = B.Stmt "" empty True
+type StatementT = PStmt -> PStmt
 
 data QualifiedTable = QualifiedTable {
   qtSchema :: Text
@@ -36,16 +43,16 @@ data OrderTerm = OrderTerm {
 
 limitT :: Maybe NonnegRange -> StatementT
 limitT r q =
-  q <> (" LIMIT " <> limit <> " OFFSET " <> offset <> " ", [], mempty)
+  q <> B.Stmt (" LIMIT " <> limit <> " OFFSET " <> offset <> " ") empty True
   where
     limit  = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
     offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
 
 whereT :: Net.Query -> StatementT
 whereT params q =
- if L.null params
+ if L.null cols
    then q
-   else q <> (" where ",[],mempty) <> conjunction
+   else q <> B.Stmt " where " empty True <> conjunction
  where
    cols = [ col | col <- params, fst col `notElem` ["order"] ]
    conjunction = mconcat $ L.intersperse andq (map wherePred cols)
@@ -54,94 +61,85 @@ orderT :: [OrderTerm] -> StatementT
 orderT ts q =
   if L.null ts
     then q
-    else q <> (" order by ",[],mempty) <> clause
+    else q <> B.Stmt " order by " empty True <> clause
   where
    clause = mconcat $ L.intersperse commaq (map queryTerm ts)
-   queryTerm :: OrderTerm -> DynamicSQL
-   queryTerm t = (" " <> cs (pgFmtIdent $ otTerm t) <> " "
-                      <> otDirection t              <> " "
-                  , [], mempty)
+   queryTerm :: OrderTerm -> PStmt
+   queryTerm t = B.Stmt
+                   (" " <> cs (pgFmtIdent $ otTerm t) <> " "
+                        <> cs (otDirection t)         <> " ")
+                   empty True
 
 parentheticT :: StatementT
-parentheticT (sql, params, pre) =
-  (" (" <> sql <> ") ", params, pre)
+parentheticT s =
+  s { B.stmtTemplate = " (" <> B.stmtTemplate s <> ") " }
 
-iffNotT :: DynamicSQL -> StatementT
-iffNotT (aq, ap, apre) (bq, bp, bpre) =
-  ("WITH aaa AS (" <> aq <> " returning *) " <>
-    bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)"
-  , ap ++ bp
-  , All $ getAll apre && getAll bpre
-  )
+iffNotT :: PStmt -> StatementT
+iffNotT (B.Stmt aq ap apre) (B.Stmt bq bp bpre) =
+  B.Stmt
+    ("WITH aaa AS (" <> aq <> " returning *) " <>
+      bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)")
+    (ap <> bp)
+    (apre && bpre)
 
-countRows :: QualifiedTable -> DynamicSQL
-countRows t =
-  ("select count(1) from " <> fromQt t, [], mempty)
+countT :: StatementT
+countT s =
+  s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT count(1) FROM qqq" }
+
+countRows :: QualifiedTable -> PStmt
+countRows t = B.Stmt ("select count(1) from " <> fromQt t) empty True
 
 asJsonWithCount :: StatementT
-asJsonWithCount (sql, params, pre) = (
-    "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from (" <> sql <> ") t"
-  , params, pre
-  )
+asJsonWithCount s = s { B.stmtTemplate =
+     "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from ("
+  <> B.stmtTemplate s <> ") t" }
 
 asJsonRow :: StatementT
-asJsonRow (sql, params, pre) = (
-    "row_to_json(t) from (" <> sql <> ") t", params, pre
-  )
+asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" }
 
-selectStar :: QualifiedTable -> DynamicSQL
-selectStar t =
-  ("select * from " <> fromQt t, [], mempty)
+selectStar :: QualifiedTable -> PStmt
+selectStar t = B.Stmt ("select * from " <> fromQt t) empty True
 
-insertInto :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL
-insertInto t [] _ =
-  ("insert into " <> fromQt t <> " default values returning *", [], mempty)
-insertInto t cols vals =
+returningStarT :: StatementT
+returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }
+
+deleteFrom :: QualifiedTable -> PStmt
+deleteFrom t = B.Stmt ("delete from " <> fromQt t) empty True
+
+insertInto :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
+insertInto t [] _ = B.Stmt
+  ("insert into " <> fromQt t <> " default values returning *") empty True
+insertInto t cols vals = B.Stmt
   ("insert into " <> fromQt t <> " (" <>
-    cs (intercalate ", " (map pgFmtIdent cols)) <>
-    ") values (" <>
-    cs (
-      intercalate ", " (map
-        ((<> "::unknown") . pgFmtLit . unquoted)
-        vals)
-    ) <> ") returning row_to_json(" <> fromQt t <> ".*)"
-  , []
-  , mempty
-  )
+    intercalate ", " (map pgFmtIdent cols) <>
+    ") values ("
+    <> intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals)
+    <> ") returning row_to_json(" <> fromQt t <> ".*)")
+  empty True
 
-insertSelect :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL
-insertSelect t [] _ =
-  ("insert into " <> fromQt t <> " default values returning *", [], mempty)
-insertSelect t cols vals =
-  ("insert into " <> fromQt t <> " (" <>
-    cs (intercalate ", " (map pgFmtIdent cols)) <>
-    ") select " <>
-    cs (
-      intercalate ", " (map
-        ((<> "::unknown") . pgFmtLit . unquoted)
-        vals)
-    )
-  , []
-  , mempty
-  )
+insertSelect :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
+insertSelect t [] _ = B.Stmt
+  ("insert into " <> fromQt t <> " default values returning *") empty True
+insertSelect t cols vals = B.Stmt
+  ("insert into " <> fromQt t <> " ("
+    <> intercalate ", " (map pgFmtIdent cols)
+    <> ") select "
+    <> intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals))
+  empty True
 
-update :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL
-update t cols vals =
-  ("update " <> fromQt t <> " set (" <>
-    cs (intercalate ", " (map pgFmtIdent cols)) <>
-    ") = (" <>
-    cs (
-      intercalate ", " (map
-        ((<> "::unknown") . pgFmtLit . unquoted)
-        vals)
-    ) <> ")"
-  , []
-  , mempty
-  )
+update :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
+update t cols vals = B.Stmt
+  ("update " <> fromQt t <> " set ("
+    <> intercalate ", " (map pgFmtIdent cols)
+    <> ") = ("
+    <> intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals)
+    <> ")")
+  empty True
 
-wherePred :: Net.QueryItem -> DynamicSQL
-wherePred (col, predicate) =
-  (" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> "::unknown ", [], mempty)
+wherePred :: Net.QueryItem -> PStmt
+wherePred (col, predicate) = B.Stmt
+  (" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> "::unknown ")
+  empty True
 
   where
     opCode:rest = split (=='.') $ cs $ fromMaybe "." predicate
@@ -171,11 +169,11 @@ orderParseTerm s =
             else Nothing
        _ -> Nothing
 
-commaq :: DynamicSQL
-commaq  = (", ", [], mempty)
+commaq :: PStmt
+commaq  = B.Stmt ", " empty True
 
-andq :: DynamicSQL
-andq = (" and ", [], mempty)
+andq :: PStmt
+andq = B.Stmt " and " empty True
 
 pgFmtIdent :: Text -> Text
 pgFmtIdent x =
@@ -198,8 +196,8 @@ pgFmtLit x =
 trimNullChars :: Text -> Text
 trimNullChars = Data.Text.takeWhile (/= '\x0')
 
-fromQt :: QualifiedTable -> BS.ByteString
-fromQt t = cs $ pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)
+fromQt :: QualifiedTable -> Text
+fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)
 
 unquoted :: JSON.Value -> Text
 unquoted (JSON.String t) = t
@@ -207,14 +205,3 @@ unquoted (JSON.Number n) =
   cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
 unquoted (JSON.Bool b) = cs . show $ b
 unquoted _ = ""
-
-pgParam :: JSON.Value -> H.StatementArgument H.Postgres
-pgParam (JSON.Number n) = H.renderValue
-  (cs $ formatScientific Fixed
-       (if isInteger n then Just 0 else Nothing) n :: Text)
-pgParam (JSON.String s) = H.renderValue s
-pgParam (JSON.Bool      b) = H.renderValue $
-  if b then "t" else "f" :: Text
-pgParam JSON.Null       = H.renderValue (Nothing :: Maybe Text)
-pgParam (JSON.Object o) = H.renderValue $ JSON.encode o
-pgParam (JSON.Array  a) = H.renderValue $ JSON.encode a

src/PgStructure.hs

@@ -3,25 +3,21 @@
 module PgStructure where
 
 import PgQuery (QualifiedTable(..))
-import Data.Functor ( (<$>) )
 import Data.Text hiding (foldl, map, zipWith, concat)
 import Data.Aeson
 import Data.Functor.Identity
-import qualified Data.Vector as V
 import Data.String.Conversions (cs)
+import Data.Maybe (fromMaybe)
+import Control.Applicative ( (<$>) )
 
-import Control.Applicative ( (<*>) )
-
-import qualified Data.List as L
 import qualified Data.Map as Map
 
 import qualified Hasql as H
-import qualified Hasql.Backend as H
-import qualified Hasql.Postgres as H
+import qualified Hasql.Postgres as P
 
-foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map Text ForeignKey)
+foreignKeys :: QualifiedTable -> H.Tx P.Postgres s (Map.Map Text ForeignKey)
 foreignKeys table = do
-  r :: [(Text, Text, Text)] <- H.list $ [H.q|
+  r <- H.listEx $ [H.stmt|
       select kcu.column_name, ccu.table_name AS foreign_table_name,
         ccu.column_name AS foreign_column_name
       from information_schema.table_constraints AS tc
@@ -36,58 +32,65 @@ foreignKeys table = do
 
   return $ foldl addKey Map.empty r
   where
-    addKey m (col, ftab, fcol) = Map.insert col (ForeignKey (cs ftab) (cs fcol)) m
+    addKey :: Map.Map Text ForeignKey -> (Text, Text, Text) -> Map.Map Text ForeignKey
+    addKey m (col, ftab, fcol) = Map.insert col (ForeignKey ftab fcol) m
 
 
-tables :: Text -> H.Tx H.Postgres s [Table]
-tables schema =
-  H.list $ [H.q|
+tables :: Text -> H.Tx P.Postgres s [Table]
+tables schema = do
+  rows <- H.listEx $
+    [H.stmt|
       select table_schema, table_name,
              is_insertable_into
         from information_schema.tables
        where table_schema = ?
        order by table_name
     |] schema
+  return $ map tableFromRow rows
 
 
-columns :: QualifiedTable -> H.Tx H.Postgres s [Column]
+columns :: QualifiedTable -> H.Tx P.Postgres s [Column]
 columns table = do
-  cols <- H.list $ [H.q|
-    select info.table_schema as schema, info.table_name as table_name,
-           info.column_name as name, info.ordinal_position as position,
-           info.is_nullable as nullable, info.data_type as col_type,
-           info.is_updatable as updatable,
-           info.character_maximum_length as max_len,
-           info.numeric_precision as precision,
-           info.column_default as default_value,
-           array_to_string(enum_info.vals, ',') as enum
-       from (
-         select table_schema, table_name, column_name, ordinal_position,
-                is_nullable, data_type, is_updatable,
-                character_maximum_length, numeric_precision,
-                column_default, udt_name
-           from information_schema.columns
-          where table_schema = ? and table_name = ?
-       ) as info
-       left outer join (
-         select n.nspname as s,
-                t.typname as n,
-                array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals
-         from pg_type t
-            join pg_enum e on t.oid = e.enumtypid
-            join pg_catalog.pg_namespace n ON n.oid = t.typnamespace
-         group by s, n
-       ) as enum_info
-       on (info.udt_name = enum_info.n)
-    order by position |] (qtSchema table) (qtName table)
+  cols <- H.listEx $ [H.stmt|
+      select info.table_schema as schema, info.table_name as table_name,
+             info.column_name as name, info.ordinal_position as position,
+             info.is_nullable as nullable, info.data_type as col_type,
+             info.is_updatable as updatable,
+             info.character_maximum_length as max_len,
+             info.numeric_precision as precision,
+             info.column_default as default_value,
+             array_to_string(enum_info.vals, ',') as enum
+         from (
+           select table_schema, table_name, column_name, ordinal_position,
+                  is_nullable, data_type, is_updatable,
+                  character_maximum_length, numeric_precision,
+                  column_default, udt_name
+             from information_schema.columns
+            where table_schema = ? and table_name = ?
+         ) as info
+         left outer join (
+           select n.nspname as s,
+                  t.typname as n,
+                  array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals
+           from pg_type t
+              join pg_enum e on t.oid = e.enumtypid
+              join pg_catalog.pg_namespace n ON n.oid = t.typnamespace
+           group by s, n
+         ) as enum_info
+         on (info.udt_name = enum_info.n)
+      order by position |]
+    (qtSchema table) (qtName table)
 
   fks <- foreignKeys table
-  return $ map (\col -> col { colFK = Map.lookup (cs . colName $ col) fks }) cols
+  return $ map (addFK fks . columnFromRow) cols
+
+  where
+    addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks }
 
 
-primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [Text]
+primaryKeyColumns :: QualifiedTable -> H.Tx P.Postgres s [Text]
 primaryKeyColumns table = do
-  r :: [Identity Text] <- H.list $ [H.q|
+  r <- H.listEx $ [H.stmt|
     select kc.column_name
       from
         information_schema.table_constraints tc,
@@ -101,9 +104,6 @@ primaryKeyColumns table = do
   return $ map runIdentity r
 
 
-vanishNull :: [a] -> Maybe [a]
-vanishNull xs = if L.null xs then Nothing else Just xs
-
 toBool :: Text -> Bool
 toBool = (== "YES")
 
@@ -132,37 +132,21 @@ data Column = Column {
 , colFK :: Maybe ForeignKey
 } deriving (Show)
 
-instance H.RowParser H.Postgres Column where
-  parseRow r =
-    let schema     = H.parseResult $ r V.! 0
-        table      = H.parseResult $ r V.! 1
-        name       = H.parseResult $ r V.! 2
-        position   = H.parseResult $ r V.! 3
-        nullable   = toBool <$> (H.parseResult $ r V.! 4 :: Either Text Text)
-        typ        = H.parseResult $ r V.! 5
-        updatable  = toBool <$> (H.parseResult $ r V.! 6 :: Either Text Text)
-        maxLen     = H.parseResult $ r V.! 7
-        precision  = H.parseResult $ r V.! 8
-        defValue   = H.parseResult $ r V.! 9
-        enum       = either (const $ Right []) (Right . split (==','))
-                       (H.parseResult $ r V.! 10 :: Either Text Text)
-      in
-    if V.length r /= 11
-       then Left "Wrong number of fields in Column"
-       else Column <$> schema <*> table <*> name <*> position <*> nullable
-                   <*> typ <*> updatable <*> maxLen <*> precision
-                   <*> defValue <*> enum
-                   <*> return Nothing
+tableFromRow :: (Text, Text, Text) -> Table
+tableFromRow (s, n, i) = Table s n (toBool i)
 
+columnFromRow :: (Text,       Text,      Text,
+                  Int,        Text,      Text,
+                  Text,       Maybe Int, Maybe Int,
+                  Maybe Text, Maybe Text)
+              -> Column
+columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) =
+  Column s t n pos (toBool nul) typ (toBool u) l p d (parseEnum e) Nothing
+
+  where
+    parseEnum :: Maybe Text -> [Text]
+    parseEnum str = fromMaybe [] $ split (==',') <$> str
 
-instance H.RowParser H.Postgres Table where
-  parseRow r =
-    let schema     = H.parseResult $ r V.! 0
-        name       = H.parseResult $ r V.! 1
-        insertable = toBool <$> (H.parseResult $ r V.! 2 :: Either Text Text) in
-    if V.length r /= 3
-       then Left "Wrong number of fields in Table"
-       else Table <$> schema <*> name <*> insertable
 
 instance ToJSON Column where
   toJSON c = object [

test/Feature/AuthSpec.hs

@@ -11,16 +11,21 @@ import SpecHelper
 -- }}}
 
 spec :: Spec
-spec = before resetDb $ around withApp $
-  describe "authorization" $ do
-    it "hides tables that anonymous does not own" $
-      get "/authors_only" `shouldRespondWith` 404
-    it "indicates login failure" $ do
-      let auth = authHeader "postgrest_test_author" "fakefake"
-      request methodGet "/authors_only" [auth] ""
-        `shouldRespondWith` 401
-    it "allows users with permissions to see their tables" $ do
-      _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-      let auth = authHeader "jdoe" "1234"
-      request methodGet "/authors_only" [auth] ""
-        `shouldRespondWith` 200
+spec = beforeAll
+  (clearTable "postgrest.auth") . afterAll_ (clearTable "postgrest.auth")
+  $ around withApp
+  $ describe "authorization" $ do
+
+  it "hides tables that anonymous does not own" $
+    get "/authors_only" `shouldRespondWith` 404
+
+  it "indicates login failure" $ do
+    let auth = authHeader "postgrest_test_author" "fakefake"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 401
+
+  it "allows users with permissions to see their tables" $ do
+    _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
+    let auth = authHeader "jdoe" "1234"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 200

test/Feature/CorsSpec.hs

@@ -12,8 +12,7 @@ import Network.HTTP.Types
 -- }}}
 
 spec :: Spec
-spec = before resetDb $ around withApp $
-  describe "CORS" $ do
+spec = around withApp $ describe "CORS" $ do
     let preflightHeaders = [
           ("Accept", "*/*"),
           ("Origin", "http://example.com"),

test/Feature/DeleteSpec.hs

@@ -0,0 +1,37 @@
+module Feature.DeleteSpec where
+
+import Test.Hspec
+import Test.Hspec.Wai
+import SpecHelper
+
+import Network.HTTP.Types
+
+spec :: Spec
+spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable "items")
+  . around withApp $
+  describe "Deleting" $ do
+    context "existing record" $ do
+      it "succeeds with 204 and deletion count" $
+        request methodDelete "/items?id=eq.1" [] ""
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Nothing
+          , matchStatus  = 204
+          , matchHeaders = ["Content-Range" <:> "*/1"]
+          }
+
+      it "actually clears items ouf the db" $ do
+        _ <- request methodDelete "/items?id=lt.15" [] ""
+        get "/items"
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just "[{\"id\":15}]"
+          , matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "0-0/1"]
+          }
+
+    context "known route, unknown record" $
+      it "fails with 404" $
+        request methodDelete "/items?id=eq.101" [] "" `shouldRespondWith` 404
+
+    context "totally unknown route" $
+      it "fails with 404" $
+        request methodDelete "/foozle?id=eq.101" [] "" `shouldRespondWith` 404

test/Feature/InsertSpec.hs

@@ -16,12 +16,10 @@ import Control.Monad (replicateM_)
 
 import TestTypes(IncPK(..), CompoundPK(..))
 
---import Debug.Trace
-
 spec :: Spec
-spec = before resetDb $ around withApp $ do
+spec = afterAll_ resetDb $ around withApp $ do
   describe "Posting new record" $ do
-    it "accepts disparate json types" $ do
+    after_ (clearTable "menagerie") . it "accepts disparate json types" $ do
       p <- post "/menagerie"
         [json| {
           "integer": 13, "double": 3.14159, "varchar": "testing!"
@@ -33,7 +31,7 @@ spec = before resetDb $ around withApp $ do
         simpleStatus p `shouldBe` created201
 
     context "with no pk supplied" $ do
-      context "into a table with auto-incrementing pk" $
+      context "into a table with auto-incrementing pk" . after_ (clearTable "auto_incrementing_pk") $
         it "succeeds with 201 and link" $ do
           p <- post "/auto_incrementing_pk" [json| { "non_nullable_string":"not null"} |]
           liftIO $ do
@@ -52,7 +50,7 @@ spec = before resetDb $ around withApp $ do
           post "/simple_pk" [json| { "extra":"foo"} |]
             `shouldRespondWith` 400
 
-      context "into a table with no pk" $
+      context "into a table with no pk" . after_ (clearTable "no_pk") $
         it "succeeds with 201 and a link including all fields" $ do
           p <- post "/no_pk" [json| { "a":"foo", "b":"bar" } |]
           liftIO $ do
@@ -60,7 +58,7 @@ spec = before resetDb $ around withApp $ do
             simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=eq.foo&b=eq.bar"
             simpleStatus p `shouldBe` created201
 
-    context "with compound pk supplied" $
+    context "with compound pk supplied" . after_ (clearTable "compound_pk") $
       it "builds response location header appropriately" $
         post "/compound_pk" [json| { "k1":12, "k2":42 } |]
           `shouldRespondWith` ResponseMatcher {
@@ -101,7 +99,7 @@ spec = before resetDb $ around withApp $ do
               [json| { "k1":12, "k2":42 } |]
                 `shouldRespondWith` 400
 
-        context "specifying every column in the table" $ do
+        context "specifying every column in the table" . after_ (clearTable "compound_pk") $ do
           it "can create a new record" $ do
             p <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
                  [json| { "k1":12, "k2":42, "extra":3 } |]
@@ -131,7 +129,7 @@ spec = before resetDb $ around withApp $ do
               let record = head rows
               compoundExtra record `shouldBe` Just 5
 
-      context "with an auto-incrementing primary key" $
+      context "with an auto-incrementing primary key" . after_ (clearTable "auto_incrementing_pk") $
 
         it "succeeds with 204" $
           request methodPut "/auto_incrementing_pk?id=eq.1" []
@@ -161,7 +159,8 @@ spec = before resetDb $ around withApp $ do
           [json| { "extra":20 } |]
             `shouldRespondWith` 204
 
-    context "in a nonempty table" $ do
+    context "in a nonempty table" . before_ (clearTable "items" >> createItems 15) .
+      after_ (clearTable "items") $ do
       it "can update a single item" $ do
         g <- get "/items?id=eq.42"
         liftIO $ simpleHeaders g

test/Feature/QuerySpec.hs

@@ -6,7 +6,8 @@ import Test.Hspec.Wai
 import SpecHelper
 
 spec :: Spec
-spec = before resetDb $ around withApp $ do
+spec = beforeAll (clearTable "items" >> createItems 15)
+  . afterAll_ (clearTable "items") . around withApp $ do
   describe "Querying a nonexistent table" $
     it "causes a 404" $
       get "/faketable" `shouldRespondWith` 404
@@ -38,6 +39,9 @@ spec = before resetDb $ around withApp $ do
         , matchHeaders = ["Content-Range" <:> "0-1/2"]
         }
 
+    it "without other constraints" $
+      get "/items?order=asc.id" `shouldRespondWith` 200
+
   describe "Canonical location" $ do
     it "Sets Content-Location with alphabetized params" $
       get "/no_pk?b=eq.1&a=eq.1"

test/Feature/RangeSpec.hs

@@ -8,7 +8,8 @@ import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus))
 import SpecHelper
 
 spec :: Spec
-spec = before resetDb $ around withApp $
+spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable "items")
+  . around withApp $
   describe "GET /items" $ do
 
     context "without range headers" $

test/Feature/StructureSpec.hs

@@ -10,7 +10,7 @@ import SpecHelper
 import Network.HTTP.Types
 
 spec :: Spec
-spec = before resetDb $ around withApp $ do
+spec = around withApp $ do
   describe "GET /" $ do
     it "lists views in schema" $
       request methodGet "/" [] ""

test/Main.hs

@@ -0,0 +1,9 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Main where
+
+import Test.Hspec
+import SpecHelper
+import Spec
+
+main :: IO ()
+main = resetDb >> hspec spec

test/Spec.hs

@@ -1 +1 @@
-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}

test/SpecHelper.hs

@@ -7,12 +7,14 @@ import Test.Hspec
 import Test.Hspec.Wai
 
 import Hasql as H
+import Hasql.Backend as H
 import Hasql.Postgres as H
 
 import Data.String.Conversions (cs)
--- import Control.Exception.Base (bracket, finally)
+import Data.Monoid
+import Data.Text hiding (map)
+import qualified Data.Vector as V
 import Control.Monad (void)
-import Control.Exception
 
 import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,
                                   hRange, hAuthorization)
@@ -24,9 +26,10 @@ import qualified Data.ByteString.Char8 as BS
 import Network.Wai.Middleware.Cors (cors)
 import System.Process (readProcess)
 
-import App (app, sqlError, isSqlError)
+import App (app)
 import Config (AppConfig(..), corsPolicy)
 import Middleware
+import Error(errResponse)
 -- import Auth (addUser)
 
 isLeft :: Either a b -> Bool
@@ -36,35 +39,41 @@ isLeft _ = False
 cfg :: AppConfig
 cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10
 
-testSettings :: SessionSettings
-testSettings = fromMaybe (error "bad settings") $ H.sessionSettings 1 30
+testPoolOpts :: PoolSettings
+testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30
 
-pgSettings :: Postgres
-pgSettings = H.ParamSettings "localhost" 5432 "postgrest_test" "" "postgrest_test"
+pgSettings :: H.Settings
+pgSettings = H.ParamSettings (cs $ configDbHost cfg)
+                             (fromIntegral $ configDbPort cfg)
+                             (cs $ configDbUser cfg)
+                             (cs $ configDbPass cfg)
+                             (cs $ configDbName cfg)
 
 withApp :: ActionWith Application -> IO ()
-withApp perform =
+withApp perform = do
   let anonRole = cs $ configAnonRole cfg
-      currRole = cs $ configDbUser cfg in
-  perform $ middle $ \req resp ->
-    H.session pgSettings testSettings $ H.sessionUnlifter >>= \unlift ->
-      liftIO $ do
-        body <- strictRequestBody req
-        resp =<< catchJust isSqlError
-          (unlift $ H.tx Nothing
-                  $ authenticated currRole anonRole (app body) req)
-          (return . sqlError)
+      currRole = cs $ configDbUser cfg
+  pool :: H.Pool H.Postgres
+    <- H.acquirePool pgSettings testPoolOpts
+
+  perform $ middle $ \req resp -> do
+    body <- strictRequestBody req
+    result <- liftIO $ H.session pool $ H.tx Nothing
+      $ authenticated currRole anonRole (app body) req
+    either (resp . errResponse) resp result
 
   where middle = cors corsPolicy
 
 
 resetDb :: IO ()
 resetDb = do
-  H.session pgSettings testSettings $
+  pool :: H.Pool H.Postgres
+    <- H.acquirePool pgSettings testPoolOpts
+  void . liftIO $ H.session pool $
     H.tx Nothing $ do
-      H.unit [H.q| drop schema if exists "1" cascade |]
-      H.unit [H.q| drop schema if exists private cascade |]
-      H.unit [H.q| drop schema if exists postgrest cascade |]
+      H.unitEx [H.stmt| drop schema if exists "1" cascade |]
+      H.unitEx [H.stmt| drop schema if exists private cascade |]
+      H.unitEx [H.stmt| drop schema if exists postgrest cascade |]
 
   loadFixture "roles"
   loadFixture "schema"
@@ -89,6 +98,22 @@ authHeader :: String -> String -> Header
 authHeader u p =
   (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p))
 
+clearTable :: Text -> IO ()
+clearTable table = do
+  pool :: H.Pool H.Postgres
+    <- H.acquirePool pgSettings testPoolOpts
+  void . liftIO $ H.session pool $ H.tx Nothing $
+    H.unitEx $ H.Stmt ("delete from \"1\"."<>table) V.empty True
+
+createItems :: Int -> IO ()
+createItems n = do
+  pool :: H.Pool H.Postgres
+    <- H.acquirePool pgSettings testPoolOpts
+  void . liftIO $ H.session pool $ H.tx Nothing txn
+  where
+    txn = sequence_ $ map H.unitEx stmts
+    stmts = map [H.stmt|insert into "1".items (id) values (?)|] [1..n]
+
 -- for hspec-wai
 pending_ :: WaiSession ()
 pending_ = liftIO Test.Hspec.pending

test/Unit/ErrorsSpec.hs

@@ -1,41 +0,0 @@
-module Unit.ErrorsSpec where
-
-import Test.Hspec
-
-import Text.Parsec
-import PgError
-import Data.Either (rights)
-
-spec :: Spec
-spec =
-  describe "Parsing Hasql errors" $ do
-    it "can handle status and code" $
-      let p = parse message "" "Status: \"foo\"; Code: \"abc\"." in
-      rights [p] `shouldBe` [
-          Message (Just "foo") "abc" Nothing Nothing
-        ]
-    it "can handle weird redundant quotes in status" $
-      let p = parse message "" "Status: \"\"foo\"\"; Code: \"abc\"." in
-      rights [p] `shouldBe` [
-          Message (Just "foo") "abc" Nothing Nothing
-        ]
-    it "can handle text and code" $
-      let p = parse message "" "Message: \"foo\"; Code: \"abc\"." in
-      rights [p] `shouldBe` [
-          Message Nothing "abc" (Just "foo") Nothing
-        ]
-    it "can handle status, text and code" $
-      let p = parse message "" "Status: \"hi\"; Message: \"foo\"; Code: \"abc\"." in
-      rights [p] `shouldBe` [
-          Message (Just "hi") "abc" (Just "foo") Nothing
-        ]
-    it "can handle unescaped quotes in message" $
-      let p = parse message "" "Status: \"hi\"; Message: \"unknown \"foo\"!\"; Code: \"abc\"." in
-      rights [p] `shouldBe` [
-          Message (Just "hi") "abc" (Just "unknown \"foo\"!") Nothing
-        ]
-    it "can handle periods in message" $
-      let p = parse message "" "Message: \"unknown \"foo\".bar\"; Code: \"42P01\"." in
-      rights [p] `shouldBe` [
-          Message Nothing "42P01" (Just "unknown \"foo\".bar") Nothing
-        ]

test/fixtures/schema.sql

@@ -453,22 +453,6 @@ SELECT pg_catalog.setval('has_fk_id_seq', 1, false);
 --
 
 INSERT INTO items (id) VALUES (1);
-INSERT INTO items (id) VALUES (2);
-INSERT INTO items (id) VALUES (3);
-INSERT INTO items (id) VALUES (4);
-INSERT INTO items (id) VALUES (5);
-INSERT INTO items (id) VALUES (6);
-INSERT INTO items (id) VALUES (7);
-INSERT INTO items (id) VALUES (8);
-INSERT INTO items (id) VALUES (9);
-INSERT INTO items (id) VALUES (10);
-INSERT INTO items (id) VALUES (11);
-INSERT INTO items (id) VALUES (12);
-INSERT INTO items (id) VALUES (13);
-INSERT INTO items (id) VALUES (14);
-INSERT INTO items (id) VALUES (15);
-
-
 --
 -- TOC entry 2339 (class 0 OID 0)
 -- Dependencies: 198