{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses, RankNTypes, ConstraintKinds
           , RecordWildCards #-}
{-# LANGUAGE GADTs, DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
-- | Use this module to add logging to your monad.
--   A log is a structured value that can hold information like severity, log message, timestamp,
--   callstack, etc.
--
--   Logging is treated like a stream of logs comming from your application and functions that
--   transform the logs take a stream and output a stream. Functions like 'logInfo' push a new log
--   into the stream and functions like 'setTimestampToNow' take a stream of logs and attach extra
--   info onto each log (current time in this case).
--
--   Read the documentation of individual functions to get a feel for what you can do.
module Control.Effects.Logging (module Control.Effects.Logging) where

import Interlude hiding (truncate)
import Control.Effects as Control.Effects.Logging
import Control.Effects.Signal

import qualified Data.Text as Text
import Data.Time.ISO8601

import GHC.Stack
import Data.Time (UTCTime, getCurrentTime)

import Language.Haskell.HsColour.ANSI
import System.Directory
import System.FilePath
import Data.UUID.V4

import Data.String

import Control.Effects.Early
import Data.UUID
import GHC.Generics
import Data.Void

-- | The logging effect.
data Logging
instance Effect Logging where
    data EffMethods Logging m = LoggingMethods
        { _logEffect :: Log -> m () }
        deriving (Generic)

-- | Send a single log into the stream.
logEffect :: MonadEffect Logging m => Log -> m ()
LoggingMethods logEffect = effect

-- | Arbitrary piece of text. Logs contain a list of these.
newtype Tag     = Tag     Text deriving (Eq, Ord, Read, Show)

-- | A name for a "layer" of your application. Typically, a log will contain a stack of contexts.
--   Think of it as a call stack specific for your application.
newtype Context = Context { getContext :: Text } deriving (Eq, Ord, Read, Show)

-- | The severity of the log.
data Level = Debug | Info | Warning | Error | Fatal deriving (Eq, Ord, Read, Show)

-- | If a notion of a user exists for your application, you can add this information to your logs.
data LogUser = LogUser { logUserId       :: Text
                       , logUserEmail    :: Maybe Text
                       , logUserUsername :: Maybe Text }
                       deriving (Eq, Ord, Read, Show)

addIfExists :: Text -> Maybe Value -> [(Text, Value)] -> [(Text, Value)]
addIfExists _ Nothing  ps = ps
addIfExists n (Just v) ps = (n, v) : ps

instance ToJSON LogUser where
    toJSON LogUser{..} =
        object $ ["id" .= logUserId]
               & addIfExists "username" (String <$> logUserUsername)
               & addIfExists "email"    (String <$> logUserEmail)

-- | Breadcrumbs are the steps that happened before a log.
data Crumb = Crumb { crumbTimestamp :: UTCTime
                   , crumbMessage   :: Maybe Text
                   , crumbCategory  :: Text
                   , crumbData      :: CrumbData }
                   deriving (Eq, Read, Show)

-- | Crumbs come in two varieties. A normal crumb is a list of key-value pairs. There's also a
--   'HttpCrumb' where you can put more specific information about the processed HTTP request (if
--   your application is a web server).
data CrumbData = DefaultCrumb [(Text, Value)]
               | HttpCrumb { crumbUrl        :: Text
                           , crumbMethod     :: Text
                           , crumbStatusCode :: Int
                           , crumbReason     :: Text }
               deriving (Eq, Read, Show)

instance ToJSON CrumbData where
    toJSON (DefaultCrumb d) = object d
    toJSON HttpCrumb{..}    =
        object [ "url"         .= crumbUrl
               , "method"      .= crumbMethod
               , "status_code" .= crumbStatusCode
               , "reason"      .= crumbReason ]

instance ToJSON Crumb where
    toJSON Crumb{..} =
        object $ [ "timestamp" .= formatISO8601 crumbTimestamp
                 , "category"  .= crumbCategory
                 , "type"      .= case crumbData of
                     DefaultCrumb _ -> "default" :: Text
                     HttpCrumb{}    -> "http"
                 , "data"      .= crumbData ]
               & addIfExists "message" (String <$> crumbMessage)

-- | Logs can hold arbitrary data serialized as a 'ByteString'. Additionally, a summary can be
--   provided which is intended to be displayed fully in log summaries.
data LogData = LogData { dataPayload :: ByteString
                       , dataSummary :: Text }
    deriving (Eq, Ord, Read, Show)
instance IsString LogData where
    fromString s = LogData (toS s) ""

data Log = Log { logMessage   :: Text
               , logLevel     :: Level
               , logTags      :: [Tag]
               , logContext   :: [Context]
               , logUser      :: Maybe LogUser
               , logCrumbs    :: [Crumb]
               , logData      :: LogData
               , logTimestamp :: Maybe UTCTime
               , logCallStack :: CallStack }
               deriving (Show)

-- | A generic exception holding only a piece of text.
newtype GenericException = GenericException Text deriving (Eq, Ord, Read, Show)
instance Exception GenericException

-- | A generic handler for logs. Since it's polymorphic in 'm' you can choose to emit more logs
--   and make it a log transformer instead.
handleLogging :: Functor m => (Log -> m ()) -> RuntimeImplemented Logging m a -> m a
handleLogging f = implement (LoggingMethods f)

-- | Add a new context on top of every log that comes from the given computation.
layerLogs :: (HasCallStack, MonadEffect Logging m) => Context -> RuntimeImplemented Logging m a -> m a
layerLogs ctx = handleLogging (\log' -> logEffect (log' { logContext = ctx : logContext log' }))

-- | Get the bottom-most context if it exists.
originContext :: Log -> Maybe Context
originContext Log{..} = listToMaybe (Interlude.reverse logContext)

logWithLevel :: (HasCallStack, MonadEffect Logging m) => Level -> Text -> m ()
logWithLevel lvl msg = logEffect $ Log msg lvl [] [] Nothing [] "" Nothing callStack

logInfo, logWarning, logError, logDebug, logFatal
    :: (HasCallStack, MonadEffect Logging m) => Text -> m ()
logInfo = logWithLevel Info
logWarning = logWithLevel Warning
logError = logWithLevel Error
logDebug = logWithLevel Debug
logFatal = logWithLevel Fatal

-- | Log an error and then throw the given exception.
logAndError :: (Exception e, MonadEffect Logging m, MonadThrow m, HasCallStack) => Text -> e -> m a
logAndError msg err = logError msg >> throwM err

-- | Log an error and then throw a checked exception.
--   Read about checked exceptions in 'Control.Effects.Signal'.
logAndThrowsErr :: (MonadEffects '[Logging, Signal e Void] m, HasCallStack) => Text -> e -> m a
logAndThrowsErr msg err = logError msg >> throwSignal err

-- | Log an error and throw a generic exception containing the text of the error message.
logAndThrowGeneric :: (MonadEffect Logging m, MonadThrow m, HasCallStack) => Text -> m a
logAndThrowGeneric msg = logError msg >> throwM (GenericException msg)

-- | Log a stripped-down version of the logs to the console.
--   Only contains the message and the severity.
logMessagesToStdout :: MonadIO m => RuntimeImplemented Logging m a -> m a
logMessagesToStdout = handleLogging (\Log{..} -> putText (pshow logLevel <> ": " <> logMessage))

-- | Log everything to the console. Uses the 'Show' instance for 'Log'.
logRawToStdout :: MonadIO m => RuntimeImplemented Logging m a -> m a
logRawToStdout = handleLogging print

-- | Discard the logs.
muteLogs :: Monad m => RuntimeImplemented Logging m a -> m a
muteLogs = handleLogging (const (return ()))

-- | Use the given function to transform and possibly discard logs.
witherLogs :: MonadEffect Logging m => (Log -> m (Maybe Log)) -> RuntimeImplemented Logging m a -> m a
witherLogs f = handleLogging $ f >=> maybe (return ()) logEffect

-- | Only let through logs that satisfy the given predicate.
filterLogs :: MonadEffect Logging m => (Log -> Bool) -> RuntimeImplemented Logging m a -> m a
filterLogs f = witherLogs (\l -> return $ if f l then Just l else Nothing)

-- | Transform logs with the given function.
mapLogs :: MonadEffect Logging m => (Log -> m Log) -> RuntimeImplemented Logging m a -> m a
mapLogs f = witherLogs ((Just <$>) . f)

-- | Filter out logs that are comming from below a certain depth.
logIfDepthLessThan :: MonadEffect Logging m => Int -> RuntimeImplemented Logging m a -> m a
logIfDepthLessThan n = logIfDepth (< n)

-- | Filter logs whose depth satisfies the given predicate.
logIfDepth :: MonadEffect Logging m => (Int -> Bool) -> RuntimeImplemented Logging m a -> m a
logIfDepth cond = filterLogs (\Log{..} -> cond (length logContext))

-- | For each log, add it's message to the logs breadcrumb list. This is useful so you don't have
--   to manually add crumbs.
messagesToCrumbs :: (MonadIO m, MonadEffect Logging m) => RuntimeImplemented Logging m a -> m a
messagesToCrumbs = mapLogs $ \l@Log{..} -> do
    time <- liftIO getCurrentTime
    let cat = Text.intercalate "." (fmap getContext logContext)
    return (l { logCrumbs = logCrumbs ++ [Crumb time (Just logMessage) cat (DefaultCrumb [])] })

-- | Each log that passes through will get all of the crumbs of the previous logs added.
--   If, for example, you're writing a web server, you might want to have this handler over the
--   request handler so that if an error occurs you can see all the steps that happened before it,
--   during the handling of that request.
collectCrumbs :: MonadEffect Logging m => RuntimeImplemented Logging (StateT [Crumb] m) a -> m a
collectCrumbs = flip evalStateT [] . mapLogs (\l@Log{..} -> do
    crumbs <- get
    let newCrumbs = crumbs ++ logCrumbs
    put newCrumbs
    return (l { logCrumbs = newCrumbs }))

-- | Add a user to every log.
addUserToLogs :: MonadEffect Logging m => LogUser -> RuntimeImplemented Logging m a -> m a
addUserToLogs user = mapLogs (\l -> return (l { logUser = Just user }))

-- | Add a crumb to every log.
addCrumbToLogs :: MonadEffect Logging m => Crumb -> RuntimeImplemented Logging m a -> m a
addCrumbToLogs crumb = mapLogs (\l -> return (l { logCrumbs = logCrumbs l ++ [crumb] }))

-- | Attach arbitrary data to every log. Typically you want to use this handler on
--   'logX' functions directly like @setDataWithSummary "some data" (logInfo "some info")@
setDataWithSummary :: MonadEffect Logging m => LogData -> RuntimeImplemented Logging m a -> m a
setDataWithSummary dat = mapLogs (\l -> return (l { logData = dat }))

-- | Attach an arbitrary 'ByteString' to every log. Typically you want to use this handler on
--   'logX' functions directly like @setDataTo "some data" (logInfo "some info")@
setDataTo :: MonadEffect Logging m => ByteString -> RuntimeImplemented Logging m a -> m a
setDataTo bs = setDataWithSummary (LogData bs "")

-- | Attach an arbitrary value to every log using it's 'ToJSON' instance.
--   Typically you want to use this handler on 'logX' functions directly like
--   @setDataToJsonOf 123 (logInfo "some info")@
setDataToJsonOf :: (MonadEffect Logging m, ToJSON v) => v -> RuntimeImplemented Logging m a -> m a
setDataToJsonOf = setDataTo . toS . encode

-- | Attach an arbitrary value to every log using it's 'Show' instance.
--   Typically you want to use this handler on 'logX' functions directly like
--   @setDataToShowOf 123 (logInfo "some info")@
setDataToShowOf :: (MonadEffect Logging m, Show v) => v -> RuntimeImplemented Logging m a -> m a
setDataToShowOf = setDataTo . pshow

-- | Add the current time to every log.
setTimestampToNow :: (MonadEffect Logging m, MonadIO m) => RuntimeImplemented Logging m a -> m a
setTimestampToNow = mapLogs $ \l -> do
    time <- liftIO getCurrentTime
    return (l { logTimestamp = Just time })

highlightT :: [Highlight] -> Text -> Text
highlightT hs = toS . highlight hs . toS

yellow :: Text -> Text
yellow = highlightT [Foreground Yellow]

colorFromLevel :: Level -> [Highlight]
colorFromLevel Debug = [Foreground Cyan]
colorFromLevel Info = [Foreground White]
colorFromLevel Warning = [Foreground Yellow]
colorFromLevel Error = [Foreground Red]
colorFromLevel Fatal = [Foreground Black, Background Red]

-- | Puts data of each log into a separate file inside of a given directory. Replaces the data of
--   the logs with the path to the files.
writeDataToFiles ::
    ( MonadEffect Logging m, MonadIO m )
    => FilePath -> RuntimeImplemented Logging m a -> m a
writeDataToFiles path m = do
    liftIO (createDirectoryIfMissing True path)
    m & mapLogs ( \l@Log{..} -> do
        uuid <- liftIO nextRandom
        let fp = path </> toString uuid <.> "txt"
        let LogData{..} = logData
        liftIO $
            writeFile fp
                (toS dataSummary <> "\n"
                <> toSL dataPayload <> "\n"
                <> pshow logCrumbs <> "\n"
                <> prettyCallStack logCallStack)
        return (l { logData = LogData "" (toS fp) }) )

truncate :: Int -> Text -> Text
truncate at txt = if Text.length txt > at then Text.take (at - 4) txt <> " ..." else txt

manyLines :: Int -> Text -> Text
manyLines trunc =
        Text.lines
    >>> fmap (truncate trunc)
    >>> zip [0 :: Int ..]
    >>> fmap (\(i, l) -> if i == 0 then l else "│          " <> l)
    >>> Text.intercalate "\n"

-- | Print out the logs in rich format. Truncates at the given length.
--   Logs will contain: message, timestamp, data, user and the call stack.
prettyPrintSummary :: MonadIO m => Int -> RuntimeImplemented Logging m a -> m a
prettyPrintSummary trunc h =
    flip handleLogging h $ \Log{..} -> liftIO $ do
        let callStackSection = manyLines trunc (toS (prettyCallStack logCallStack))
        let LogData{..} = logData
        let dataSection =
                if dataSummary == "" then truncate trunc (toSL dataPayload)
                else manyLines trunc dataSummary
        putText      "┌"
        putText     ("│ " <> highlightT (colorFromLevel logLevel) (pshow logLevel <> " Log"))
        putText     ("│ " <> yellow "Message: " <> logMessage)
        handleEarly $ do
            ts <- ifNothingEarlyReturn () logTimestamp
            putText ("│ " <> yellow "Time:    " <> pshow ts)
        unless (Text.null dataSection) $
            putText ("│ " <> yellow "Data:    " <> dataSection)
        when (isJust logUser) $ do
            let Just LogUser{..} = logUser
            putText ("│ " <> yellow "User:    " <> logUserId <> ", "
                                   <> fromMaybe " - " logUserEmail <> ", "
                                   <> fromMaybe " - " logUserUsername)
        putText     ("│ " <> yellow "Stack:   " <> callStackSection)
        putText      "└"

-- | Catches all IO exceptions, logs them and throws them back. The callstack in the log is __not__
--   the callstack of the exception.
logIOExceptions :: (MonadEffect Logging m, MonadCatch m) => m a -> m a
logIOExceptions = handleAll $ \(SomeException e) -> do
    logError "An IO exception occurred"
        & setDataWithSummary (LogData (pshow e) (toS (displayException e)))
    throwM e