hasura · paf31 · Jul 14, 2020 · Jul 10, 2020 · Jul 14, 2020 · Jul 14, 2020
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -5,11 +5,11 @@
 ### Bug fixes and improvements
 
 (Add entries here in the order of: server, console, cli, docs, others)
-- server: adjustments to idle GC to try to free memory more eagerly (related to #3388)
 
-- docs: add page on created_at / updated_at timestamps (close #2880) (#5223)
+- server: adjustments to idle GC to try to free memory more eagerly (related to #3388)
 - server: process events generated by the event triggers asynchronously (close #5189) (#5352)
 - console: display line number that error originated from in GraphQL editor (close #4849) (#4942)
+- docs: add page on created_at / updated_at timestamps (close #2880) (#5223)
 
 ## `v1.3.0-beta.4`
 

@@ -127,6 +127,7 @@ constraints: any.Cabal ==3.2.0.0,
              any.erf ==2.0.0.0,
              any.errors ==2.3.0,
              any.exceptions ==0.10.4,
+             exceptions +transformers-0-4,
              any.fail ==4.9.0.0,
              any.fast-logger ==3.0.1,
              any.file-embed ==0.0.11.2,

@@ -225,6 +225,7 @@ library
                      , Control.Monad.Unique
                      , Data.Aeson.Extended
                      , Data.Aeson.Ordered
+                     , Data.Environment
                      , Data.HashMap.Strict.Extended
                      , Data.HashMap.Strict.InsOrd.Extended
                      , Data.List.Extended

@@ -2,6 +2,7 @@
 
 module Main where
 
+import           Control.Exception
 import           Data.Text.Conversions      (convertText)
 
 import           Hasura.App
@@ -14,20 +15,32 @@ import           Hasura.Server.Init
 import           Hasura.Server.Migrate      (downgradeCatalog, dropCatalog)
 import           Hasura.Server.Version
 
+import qualified Data.ByteString.Char8      as BC
 import qualified Data.ByteString.Lazy       as BL
 import qualified Data.ByteString.Lazy.Char8 as BLC
+import qualified Data.Environment           as Env
 import qualified Database.PG.Query          as Q
+import qualified System.Exit                as Sys
 import qualified System.Posix.Signals       as Signals
 
 main :: IO ()
-main = parseArgs >>= unAppM . runApp
+main = do
+  tryExit $ do
+    args <- parseArgs
+    env  <- Env.getEnvironment
+    unAppM (runApp env args)
+  where
+    tryExit io = try io >>= \case
+      Left (ExitException _code msg) -> BC.putStrLn msg >> Sys.exitFailure
+      Right r -> return r
 
-runApp :: HGEOptions Hasura -> AppM ()
-runApp (HGEOptionsG rci hgeCmd) =
-  withVersion $$(getVersionFromEnvironment) case hgeCmd of
+runApp :: Env.Environment -> HGEOptions Hasura -> AppM ()
+runApp env (HGEOptionsG rci hgeCmd) =
+  withVersion $$(getVersionFromEnvironment) $ case hgeCmd of
     HCServe serveOptions -> do
-      (initCtx, initTime) <- initialiseCtx hgeCmd rci
-      -- Catches the SIGTERM signal and initiates a graceful shutdown.
+      (initCtx, initTime) <- initialiseCtx env hgeCmd rci
+      let shutdownApp = return ()
+      -- Catches the SIGTERM signal and initiates a graceful shutdown. 
       -- Graceful shutdown for regular HTTP requests is already implemented in
       -- Warp, and is triggered by invoking the 'closeSocket' callback.
       -- We only catch the SIGTERM signal once, that is, if the user hits CTRL-C
@@ -36,35 +49,36 @@ runApp (HGEOptionsG rci hgeCmd) =
         Signals.sigTERM
         (Signals.CatchOnce (shutdownGracefully initCtx))
         Nothing
-      runHGEServer serveOptions initCtx Nothing initTime
+      runHGEServer env serveOptions initCtx Nothing initTime shutdownApp
+
     HCExport -> do
-      (initCtx, _) <- initialiseCtx hgeCmd rci
+      (initCtx, _) <- initialiseCtx env hgeCmd rci
       res <- runTx' initCtx fetchMetadata Q.ReadCommitted
-      either printErrJExit printJSON res
+      either (printErrJExit MetadataExportError) printJSON res
 
     HCClean -> do
-      (initCtx, _) <- initialiseCtx hgeCmd rci
+      (initCtx, _) <- initialiseCtx env hgeCmd rci
       res <- runTx' initCtx dropCatalog Q.ReadCommitted
-      either printErrJExit (const cleanSuccess) res
+      either (printErrJExit MetadataCleanError) (const cleanSuccess) res
 
     HCExecute -> do
-      (InitCtx{..}, _) <- initialiseCtx hgeCmd rci
+      (InitCtx{..}, _) <- initialiseCtx env hgeCmd rci
       queryBs <- liftIO BL.getContents
       let sqlGenCtx = SQLGenCtx False
-      res <- runAsAdmin _icPgPool sqlGenCtx _icHttpManager do
-        schemaCache <- buildRebuildableSchemaCache
-        execQuery queryBs
+      res <- runAsAdmin _icPgPool sqlGenCtx _icHttpManager $ do
+        schemaCache <- buildRebuildableSchemaCache env
+        execQuery env queryBs
           & runHasSystemDefinedT (SystemDefined False)
           & runCacheRWT schemaCache
           & fmap (\(res, _, _) -> res)
-      either printErrJExit (liftIO . BLC.putStrLn) res
+      either (printErrJExit ExecuteProcessError) (liftIO . BLC.putStrLn) res
 
     HCDowngrade opts -> do
-      (InitCtx{..}, initTime) <- initialiseCtx hgeCmd rci
+      (InitCtx{..}, initTime) <- initialiseCtx env hgeCmd rci
       let sqlGenCtx = SQLGenCtx False
       res <- downgradeCatalog opts initTime
              & runAsAdmin _icPgPool sqlGenCtx _icHttpManager
-      either printErrJExit (liftIO . print) res
+      either (printErrJExit DowngradeProcessError) (liftIO . print) res
 
     HCVersion -> liftIO $ putStrLn $ "Hasura GraphQL Engine: " ++ convertText currentVersion
   where

@@ -0,0 +1,35 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Data.Environment
+    ( Environment()
+    , getEnvironment
+    , mkEnvironment
+    , emptyEnvironment
+    , maybeEnvironment
+    , lookupEnv)
+where
+
+import Hasura.Prelude
+import Data.Aeson
+
+import qualified System.Environment
+import qualified Data.Map as M
+
+newtype Environment = Environment (M.Map String String) deriving (Eq, Show, Generic)
+
+instance FromJSON Environment
+
+getEnvironment :: IO Environment
+getEnvironment = mkEnvironment <$> System.Environment.getEnvironment
+
+maybeEnvironment :: Maybe Environment -> Environment
+maybeEnvironment = fromMaybe emptyEnvironment
+
+mkEnvironment :: [(String, String)] -> Environment
+mkEnvironment = Environment . M.fromList
+
+emptyEnvironment :: Environment
+emptyEnvironment = Environment M.empty
+
+lookupEnv :: Environment -> String -> Maybe String
+lookupEnv (Environment es) k = M.lookup k es
@@ -13,12 +13,12 @@ where
 import           Hasura.Prelude
 
 import qualified Data.Text                  as T
+import qualified Data.Environment           as Env
 
 import           Data.Attoparsec.Combinator (lookAhead)
 import           Data.Attoparsec.Text
 import           Instances.TH.Lift          ()
 import           Language.Haskell.TH.Syntax (Lift)
-import           System.Environment         (lookupEnv)
 import           Test.QuickCheck
 
 newtype Variable = Variable {unVariable :: Text}
@@ -63,22 +63,22 @@ parseURLTemplate t = parseOnly parseTemplate t
     parseVariable =
       string "{{" *> (Variable . T.pack <$> manyTill anyChar (string "}}"))
 
-renderURLTemplate :: MonadIO m => URLTemplate -> m (Either String Text)
-renderURLTemplate template = do
-  eitherResults <- mapM renderTemplateItem $ unURLTemplate template
-  let errorVariables = lefts eitherResults
-  pure $ case errorVariables of
+renderURLTemplate :: Env.Environment -> URLTemplate -> Either String Text
+renderURLTemplate env template =
+  case errorVariables of
     [] -> Right $ T.concat $ rights eitherResults
     _  -> Left $ T.unpack $ "Value for environment variables not found: "
           <> T.intercalate ", " errorVariables
   where
+    eitherResults = map renderTemplateItem $ unURLTemplate template
+    errorVariables = lefts eitherResults
     renderTemplateItem = \case
-      TIText t -> pure $ Right t
-      TIVariable (Variable var) -> do
-        maybeEnvValue <- liftIO $ lookupEnv $ T.unpack var
-        pure $ case maybeEnvValue of
-               Nothing    -> Left var
-               Just value -> Right $ T.pack value
+      TIText t -> Right t
+      TIVariable (Variable var) ->
+        let maybeEnvValue = Env.lookupEnv env $ T.unpack var
+          in case maybeEnvValue of
+                  Nothing    -> Left var
+                  Just value -> Right $ T.pack value
 
 -- QuickCheck generators
 instance Arbitrary Variable where