comments for Main.hs (#888)
This commit is contained in:
Pfalzgraf Martin
committed by
Joe Nelson
Joe Nelson
parent
1513c88f77
commit
c47e37177d
@@ -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
|
||||
+180
-73
@@ -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 "." "="
|
||||
|
||||
Reference in New Issue
Block a user