From c47e37177d21c5094fbeab4705b78d063742fc61 Mon Sep 17 00:00:00 2001 From: Pfalzgraf Martin Date: Wed, 12 Jul 2017 01:11:20 +1000 Subject: [PATCH] comments for Main.hs (#888) --- .stylish-haskell.yaml | 190 +++++++++++++++++++++++++++++++ main/Main.hs | 253 ++++++++++++++++++++++++++++++------------ 2 files changed, 370 insertions(+), 73 deletions(-) create mode 100644 .stylish-haskell.yaml diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 000000000..016013c37 --- /dev/null +++ b/.stylish-haskell.yaml @@ -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'. + # + # - : 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 diff --git a/main/Main.hs b/main/Main.hs index 09f8ce5ec..7cd881c03 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -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 "." "="