Add more debug logging

libs/extended/package.yaml

@@ -17,6 +17,7 @@ dependencies:
 - base
 - bytestring
 - extra
+- aeson
 - imports
 - optparse-applicative
 - tinylog
@@ -34,6 +35,7 @@ dependencies:
 - servant-swagger
 - string-conversions
 - transformers
+- text
 - wai
 library:
   source-dirs: src

libs/extended/src/System/Logger/Extended.hs

@@ -1,29 +1,90 @@
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DerivingStrategies         #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 -- | Tinylog convenience things.
 module System.Logger.Extended
     ( module Log
+    , LogFormat(..)
     , mkLogger
     , mkLogger'
     , LoggerT(..)
     , runWithLogger
+    , netStringsToLogFormat
     ) where
 
-import Imports
 import Control.Monad.Catch
+import Data.Aeson
+import Data.Aeson.Encoding (pair, list, text)
 import Database.CQL.IO
+import GHC.Generics
+import Imports
 import System.Logger as Log
-
-import qualified Data.ByteString.Lazy.Char8 as L
+import Data.String.Conversions (cs)
 import qualified Data.ByteString.Lazy.Builder as B
+import qualified Data.ByteString.Lazy.Char8 as L
 import qualified System.Logger.Class as LC
 
-mkLogger :: Log.Level -> Bool -> IO Log.Logger
-mkLogger lvl netstr = Log.new
+
+deriving instance Generic LC.Level
+instance FromJSON LC.Level
+instance ToJSON LC.Level
+
+-- | The log formats supported
+data LogFormat = JSON | Plain | Netstring 
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (ToJSON, FromJSON)
+
+-- | We use this as an intermediate structure to ease the implementation of the
+-- ToJSON instance but we could just inline everything. I think this has
+-- negligible impact and makes the code a bit more readable. Let me know
+data Element' = Element' Series [Builder]
+
+elementToEncoding :: Element' -> Encoding
+elementToEncoding (Element' fields msgs) = pairs $ fields <> msgsToSeries msgs
+    where
+      msgsToSeries :: [Builder] -> Series
+      msgsToSeries  = pair "msgs" . list (text . cs . eval)
+
+collect :: [Element] -> Element'
+collect = foldr go (Element' mempty [])
+  where
+    go :: Element -> Element' -> Element'
+    go (Bytes b) (Element' f m) =
+      Element' f (b : m)
+    go (Field k v) (Element' f m) = 
+      Element' (f <> pair (cs . eval $ k) (text . cs . eval $ v)) m
+
+jsonRenderer :: Renderer
+jsonRenderer _sep _dateFormat _logLevel = fromEncoding  . elementToEncoding . collect
+
+-- | Here for backwards-compatibility reasons
+netStringsToLogFormat :: Bool -> LogFormat
+netStringsToLogFormat True = Netstring
+netStringsToLogFormat False = Plain
+
+-- | Creates a logger given a log format Also takes an useNetstrings argument
+-- which is there because we cannot immediatelly deprecate the old interface.
+-- Old configs only provide the useNetstrings argument and not the logFormat
+-- argument, and in that case implement the old behaviour of either enabling
+-- plain text logging or netstring logging.  If both arguments are set,
+-- logFormat takes presedence over useNetstrings
+--
+-- FUTUREWORK: Once we get rid of the useNetstrings in our config files, we can
+-- remove this function and rename 'mkLoggerNew' to 'mkLogger'
+mkLogger :: Log.Level -> Maybe (Last Bool) -> Maybe (Last LogFormat) -> IO  Log.Logger
+mkLogger lvl useNetstrings logFormat = do
+  mkLoggerNew lvl $
+    case (fmap netStringsToLogFormat <$> useNetstrings) <> logFormat of
+      Just x -> getLast x
+      Nothing -> Plain
+
+-- | Version of mkLogger that doesn't support the deprecated useNetstrings option
+mkLoggerNew :: Log.Level -> LogFormat -> IO Log.Logger
+mkLoggerNew lvl logFormat = Log.new
     . Log.setReadEnvironment False
     . Log.setOutput Log.StdOut
     . Log.setFormat Nothing
-    $ simpleSettings (Just lvl) (Just netstr)
+    $ simpleSettings lvl logFormat
 
 -- | Variant of Log.defSettings:
 --
@@ -33,15 +94,16 @@ mkLogger lvl netstr = Log.new
 --
 --   * use 'canonicalizeWhitespace'.
 --
-simpleSettings :: Maybe Level -> Maybe Bool -> Log.Settings
-simpleSettings lvl netstr
-  = maybe id setLogLevel lvl
-  . setRenderer (canonicalizeWhitespace rndr)
+simpleSettings :: Log.Level -> LogFormat -> Log.Settings
+simpleSettings lvl logFormat
+  = Log.setLogLevel lvl
+  . Log.setRenderer (canonicalizeWhitespace rndr)
   $ Log.defSettings
   where
-    rndr = case netstr of
-      Just True  -> \_ _ _ -> renderNetstr
-      _          -> \s _ _ -> renderDefault s
+    rndr = case logFormat of
+      Netstring  -> \_separator _dateFormat _level -> Log.renderNetstr
+      Plain -> \ separator _dateFormat _level -> Log.renderDefault separator
+      JSON -> jsonRenderer
 
 -- | Replace all whitespace characters in the output of a renderer by @' '@.
 -- Log output must be ASCII encoding.
@@ -50,7 +112,7 @@ simpleSettings lvl netstr
 -- places and situations in your code and your dependencies that inject newlines
 -- into your log messages, you can choose to call 'canonicalizeWhitespace' on
 -- your renderer.)
-canonicalizeWhitespace :: Renderer -> Renderer
+canonicalizeWhitespace :: Log.Renderer -> Log.Renderer
 canonicalizeWhitespace rndrRaw delim df lvl
   = B.lazyByteString . nl2sp . B.toLazyByteString . rndrRaw delim df lvl
   where

libs/imports/package.yaml

@@ -16,7 +16,6 @@ copyright: (c) 2018 Wire Swiss GmbH
 license: AGPL-3
 dependencies:
 - base
-- aeson
 - extra
 - unliftio
 - unliftio-core

libs/imports/src/Imports.hs

@@ -71,8 +71,6 @@ module Imports
     , unlessM
     ) where
 
-import Orphans ()
-
 -- Explicitly saying what to import because some things from Prelude clash
 -- with e.g. UnliftIO modules
 import Prelude (
@@ -100,8 +98,8 @@ import Data.Void
 import Data.Bool
 import Data.Char
 import Data.Ord
-import Data.Semigroup (Semigroup)
-import Data.Monoid
+import Data.Semigroup hiding (diff, Option, option) -- conflicts with Options.Applicative.Option (should we care?)
+import Data.Monoid hiding (First(..), Last(..)) -- First and Last are going to be deprecated. Use Semigroup instead
 import Data.Maybe
 import Data.Either
 import Data.Foldable

services/brig/src/Brig/App.hs

@@ -155,7 +155,7 @@ newEnv o = do
     Just sha256 <- getDigestByName "SHA256"
     Just sha512 <- getDigestByName "SHA512"
     mtr <- Metrics.metrics
-    lgr <- Log.mkLogger (Opt.logLevel o) (Opt.logNetStrings o)
+    lgr <- Log.mkLogger (Opt.logLevel o) (Opt.logNetStrings o) (Opt.logFormat o)
     cas <- initCassandra o lgr
     mgr <- initHttpManager
     ext <- initExtGetManager

services/brig/src/Brig/Options.hs

@@ -17,7 +17,7 @@ import Data.Scientific (toBoundedInteger)
 import Data.Time.Clock (NominalDiffTime)
 import Data.Yaml (FromJSON(..), ToJSON(..))
 import Util.Options
-import System.Logger.Class (Level)
+import System.Logger.Extended (Level, LogFormat)
 
 import qualified Brig.ZAuth  as ZAuth
 import qualified Data.Yaml   as Y
@@ -257,9 +257,9 @@ data Opts = Opts
 
     -- Logging
     , logLevel      :: !Level                  -- ^ Log level (Debug, Info, etc)
-    , logNetStrings :: !Bool                   -- ^ Use netstrings encoding (see
+    , logNetStrings :: !(Maybe (Last Bool))    -- ^ Use netstrings encoding (see
                                                --   <http://cr.yp.to/proto/netstrings.txt>)
-
+    , logFormat     :: !(Maybe (Last LogFormat)) -- ^ Logformat to use
     -- TURN
     , turn          :: !TurnOpts               -- ^ TURN server settings
 

services/cannon/src/Cannon/Options.hs

@@ -10,14 +10,15 @@ module Cannon.Options
     , externalHostFile
     , logLevel
     , logNetStrings
+    , logFormat
     , Opts
     )
 where
 
 import Imports
 import Control.Lens (makeFields)
 import Data.Aeson.APIFieldJsonTH
-import System.Logger.Class (Level)
+import System.Logger.Extended (Level, LogFormat)
 
 
 data Cannon = Cannon
@@ -42,7 +43,8 @@ data Opts = Opts
     { _optsCannon         :: !Cannon
     , _optsGundeck        :: !Gundeck
     , _optsLogLevel       :: !Level
-    , _optsLogNetStrings  :: !Bool
+    , _optsLogNetStrings  :: !(Maybe (Last Bool))
+    , _optsLogFormat      :: !(Maybe (Last LogFormat))
     } deriving (Eq, Show, Generic)
 
 makeFields ''Opts

services/cannon/src/Cannon/Run.hs

@@ -28,7 +28,7 @@ run :: Opts -> IO ()
 run o = do
     ext <- loadExternal
     m <- Middleware.metrics
-    g <- L.mkLogger (o ^. logLevel) (o ^. logNetStrings)
+    g <- L.mkLogger (o ^. logLevel) (o ^. logNetStrings) (o ^. logFormat)
     e <- mkEnv <$> pure m
                <*> pure ext
                <*> pure o

services/cargohold/src/CargoHold/App.hs

@@ -84,7 +84,7 @@ makeLenses ''Env
 newEnv :: Opts -> IO Env
 newEnv o = do
     met  <- Metrics.metrics
-    lgr  <- Log.mkLogger (o^.optLogLevel) (o^.optLogNetStrings)
+    lgr  <- Log.mkLogger (o^.optLogLevel) (o^.optLogNetStrings) (o^.optLogFormat)
     mgr  <- initHttpManager
     awe  <- initAws o lgr mgr
     return $ Env awe met lgr mgr def (o^.optSettings)

services/cargohold/src/CargoHold/Options.hs

@@ -6,7 +6,7 @@ import Imports
 import CargoHold.CloudFront (Domain (..), KeyPairId (..))
 import Control.Lens hiding (Level)
 import Data.Aeson.TH
-import System.Logger (Level)
+import System.Logger.Extended (Level, LogFormat)
 import Util.Options
 import Util.Options.Common
 
@@ -62,8 +62,9 @@ data Opts = Opts
     , _optSettings  :: !Settings
     -- Logging
     , _optLogLevel      :: !Level  -- ^ Log level (Debug, Info, etc)
-    , _optLogNetStrings :: !Bool   -- ^ Use netstrings encoding:
-                                   --   <http://cr.yp.to/proto/netstrings.txt>
+    , _optLogNetStrings :: !(Maybe (Last Bool))   -- ^ Use netstrings encoding:
+                                                  --   <http://cr.yp.to/proto/netstrings.txt>
+    , _optLogFormat :: !(Maybe (Last LogFormat))  --- ^ Log format
     } deriving (Show, Generic)
 
 deriveFromJSON toOptionFieldName ''Opts

services/galley/src/Galley/API/LegalHold.hs

@@ -3,12 +3,12 @@ module Galley.API.LegalHold where
 import Imports
 import Galley.API.Error
 import Brig.Types.Provider
-import Brig.Types.Team.LegalHold
+import Brig.Types.Team.LegalHold hiding (userId)
 import Brig.Types.Client.Prekey
 import Control.Monad.Catch
 import Control.Lens (view, (^.))
 import Data.Id
-import Data.ByteString.Conversion (toByteString')
+import Data.ByteString.Conversion (toByteString', toByteString)
 import Data.Misc
 import Data.LegalHold (UserLegalHoldStatus(..))
 import Galley.API.Util
@@ -42,6 +42,10 @@ createSettings (zusr ::: tid ::: req ::: _) = do
     assertLegalHoldEnabled tid
 
     membs <- Data.teamMembers tid
+    let zothers = map (view userId) membs
+    Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers)
+              . Log.msg (Log.val "LegalHold.createSettings")
+
     void $ permissionCheck zusr ChangeLegalHoldTeamSettings membs
 
     newService :: NewLegalHoldService
@@ -71,8 +75,11 @@ getSettings (zusr ::: tid ::: _) = do
 removeSettings :: UserId ::: TeamId ::: JsonRequest RemoveLegalHoldSettingsRequest ::: JSON -> Galley Response
 removeSettings (zusr ::: tid ::: req ::: _) = do
     assertLegalHoldEnabled tid
-
     membs <- Data.teamMembers tid
+    let zothers = map (view userId) membs
+    Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers)
+              . Log.msg (Log.val "LegalHold.removeSettings")
+
     void $ permissionCheck zusr ChangeLegalHoldTeamSettings membs
     RemoveLegalHoldSettingsRequest mPassword <- fromJsonBody req
     ensureReAuthorised zusr mPassword
@@ -87,6 +94,10 @@ removeSettings'
     -> Galley ()
 removeSettings' tid mMembers = do
     membs <- maybe (Data.teamMembers tid) pure mMembers
+    let zothers = map (view userId) membs
+    Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers)
+              . Log.msg (Log.val "LegalHold.removeSettings'")
+
     let lhMembers = filter ((== UserLegalHoldEnabled) . view legalHoldStatus) membs
     -- I picked this number by fair dice roll, feel free to change it :P
     pooledMapConcurrentlyN_ 6 removeLHForUser lhMembers
@@ -129,6 +140,8 @@ requestDevice :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response
 requestDevice (zusr ::: tid ::: uid ::: _) = do
     assertLegalHoldEnabled tid
 
+    Log.debug $ Log.field "targets" (toByteString uid)
+              . Log.msg (Log.val "LegalHold.requestDevice")
     membs <- Data.teamMembers tid
     void $ permissionCheck zusr ChangeLegalHoldUserSettings membs
 
@@ -164,6 +177,8 @@ approveDevice
     -> Galley Response
 approveDevice (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do
     assertLegalHoldEnabled tid
+    Log.debug $ Log.field "targets" (toByteString uid)
+              . Log.msg (Log.val "LegalHold.approveDevice")
 
     unless (zusr == uid) (throwM accessDenied)
     assertOnTeam uid tid
@@ -199,6 +214,8 @@ disableForUser
   :: UserId ::: TeamId ::: UserId ::: JsonRequest DisableLegalHoldForUserRequest ::: JSON
   -> Galley Response
 disableForUser (zusr ::: tid ::: uid ::: req ::: _) = do
+    Log.debug $ Log.field "targets" (toByteString uid)
+              . Log.msg (Log.val "LegalHold.disableForUser")
     membs <- Data.teamMembers tid
     void $ permissionCheck zusr ChangeLegalHoldUserSettings membs
     if userLHNotDisabled membs