improves logging

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

resources/sys/appmgr/0.0.0/appmgr

@@ -1 +0,0 @@
-appmgr downloaded

resources/sys/sys.tar.gz/1.1.1/sys.tar.gz

@@ -1 +0,0 @@
-get it all up down around

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

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

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 @_ @()

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: {}