Bump version

Fixes #42

.travis.yml

@@ -12,7 +12,7 @@ before_install:
   - travis_retry sudo apt-get install --force-yes happy-1.19.3 alex-3.1.3
   - export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.3/bin:$PATH
 install:
-  - curl http://bin.begriffs.com/dbapi/cabal-sandbox.tar.xz | tar xJ
+  - travis_retry curl http://bin.begriffs.com/dbapi/cabal-sandbox.tar.xz | tar xJ
   - chmod a+x .cabal-sandbox/bin/*
   - cabal sandbox init
   - cabal install --enable-test --dependencies-only

dbapi.cabal

@@ -1,5 +1,5 @@
 name:                  dbapi
-version:               0.1.0.0
+version:               0.2.2.1
 synopsis:              The database is your api
 license:               MIT
 license-file:          LICENSE
@@ -17,22 +17,20 @@ executable dbapi
                      , HDBC, HDBC-postgresql
                      , warp, wai >= 3.0.1 && < 3.0.2
                      , wai-extra, wai-cors
-                     , HTTP, convertible
+                     , wai-middleware-static >= 0.6.0
+                     , HTTP, convertible, http-types
                      , case-insensitive
-                     , http-types, scientific, time
-                     , bytestring, aeson, network
-                     , text , containers
+                     , scientific, time
+                     , aeson, network >= 2.6
+                     , bytestring, text, split, string-conversions
+                     , containers, unordered-containers
                      , optparse-applicative >= 0.9.1 && < 0.10
-                     , unordered-containers
-                     , regex-base
-                     , string-conversions
-                     , http-media, regex-tdfa
+                     , regex-base, regex-tdfa
                      , Ranged-sets
                      , transformers
-                     , warp-tls
-                     , bcrypt
-                     , base64-string
-                     , split
+                     , bcrypt, base64-string
+                     , network-uri >= 2.6
+                     , resource-pool, process
   Other-Modules:       Dbapi
                      , PgStructure
                      , PgQuery
@@ -54,8 +52,9 @@ Test-Suite spec
                      , HTTP, convertible
                      , case-insensitive
                      , wai-extra, wai-cors, containers
+                     , wai-middleware-static >= 0.6.0
                      , http-types, scientific, time
-                     , bytestring, aeson, network
+                     , bytestring, aeson, network >= 2.6
                      , text, optparse-applicative
                      , unordered-containers
                      , regex-base
@@ -63,7 +62,8 @@ Test-Suite spec
                      , http-media, regex-tdfa
                      , Ranged-sets
                      , transformers
-                     , warp-tls
                      , bcrypt
                      , base64-string
                      , split
+                     , network-uri >= 2.6
+                     , resource-pool

src/Dbapi.hs

@@ -6,7 +6,6 @@ module Dbapi where
 import Types (SqlRow, getRow)
 
 import Control.Monad (join)
-import Control.Exception.Base (bracket_)
 import Control.Arrow ((***))
 import Control.Applicative
 import Options.Applicative hiding (columns)
@@ -42,16 +41,14 @@ import qualified Data.Aeson as JSON
 import PgQuery
 import RangeQuery
 import Data.Ranged.Ranges (emptyRange)
-import Codec.Binary.Base64.String (decode)
 
 -- }}}
 
 data AppConfig = AppConfig {
     configDbUri :: String
   , configPort  :: Int
-  , configSslCert :: FilePath
-  , configSslKey  :: FilePath
   , configAnonRole :: String
+  , configSecure :: Bool
   }
 
 jsonContentType :: (HeaderName, BS.ByteString)
@@ -62,7 +59,7 @@ jsonBodyAction req handler = do
   parse <- jsonBody req
   case parse of
     Left err -> return $ responseLBS status400 [jsonContentType] json
-      where json = JSON.encode . JSON.object $ [("error", JSON.String $ cs err)]
+      where json = JSON.encode . JSON.object $ [("error", JSON.String $ "Failed to parse JSON payload. " <> cs err) ]
     Right body -> handler body
 
 jsonBody :: Request -> IO (Either String SqlRow)
@@ -73,34 +70,8 @@ filterByKeys m keys =
   if null keys then m else
     m `intersection` fromList (zip keys $ repeat undefined)
 
-httpRequesterRole :: RequestHeaders -> Connection -> IO LoginAttempt
-httpRequesterRole hdrs conn = do
-  let auth = fromMaybe "" $ lookup hAuthorization hdrs
-  case BS.split ' ' (cs auth) of
-    ("Basic" : b64 : _) ->
-      case BS.split ':' $ cs (decode $ cs b64) of
-        (u:p:_) -> signInRole u p conn
-        _ -> return MalformedAuth
-    _ -> return NoCredentials
-
-
-app :: Connection -> DbRole -> Application
-app conn anonymous req respond = do
-  attempt <- httpRequesterRole (requestHeaders req) conn
-
-  case attempt of
-    MalformedAuth ->
-      respond $ responseLBS status400 [] "Malformed basic auth header"
-    LoginFailed ->
-      respond $ responseLBS status401 [] "Invalid username or password"
-    LoginSuccess role ->
-      bracket_ (pgSetRole conn role) (pgResetRole conn) $ appWithRole conn req respond
-    NoCredentials ->
-      bracket_ (pgSetRole conn anonymous) (pgResetRole conn) $ appWithRole conn req respond
-
-
-appWithRole :: Connection -> Application
-appWithRole conn req respond =
+app :: Connection -> Application
+app conn req respond =
   respond =<< case (path, verb) of
     ([], _) ->
       responseLBS status200 [jsonContentType] <$> printTables ver conn
@@ -120,7 +91,7 @@ appWithRole conn req respond =
                         rawQueryString req
         return $ addHeaders [
           ("Content-Location",
-           "/" <> cs table <> "?" <> cs canonical
+           "/" <> cs table <> if null canonical then "" else "?" <> cs canonical
           )] r
 
     ([table], "POST") ->
@@ -208,7 +179,6 @@ respondWithRangedResult rr =
     total  = rrTotal rr
     status
       | from > total            = status416
-      | total == 0               = status204
       | (1 + to - from) < total = status206
       | otherwise               = status200
 

src/Main.hs

@@ -1,21 +1,21 @@
 {-# LANGUAGE OverloadedStrings #-}
 
--- {{{ Imports
-
 module Main where
 import Dbapi
-import Middleware (reportPgErrors)
+import Middleware (inTransaction, authenticated, withSavepoint, clientErrors,
+  redirectInsecure, withDBConnection)
 import Network.Wai.Handler.Warp hiding (Connection)
-import Database.HDBC.PostgreSQL (connectPostgreSQL')
 import Data.String.Conversions (cs)
 
+import Control.Monad (unless)
 import Control.Applicative
 import Options.Applicative hiding (columns)
-import Network.Wai.Handler.WarpTLS (tlsSettings, runTLS)
 import Network.Wai.Middleware.Gzip (gzip, def)
 import Network.Wai.Middleware.Cors (cors)
-
--- }}}
+import Network.Wai.Middleware.Static (staticPolicy, only)
+import Database.HDBC (disconnect)
+import Database.HDBC.PostgreSQL(connectPostgreSQL')
+import Data.Pool(createPool)
 
 argParser :: Parser AppConfig
 argParser = AppConfig
@@ -23,25 +23,25 @@ argParser = AppConfig
     <> help "database uri to expose, e.g. postgres://user:pass@host:port/database")
   <*> option (long "port" <> short 'p' <> metavar "NUMBER" <> value 3000
     <> help "port number on which to run HTTP server")
-  <*> strOption (long "sslcert" <> short 'c' <> metavar "PATH" <> value "test/test.crt"
-    <> help "path to SSL cert file")
-  <*> strOption (long "sslkey" <> short 'k' <> metavar "PATH" <> value "test/test.key"
-    <> help "path to SSL key file")
   <*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE"
     <> help "postgres role to use for non-authenticated requests")
+  <*> switch (long "secure" <> short 's'
+    <> help "Redirect all requests to HTTPS" )
 
 main :: IO ()
 main = do
   conf <- execParser (info (helper <*> argParser) describe)
+  pool <- createPool (connectPostgreSQL' (configDbUri conf)) disconnect 1 600 10
   let port = configPort conf
-  let dburi = configDbUri conf
 
-  let tls = tlsSettings (configSslCert conf) (configSslKey conf)
-  let settings = setPort port defaultSettings
+  unless (configSecure conf) $
+    putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
 
   Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
-  conn <- connectPostgreSQL' dburi
-  runTLS tls settings $ gzip def $ cors corsPolicy $ reportPgErrors $ app conn (cs $ configAnonRole conf)
-
+  run port $ (if configSecure conf then redirectInsecure else id)
+    . gzip def . cors corsPolicy . clientErrors
+    . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
+    . withDBConnection pool . inTransaction
+    . authenticated (cs $ configAnonRole conf) . withSavepoint $ app
   where
     describe = progDesc "create a REST API to an existing Postgres database"

src/Middleware.hs

@@ -3,14 +3,69 @@
 
 module Middleware where
 
-import Data.Aeson
+import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
+import Data.Maybe (fromMaybe)
+import Data.Monoid (mconcat)
+import Data.Pool(withResource, Pool)
 
-import Network.HTTP.Types.Header (hContentType)
-import Network.HTTP.Types.Status (status400)
+import Database.HDBC (runRaw)
+import Database.HDBC.PostgreSQL (Connection)
 import Database.HDBC.Types (SqlError(..))
-import Control.Exception (catchJust)
-import Network.Wai
 
+import Data.String.Conversions(cs)
+import qualified Data.ByteString.Char8 as BS
+import Control.Exception (finally, throw, catchJust, catch, SomeException,
+    bracket_)
+
+import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization,
+  hLocation)
+import Network.HTTP.Types.Status (status400, status401, status404, status301)
+import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
+                   rawQueryString, isSecure)
+import Network.URI (URI(..), parseURI)
+
+import PgQuery(LoginAttempt(..), signInRole, setRole, resetRole)
+import Codec.Binary.Base64.String (decode)
+
+
+withDBConnection :: Pool Connection -> (Connection -> Application) -> Application
+withDBConnection pool app req respond =
+  withResource pool (\c -> app c req respond)
+
+inTransaction :: (Connection -> Application) -> Connection -> Application
+inTransaction app conn req respond =
+  finally (runRaw conn "begin" >> app conn req respond) (runRaw conn "commit")
+
+withSavepoint :: (Connection -> Application) -> Connection -> Application
+withSavepoint app conn req respond = do
+  runRaw conn "savepoint req_sp"
+  catch (app conn req respond) (\e -> let _ = (e::SomeException) in
+    runRaw conn "rollback to savepoint req_sp" >> throw e)
+
+authenticated :: BS.ByteString -> (Connection -> Application) ->
+                 Connection -> Application
+authenticated anon app conn req respond = do
+  attempt <- httpRequesterRole (requestHeaders req)
+  case attempt of
+    MalformedAuth ->
+      respond $ responseLBS status400 [] "Malformed basic auth header"
+    LoginFailed ->
+      respond $ responseLBS status401 [] "Invalid username or password"
+    LoginSuccess role ->
+      bracket_ (setRole conn role) (resetRole conn) $ app conn req respond
+    NoCredentials ->
+      bracket_ (setRole conn anon) (resetRole conn) $ app conn req respond
+
+ where
+   httpRequesterRole :: RequestHeaders -> IO LoginAttempt
+   httpRequesterRole hdrs = do
+    let auth = fromMaybe "" $ lookup hAuthorization hdrs
+    case BS.split ' ' (cs auth) of
+      ("Basic" : b64 : _) ->
+        case BS.split ':' $ cs (decode $ cs b64) of
+          (u:p:_) -> signInRole u p conn
+          _ -> return MalformedAuth
+      _ -> return NoCredentials
 
 instance ToJSON SqlError where
   toJSON t = object [
@@ -21,13 +76,35 @@ instance ToJSON SqlError where
       ]
     ]
 
-reportPgErrors :: Middleware
-reportPgErrors app req respond =
-  catchJust isPgException (app req respond) (
-      respond . responseLBS status400 [(hContentType, "application/json")]
-              . encode
-    )
+clientErrors :: Application -> Application
+clientErrors app req respond =
+  catchJust isPgException (app req respond) $ \err ->
+    respond $ if seState err == "42P01"
+       then responseLBS status404 [] ""
+       else responseLBS status400 [(hContentType, "application/json")] (encode err)
 
   where
     isPgException :: SqlError -> Maybe SqlError
     isPgException = Just
+
+
+redirectInsecure :: Application -> Application
+redirectInsecure app req respond = do
+  let hdrs = requestHeaders req
+      host = lookup "host" hdrs
+      uriM = parseURI . cs =<< mconcat [
+        Just "https://",
+        host,
+        Just $ rawPathInfo req,
+        Just $ rawQueryString req]
+      isHerokuSecure = lookup "x-forwarded-proto" hdrs == Just "https"
+
+  if not (isSecure req || isHerokuSecure)
+    then case uriM of
+              Just uri ->
+                respond $ responseLBS status301 [
+                    (hLocation, cs . show $ uri { uriScheme = "https:" })
+                  ] ""
+              Nothing ->
+                respond $ responseLBS status400 [] "SSL is required"
+    else app req respond

src/PgQuery.hs

@@ -8,8 +8,8 @@ module PgQuery (
 , upsert
 , addUser
 , signInRole
-, pgSetRole
-, pgResetRole
+, setRole
+, resetRole
 , checkPass
 , RangedResult(..)
 , LoginAttempt(..)
@@ -19,8 +19,9 @@ module PgQuery (
 import Data.Text (Text)
 import Data.String.Conversions (cs)
 import Data.Functor ( (<$>) )
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
 import Data.List (intersperse, intercalate)
+import Data.List.Split (splitOn)
 import Data.Monoid ((<>), mconcat)
 import qualified Data.Map as M
 
@@ -65,25 +66,60 @@ getRows schema table qq range conn = do
       jsonArrayRows
       (selectStarClause schema table
         <> whereClause qq
+        <> orderClause qq
         <> limitClause range)
   r <- quickQuery conn query []
 
   return $ case r of
-           [[total, _, SqlNull]] -> RangedResult offset 0 (fromSql total) ""
+           [[total, _, SqlNull]] -> RangedResult offset 0 (fromSql total) "[]"
            [[total, limited_total, json]] ->
             RangedResult offset (offset + fromSql limited_total - 1)
                          (fromSql total) (fromSql json)
-           _ -> RangedResult 0 0 0 ""
+           _ -> RangedResult 0 0 0 "[]"
 
   where
     offset = fromMaybe 0 $ R.offset <$> range
 
+
 whereClause :: Net.Query -> QuotedSql
 whereClause qs =
   if null qs then ("", []) else (" where ", []) <> conjunction
 
   where
-    conjunction = mconcat $ intersperse (" and ", []) (map wherePred qs)
+    cols = [ col | col <- qs, fst col `notElem` ["order"] ]
+    conjunction = mconcat $ intersperse (" and ", []) (map wherePred cols)
+
+
+orderClause :: Net.Query -> QuotedSql
+orderClause qs = do
+  let order = fromMaybe "" $ join $ lookup "order" qs
+      terms = mapMaybe parseOrderTerm $ splitOn "," $ cs order
+      termPred = mconcat $ intersperse (", ", []) (map orderTermSql terms)
+
+  if null terms
+     then ("", [])
+     else (" order by ", []) <> termPred
+
+  where
+    parseOrderTerm :: String -> Maybe OrderTerm
+    parseOrderTerm s =
+      case splitOn "." s of
+           [d,c] ->
+             if d `elem` ["asc", "desc"]
+                then Just $ OrderTerm d c
+                else Nothing
+           _ -> Nothing
+
+    orderTermSql :: OrderTerm -> QuotedSql
+    orderTermSql t =
+      ("%I " <> otDirection t, [toSql $ otColumn t])
+
+
+data OrderTerm = OrderTerm {
+  otDirection :: String
+, otColumn :: String
+}
+
 
 wherePred :: Net.QueryItem -> QuotedSql
 wherePred (column, predicate) =
@@ -165,9 +201,11 @@ placeholders :: String -> SqlRow -> String
 placeholders symbol = intercalate ", " . map (const symbol) . getRow
 
 insertClause :: Schema -> Text -> SqlRow -> QuotedSql
+insertClause schema table (SqlRow []) =
+  ("insert into %I.%I default values returning *", [toSql schema, toSql table])
 insertClause schema table row =
-    ("insert into %I.%I (" ++ placeholders "%I" row ++ ")",
-     map toSql $ cs schema : table : sqlRowColumns row)
+  ("insert into %I.%I (" ++ placeholders "%I" row ++ ")",
+  map toSql $ cs schema : table : sqlRowColumns row)
   <> (" values (" ++ placeholders "?" row ++ ") returning *", sqlRowValues row)
 
 
@@ -201,10 +239,10 @@ populateSql conn sql = do
     ph :: [a] -> String
     ph = intercalate ", " . map (const "?::varchar")
 
-pgSetRole :: Connection -> DbRole -> IO ()
-pgSetRole conn role = do
+setRole :: Connection -> DbRole -> IO ()
+setRole conn role = do
   query <- populateSql conn ("set role %I", [toSql role])
   void $ run conn query []
 
-pgResetRole :: Connection -> IO ()
-pgResetRole conn = void $ run conn "reset role" []
+resetRole :: Connection -> IO ()
+resetRole conn = void $ run conn "reset role" []

src/PgStructure.hs

@@ -136,7 +136,7 @@ columns s t conn = do
     \   left outer join ( \
     \     select n.nspname as s, \
     \            t.typname as n, \
-    \            array_agg(e.enumlabel) as vals \
+    \            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 \

test/Feature/AuthSpec.hs

@@ -12,16 +12,13 @@ import SpecHelper
 spec :: Spec
 spec = around appWithFixture $
   describe "authorization" $ do
-    it "hides tables that anonymous does not own" $ do
-      pendingWith_ "Fix pg exception"
+    it "hides tables that anonymous does not own" $
       get "/authors_only" `shouldRespondWith` 400 -- TODO: should be 404
     it "indicates login failure" $ do
-      pendingWith_ "Fix pg exception"
       let auth = authHeader "dbapi_test_author_a" "fakefake"
       request methodGet "/authors_only" [auth] ""
         `shouldRespondWith` 401
-    it "allows users with permissions to see their tables" $ do
-      pendingWith_ "Fix pg exception"
-      let auth = authHeader "dbapi_test_author_a" ""
-      request methodGet "/authors_only" [auth] ""
-        `shouldRespondWith` 400
+    -- it "allows users with permissions to see their tables" $ do
+    --   let auth = authHeader "dbapi_test_author_a" ""
+    --   request methodGet "/authors_only" [auth] ""
+    --     `shouldRespondWith` 200

test/Feature/InsertSpec.hs

@@ -27,7 +27,7 @@ spec = around appWithFixture $ do
         [json| {
           "integer": 13, "double": 3.14159, "varchar": "testing!"
         , "boolean": false, "date": "01/01/1900", "money": "$3.99"
-        , "enum": ["foo"]
+        , "enum": "foo"
         } |]
         `shouldRespondWith` 201
 
@@ -39,7 +39,7 @@ spec = around appWithFixture $ do
             simpleBody p `shouldBe` ""
             simpleHeaders p `shouldSatisfy` matchHeader hLocation "/auto_incrementing_pk\\?id=eq\\.[0-9]+"
             simpleStatus p `shouldBe` created201
-          let Just location = getHeader hLocation $ simpleHeaders p
+          let Just location = lookup hLocation $ simpleHeaders p
           r <- get location
           let [record] = fromJust (JSON.decode $ simpleBody r :: Maybe [IncPK])
           liftIO $ do
@@ -47,8 +47,7 @@ spec = around appWithFixture $ do
             incNullableStr record `shouldBe` Nothing
 
       context "into a table with simple pk" $
-        it "fails with 400 and error" $ do
-          pendingWith_ "Fix pg exception"
+        it "fails with 400 and error" $
           post "/simple_pk" [json| { "extra":"foo"} |]
             `shouldRespondWith` 400
 
@@ -69,6 +68,15 @@ spec = around appWithFixture $ do
             matchHeaders = ["Location" <:> "/compound_pk?k1=eq.12&k2=eq.42"]
           }
 
+    context "with invalid json payload" $
+      it "fails with 400 and error" $
+        post "/simple_pk" "}{ x = 2"
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [json| {"error":"Failed to parse JSON payload. Failed reading: satisfy"} |]
+          , matchStatus  = 400
+          , matchHeaders = []
+          }
+
   describe "Putting record" $ do
 
     context "to unkonwn uri" $

test/Feature/QuerySpec.hs

@@ -9,6 +9,10 @@ import SpecHelper
 
 spec :: Spec
 spec = around appWithFixture $ do
+  describe "Querying a nonexistent table" $
+    it "causes a 404" $
+      get "/faketable" `shouldRespondWith` 404
+
   describe "Filtering response" $
     context "column equality" $
 
@@ -20,11 +24,35 @@ spec = around appWithFixture $ do
           , matchHeaders = ["Content-Range" <:> "0-0/1"]
           }
 
-  describe "Canonical location" $
+  describe "ordering response" $ do
+    it "by a column asc" $
+      get "/items?id=lte.2&order=asc.id"
+        `shouldRespondWith` ResponseMatcher {
+          matchBody    = Just "[{\"id\":1},{\"id\":2}]"
+        , matchStatus  = 200
+        , matchHeaders = ["Content-Range" <:> "0-1/2"]
+        }
+    it "by a column desc" $
+      get "/items?id=lte.2&order=desc.id"
+        `shouldRespondWith` ResponseMatcher {
+          matchBody    = Just "[{\"id\":2},{\"id\":1}]"
+        , matchStatus  = 200
+        , matchHeaders = ["Content-Range" <:> "0-1/2"]
+        }
+
+  describe "Canonical location" $ do
     it "Sets Content-Location with alphabetized params" $
       get "/no_pk?b=eq.1&a=eq.1"
         `shouldRespondWith` ResponseMatcher {
-          matchBody    = Nothing
-        , matchStatus  = 204
+          matchBody    = Just "[]"
+        , matchStatus  = 200
         , matchHeaders = ["Content-Location" <:> "/no_pk?a=eq.1&b=eq.1"]
         }
+
+    it "Omits question mark when there are no params" $
+      get "/no_pk"
+        `shouldRespondWith` ResponseMatcher {
+          matchBody    = Just "[]"
+        , matchStatus  = 200
+        , matchHeaders = ["Content-Location" <:> "/no_pk"]
+        }

test/Feature/RangeSpec.hs

@@ -37,8 +37,8 @@ spec = around appWithFixture $
           request methodGet "/menagerie"
                   (rangeHdrs $ ByteRangeFromTo 0 1) ""
             `shouldRespondWith` ResponseMatcher {
-              matchBody    = Nothing
-            , matchStatus  = 204
+              matchBody    = Just "[]"
+            , matchStatus  = 200
             , matchHeaders = ["Content-Range" <:> "*/0"]
             }
 

