WIP: share server code between tests and program

- Share server code in Main - Switch to hasql-pool - Use pool in tests - DRY up test runner
2016-02-21 12:22:18 -08:00
parent 8a006f07a7
commit d7fe59f0b0
15 changed files with 109 additions and 141 deletions
@@ -7,11 +7,13 @@ module PostgREST.Error (pgErrResponse, errResponse) where

 import           Data.Aeson                ((.=))
 import qualified Data.Aeson                as JSON
+import           Data.Maybe                (fromMaybe)
 import           Data.Monoid               ((<>))
 import           Data.String.Conversions   (cs)
 import           Data.Text                 (Text)
 import qualified Data.Text                 as T
 import qualified Hasql.Session             as H
+import qualified Hasql.Pool                as P
 import           Network.HTTP.Types.Header
 import qualified Network.HTTP.Types.Status as HT
 import           Network.Wai               (Response, responseLBS)
@@ -19,10 +21,17 @@ import           Network.Wai               (Response, responseLBS)
 errResponse :: HT.Status -> Text -> Response
 errResponse status message = responseLBS status [(hContentType, "application/json")] (cs $ T.concat ["{\"message\":\"",message,"\"}"])

-pgErrResponse :: H.Error -> Response
+pgErrResponse :: P.UsageError -> Response
 pgErrResponse e = responseLBS (httpStatus e)
  [(hContentType, "application/json")] (JSON.encode e)

+instance JSON.ToJSON P.UsageError where
+  toJSON (P.ConnectionError e) = JSON.object [
+    "code" .= ("" :: T.Text),
+    "message" .= ("Connection error" :: T.Text),
+    "details" .= (cs (fromMaybe "" e) :: T.Text)]
+  toJSON e = JSON.toJSON e -- H.Error
+
 instance JSON.ToJSON H.Error where
  toJSON (H.ResultError (H.ServerError c m d h)) = JSON.object [
    "code" .= (cs c::T.Text),
@@ -51,15 +60,17 @@ instance JSON.ToJSON H.Error where
    "message" .= ("Database client error"::String),
    "details" .= (fmap cs d::Maybe T.Text)]

-httpStatus :: H.Error -> HT.Status
-httpStatus (H.ResultError (H.ServerError c _ _ _)) =
+httpStatus :: P.UsageError -> HT.Status
+httpStatus (P.ConnectionError _) =
+  HT.status500
+httpStatus (P.SessionError (H.ResultError (H.ServerError c _ _ _))) =
  case cs c of
    '0':'8':_ -> HT.status503 -- pg connection err
    '0':'9':_ -> HT.status500 -- triggered action exception
    '0':'L':_ -> HT.status403 -- invalid grantor
    '0':'P':_ -> HT.status403 -- invalid role specification
-    "23503" -> HT.status409 -- foreign_key_violation
-    "23505" -> HT.status409 -- unique_violation
+    "23503"   -> HT.status409 -- foreign_key_violation
+    "23505"   -> HT.status409 -- unique_violation
    '2':'5':_ -> HT.status500 -- invalid tx state
    '2':'8':_ -> HT.status403 -- invalid auth specification
    '2':'D':_ -> HT.status500 -- invalid tx termination
@@ -76,8 +87,8 @@ httpStatus (H.ResultError (H.ServerError c _ _ _)) =
    'H':'V':_ -> HT.status500 -- foreign data wrapper error
    'P':'0':_ -> HT.status500 -- PL/pgSQL Error
    'X':'X':_ -> HT.status500 -- internal Error
-    "42P01" -> HT.status404 -- undefined table
-    "42501" -> HT.status404 -- insufficient privilege
-    _ -> HT.status400
-httpStatus (H.ResultError _) = HT.status500
-httpStatus (H.ClientError _) = HT.status503
+    "42P01"   -> HT.status404 -- undefined table
+    "42501"   -> HT.status404 -- insufficient privilege
+    _         -> HT.status400
+httpStatus (P.SessionError (H.ResultError _)) = HT.status500
+httpStatus (P.SessionError (H.ClientError _)) = HT.status503
@@ -1,6 +1,6 @@
 {-# LANGUAGE CPP #-}

-module Main where
+module PostgREST.Main where


 import           PostgREST.App
@@ -9,21 +9,20 @@ import           PostgREST.Config                     (AppConfig (..),
                                                       prettyVersion,
                                                       readOptions)
 import           PostgREST.DbStructure
-import           PostgREST.Error                      (errResponse, pgErrResponse)
+import           PostgREST.Error                      (pgErrResponse)
 import           PostgREST.Middleware
+import           PostgREST.Types                      (DbStructure)
 import           PostgREST.QueryBuilder               (inTransaction, Isolation(..))

 import           Control.Monad
 import           Data.Monoid                          ((<>))
-import           Data.Pool
 import           Data.String.Conversions              (cs)
 import           Data.Time.Clock.POSIX                (getPOSIXTime)
 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 qualified Hasql.Pool                           as P
 import           Network.Wai
 import           Network.Wai.Handler.Warp
 import           Network.Wai.Middleware.RequestLogger (logStdout)
@@ -55,51 +54,45 @@ main = do

  conf <- readOptions
  let port = configPort conf
+      pgSettings = cs (configDatabase conf)
+      appSettings = setPort port
+                  . setServerName (cs $ "postgrest/" <> prettyVersion)
+                  $ defaultSettings

  unless (secret "secret" /= configJwtSecret conf) $
    putStrLn "WARNING, running in insecure mode, JWT secret is the default value"
  Prelude.putStrLn $ "Listening on port " ++
    (show $ configPort conf :: String)

-  let pgSettings = cs (configDatabase conf)
-      appSettings = setPort port
-                  . setServerName (cs $ "postgrest/" <> prettyVersion)
-                  $ defaultSettings
-      middle = logStdout . defaultMiddle

-  pool <- createPool (H.acquire pgSettings)
-            (either (const $ return ()) H.release) 1 1 (configPool conf)
-
-  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
+  pool <- P.acquire (configPool conf, 10, pgSettings)

 #ifndef mingw32_HOST_OS
  tid <- myThreadId
  void $ installHandler keyboardSignal (Catch $ do
-      destroyAllResources pool
+      P.release pool
      throwTo tid UserInterrupt
    ) Nothing
 #endif

-  runSettings appSettings $ middle $ \ req respond -> do
+  result <- P.use pool $ do
+    supported <- isServerVersionSupported
+    unless supported $ error (
+      "Cannot run in this PostgreSQL version, PostgREST needs at least "
+      <> show minimumPgVersion)
+    getDbStructure (cs $ configSchema conf)
+
+  let dbStructure = either (error.show) id result
+  runSettings appSettings $ postgrest conf dbStructure pool
+
+postgrest :: AppConfig -> DbStructure -> P.Pool -> Application
+postgrest conf dbStructure pool =
+  let middle = logStdout . defaultMiddle in
+
+  middle $ \ req respond -> do
    time <- getPOSIXTime
    body <- strictRequestBody req
-    let handleReq = H.run $ inTransaction ReadCommitted
-          (runWithClaims conf time (app dbStructure conf body) req)
-    res <- withResource pool $ \case
-      Left err -> return $ errResponse HT.status500 (cs . show $ err)
-      Right c -> do
-        resOrError <- handleReq c
-        return $ either pgErrResponse id resOrError
-    respond res
+    let handleReq = inTransaction ReadCommitted $
+          runWithClaims conf time (app dbStructure conf body) req
+    resp <- either pgErrResponse id <$> P.use pool handleReq
+    respond resp