From 3844f3ee96d70825323d01567aba4843ca1f74fa Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 18 Jan 2016 22:41:36 -0800 Subject: [PATCH] The app compiles but totally untested --- postgrest.cabal | 7 ++++- src/PostgREST/Error.hs | 10 +++--- src/PostgREST/Main.hs | 71 ++++++++++++++++++++++-------------------- 3 files changed, 48 insertions(+), 40 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index ea8acb100..09c6a9450 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -28,7 +28,7 @@ executable postgrest ghc-options: -Wall -W -O2 main-is: PostgREST/Main.hs - default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes + default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase default-language: Haskell2010 build-depends: aeson >= 0.8 , base >= 4.8 && < 5 @@ -36,13 +36,16 @@ executable postgrest , case-insensitive , cassava , containers + , contravariant , errors , hasql >= 0.19.3.1 && < 0.20 + , interpolatedstring-perl6 , jwt , optparse-applicative >= 0.11 && < 0.13 , parsec , postgrest , regex-tdfa + , resource-pool , safe >= 0.3 && < 0.4 , scientific , string-conversions @@ -166,6 +169,7 @@ Test-Suite spec , case-insensitive , cassava , containers + , contravariant , errors , hasql , heredoc @@ -174,6 +178,7 @@ Test-Suite spec , hspec-wai , hspec-wai-json , http-types + , interpolatedstring-perl6 , jwt , optparse-applicative , packdeps diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 71ddafa3b..e6629f5dd 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} -module PostgREST.Error (PgError, pgErrResponse, errResponse) where +module PostgREST.Error (pgErrResponse, errResponse) where import Data.Aeson ((.=)) @@ -16,16 +16,14 @@ import Network.HTTP.Types.Header import qualified Network.HTTP.Types.Status as HT import Network.Wai (Response, responseLBS) -type PgError = H.Error - errResponse :: HT.Status -> Text -> Response errResponse status message = responseLBS status [(hContentType, "application/json")] (cs $ T.concat ["{\"message\":\"",message,"\"}"]) -pgErrResponse :: PgError -> Response +pgErrResponse :: H.Error -> Response pgErrResponse e = responseLBS (httpStatus e) [(hContentType, "application/json")] (JSON.encode e) -instance JSON.ToJSON PgError where +instance JSON.ToJSON H.Error where toJSON (H.ResultError (H.ServerError c m d h)) = JSON.object [ "code" .= (cs c::T.Text), "message" .= (cs m::T.Text), @@ -53,7 +51,7 @@ instance JSON.ToJSON PgError where "message" .= ("Database client error"::String), "details" .= (fmap cs d::Maybe T.Text)] -httpStatus :: PgError -> HT.Status +httpStatus :: H.Error -> HT.Status httpStatus (H.ResultError (H.ServerError c _ _ _)) = case cs c of '0':'8':_ -> HT.status503 -- pg connection err diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 5061d9e19..a4075e3f2 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -9,19 +9,20 @@ import PostgREST.Config (AppConfig (..), prettyVersion, readOptions) import PostgREST.DbStructure -import PostgREST.Error (PgError, pgErrResponse) +import PostgREST.Error (errResponse, pgErrResponse) import PostgREST.Middleware import Control.Monad (unless, void) -import Control.Monad.IO.Class (liftIO) -import Data.Aeson (encode) -import Data.Functor.Identity import Data.Monoid ((<>)) +import Data.Pool import Data.String.Conversions (cs) -import Data.Text (Text) import Data.Time.Clock.POSIX (getPOSIXTime) -import qualified Hasql as H -import qualified Hasql.Postgres as P +import qualified Hasql.Query as H +import qualified Hasql.Connection as H +import qualified Hasql.Session as H +import qualified Hasql.Decoders as HD +import qualified Hasql.Encoders as HE +import qualified Network.HTTP.Types.Status as HT import Network.Wai import Network.Wai.Handler.Warp hiding (Connection) import Network.Wai.Middleware.RequestLogger (logStdout) @@ -36,13 +37,14 @@ import Control.Concurrent (myThreadId) import Control.Exception.Base (throwTo, AsyncException(..)) #endif -isServerVersionSupported :: H.Session P.Postgres IO Bool +isServerVersionSupported :: H.Session Bool isServerVersionSupported = do - Identity (row :: Text) <- H.tx Nothing $ H.singleEx [H.stmt|SHOW server_version_num|] - return $ read (cs row) >= minimumPgVersion - -hasqlError :: PgError -> IO a -hasqlError = error . cs . encode + ver <- H.query () pgVersion + return $ read (cs ver) >= minimumPgVersion + where + pgVersion = + H.statement "SHOW server_version_num" + HE.unit (HD.singleRow $ HD.value HD.text) True main :: IO () main = do @@ -58,40 +60,43 @@ main = do Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String) - let pgSettings = P.StringSettings $ cs (configDatabase conf) + let pgSettings = cs (configDatabase conf) appSettings = setPort port . setServerName (cs $ "postgrest/" <> prettyVersion) $ defaultSettings middle = logStdout . defaultMiddle - poolSettings <- maybe (fail "Improper session settings") return $ - H.poolSettings (fromIntegral $ configPool conf) 30 - pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings + pool <- createPool (H.acquire pgSettings) + (either (const $ return ()) H.release) 1 1 (configPool conf) - supportedOrError <- H.session pool isServerVersionSupported - either hasqlError - (\supported -> - unless supported $ - error ( - "Cannot run in this PostgreSQL version, PostgREST needs at least " - <> show minimumPgVersion) - ) supportedOrError + dbStructure <- withResource pool $ \case + Left err -> error $ show err + Right c -> do + supported <- H.run isServerVersionSupported c + case supported of + Left e -> error $ show e + Right good -> unless good $ + error ( + "Cannot run in this PostgreSQL version, PostgREST needs at least " + <> show minimumPgVersion) + + dbOrError <- H.run (getDbStructure (cs $ configSchema conf)) c + either (error . show) return dbOrError #ifndef mingw32_HOST_OS tid <- myThreadId void $ installHandler keyboardSignal (Catch $ do - H.releasePool pool + destroyAllResources pool throwTo tid UserInterrupt ) Nothing #endif - let txSettings = Just (H.ReadCommitted, Just True) - dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema conf) - dbStructure <- either hasqlError return dbOrError - runSettings appSettings $ middle $ \ req respond -> do time <- getPOSIXTime body <- strictRequestBody req - resOrError <- liftIO $ H.session pool $ H.tx txSettings $ - runWithClaims conf time (app dbStructure conf body) req - either (respond . pgErrResponse) respond resOrError + let handleReq = H.run (runWithClaims conf time (app dbStructure conf body) req) + withResource pool $ \case + Left err -> respond $ errResponse HT.status500 (cs . show $ err) + Right c -> do + resOrError <- handleReq c + either (respond . pgErrResponse) respond resOrError