test/SpecHelper.hs

@@ -9,18 +9,18 @@ import Database.HDBC
 import Database.HDBC.PostgreSQL
 
 import Data.String.Conversions (cs)
-import Control.Exception.Base (bracket, finally, tryJust)
-import Control.Monad (when)
+import Control.Exception.Base (bracket, finally)
 
 import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,
                                   hRange, hAuthorization)
 import Codec.Binary.Base64.String (encode)
 import Data.CaseInsensitive (CI(..))
 import Text.Regex.TDFA ((=~))
-import qualified Data.HashMap.Strict as Hash
 import qualified Data.ByteString.Char8 as BS
 import Network.Wai.Middleware.Cors (cors)
 
+import Middleware(clientErrors, withSavepoint, authenticated)
+
 import Dbapi (app, corsPolicy, AppConfig(..))
 import PgQuery(addUser)
 
@@ -29,7 +29,7 @@ isLeft (Left _ ) = True
 isLeft _ = False
 
 cfg :: AppConfig
-cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "test/test.crt" "test/test.key" "dbapi_anonymous"
+cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False
 
 openConnection :: IO Connection
 openConnection = connectPostgreSQL' $ configDbUri cfg
@@ -59,23 +59,15 @@ withUser name pass role action conn = do
 withApp :: ActionWith Application -> ActionWith Connection
 withApp action conn = do
   runRaw conn "begin;"
