content: {-# LANGUAGE Rank2Types   #-}
  {-# LANGUAGE TypeFamilies #-}
  
  module Pos.Util.Wlog.Compatibility
          (  -- * CanLog
             CanLog (..)
           , WithLogger
             -- * Pure logging
           , dispatchEvents
           , LogEvent (..)
           , setupLogging
           , setupLogging'
           , setupTestLogging
             -- * Logging functions
           , logDebug
           , logError
           , logInfo
           , logNotice
           , logWarning
           , logMessage
           , LoggerName
           , LoggerNameBox (..)
           , HasLoggerName (..)
           , usingLoggerName
           , addLoggerName
           , setLoggerName
           , Severity (..)
             -- * LoggerConfig
           , productionB
           , retrieveLogContent
             -- * Safe logging
           , SelectionMode
           , logMCond
             -- * Named Pure logging
           , NamedPureLogger (..)
           , launchNamedPureLog
           , usingNamedPureLogger
           , runNamedPureLog
             -- * reimplementations
           , removeAllHandlers
           , centiUtcTimeF
           , getLinesLogged
             -- * Structured logging
           , logMX
           -- * Safe structured logging
           , logXCond
           ) where
  
  import           Control.Concurrent (modifyMVar_, myThreadId)
  import           Control.Lens (each)
  import           Control.Monad.Base (MonadBase)
  import           Control.Monad.Morph (MFunctor (..))
  import qualified Control.Monad.State.Lazy as StateLazy
  import           Control.Monad.Trans.Control (MonadBaseControl (..))
  import           Data.Map.Strict (lookup)
  import           Data.Sequence ((|>))
  import qualified Data.Text as T
  import qualified Data.Text.IO as TIO
  import           Data.Time (UTCTime)
  import           Data.Time.Format (defaultTimeLocale, formatTime)
  import qualified Language.Haskell.TH as TH
  
  import           Pos.Util.Log (LoggingHandler, Severity (..))
  import qualified Pos.Util.Log as Log
  import qualified Pos.Util.Log.Internal as Internal
  import           Pos.Util.Log.LoggerConfig (BackendKind (FileJsonBE),
                       LogHandler (..), LogSecurityLevel (..), LoggerConfig (..),
                       defaultInteractiveConfiguration, defaultTestConfiguration,
                       lcLoggerTree, lhName, ltHandlers, ltMinSeverity)
  import           System.IO.Unsafe (unsafePerformIO)
  
  import           Universum
  
  import qualified Katip as K
  import qualified Katip.Core as KC
  
  type LoggerName = Log.LoggerName
  
  class Monad m => CanLog m where
      dispatchMessage :: LoggerName -> Severity -> Text -> m ()
  
      default dispatchMessage :: (MonadTrans t, t n ~ m, CanLog n)
                              => LoggerName
                              -> Severity
                              -> Text
                              -> m ()
      dispatchMessage name severity msg = lift $ dispatchMessage name severity msg
  
  instance CanLog m => CanLog (LoggerNameBox m)
  instance CanLog m => CanLog (ReaderT r m)
  instance CanLog m => CanLog (StateT s m)
  instance CanLog m => CanLog (StateLazy.StateT s m)
  instance CanLog m => CanLog (ExceptT s m)
  
  -- FIXME this is awful.
  -- It may be ostensibly convenient, but it's just wrong, and in fact very
  -- inconvenient because it brings about global mutable (and uninitialized!)
  -- state. So much for pure functional programming.
  instance CanLog IO where
      dispatchMessage name severity msg = do
          lh <- readMVar loggingHandler
          mayEnv <- Internal.getLogEnv lh
          case mayEnv of
              -- FIXME
              -- If you need a resource in order to do logging, use a lambda.
              Nothing -> error "logging not yet initialized. Abort."
              Just env -> do
                  mayConfig <- Internal.getConfig lh
                  case mayConfig of
                      -- FIXME
                      -- If you need configuration in order to do logging, use
                      -- a lambda.
                      Nothing -> error "no logging configuration. Abort."
                      Just lc -> when (severity >= lc ^. lcLoggerTree ^. ltMinSeverity)
                                   $ Log.logItem' ()
                                         (K.Namespace (T.split (=='.') name))
                                         env
                                         Nothing
                                         (Internal.sev2klog severity)
                                         (K.logStr msg)
  
  type WithLogger m = (CanLog m, HasLoggerName m)
  
  {-# INLINE logInfo #-}
  {-# INLINE logNotice #-}
  {-# INLINE logWarning #-}
  {-# INLINE logError #-}
  logDebug, logInfo, logNotice, logWarning, logError
    :: WithLogger m
    => Text -> m ()
  logDebug   = logMessage Debug
  logInfo    = logMessage Info
  logNotice  = logMessage Notice
  logWarning = logMessage Warning
  logError   = logMessage Error
  
  {-# INLINE logMessage #-}
  logMessage :: WithLogger m => Severity -> Text -> m ()
  logMessage severity msg = do
      name <- askLoggerName
      dispatchMessage name severity msg
  
  newtype LoggerNameBox m a = LoggerNameBox
      { loggerNameBoxEntry :: ReaderT LoggerName m a
      } deriving (Functor, Applicative, Monad, MonadIO, MonadTrans,
                  MonadBase b, MonadThrow, MonadCatch, MonadMask, MonadState s)
  
  instance MonadReader r m => MonadReader r (LoggerNameBox m) where
      ask = lift ask
      reader = lift . reader
      local f (LoggerNameBox m) = askLoggerName >>= lift . local f . runReaderT m
  
  instance MonadBaseControl b m => MonadBaseControl b (LoggerNameBox m) where
      type StM (LoggerNameBox m) a = StM (ReaderT LoggerName m) a
      liftBaseWith io =
          LoggerNameBox $ liftBaseWith $ \runInBase -> io $ runInBase . loggerNameBoxEntry
      restoreM = LoggerNameBox . restoreM
  
  instance MFunctor LoggerNameBox where
      hoist f = LoggerNameBox . hoist f . loggerNameBoxEntry
  
  usingLoggerName :: LoggerName -> LoggerNameBox m a -> m a
  usingLoggerName name = flip runReaderT name . loggerNameBoxEntry
  
  class HasLoggerName m where
  
    askLoggerName :: m LoggerName
    modifyLoggerName :: (LoggerName -> LoggerName) -> m a -> m a
  
    default askLoggerName :: (MonadTrans t, t n ~ m, Monad n, HasLoggerName n)
                          => m LoggerName
    askLoggerName = lift askLoggerName
  
    default modifyLoggerName :: (MFunctor t, t n ~ m, Monad n, HasLoggerName n)
                             => (LoggerName -> LoggerName) -> m a -> m a
    modifyLoggerName f = hoist (modifyLoggerName f)
  
  instance HasLoggerName IO where
      askLoggerName    = pure "*production*"
      modifyLoggerName = const id
  
  instance (Monad m, HasLoggerName m) => HasLoggerName (StateT a m)
  instance (Monad m, HasLoggerName m) => HasLoggerName (StateLazy.StateT a m)
  instance (Monad m, HasLoggerName m) => HasLoggerName (ReaderT a m)
  instance HasLoggerName Identity where
      askLoggerName    = Identity "Identity"
      modifyLoggerName = flip const
  
  instance (Monad m, HasLoggerName m) => HasLoggerName (ExceptT e m)
  instance Monad m => HasLoggerName (LoggerNameBox m) where
    askLoggerName = LoggerNameBox ask
    modifyLoggerName how = LoggerNameBox . local how . loggerNameBoxEntry
  
  addLoggerName :: HasLoggerName m => LoggerName -> m a -> m a
  addLoggerName m = modifyLoggerName (<> ("." `T.append` m))
  
  setLoggerName :: HasLoggerName m => LoggerName -> m a -> m a
  setLoggerName m = modifyLoggerName (const m)
  
  launchNamedPureLog
      :: (WithLogger n, Monad m)
      => (forall f. Functor f => m (f a) -> n (f b))
      -> NamedPureLogger m a
      -> n b
  launchNamedPureLog hoist' namedPureLogger = do
      name <- askLoggerName
      (logs, res) <- hoist' $ swap <$> usingNamedPureLogger name namedPureLogger
      res <$ dispatchEvents logs
  
  usingNamedPureLogger :: Functor m
                       => LoggerName
                       -> NamedPureLogger m a
                       -> m (a, [LogEvent])
  usingNamedPureLogger name (NamedPureLogger action) =
      usingLoggerName name $ runPureLog action
  
  data LogEvent = LogEvent
      { leLoggerName :: !LoggerName
      , leSeverity   :: !Severity
      , leMessage    :: !Text
      } deriving (Show)
  
  runPureLog :: Functor m => PureLogger m a -> m (a, [LogEvent])
  runPureLog = fmap (second toList) . usingStateT mempty . runPureLogger
  
  newtype PureLogger m a = PureLogger
      { runPureLogger :: StateT (Seq LogEvent) m a
      } deriving (Functor, Applicative, Monad, MonadTrans, MonadState (Seq LogEvent),
                  MonadThrow, HasLoggerName)
  
  instance Monad m => CanLog (PureLogger m) where
      dispatchMessage name severity message = modify' (|> (LogEvent name severity message))
  instance MFunctor PureLogger where
      hoist f = PureLogger . hoist f . runPureLogger
  
  
  newtype NamedPureLogger m a = NamedPureLogger
      { runNamedPureLogger :: PureLogger (LoggerNameBox m) a
      } deriving (Functor, Applicative, Monad, MonadState (Seq LogEvent),
                  MonadThrow, HasLoggerName)
  
  instance MonadTrans NamedPureLogger where
      lift = NamedPureLogger . lift . lift
  instance Monad m => CanLog (NamedPureLogger m) where
      dispatchMessage name sev msg =
          NamedPureLogger $ dispatchMessage name sev msg
  instance MFunctor NamedPureLogger where
      hoist f = NamedPureLogger . hoist (hoist f) . runNamedPureLogger
  instance MonadIO m => MonadIO (NamedPureLogger m) where
      liftIO = lift . liftIO
  
  runNamedPureLog
      :: (Monad m, HasLoggerName m)
      => NamedPureLogger m a -> m (a, [LogEvent])
  runNamedPureLog (NamedPureLogger action) =
      askLoggerName >>= (`usingLoggerName` runPureLog action)
  
  dispatchEvents :: CanLog m => [LogEvent] -> m ()
  dispatchEvents = mapM_ dispatchLogEvent
    where
      dispatchLogEvent (LogEvent name sev t) = dispatchMessage name sev t
  
  -- | internal access to logging handler
  {-# NOINLINE loggingHandler #-}
  loggingHandler :: MVar LoggingHandler
  loggingHandler = unsafePerformIO $ do
      newMVar $ error "LoggingHandler MVar is not initialized."
  
  -- | setup logging used in tests
  setupTestLogging :: IO ()
  setupTestLogging = setupLogging "test" (defaultTestConfiguration Debug)
  
  -- | setup logging according to configuration @LoggerConfig@
  --   the backends (scribes) will be registered with katip
  setupLogging :: MonadIO m => Text -> LoggerConfig -> m ()
  setupLogging cfoKey lc = liftIO $
      modifyMVar_ loggingHandler $ const $ Log.setupLogging cfoKey lc
  
  --  | Same with 'setupLogging' but also returns the 'LoggingHandler'
  setupLogging' :: MonadIO m => Text -> LoggerConfig -> m LoggingHandler
  setupLogging' cfoKey lc = liftIO $ do
      modifyMVar_ loggingHandler $ const $ Log.setupLogging cfoKey lc
      readMVar loggingHandler
  
  getLinesLogged :: IO Integer
  getLinesLogged = do
      lh <- liftIO $ readMVar loggingHandler
      Internal.getLinesLogged lh
  
  -- | various reimplementations
  
  productionB :: LoggerConfig
  productionB = defaultInteractiveConfiguration Debug
  
  retrieveLogContent :: FilePath -> Maybe Int -> IO [Text]
  retrieveLogContent fp maylines = do
      let nlines = fromMaybe 9999 maylines
      ((take nlines) . reverse . lines) <$> TIO.readFile fp
  
  centiUtcTimeF :: UTCTime -> Text
  centiUtcTimeF utc =
      T.pack $ formatTime defaultTimeLocale tsformat utc
    where
      tsformat :: String
      tsformat = "%F %T%2Q %Z"
  
  -- do nothing, logs are closed by finalizers
  removeAllHandlers :: LoggingHandler -> IO ()
  removeAllHandlers = Log.closeLogScribes
  
  -- Safe and structured logging.
  
  -- | Whether to log to given log handler.
  type SelectionMode = LogSecurityLevel -> Bool
  type LogHandlerExclusion = [LogHandler] -> [LogHandler]
  
  logMCond :: MonadIO m => LoggerName -> Severity -> Text -> SelectionMode -> m ()
  logMCond name severity msg cond = do
      let ns = K.Namespace (T.split (=='.') name)
      lh <- liftIO $ readMVar loggingHandler
      logItemCond lh
                  ()
                  ns
                  Nothing
                  (Internal.sev2klog severity)
                  (filterWithSafety cond)
                  (Just msg)
  
  -- | Keeps only 'Scribes' which match the 'SelectionMode'.
  filterWithSafety :: SelectionMode -> LogHandlerExclusion
  filterWithSafety condition = filter (\lh -> case _lhSecurityLevel lh of
      Nothing -> False
      Just s  -> condition s)
  
  -- | Logs an item only into JSON 'Scribes'.
  --   Also, ToJSON a => KC.LogItem (see Pos.Util.Log).
  logMX :: (MonadIO m, Log.ToObject a) => LoggerName -> Severity -> a -> m ()
  logMX name severity a = do
      let ns = K.Namespace (T.split (=='.') name)
      lh <- liftIO $ readMVar loggingHandler
      logItemCond lh
                  a
                  ns
                  Nothing
                  (Internal.sev2klog severity)
                  filterJsonScribes
                  Nothing
  
  -- | Filters out 'Scribes' that are not JSON 'Scribes'.
  filterJsonScribes :: LogHandlerExclusion
  filterJsonScribes = filter (\lh -> _lhBackend lh == FileJsonBE)
  
  -- | Logs an item only into JSON 'Scribes' which match the 'SelectionMode'.
  logXCond :: (MonadIO m, Log.ToObject a) => LoggerName -> Severity -> a -> SelectionMode -> m ()
  logXCond name severity a cond = do
      let ns = K.Namespace (T.split (=='.') name)
      lh <- liftIO $ readMVar loggingHandler
      logItemCond lh
                  a
                  ns
                  Nothing
                  (Internal.sev2klog severity)
                  ((filterWithSafety cond) . filterJsonScribes)
                  Nothing
  
  --  | Writes only to 'Scribes's filtered with 'LogHandlerExclusion' function.
  logItemCond
      :: (Log.ToObject a, MonadIO m)
      => LoggingHandler
      -> a
      -> K.Namespace
      -> Maybe TH.Loc
      -> K.Severity
      -> LogHandlerExclusion
      -> Maybe Text
      -> m ()
  logItemCond lhandler a ns loc sev strainer mayMsg = do
      mayle <- liftIO $ Internal.getLogEnv lhandler
      case mayle of
          Nothing -> error "logging not yet initialized. Abort."
          Just le -> do
              maycfg <- liftIO $ Internal.getConfig lhandler
              let cfg = case maycfg of
                      Nothing -> error "No Configuration for logging found. Abort."
                      Just c  -> c
              let sevmin = Internal.sev2klog $ cfg ^. lcLoggerTree ^. ltMinSeverity
              when (sev >= sevmin)
                $ liftIO $ do
                  threadId <- myThreadId
                  time <- K._logEnvTimer le
                  let item = K.Item {
                        K._itemApp       = K._logEnvApp le
                      , K._itemEnv       = K._logEnvEnv le
                      , K._itemSeverity  = sev
                      , K._itemThread    = KC.mkThreadIdText threadId
                      , K._itemHost      = K._logEnvHost le
                      , K._itemProcess   = K._logEnvPid le
                      , K._itemPayload   = a
                      , K._itemMessage   = maybe mempty K.logStr mayMsg
                      , K._itemTime      = time
                      , K._itemNamespace = (K._logEnvApp le) <> ns
                      , K._itemLoc       = loc
                      }
                  let lhs = cfg ^. lcLoggerTree ^. ltHandlers ^.. each
                  forM_ (strainer lhs) (\ lh -> do
                      case lookup (lh ^. lhName) (K._logEnvScribes le) of
                          Nothing -> error ("Not found Scribe with name: " <> lh ^. lhName)
                          Just scribeH -> atomically
                              (KC.tryWriteTBQueue (KC.shChan scribeH) (KC.NewItem item)))
  