jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

The app compiles but totally untested

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