-  action $ cors corsPolicy $ app conn "dbapi_anonymous"
+  action $ cors corsPolicy $ authenticated "dbapi_anonymous" app conn
   rollback conn
 
 appWithFixture :: ActionWith Application -> IO ()
 appWithFixture action = withDatabaseConnection $ \c -> do
-  result <- tryJust transactionAborted $ do
-    runRaw c "begin;"
-    action $ cors corsPolicy $ app c "dbapi_anonymous"
-    rollback c
-
-  when (isLeft result) $
-    putStrLn "note: commands ignored after aborted transaction"
-
-  where
-    transactionAborted :: SqlError -> Maybe ()
-    transactionAborted e =
-      if seState e == "25P02" then Just () else Nothing
+  runRaw c "begin;"
+  action $ cors corsPolicy . clientErrors  $
+    (authenticated "dbapi_anonymous" . withSavepoint) app c
+  rollback c
 
 rangeHdrs :: ByteRange -> [Header]
 rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)]
@@ -83,22 +75,18 @@ rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)]
 rangeUnit :: Header
 rangeUnit = ("Range-Unit" :: CI BS.ByteString, "items")
 
-getHeader :: CI BS.ByteString -> [Header] -> Maybe BS.ByteString
-getHeader name headers =
-  Hash.lookup name $ Hash.fromList headers
-
 matchHeader :: CI BS.ByteString -> String -> [Header] -> Bool
 matchHeader name valRegex headers =
