From 79329797e3e41d213caa45089ed991e518abf176 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 28 Sep 2021 17:59:28 -0600 Subject: [PATCH] improves logging --- package.yaml | 2 + resources/sys/appmgr/0.0.0/appmgr | 1 - resources/sys/proxy.pac/0.1.0/proxy.pac | 0 resources/sys/sys.tar.gz/1.1.1/sys.tar.gz | 1 - src/Application.hs | 5 +- src/Foundation.hs | 60 ++++++++++++++++++++++- src/Lib/PkgRepository.hs | 1 + stack.yaml | 2 + 8 files changed, 66 insertions(+), 6 deletions(-) delete mode 100644 resources/sys/appmgr/0.0.0/appmgr delete mode 100644 resources/sys/proxy.pac/0.1.0/proxy.pac delete mode 100644 resources/sys/sys.tar.gz/1.1.1/sys.tar.gz diff --git a/package.yaml b/package.yaml index 111f690..422dfe3 100644 --- a/package.yaml +++ b/package.yaml @@ -15,6 +15,7 @@ default-extensions: dependencies: - base >=4.12 && <5 - aeson + - ansi-terminal - attoparsec - binary - bytestring @@ -36,6 +37,7 @@ dependencies: - interpolate - lens - monad-logger + - monad-logger-extras - persistent - persistent-postgresql - persistent-template diff --git a/resources/sys/appmgr/0.0.0/appmgr b/resources/sys/appmgr/0.0.0/appmgr deleted file mode 100644 index bfad61c..0000000 --- a/resources/sys/appmgr/0.0.0/appmgr +++ /dev/null @@ -1 +0,0 @@ -appmgr downloaded \ No newline at end of file diff --git a/resources/sys/proxy.pac/0.1.0/proxy.pac b/resources/sys/proxy.pac/0.1.0/proxy.pac deleted file mode 100644 index e69de29..0000000 diff --git a/resources/sys/sys.tar.gz/1.1.1/sys.tar.gz b/resources/sys/sys.tar.gz/1.1.1/sys.tar.gz deleted file mode 100644 index 32e0202..0000000 --- a/resources/sys/sys.tar.gz/1.1.1/sys.tar.gz +++ /dev/null @@ -1 +0,0 @@ -get it all up down around \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index 993fb37..cb1d049 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -291,9 +291,9 @@ startWeb foundation = do where startWeb' app = (`onException` (appStopFsNotify foundation)) $ do let AppSettings {..} = appSettings foundation - putStrLn @Text $ "Launching Tor Web Server on port " <> show torPort + runLog $ $logInfo $ "Launching Tor Web Server on port " <> show torPort torAction <- async $ runSettings (warpSettings torPort foundation) app - putStrLn @Text $ "Launching Web Server on port " <> show appPort + runLog $ $logInfo $ "Launching Web Server on port " <> show appPort action <- if sslAuto then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app else async $ runSettings (warpSettings appPort foundation) app @@ -316,6 +316,7 @@ startWeb foundation = do putMVar (appShouldRestartWeb foundation) False putStrLn @Text "Restarting Web Server" startWeb' app + runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation)) restartWeb :: RegistryCtx -> IO () restartWeb foundation = do diff --git a/src/Foundation.hs b/src/Foundation.hs index 33e586e..44c228c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2,27 +2,47 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} module Foundation where import Startlude hiding ( Handler ) -import Control.Monad.Logger ( LogSource ) +import Control.Monad.Logger ( Loc + , LogSource + , LogStr + , ToLogStr(toLogStr) + , fromLogStr + ) import Database.Persist.Sql hiding ( update ) import Lib.Registry import Yesod.Core import Yesod.Core.Types ( HandlerData(handlerEnv) - , Logger + , Logger(loggerDate) , RunHandlerEnv(rheChild, rheSite) + , loggerPutStr ) import qualified Yesod.Core.Unsafe as Unsafe +import qualified Control.Monad.Logger.Extras as Extra +import Control.Monad.Logger.Extras ( wrapSGRCode ) import Control.Monad.Reader.Has ( Has(extract, update) ) +import Data.String.Interpolate.IsString + ( i ) +import qualified Data.Text as T +import Language.Haskell.TH ( Loc(..) ) import Lib.PkgRepository import Lib.Types.AppIndex import Settings +import System.Console.ANSI.Codes ( Color(..) + , ColorIntensity(..) + , ConsoleLayer(Foreground) + , SGR(SetColor) + ) import System.FilePath ( () ) +import Yesod ( defaultMessageLoggerSource ) import Yesod.Persist.Core -- | The foundation datatype for your application. This can be a good place to @@ -101,6 +121,42 @@ instance Yesod RegistryCtx where makeLogger :: RegistryCtx -> IO Logger makeLogger = return . appLogger + messageLoggerSource :: RegistryCtx -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO () + messageLoggerSource ctx logger = \loc src lvl str -> do + shouldLog <- shouldLogIO ctx src lvl + when shouldLog $ do + date <- loggerDate logger + let + formatted = + toLogStr date + <> ( toLogStr + . wrapSGRCode [SetColor Foreground Vivid (colorFor lvl)] + $ fromLogStr + ( " [" + <> renderLvl lvl + <> (if T.null src then mempty else "#" <> toLogStr src) + <> "] " + <> str + ) + ) + <> (toLogStr + (wrapSGRCode [SetColor Foreground Dull White] + [i| @ #{loc_filename loc}:#{fst $ loc_start loc}\n|] + ) + ) + loggerPutStr logger formatted + where + renderLvl lvl = case lvl of + LevelOther t -> toLogStr t + _ -> toLogStr @String $ drop 5 $ show lvl + colorFor = \case + LevelDebug -> Green + LevelInfo -> Blue + LevelWarn -> Yellow + LevelError -> Red + LevelOther _ -> White + + -- How to run database actions. instance YesodPersist RegistryCtx where type YesodPersistBackend RegistryCtx = SqlBackend diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index b062d93..9c4a4e7 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -173,6 +173,7 @@ extractPkg fp = (`onException` cleanup) $ do watchPkgRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => m (IO Bool) watchPkgRepoRoot = do + $logInfo "Starting FSNotify Watch Manager" root <- asks pkgRepoFileRoot runInIO <- askRunInIO box <- newEmptyMVar @_ @() diff --git a/stack.yaml b/stack.yaml index 940057b..9739af5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -42,6 +42,8 @@ packages: extra-deps: - protolude-0.3.0 - esqueleto-3.5.1.0 + - monad-logger-extras-0.1.1.1 + - wai-request-spec-0.10.2.4 # Override default flag values for local packages and extra-deps # flags: {}