add basic ARCHITECTURE.md (#2503)

* refactor: move ApiRequest a top-level module
* refactor: rename DbStructure to SchemaCache
* refactor: GucHeader inside Response
* refactor: admin app to Workers

src/PostgREST/Workers.hs

@@ -1,30 +1,40 @@
 {-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE NamedFieldPuns  #-}
 {-# LANGUAGE RecordWildCards #-}
 
 module PostgREST.Workers
   ( connectionWorker
   , reReadConfig
-  , listener
+  , runListener
+  , runAdmin
   ) where
 
 import qualified Data.Aeson                 as JSON
 import qualified Data.ByteString            as BS
 import qualified Data.ByteString.Lazy       as LBS
+import qualified Data.Text                  as T
 import qualified Data.Text.Encoding         as T
 import qualified Hasql.Notifications        as SQL
+import qualified Hasql.Session              as SQL
 import qualified Hasql.Transaction.Sessions as SQL
+import qualified Network.HTTP.Types.Status  as HTTP
+import qualified Network.Wai                as Wai
+import qualified Network.Wai.Handler.Warp   as Warp
 
 import Control.Retry    (RetryStatus, capDelay, exponentialBackoff,
                          retrying, rsPreviousDelay)
 import Hasql.Connection (acquire)
 
+import Network.Socket
+import Network.Socket.ByteString
+
 import PostgREST.AppState         (AppState)
 import PostgREST.Config           (AppConfig (..), readAppConfig)
 import PostgREST.Config.Database  (queryDbSettings, queryPgVersion)
 import PostgREST.Config.PgVersion (PgVersion (..), minimumPgVersion)
-import PostgREST.DbStructure      (queryDbStructure)
 import PostgREST.Error            (PgError (PgError), checkIsFatal,
                                    errorPayload)
+import PostgREST.SchemaCache      (querySchemaCache)
 
 import qualified PostgREST.AppState as AppState
 
@@ -45,7 +55,7 @@ data SCacheStatus
   | SCFatalFail
 
 -- | The purpose of this worker is to obtain a healthy connection to pg and an
--- up-to-date schema cache(DbStructure).  This method is meant to be called
+-- up-to-date schema cache(SchemaCache).  This method is meant to be called
 -- 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 performed in a separate thread.
@@ -54,7 +64,7 @@ data SCacheStatus
 --  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.
---  3. Obtains the dbStructure. If this fails, it goes back to 1.
+--  3. Obtains the sCache. If this fails, it goes back to 1.
 connectionWorker :: AppState -> IO ()
 connectionWorker appState = do
   runExclusively (AppState.getWorkerSem appState) work
@@ -148,14 +158,14 @@ establishConnection appState =
       when itShould $ AppState.putRetryNextIn appState delay
       return itShould
 
--- | Load the DbStructure by using a connection from the pool.
+-- | Load the SchemaCache by using a connection from the pool.
 loadSchemaCache :: AppState -> IO SCacheStatus
 loadSchemaCache appState = do
   AppConfig{..} <- AppState.getConfig appState
   result <-
     let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
     AppState.usePool appState . transaction SQL.ReadCommitted SQL.Read $
-      queryDbStructure (toList configDbSchemas) configDbExtraSearchPath configDbPreparedStatements
+      querySchemaCache (toList configDbSchemas) configDbExtraSearchPath configDbPreparedStatements
   case result of
     Left e -> do
       let
@@ -168,18 +178,22 @@ loadSchemaCache appState = do
           AppState.logWithZTime appState hint
           return SCFatalFail
         Nothing -> do
-          AppState.putDbStructure appState Nothing
+          AppState.putSchemaCache appState Nothing
           AppState.logWithZTime appState "An error ocurred when loading the schema cache"
           putErr
           return SCOnRetry
 
-    Right dbStructure -> do
-      AppState.putDbStructure appState (Just dbStructure)
+    Right sCache -> do
+      AppState.putSchemaCache appState (Just sCache)
       when (isJust configDbRootSpec) .
-        AppState.putJsonDbS appState . LBS.toStrict $ JSON.encode dbStructure
+        AppState.putJsonDbS appState . LBS.toStrict $ JSON.encode sCache
       AppState.logWithZTime appState "Schema cache loaded"
       return SCLoaded
 
+runListener :: AppConfig -> AppState -> IO ()
+runListener AppConfig{configDbChannelEnabled} appState =
+  when configDbChannelEnabled $ listener appState
+
 -- | Starts a dedicated pg connection to LISTEN for notifications.  When a
 -- NOTIFY <db-channel> - with an empty payload - is done, it refills the schema
 -- cache.  It uses the connectionWorker in case the LISTEN connection dies.
@@ -264,3 +278,68 @@ reReadConfig startingUp appState = do
         pass
       else
         AppState.logWithZTime appState "Config reloaded"
+
+runAdmin :: AppConfig -> AppState -> Warp.Settings -> IO ()
+runAdmin conf@AppConfig{configAdminServerPort} appState settings =
+  whenJust configAdminServerPort $ \adminPort -> do
+    AppState.logWithZTime appState $ "Admin server listening on port " <> show adminPort
+    void . forkIO $ Warp.runSettings (settings & Warp.setPort adminPort) adminApp
+  where
+    whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
+    whenJust mg f = maybe (pure ()) f mg
+    adminApp = admin appState conf
+
+-- | PostgREST admin application
+admin :: AppState.AppState -> AppConfig -> Wai.Application
+admin appState appConfig req respond  = do
+  isMainAppReachable  <- any isRight <$> reachMainApp appConfig
+  isSchemaCacheLoaded <- isJust <$> AppState.getSchemaCache appState
+  isConnectionUp      <-
+    if configDbChannelEnabled appConfig
+      then AppState.getIsListenerOn appState
+      else isRight <$> AppState.usePool appState (SQL.sql "SELECT 1")
+
+  case Wai.pathInfo req of
+    ["ready"] ->
+      respond $ Wai.responseLBS (if isMainAppReachable && isConnectionUp && isSchemaCacheLoaded then HTTP.status200 else HTTP.status503) [] mempty
+    ["live"] ->
+      respond $ Wai.responseLBS (if isMainAppReachable then HTTP.status200 else HTTP.status503) [] mempty
+    _ ->
+      respond $ Wai.responseLBS HTTP.status404 [] mempty
+
+-- Try to connect to the main app socket
+-- Note that it doesn't even send a valid HTTP request, we just want to check that the main app is accepting connections
+-- The code for resolving the "*4", "!4", "*6", "!6", "*" special values is taken from
+-- https://hackage.haskell.org/package/streaming-commons-0.2.2.4/docs/src/Data.Streaming.Network.html#bindPortGenEx
+reachMainApp :: AppConfig -> IO [Either IOException ()]
+reachMainApp AppConfig{..} =
+  case configServerUnixSocket of
+    Just path ->  do
+      sock <- socket AF_UNIX Stream 0
+      (:[]) <$> try (do
+        connect sock $ SockAddrUnix path
+        withSocketsDo $ bracket (pure sock) close sendEmpty)
+    Nothing -> do
+      let
+        host | configServerHost `elem` ["*4", "!4", "*6", "!6", "*"] = Nothing
+             | otherwise                                             = Just configServerHost
+        filterAddrs xs =
+          case configServerHost of
+              "*4" -> ipv4Addrs xs ++ ipv6Addrs xs
+              "!4" -> ipv4Addrs xs
+              "*6" -> ipv6Addrs xs ++ ipv4Addrs xs
+              "!6" -> ipv6Addrs xs
+              _    -> xs
+        ipv4Addrs = filter ((/=) AF_INET6 . addrFamily)
+        ipv6Addrs = filter ((==) AF_INET6 . addrFamily)
+
+      addrs <- getAddrInfo (Just $ defaultHints { addrSocketType = Stream }) (T.unpack <$> host) (Just . show $ configServerPort)
+      tryAddr `traverse` filterAddrs addrs
+  where
+    sendEmpty sock = void $ send sock mempty
+    tryAddr :: AddrInfo -> IO (Either IOException ())
+    tryAddr addr = do
+      sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+      try $ do
+        connect sock $ addrAddress addr
+        withSocketsDo $ bracket (pure sock) close sendEmpty