-  maybe False (=~ valRegex) $ getHeader name headers
+  maybe False (=~ valRegex) $ lookup name headers
 
 authHeader :: String -> String -> Header
 authHeader user pass =
-  (hAuthorization, cs $ "Basic: " ++ encode (user ++ ":" ++ pass))
+  (hAuthorization, cs $ "Basic " ++ encode (user ++ ":" ++ pass))
 
 -- for hspec-wai
 pending_ :: WaiSession ()
-pending_ = liftIO pending
+pending_ = liftIO Test.Hspec.pending
 
 -- for hspec-wai
 pendingWith_ :: String -> WaiSession ()
-pendingWith_ = liftIO . pendingWith
+pendingWith_ = liftIO . Test.Hspec.pendingWith

test/Unit/ErrorsSpec.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Unit.ErrorsSpec where
+
+import Test.Hspec
+
+import Database.HDBC (runRaw, quickQuery, fromSql, SqlError)
+import SpecHelper (dbWithSchema)
+import Middleware (withSavepoint)
+import PgQuery (insert)
+import Types(SqlRow(..))
+import Control.Exception(catch)
+import Control.Monad(void)
+import Network.Wai (defaultRequest, responseLBS)
+import Network.HTTP.Types.Status (ok200)
+
+spec :: Spec
+spec = let
+  dbErrApp conn _ res = do
+    putStrLn "In fake app"
+    _ <- insert "1" "items" (SqlRow []) conn
+    runRaw conn "select 1/0"
+    _ <- insert "1" "items" (SqlRow []) conn
+    res $ responseLBS ok200 [("Content-Type", "application/json")] "{}"
+  in around dbWithSchema $
+
+    describe "withSavepoint" $
+      it "allows partial rollback of request" $ \c -> do
+        let app = withSavepoint dbErrApp c
+        [[beforeCount]] <- quickQuery c "select count(*) from \"1\".items" []
+        runRaw c "set role dbapi_anonymous"
+        _ <- insert "1" "items" (SqlRow []) c
+        catch (void $ app defaultRequest (const undefined) ) $
+          \e -> let _ = (e::SqlError) in do
+          _ <- insert "1" "items" (SqlRow []) c
+          [[afterCount]] <- quickQuery c "select count(*) from \"1\".items" []
+          fromSql afterCount `shouldBe` (fromSql beforeCount::Int) + 2

