128 lines
4.7 KiB
Haskell
128 lines
4.7 KiB
Haskell
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
module Main where
|
|
|
|
|
|
import Paths_postgrest (version)
|
|
-- added
|
|
import PostgREST.PgStructure
|
|
--import Data.Aeson
|
|
--import Data.List (find)
|
|
--import Data.Maybe (isJust)
|
|
import PostgREST.Types
|
|
--import Network.HTTP.Types.Status
|
|
--import Network.HTTP.Types.Header
|
|
import Network.Wai
|
|
|
|
|
|
import PostgREST.App
|
|
import PostgREST.Error (errResponse)
|
|
import PostgREST.Middleware
|
|
|
|
import Control.Monad (unless)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Data.Functor.Identity
|
|
import Data.List (intercalate)
|
|
import Data.String.Conversions (cs)
|
|
import Data.Text (Text)
|
|
import Data.Version (versionBranch)
|
|
import qualified Hasql as H
|
|
import qualified Hasql.Postgres as P
|
|
import Network.Wai.Handler.Warp hiding (Connection)
|
|
import Network.Wai.Middleware.RequestLogger (logStdout)
|
|
import Options.Applicative hiding (columns)
|
|
|
|
import System.IO (BufferMode (..),
|
|
hSetBuffering, stderr,
|
|
stdin, stdout)
|
|
|
|
import PostgREST.Config (AppConfig (..),
|
|
argParser)
|
|
|
|
isServerVersionSupported :: H.Session P.Postgres IO Bool
|
|
isServerVersionSupported = do
|
|
Identity (row :: Text) <- H.tx Nothing $ H.singleEx $ [H.stmt|SHOW server_version_num|]
|
|
return $ read (cs row) >= (90200::Integer)
|
|
|
|
main :: IO ()
|
|
main = do
|
|
hSetBuffering stdout LineBuffering
|
|
hSetBuffering stdin LineBuffering
|
|
hSetBuffering stderr NoBuffering
|
|
|
|
let opts = info (helper <*> argParser) $
|
|
fullDesc
|
|
<> progDesc (
|
|
"PostgREST "
|
|
<> prettyVersion
|
|
<> " / create a REST API to an existing Postgres database"
|
|
)
|
|
parserPrefs = prefs showHelpOnError
|
|
conf <- customExecParser parserPrefs opts
|
|
let port = configPort conf
|
|
|
|
unless (configSecure conf) $
|
|
putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
|
|
unless ("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 = P.ParamSettings (cs $ configDbHost conf)
|
|
(fromIntegral $ configDbPort conf)
|
|
(cs $ configDbUser conf)
|
|
(cs $ configDbPass conf)
|
|
(cs $ configDbName conf)
|
|
appSettings = setPort port
|
|
. setServerName (cs $ "postgrest/" <> prettyVersion)
|
|
$ defaultSettings
|
|
middle = logStdout . defaultMiddle (configSecure conf)
|
|
|
|
poolSettings <- maybe (fail "Improper session settings") return $
|
|
H.poolSettings (fromIntegral $ configPool conf) 30
|
|
pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings
|
|
|
|
supportedOrError <- H.session pool isServerVersionSupported
|
|
either (fail . show)
|
|
(\supported ->
|
|
unless supported $
|
|
fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0"
|
|
) supportedOrError
|
|
|
|
-- read the structure of the database
|
|
-- read the structure of the database
|
|
let txParam = (Just (H.ReadCommitted, Just True))
|
|
|
|
tblsRes <- H.session pool $ H.tx txParam alltables
|
|
let allTables = either (fail . show) id tblsRes
|
|
|
|
relsRes <- H.session pool $ H.tx txParam allrelations
|
|
let allRelations = either (fail . show) id relsRes
|
|
|
|
colsRes <- H.session pool $ H.tx txParam $ allcolumns allRelations
|
|
let allColumns = either (fail . show) id colsRes
|
|
|
|
pkRes <- H.session pool $ H.tx txParam allprimaryKeys
|
|
let allPrimaryKeys = either (fail . show) id pkRes
|
|
|
|
-- tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl
|
|
-- let allTablesAcl = either (fail . show) id tableAclRes
|
|
|
|
|
|
let dbstructure = DbStructure {
|
|
tables=allTables
|
|
, columns=allColumns
|
|
, relations=allRelations
|
|
, primaryKeys=allPrimaryKeys
|
|
--, tablesAcl=allTablesAcl
|
|
}
|
|
|
|
runSettings appSettings $ middle $ \ req respond -> do
|
|
body <- strictRequestBody req
|
|
resOrError <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True)) $
|
|
authenticated conf (app dbstructure conf body) req
|
|
either (respond . errResponse) respond resOrError
|
|
|
|
where
|
|
prettyVersion = intercalate "." $ map show $ versionBranch version
|