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

comments for Main.hs (#888)

Browse Source
This commit is contained in:
Pfalzgraf Martin
2017-07-11 08:11:20 -07:00
committed by Joe Nelson
parent 1513c88f77
commit c47e37177d
2 changed files with 370 additions and 73 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.stylish-haskell.yaml
+190
View File
@@ -0,0 +1,190 @@
# stylish-haskell configuration file
# ==================================
# The stylish-haskell tool is mainly configured by specifying steps. These steps
# are a list, so they have an order, and one specific step may appear more than
# once (if needed). Each file is processed by these steps in the given order.
steps:
# Convert some ASCII sequences to their Unicode equivalents. This is disabled
# by default.
# - unicode_syntax:
# # In order to make this work, we also need to insert the UnicodeSyntax
# # language pragma. If this flag is set to true, we insert it when it's
# # not already present. You may want to disable it if you configure
# # language extensions using some other method than pragmas. Default:
# # true.
# add_language_pragma: true
# Align the right hand side of some elements. This is quite conservative
# and only applies to statements where each element occupies a single
# line.
- simple_align:
cases: true
top_level_patterns: true
records: true
# Import cleanup
- imports:
# There are different ways we can align names and lists.
#
# - global: Align the import names and import list throughout the entire
# file.
#
# - file: Like global, but don't add padding when there are no qualified
# imports in the file.
#
# - group: Only align the imports per group (a group is formed by adjacent
# import lines).
#
# - none: Do not perform any alignment.
#
# Default: global.
align: global
# Folowing options affect only import list alignment.
#
# List align has following options:
#
# - after_alias: Import list is aligned with end of import including
# 'as' and 'hiding' keywords.
#
# > import qualified Data.List as List (concat, foldl, foldr, head,
# > init, last, length)
#
# - with_alias: Import list is aligned with start of alias or hiding.
#
# > import qualified Data.List as List (concat, foldl, foldr, head,
# > init, last, length)
#
# - new_line: Import list starts always on new line.
#
# > import qualified Data.List as List
# > (concat, foldl, foldr, head, init, last, length)
#
# Default: after_alias
list_align: after_alias
# Long list align style takes effect when import is too long. This is
# determined by 'columns' setting.
#
# - inline: This option will put as much specs on same line as possible.
#
# - new_line: Import list will start on new line.
#
# - new_line_multiline: Import list will start on new line when it's
# short enough to fit to single line. Otherwise it'll be multiline.
#
# - multiline: One line per import list entry.
# Type with contructor list acts like single import.
#
# > import qualified Data.Map as M
# > ( empty
# > , singleton
# > , ...
# > , delete
# > )
#
# Default: inline
long_list_align: inline
# Align empty list (importing instances)
#
# Empty list align has following options
#
# - inherit: inherit list_align setting
#
# - right_after: () is right after the module name:
#
# > import Vector.Instances ()
#
# Default: inherit
empty_list_align: inherit
# List padding determines indentation of import list on lines after import.
# This option affects 'long_list_align'.
#
# - <integer>: constant value
#
# - module_name: align under start of module name.
# Useful for 'file' and 'group' align settings.
list_padding: 4
# Separate lists option affects formating of import list for type
# or class. The only difference is single space between type and list
# of constructors, selectors and class functions.
#
# - true: There is single space between Foldable type and list of it's
# functions.
#
# > import Data.Foldable (Foldable (fold, foldl, foldMap))
#
# - false: There is no space between Foldable type and list of it's
# functions.
#
# > import Data.Foldable (Foldable(fold, foldl, foldMap))
#
# Default: true
separate_lists: true
# Language pragmas
- language_pragmas:
# We can generate different styles of language pragma lists.
#
# - vertical: Vertical-spaced language pragmas, one per line.
#
# - compact: A more compact style.
#
# - compact_line: Similar to compact, but wrap each line with
# `{-#LANGUAGE #-}'.
#
# Default: vertical.
style: vertical
# Align affects alignment of closing pragma brackets.
#
# - true: Brackets are aligned in same collumn.
#
# - false: Brackets are not aligned together. There is only one space
# between actual import and closing bracket.
#
# Default: true
align: true
# stylish-haskell can detect redundancy of some language pragmas. If this
# is set to true, it will remove those redundant pragmas. Default: true.
remove_redundant: true
# Replace tabs by spaces. This is disabled by default.
# - tabs:
# # Number of spaces to use for each tab. Default: 8, as specified by the
# # Haskell report.
# spaces: 8
# Remove trailing whitespace
- trailing_whitespace: {}
# A common setting is the number of columns (parts of) code will be wrapped
# to. Different steps take this into account. Default: 80.
columns: 70
# By default, line endings are converted according to the OS. You can override
# preferred format here.
#
# - native: Native newline format. CRLF on Windows, LF on other OSes.
#
# - lf: Convert to LF ("\n").
#
# - crlf: Convert to CRLF ("\r\n").
#
# Default: native.
newline: native
# Sometimes, language extensions are specified in a cabal file or from the
# command line instead of using language pragmas in the file. stylish-haskell
# needs to be aware of these, so it can parse the file correctly.
#
# No language extensions are enabled by default.
language_extensions:
- TemplateHaskell
- QuasiQuotes
- CPP
main/Main.hs
+180 -73
View File
@@ -2,39 +2,49 @@
module Main where
import PostgREST.App (postgrest)
import PostgREST.Config (AppConfig (..),
PgVersion (..),
minimumPgVersion,
prettyVersion, readOptions)
import PostgREST.DbStructure (getDbStructure)
import PostgREST.Error (encodeError)
import PostgREST.OpenAPI (isMalformedProxyUri)
import PostgREST.Types (DbStructure, Schema)
import Protolude
import PostgREST.App
import PostgREST.Config (AppConfig (..),
PgVersion (..),
minimumPgVersion,
prettyVersion,
readOptions)
import PostgREST.Error (encodeError)
import PostgREST.OpenAPI (isMalformedProxyUri)
import PostgREST.DbStructure
import PostgREST.Types (DbStructure, Schema)
import Control.AutoUpdate
import Control.Retry
import Data.ByteString.Base64 (decode)
import Data.String (IsString (..))
import Data.Text (stripPrefix, pack, replace)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Text.IO (hPutStrLn, readFile)
import Data.Time.Clock.POSIX (getPOSIXTime)
import qualified Hasql.Query as H
import qualified Hasql.Session as H
import qualified Hasql.Decoders as HD
import qualified Hasql.Encoders as HE
import qualified Hasql.Pool as P
import Network.Wai.Handler.Warp
import System.IO (BufferMode (..),
hSetBuffering)
import Data.IORef
import Control.AutoUpdate (defaultUpdateSettings,
mkAutoUpdate, updateAction)
import Control.Retry (RetryStatus, capDelay,
exponentialBackoff,
retrying, rsPreviousDelay)
import Data.ByteString.Base64 (decode)
import Data.IORef (IORef, atomicWriteIORef,
newIORef, readIORef)
import Data.String (IsString (..))
import Data.Text (pack, replace, stripPrefix)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Text.IO (hPutStrLn, readFile)
import Data.Time.Clock.POSIX (getPOSIXTime)
import qualified Hasql.Decoders as HD
import qualified Hasql.Encoders as HE
import qualified Hasql.Pool as P
import qualified Hasql.Query as H
import qualified Hasql.Session as H
import Network.Wai.Handler.Warp (defaultSettings,
runSettings, setHost,
setPort, setServerName,
setTimeout)
import System.IO (BufferMode (..),
hSetBuffering)
#ifndef mingw32_HOST_OS
import System.Posix.Signals
#endif
{-|
Used by connectionWorker to know if it should throw an error and kill the
main thread.
-}
isServerVersionSupported :: H.Session Bool
isServerVersionSupported = do
ver <- H.query () pgVersion
@@ -45,14 +55,30 @@ isServerVersionSupported = do
HE.unit (HD.singleRow $ HD.value HD.int4) False
{-|
The purpose of this worker is to fill the refDbStructure created in 'main'
with the 'DbStructure' returned from calling 'getDbStructure'. This method
is meant to be called by multiple times by the same thread, but does nothing if
the previous invocation has not terminated. In all cases this method does not
halt the calling thread, the work is preformed in a separate thread.
Note: 'atomicWriteIORef' is essentially a lazy semaphore that prevents two
threads from running 'connectionWorker' at the same time.
Background thread that does the following :
1. Tries to connect to pg server and will keep trying until success.
2. Checks if the pg version is supported and if it's not it kills the main program.
2. Checks if the pg version is supported and if it's not it kills the main
program.
3. Obtains the dbStructure.
4. If 2 or 3 fail to give their result it means the connection is down so it goes back to 1,
otherwise it finishes his work successfully.
4. If 2 or 3 fail to give their result it means the connection is down so it
goes back to 1, otherwise it finishes his work successfully.
-}
connectionWorker :: ThreadId -> P.Pool -> Schema -> IORef (Maybe DbStructure) -> IORef Bool -> IO ()
connectionWorker
:: ThreadId -- ^ This thread is killed if 'isServerVersionSupported' returns false
-> P.Pool -- ^ The PostgreSQL connection pool
-> Schema -- ^ Schema PostgREST is serving up
-> IORef (Maybe DbStructure) -- ^ mutable reference to 'DbStructure'
-> IORef Bool -- ^ Used as a binary Semaphore
-> IO ()
connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do
isWorkerOn <- readIORef refIsWorkerOn
unless isWorkerOn $ do
@@ -82,7 +108,16 @@ connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do
atomicWriteIORef refIsWorkerOn False
putStrLn ("Connection successful" :: Text)
-- | Connect to pg server if it fails retry with capped exponential backoff until success
{-|
Used by 'connectionWorker' to check if the provided db-uri lets
the application access the PostgreSQL database. This method is used
the first time the connection is tested, but only to test before
calling 'getDbStructure' inside the 'connectionWorker' method.
The connection tries are capped, but if the connection times out no error is
thrown, just 'False' is returned.
-}
connectingSucceeded :: P.Pool -> IO Bool
connectingSucceeded pool =
retrying (capDelay 32000000 $ exponentialBackoff 1000000)
@@ -103,39 +138,70 @@ connectingSucceeded pool =
putStrLn $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..."
return itShould
{-|
This is where everything starts.
-}
main :: IO ()
main = do
--
-- LineBuffering: the entire output buffer is flushed whenever a newline is
-- output, the buffer overflows, a hFlush is issued or the handle is closed
--
-- NoBuffering: output is written immediately and never stored in the buffer
hSetBuffering stdout LineBuffering
hSetBuffering stdin LineBuffering
hSetBuffering stdin LineBuffering
hSetBuffering stderr NoBuffering
--
-- readOptions builds the 'AppConfig' from the config file specified on the
-- command line
conf <- loadSecretFile =<< readOptions
let host = configHost conf
port = configPort conf
proxy = configProxyUri conf
pgSettings = toS (configDatabase conf)
appSettings = setHost ((fromString . toS) host)
. setPort port
. setServerName (toS $ "postgrest/" <> prettyVersion)
. setTimeout 3600
$ defaultSettings
when (isMalformedProxyUri $ toS <$> proxy) $ panic
"Malformed proxy uri, a correct example: https://example.com:8443/basePath"
pgSettings = toS (configDatabase conf) -- is the db-uri
appSettings =
setHost ((fromString . toS) host) -- Warp settings
. setPort port
. setServerName (toS $ "postgrest/" <> prettyVersion)
. setTimeout 3600 $
defaultSettings
--
-- Checks that the provided proxy uri is formated correctly,
-- does not test if it works here.
when (isMalformedProxyUri $ toS <$> proxy) $
panic
"Malformed proxy uri, a correct example: https://example.com:8443/basePath"
putStrLn $ ("Listening on port " :: Text) <> show (configPort conf)
--
-- create connection pool with the provided settings, returns either
-- a 'Connection' or a 'ConnectionError'. Does not throw.
pool <- P.acquire (configPool conf, 10, pgSettings)
--
-- To be filled in by connectionWorker
refDbStructure <- newIORef Nothing
--
-- Helper ref to make sure just one connectionWorker can run at a time
refIsWorkerOn <- newIORef False
--
-- This is passed to the connectionWorker method so it can kill the main
-- thread if the PostgreSQL's version is not supported.
mainTid <- myThreadId
connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn
--
-- Sets the refDbStructure
connectionWorker
mainTid
pool
(configSchema conf)
refDbStructure
refIsWorkerOn
--
-- Only for systems with signals:
--
-- releases the connection pool whenever the program is terminated,
-- see issue #268
--
-- Plus the SIGHUP signal updates the internal 'DbStructure' by running
-- 'connectionWorker' exactly as before.
#ifndef mingw32_HOST_OS
forM_ [sigINT, sigTERM] $ \sig ->
void $ installHandler sig (Catch $ do
@@ -144,38 +210,79 @@ main = do
) Nothing
void $ installHandler sigHUP (
Catch $ connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn
) Nothing
Catch $ connectionWorker
mainTid
pool
(configSchema conf)
refDbStructure
refIsWorkerOn
) Nothing
#endif
--
-- ask for the OS time at most once per second
getTime <- mkAutoUpdate
defaultUpdateSettings { updateAction = getPOSIXTime }
getTime <-
mkAutoUpdate defaultUpdateSettings {updateAction = getPOSIXTime}
--
-- run the postgrest application
runSettings appSettings $
postgrest
conf
refDbStructure
pool
getTime
(connectionWorker
mainTid
pool
(configSchema conf)
refDbStructure
refIsWorkerOn)
runSettings appSettings $ postgrest conf refDbStructure pool getTime
(connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn)
{-|
The purpose of this function is to load the JWT secret from a file if
configJwtSecret is actually a filepath and replaces some characters if the JWT
is base64 encoded.
The reason some characters need to be replaced is because JWT is actually
base64url encoded which must be turned into just base64 before decoding.
To check if the JWT secret is provided is in fact a file path, it must be
decoded as 'Text' to be processed.
decodeUtf8: Decode a ByteString containing UTF-8 encoded text that is known to
be valid.
-}
loadSecretFile :: AppConfig -> IO AppConfig
loadSecretFile conf = extractAndTransform mSecret
where
mSecret = decodeUtf8 <$> configJwtSecret conf
isB64 = configJwtSecretIsBase64 conf
mSecret = decodeUtf8 <$> configJwtSecret conf
isB64 = configJwtSecretIsBase64 conf
--
-- The Text (variable name secret) here is mSecret from above which is the JWT
-- decoded as Utf8
--
-- stripPrefix: Return the suffix of the second string if its prefix matches
-- the entire first string.
--
-- The configJwtSecret is a filepath instead of the JWT secret itself if the
-- secret has @ as its prefix.
extractAndTransform :: Maybe Text -> IO AppConfig
extractAndTransform Nothing = return conf
extractAndTransform (Just s) =
fmap setSecret $ transformString isB64 =<<
case stripPrefix "@" s of
Nothing -> return s
Just filename -> readFile (toS filename)
extractAndTransform Nothing = return conf
extractAndTransform (Just secret) =
fmap setSecret $
transformString isB64 =<<
case stripPrefix "@" secret of
Nothing -> return secret
Just filename -> readFile (toS filename)
--
-- Turns the Base64url encoded JWT into Base64
transformString :: Bool -> Text -> IO ByteString
transformString False t = return . encodeUtf8 $ t
transformString True t =
transformString True t =
case decode (encodeUtf8 $ replaceUrlChars t) of
Left errMsg -> panic $ pack errMsg
Right bs -> return bs
setSecret bs = conf { configJwtSecret = Just bs }
replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "="
setSecret bs = conf {configJwtSecret = Just bs}
--
-- replace: Replace every occurrence of one substring with another
replaceUrlChars =
replace "_" "/" . replace "-" "+" . replace "." "="