Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-04-04 13:49:43 +00:00
Code Issues Packages Projects Releases Wiki Activity

improves logging

Browse Source
This commit is contained in:
Keagan McClelland
2021-09-28 17:59:28 -06:00
parent 50ecce1c21
commit 427c31c886
8 changed files with 67 additions and 9 deletions
Download Patch File Download Diff File Expand all files Collapse all files

60
src/Foundation.hs
View File

@@ -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