test/Unit/PgQuerySpec.hs

@@ -53,6 +53,12 @@ spec = around dbWithSchema $ do
           ("nullable_string", toSql ("a string"::String))]) conn
           `shouldThrow` \e -> seState e == "23502"
 
+      it "generates a default values query if no data is provided" $ \c -> do
+        r <- insert "1" "items" (SqlRow []) c
+        let [row] = toList r
+        quickALQuery c "select * from \"1\".items where id = ?" [snd row]
+          `shouldReturn` [[row]]
+
   let {user = "jdoe"; pass = "secret"; role = "test_default_role"}
   describe "addUser" $ do
     it "adds a correct user to the right table" $ \conn -> do

test/test.crt

@@ -1,14 +0,0 @@
------BEGIN CERTIFICATE-----
-MIICLTCCAZYCCQCj6GtISfdwNjANBgkqhkiG9w0BAQUFADBbMQswCQYDVQQGEwJV
-UzELMAkGA1UECBMCQ0ExFjAUBgNVBAcTDVNhbiBGcmFuY2lzY28xEzARBgNVBAoT
-Ckxvb3AgUmVjdXIxEjAQBgNVBAMTCWxvY2FsaG9zdDAeFw0xNDEwMDMyMDQyNDNa
-Fw0xNTEwMDMyMDQyNDNaMFsxCzAJBgNVBAYTAlVTMQswCQYDVQQIEwJDQTEWMBQG
-A1UEBxMNU2FuIEZyYW5jaXNjbzETMBEGA1UEChMKTG9vcCBSZWN1cjESMBAGA1UE
-AxMJbG9jYWxob3N0MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC5gFnTRBge
-mXdkCMD+OycujZrCWOOLIDBqRr7kDbxVXqz/TKHRVx6bz88g9egzvR2HLyA418kd
-dAu+lMmjrRv/k0Lnk/UvC1aj0huoHpOVUgOwy3qS4cE663uU5qsrgf4RDP7bLDcQ
-FDW02SQ2n5ryv8nB9TSYpvQvYPiTMMKdrwIDAQABMA0GCSqGSIb3DQEBBQUAA4GB
-AAQwkC+GSaGArAKdMIqs8/55KAjyNd11MupiCWsu1cwBJ4QJc1PxrYOMLMYnU06J
-I0v1bJ6mG06/Js0r2FHM0NXSQO+7DLPWu4LchoBgFt4ZRm2+GbLzFrfu41yn5mJN
-VeUxCBQ9hOrE8Kwe+/9IUUVPxlISF+YHOyF3DxWUViak
------END CERTIFICATE-----

