Merge pull request #75 from begriffs/errors

Errors

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,7 +41,6 @@ import qualified Data.Aeson as JSON
 import PgQuery
 import RangeQuery
 import Data.Ranged.Ranges (emptyRange)
-import Codec.Binary.Base64.String (decode)
 
 -- }}}
 
@@ -72,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

src/Main.hs

@@ -1,10 +1,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 
--- {{{ Imports
-
 module Main where
 import Dbapi
-import Middleware (reportPgErrors, redirectInsecure)
+import Middleware (inTransaction, authenticated, withSavepoint, clientErrors,
+  redirectInsecure)
 import Network.Wai.Handler.Warp hiding (Connection)
 import Database.HDBC.PostgreSQL (connectPostgreSQL')
 import Data.String.Conversions (cs)
@@ -15,8 +14,6 @@ import Options.Applicative hiding (columns)
 import Network.Wai.Middleware.Gzip (gzip, def)
 import Network.Wai.Middleware.Cors (cors)
 
--- }}}
-
 argParser :: Parser AppConfig
 argParser = AppConfig
   <$> strOption (long "db" <> short 'd' <> metavar "URI"
@@ -40,10 +37,8 @@ main = do
   Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String)
   conn <- connectPostgreSQL' dburi
   run port $ (if configSecure conf then redirectInsecure else id)
-           $ gzip def
-           $ cors corsPolicy
-           $ reportPgErrors
-           $ app conn (cs $ configAnonRole conf)
-
+    . gzip def . cors corsPolicy . clientErrors
+    $ (inTransaction . authenticated (cs $ configAnonRole conf) . withSavepoint)
+    app conn
   where
     describe = progDesc "create a REST API to an existing Postgres database"

src/Middleware.hs

@@ -3,17 +3,64 @@
 
 module Middleware where
 
-import Data.Aeson
-
-import Network.HTTP.Types.Header (hContentType, hLocation)
-import Network.HTTP.Types.Status (status400, status301)
-import Database.HDBC.Types (SqlError(..))
-import Control.Exception (catchJust)
-import Data.String.Conversions (cs)
-import Network.Wai
-import Network.URI (URI(..), parseURI)
+import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
+import Data.Maybe (fromMaybe)
 import Data.Monoid (mconcat)
 
+import Database.HDBC (runRaw)
+import Database.HDBC.PostgreSQL (Connection)
+import Database.HDBC.Types (SqlError(..))
+
+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, 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)
+
+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 [
       "error" .= object [
@@ -23,8 +70,8 @@ instance ToJSON SqlError where
       ]
     ]
 
-reportPgErrors :: Middleware
-reportPgErrors app req respond =
+clientErrors :: Application -> Application
+clientErrors app req respond =
   catchJust isPgException (app req respond) (
       respond . responseLBS status400 [(hContentType, "application/json")]
               . encode
@@ -35,7 +82,7 @@ reportPgErrors app req respond =
     isPgException = Just
 
 
-redirectInsecure :: Middleware
+redirectInsecure :: Application -> Application
 redirectInsecure app req respond = do
   let hdrs = requestHeaders req
       host = lookup "host" hdrs

src/PgQuery.hs

@@ -8,8 +8,8 @@ module PgQuery (
 , upsert
 , addUser
 , signInRole
-, pgSetRole
-, pgResetRole
+, setRole
+, resetRole
 , checkPass
 , RangedResult(..)
 , LoginAttempt(..)
@@ -165,9 +165,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 +203,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" []

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
 
@@ -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
 

test/Feature/StructureSpec.hs

@@ -35,6 +35,7 @@ uRole = "dbapi_test"} in
 
   describe "Table info" $ do
     it "is available with OPTIONS verb" $
+      pending_ >>
       request methodOptions "/menagerie" [] "" `shouldRespondWith`
       [json|
       {

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)
 
@@ -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)]
@@ -84,8 +76,7 @@ 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
+getHeader = lookup
 
 matchHeader :: CI BS.ByteString -> String -> [Header] -> Bool
 matchHeader name valRegex headers =
@@ -93,12 +84,12 @@ matchHeader name valRegex 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