{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses, RankNTypes, ConstraintKinds
           , RecordWildCards #-}
{-# LANGUAGE GADTs, DataKinds #-}
-- | 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
import Control.Effects as Control.Effects.Logging
import Control.Effects.Signal

import Data.Text hiding (length)
import Data.Time.ISO8601
import qualified Data.ByteString as BS

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

-- | The logging effect.
data Logging = Logging
data instance Effect Logging method mr where
    LoggingMsg :: Log -> Effect Logging 'Logging 'Msg
    LoggingRes :: Effect Logging 'Logging 'Res

-- | 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 = Fatal | Error | Warning | Info | Debug 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)

data Log = Log { logMessage   :: Text
               , logLevel     :: Level
               , logTags      :: [Tag]
               , logContext   :: [Context]
               , logUser      :: Maybe LogUser
               , logCrumbs    :: [Crumb]
               , logData      :: ByteString
               , 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

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

-- | 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 ()) -> EffectHandler Logging m a -> m a
handleLogging f = handleEffect (\(LoggingMsg l) -> LoggingRes <$ f l)

-- | Add a new context on top of every log that comes from the given computation.
layerLogs :: MonadEffect Logging m => Context -> EffectHandler 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)

logInfo, logWarning, logError :: (HasCallStack, MonadEffect Logging m) => Text -> m ()
logInfo msg = logEffect $ Log msg Info [] [] Nothing [] "" Nothing callStack
logWarning msg = logEffect $ Log msg Warning [] [] Nothing [] "" Nothing callStack
logError msg = logEffect $ Log msg Error [] [] Nothing [] "" Nothing callStack

-- | 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 :: (MonadEffect Logging m, Throws e 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 => EffectHandler 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 => EffectHandler Logging m a -> m a
logRawToStdout = handleLogging print

-- | Discard the logs.
muteLogs :: Monad m => EffectHandler 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)) -> EffectHandler 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) -> EffectHandler 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) -> EffectHandler 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 -> EffectHandler Logging m a -> m a
logIfDepthLessThan n = logIfDepth (< n)

-- | Filter logs whose depth satisfies the given predicate.
logIfDepth :: MonadEffect Logging m => (Int -> Bool) -> EffectHandler 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) => EffectHandler Logging m a -> m a
messagesToCrumbs = mapLogs $ \l@Log{..} -> do
    time <- liftIO getCurrentTime
    let cat = Data.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 => EffectHandler 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 -> EffectHandler 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 -> EffectHandler Logging m a -> m a
addCrumbToLogs crumb = mapLogs (\l -> return (l { logCrumbs = logCrumbs l ++ [crumb] }))

-- | 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 -> EffectHandler Logging m a -> m a
setDataTo bs = mapLogs (\l -> return (l { 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 -> EffectHandler 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 -> EffectHandler Logging m a -> m a
setDataToShowOf = setDataTo . pshow

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

-- | 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 -> EffectHandler Logging m a -> m a
prettyPrintSummary trunc h = do
    lock <- liftIO (newMVar ())
    flip handleLogging h $ \Log{..} -> liftIO $ withMVar lock $ \_ -> do
        putText      "┌"
        putText     ("| " <> pshow logLevel <> " Log")
        putText     ("| Message: " <> logMessage)
        putText     ("| Time:    " <> pshow logTimestamp)
        putText     ("| Data:    " <> toS (BS.take trunc logData) <> "...")
        when (isJust logUser) $ do
            let Just LogUser{..} = logUser
            putText ("| User:    " <> logUserId <> ", "
                                   <> fromMaybe " - " logUserEmail <> ", "
                                   <> fromMaybe " - " logUserUsername)
        putText     ("| Stack:   " <> toS (BS.take trunc (pshow logCallStack)) <> "...")
        putText      "└"