test/test.key

@@ -1,15 +0,0 @@
------BEGIN RSA PRIVATE KEY-----
-MIICXQIBAAKBgQC5gFnTRBgemXdkCMD+OycujZrCWOOLIDBqRr7kDbxVXqz/TKHR
-Vx6bz88g9egzvR2HLyA418kddAu+lMmjrRv/k0Lnk/UvC1aj0huoHpOVUgOwy3qS
-4cE663uU5qsrgf4RDP7bLDcQFDW02SQ2n5ryv8nB9TSYpvQvYPiTMMKdrwIDAQAB
-AoGAZZD0Haub9S0b5KayXMCwnFmmEaEvvR47xATGQgGPS8LRv9sKgp9LwA4RH7/k
-imeSglD4OIdVs421XH0ExlxjBiV5EzTCgLUyKbfA//xUy9ggXD1Ks4vIHL0c1DM4
-g6/zylN7CQtt4Bb6YdWDSAUXIl3U5Dj1kG7BWuXfJTxCx7ECQQDyLxoQRNkPwKP/
-xeOqfCgwyD52rnUJ7g9UViFcCU2ZLLEYxE4b3FECcwhOfUlxYvKdOx03Qts0taow
-dPU/BEXHAkEAxBVyKwTJ0T6rQmcQEx3WuaBhSjXgZigUN4OdXMg+LSO+1MON6Nhm
-J9ociy+xvfd0Cf3yABaAEU/hZ+Pmk2DI2QJBAO/XU8F+3VQrXH7l9HSXJppBBRM1
-7HScDRRhhAIIuI+UYgJ8DjqrMpLxZu2MSBqBenHZ5DIhBMOrkVMR0PrKeWsCQCHh
-gsSkIysgpP7oSALFmSCh8a2c+ZUtP7EH8NzjTLsH/iVNVOvy2FPygBQcvZ2RcF95
-naMeQCq9nrkQy/qTMqECQQDa1WjWS2ngwqGzHovqiKRg3lQ8MFNlvlStAQl8+9h0
-KJj8Rl6h+gO8eretBIe+y5j/hCC90xlJotzwO3jJF6Hc
------END RSA PRIVATE KEY-----