comments for Main.hs (#888)

.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'.
+      #
+      # - <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

@@ -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.AutoUpdate       (defaultUpdateSettings,
-import           Control.Retry
+                                           mkAutoUpdate, updateAction)
-import           Data.ByteString.Base64               (decode)
+import           Control.Retry            (RetryStatus, capDelay,
-import           Data.String                          (IsString (..))
+                                           exponentialBackoff,
-import           Data.Text                            (stripPrefix, pack, replace)
+                                           retrying, rsPreviousDelay)
-import           Data.Text.Encoding                   (encodeUtf8, decodeUtf8)
+import           Data.ByteString.Base64   (decode)
-import           Data.Text.IO                         (hPutStrLn, readFile)
+import           Data.IORef               (IORef, atomicWriteIORef,
-import           Data.Time.Clock.POSIX                (getPOSIXTime)
+                                           newIORef, readIORef)
-import qualified Hasql.Query                          as H
+import           Data.String              (IsString (..))
-import qualified Hasql.Session                        as H
+import           Data.Text                (pack, replace, stripPrefix)
-import qualified Hasql.Decoders                       as HD
+import           Data.Text.Encoding       (decodeUtf8, encodeUtf8)
-import qualified Hasql.Encoders                       as HE
+import           Data.Text.IO             (hPutStrLn, readFile)
-import qualified Hasql.Pool                           as P
+import           Data.Time.Clock.POSIX    (getPOSIXTime)
-import           Network.Wai.Handler.Warp
+import qualified Hasql.Decoders           as HD
-import           System.IO                            (BufferMode (..),
+import qualified Hasql.Encoders           as HE
-                                                       hSetBuffering)
+import qualified Hasql.Pool               as P
-import           Data.IORef
+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,
+  4. If 2 or 3 fail to give their result it means the connection is down so it
-     otherwise it finishes his work successfully.
+     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)
+      pgSettings = toS (configDatabase conf) -- is the db-uri
-      appSettings = setHost ((fromString . toS) host)
+      appSettings =
-                  . setPort port
+        setHost ((fromString . toS) host) -- Warp settings
-                  . setServerName (toS $ "postgrest/" <> prettyVersion)
+        . setPort port
-                  . setTimeout 3600
+        . setServerName (toS $ "postgrest/" <> prettyVersion)
-                  $ defaultSettings
+        . setTimeout 3600 $
-
+        defaultSettings
-  when (isMalformedProxyUri $ toS <$> proxy) $ panic
+  --
-    "Malformed proxy uri, a correct example: https://example.com:8443/basePath"
+  -- 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
+    Catch $ connectionWorker 
-   ) Nothing
+              mainTid 
+              pool 
+              (configSchema conf) 
+              refDbStructure 
+              refIsWorkerOn
+    ) Nothing
 #endif
-
+  --
   -- ask for the OS time at most once per second
-  getTime <- mkAutoUpdate
+  getTime <-
-    defaultUpdateSettings { updateAction = getPOSIXTime }
+    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
+    mSecret = decodeUtf8 <$> configJwtSecret conf
-    isB64     = configJwtSecretIsBase64 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 Nothing = return conf
-    extractAndTransform (Just s) =
+    extractAndTransform (Just secret) =
-      fmap setSecret $ transformString isB64 =<<
+      fmap setSecret $
-        case stripPrefix "@" s of
+      transformString isB64 =<<
-            Nothing       -> return s
+      case stripPrefix "@" secret of
-            Just filename -> readFile (toS filename)
+        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}
-    setSecret bs = conf { configJwtSecret = Just bs }
+    --
-
+    -- replace: Replace every occurrence of one substring with another
-    replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "="
+    replaceUrlChars =
+      replace "_" "/" . replace "-" "+" . replace "." "="