From 782d6520a2895a85854029bc57cc36fe001029a7 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 7 Dec 2014 00:11:14 -0800 Subject: [PATCH] Upgrade hasql to 0.4.0 --- dbapi.cabal | 4 ++-- src/App.hs | 11 +++++------ src/Auth.hs | 2 +- src/Main.hs | 7 ++----- src/Middleware.hs | 7 +++---- test/SpecHelper.hs | 7 ++----- 6 files changed, 15 insertions(+), 23 deletions(-) diff --git a/dbapi.cabal b/dbapi.cabal index 02737d805..a3b6c8f59 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -16,7 +16,7 @@ executable dbapi default-extensions: OverloadedStrings other-extensions: QuasiQuotes build-depends: base >=4.6 && <5 - , hasql >= 0.2.3 && < 0.3.0, hasql-backend, hasql-postgres + , hasql >= 0.4.0, hasql-backend, hasql-postgres , warp >= 3.0.2, wai >= 3.0.1 , wai-extra, wai-cors , wai-middleware-static >= 0.6.0 @@ -58,7 +58,7 @@ Test-Suite spec Other-Modules: App, Auth, Config, Spec, SpecHelper Build-Depends: base, hspec >= 2.0, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json - , hasql >= 0.2.3 && < 0.3.0, hasql-backend, hasql-postgres + , hasql >= 0.4.0, hasql-backend, hasql-postgres , warp >= 3.0.2, wai >= 3.0.1 , HTTP, convertible , case-insensitive diff --git a/src/App.hs b/src/App.hs index fa589da77..7c87d6ebe 100644 --- a/src/App.hs +++ b/src/App.hs @@ -29,7 +29,6 @@ import Data.Aeson import Data.Coerce import Data.Monoid import qualified Hasql as H -import qualified Hasql.Backend as HB import qualified Hasql.Postgres as H import PgQuery @@ -37,7 +36,7 @@ import RangeQuery import PgStructure import Auth -app :: Request -> H.Session H.Postgres IO Response +app :: Request -> H.Session H.Postgres s IO Response app req = case (path, verb) of ([], _) -> do @@ -169,12 +168,12 @@ app req = allOrigins = ("Access-Control-Allow-Origin", "*") :: Header -isSqlError :: HB.Error -> Maybe HB.Error -isSqlError (HB.ErroneousResult x) = Just $ HB.ErroneousResult x +isSqlError :: H.Error -> Maybe H.Error +isSqlError (H.ErroneousResult x) = Just $ H.ErroneousResult x isSqlError _ = Nothing -sqlErrHandler :: HB.Error -> IO Response -sqlErrHandler (HB.ErroneousResult err) = +sqlErrHandler :: H.Error -> IO Response +sqlErrHandler (H.ErroneousResult err) = return $ if "42P01" `isInfixOf` err then responseLBS status404 [] "" else responseLBS status400 [] (cs err) diff --git a/src/Auth.hs b/src/Auth.hs index 87add40f0..00fbeec7a 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -50,7 +50,7 @@ setRole role = H.unit ("set role " <> cs (pgFmtLit role), [], True) resetRole :: H.Tx H.Postgres s () resetRole = H.unit [H.q|reset role|] -addUser :: Text -> Text -> Text -> H.Session H.Postgres IO () +addUser :: Text -> Text -> Text -> H.Session H.Postgres s IO () addUser identity pass role = do Just hashed <- liftIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass) H.tx Nothing $ H.unit $ diff --git a/src/Main.hs b/src/Main.hs index 6d44c6c7a..7836e868a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,7 +7,6 @@ import Middleware import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (runReaderT, ask) import Control.Exception import Data.String.Conversions (cs) import Data.List.Split (splitOn) @@ -51,12 +50,10 @@ main = do . gzip def . cors corsPolicy . clientErrors . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) - H.session pgSettings sessSettings $ do - session' <- flip runReaderT <$> ask - + H.session pgSettings sessSettings $ H.sessionUnlifter >>= \unlift -> liftIO $ runSettings appSettings $ middle $ \req respond -> respond =<< catchJust isSqlError - (session' $ authenticated (cs $ configAnonRole conf) app req) + (unlift $ authenticated (cs $ configAnonRole conf) app req) sqlErrHandler where diff --git a/src/Middleware.hs b/src/Middleware.hs index 85529de2d..ac5aab73c 100644 --- a/src/Middleware.hs +++ b/src/Middleware.hs @@ -38,8 +38,8 @@ import Debug.Trace -- else Database.PostgreSQL.Simple.withSavepoint conn go -- where go = app conn req respond -authenticated :: Text -> (Request -> H.Session H.Postgres IO Response) -> - Request -> H.Session H.Postgres IO Response +authenticated :: Text -> (Request -> H.Session H.Postgres s IO Response) -> + Request -> H.Session H.Postgres s IO Response authenticated anon app req = do attempt <- httpRequesterRole (requestHeaders req) case attempt of @@ -51,7 +51,7 @@ authenticated anon app req = do NoCredentials -> runInRole anon where - httpRequesterRole :: RequestHeaders -> H.Session H.Postgres IO LoginAttempt + httpRequesterRole :: RequestHeaders -> H.Session H.Postgres s IO LoginAttempt httpRequesterRole hdrs = do let auth = fromMaybe "" $ lookup hAuthorization hdrs case split (==' ') (cs auth) of @@ -61,7 +61,6 @@ authenticated anon app req = do _ -> return MalformedAuth _ -> return NoCredentials - runInRole :: Text -> H.Session H.Postgres IO Response runInRole r = do H.tx Nothing $ setRole r resp <- app req diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 74eb9bfa7..5d3d86df1 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -11,9 +11,7 @@ import Hasql.Postgres as H import Data.String.Conversions (cs) -- import Control.Exception.Base (bracket, finally) -import Control.Monad.Reader (runReaderT, ask) import Control.Monad (void) -import Control.Applicative ( (<$>) ) import Control.Exception import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, @@ -47,10 +45,9 @@ pgSettings = H.Postgres "localhost" 5432 "dbapi_test" "" "dbapi_test" withApp :: ActionWith Application -> IO () withApp perform = perform $ middle $ \req resp -> - H.session pgSettings testSettings $ do - session' <- flip runReaderT <$> ask + H.session pgSettings testSettings $ H.sessionUnlifter >>= \unlift -> liftIO $ resp =<< catchJust isSqlError - (session' $ authenticated (cs $ configAnonRole cfg) app req) + (unlift $ authenticated (cs $ configAnonRole cfg) app req) sqlErrHandler where middle = cors corsPolicy