content: {-# LANGUAGE DerivingStrategies #-}
  
  module Cachix.Deploy.Log where
  
  import Cachix.API.WebSocketSubprotocol qualified as WSS
  import Control.Concurrent.STM.TMQueue qualified as TMQueue
  import Control.Exception.Safe (MonadMask, bracket)
  import Data.Aeson qualified as Aeson
  import Data.Conduit ((.|))
  import Data.Conduit qualified as Conduit
  import Data.Conduit.Combinators qualified as Conduit
  import Data.Conduit.TQueue qualified as Conduit
  import Data.Time.Clock (getCurrentTime)
  import Katip qualified
  import Network.WebSockets qualified as WS
  import Protolude hiding (bracket, toS)
  import Protolude.Conv (toS)
  
  -- A temporary crutch while we fix up the types
  type WithLog = Katip.KatipContextT IO () -> IO ()
  
  data Options = Options
    { -- | The minimum verbosity level
      verbosity :: Verbosity,
      -- | The logging namespace, e.g. agent
      namespace :: Katip.Namespace,
      -- | The logging environment, e.g. production
      environment :: Katip.Environment
    }
    deriving stock (Show, Generic)
    deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
  
  data Verbosity
    = Normal
    | Verbose
    deriving stock (Show, Generic)
    deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
  
  withLog ::
    (MonadIO m, MonadMask m) =>
    Options ->
    (WithLog -> m a) ->
    m a
  withLog Options {..} inner =
    let permit = case verbosity of
          Verbose -> Katip.DebugS
          Normal -> Katip.InfoS
  
        createLogEnv = liftIO $ do
          logEnv <- Katip.initLogEnv namespace environment
          stdoutScribe <- Katip.mkHandleScribe Katip.ColorIfTerminal stdout (Katip.permitItem permit) Katip.V2
          Katip.registerScribe "stdout" stdoutScribe Katip.defaultScribeSettings logEnv
  
        createContext logEnv = Katip.runKatipContextT logEnv () namespace
  
        closeLog = liftIO . Katip.closeScribes
     in bracket createLogEnv closeLog $ inner . createContext
  
  -- Streaming log
  
  type LogStream = Conduit.ConduitT ByteString Conduit.Void IO ()
  
  -- TODO: prepend katip-like format to each line
  streamLog :: WithLog -> WS.Connection -> TMQueue.TMQueue ByteString -> IO ()
  streamLog logger connection queue = do
    Conduit.runConduit $
      Conduit.sourceTMQueue queue
        .| Conduit.linesUnboundedAscii
        .| logLocal logger
        .| sendLog connection
  
  streamLine :: LogStream -> ByteString -> IO ()
  streamLine logStream msg = Conduit.connect (Conduit.yield $ msg <> "\n") logStream
  
  logLocal :: WithLog -> Conduit.ConduitT ByteString ByteString IO ()
  logLocal logger =
    Conduit.mapM $ \bs -> do
      logger . Katip.logLocM Katip.DebugS . Katip.ls $ bs
      return bs
  
  sendLog :: WS.Connection -> LogStream
  sendLog connection = Conduit.mapM_ $ \bs -> do
    now <- getCurrentTime
    WS.sendTextData connection $ Aeson.encode $ WSS.Log {WSS.line = toS bs, WSS.time = now}
  