yet-another-logger-0.2.2: src/System/Logger/Backend/Handle.hs

-- Copyright (c) 2014-2015 PivotCloud, Inc.
--
-- System.Logger.Backend.Handle
--
-- Please feel free to contact us at licensing@pivotmail.com with any
-- contributions, additions, or other feedback; we would love to hear from
-- you.
--
-- Licensed under the Apache License, Version 2.0 (the "License"); you may
-- not use this file except in compliance with the License. You may obtain a
-- copy of the License at http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
-- License for the specific language governing permissions and limitations
-- under the License.

-- |
-- Module: System.Logger.Backend.Handle
-- Description: Handle Backend for Yet Another Logger
-- Copyright: Copyright (c) 2014-2015 PivotCloud, Inc.
-- License: Apache License, Version 2.0
-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>
-- Stability: experimental
--

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}

module System.Logger.Backend.Handle
(
-- * Handle Configuration
  LoggerHandleConfig(..)
, loggerHandleConfigText
, readLoggerHandleConfig
, validateLoggerHandleConfig
, pLoggerHandleConfig
, pLoggerHandleConfig_

-- * Backend Configuration
, HandleBackendConfig(..)
, handleBackendConfigHandle
, handleBackendConfigColor
, defaultHandleBackendConfig
, validateHandleBackendConfig
, pHandleBackendConfig
, pHandleBackendConfig_

-- * Backend Implementation
, withHandleBackend
, withHandleBackend_
, handleBackend
, handleBackend_
) where

import Configuration.Utils hiding (Lens', Error)
import Configuration.Utils.Validation

import Control.DeepSeq
import Control.Lens hiding ((.=))
import Control.Monad.Except
import Control.Monad.Trans.Control
import Control.Monad.Writer

import qualified Data.CaseInsensitive as CI
import qualified Data.List as L
import Data.Monoid.Unicode
import Data.String
import qualified Data.Text as T
import Data.Text.Lens
import qualified Data.Text.IO as T
import Data.Typeable

import GHC.Generics

import qualified Options.Applicative as O

import Prelude.Unicode

import qualified System.Console.ANSI as A
import System.IO

-- internal modules

import System.Logger.Backend.ColorOption
import System.Logger.Internal
import System.Logger.Types

-- -------------------------------------------------------------------------- --
-- Handle Logger Backend Configuration

data LoggerHandleConfig
    = StdOut
    | StdErr
    | FileHandle FilePath
    deriving (Show, Read, Eq, Ord, Typeable, Generic)

instance NFData LoggerHandleConfig

readLoggerHandleConfig
    ∷ (MonadError e m, Eq a, Show a, CI.FoldCase a, IsText a, IsString e, Monoid e)
    ⇒ a
    → m LoggerHandleConfig
readLoggerHandleConfig x = case CI.mk tx of
    "stdout" → return StdOut
    "stderr" → return StdErr
    _ | CI.mk (L.take 5 tx) ≡ "file:" → return $ FileHandle (L.drop 5 tx)
    e → throwError $ "unexpected logger handle value: "
        ⊕ fromString (show e)
        ⊕ ", expected \"stdout\", \"stderr\", or \"file:<FILENAME>\""
  where
    tx = packed # x

loggerHandleConfigText
    ∷ (IsString a, Monoid a)
    ⇒ LoggerHandleConfig
    → a
loggerHandleConfigText StdOut = "stdout"
loggerHandleConfigText StdErr = "stderr"
loggerHandleConfigText (FileHandle f) = "file:" ⊕ fromString f

validateLoggerHandleConfig ∷ ConfigValidation LoggerHandleConfig λ
validateLoggerHandleConfig (FileHandle filepath) = validateFileWritable "file handle" filepath
validateLoggerHandleConfig _ = return ()

instance ToJSON LoggerHandleConfig where
    toJSON = String ∘ loggerHandleConfigText

instance FromJSON LoggerHandleConfig where
    parseJSON = withText "LoggerHandleConfig" $ either fail return ∘ readLoggerHandleConfig

pLoggerHandleConfig ∷ O.Parser LoggerHandleConfig
pLoggerHandleConfig = pLoggerHandleConfig_ ""

-- | A version of 'pLoggerHandleConfig' that takes a prefix for the
-- command line option.
--
-- @since 0.2
--
pLoggerHandleConfig_
    ∷ T.Text
        -- ^ prefix for the command line options.
    → O.Parser LoggerHandleConfig
pLoggerHandleConfig_ prefix = option (eitherReader readLoggerHandleConfig)
    × long (T.unpack prefix ⊕ "logger-backend-handle")
    ⊕ metavar "stdout|stderr|file:<FILENAME>"
    ⊕ help "handle where the logs are written"

-- -------------------------------------------------------------------------- --
-- Logger Backend Configuration

-- | HandleBackendConfig
--
data HandleBackendConfig = HandleBackendConfig
    { _handleBackendConfigColor ∷ !ColorOption
    , _handleBackendConfigHandle ∷ !LoggerHandleConfig
    }
    deriving (Show, Read, Eq, Ord, Typeable, Generic)

handleBackendConfigColor ∷ Lens' HandleBackendConfig ColorOption
handleBackendConfigColor = lens _handleBackendConfigColor $ \a b → a { _handleBackendConfigColor = b }

handleBackendConfigHandle ∷ Lens' HandleBackendConfig LoggerHandleConfig
handleBackendConfigHandle = lens _handleBackendConfigHandle $ \a b → a { _handleBackendConfigHandle = b }

instance NFData HandleBackendConfig

defaultHandleBackendConfig ∷ HandleBackendConfig
defaultHandleBackendConfig = HandleBackendConfig
    { _handleBackendConfigColor = defaultColorOption
    , _handleBackendConfigHandle = StdOut
    }

validateHandleBackendConfig ∷ ConfigValidation HandleBackendConfig []
validateHandleBackendConfig HandleBackendConfig{..} = do
        validateLoggerHandleConfig _handleBackendConfigHandle
        case (_handleBackendConfigHandle, _handleBackendConfigColor) of
            (FileHandle _, ColorTrue) →
                tell ["log messages are formatted using ANSI color escape codes but are written to a file"]
            _ → return ()

instance ToJSON HandleBackendConfig where
    toJSON HandleBackendConfig{..} = object
        [ "color" .= _handleBackendConfigColor
        , "handle" .= _handleBackendConfigHandle
        ]

instance FromJSON (HandleBackendConfig → HandleBackendConfig) where
    parseJSON = withObject "HandleBackendConfig" $ \o → id
        <$< handleBackendConfigColor ..: "color" × o
        <*< handleBackendConfigHandle ..: "handle" × o

pHandleBackendConfig ∷ MParser HandleBackendConfig
pHandleBackendConfig = pHandleBackendConfig_ ""

-- | A version of 'pLoggerHandleBackendConfig' that takes a prefix for the
-- command line option.
--
-- @since 0.2
--
pHandleBackendConfig_
    ∷ T.Text
        -- ^ prefix for this and all subordinate command line options.
    → MParser HandleBackendConfig
pHandleBackendConfig_ prefix = id
    <$< handleBackendConfigColor .:: pColorOption_ prefix
    <*< handleBackendConfigHandle .:: pLoggerHandleConfig_ prefix

-- -------------------------------------------------------------------------- --
-- Backend Implementation

withHandleBackend
    ∷ (MonadIO m, MonadBaseControl IO m)
    ⇒ HandleBackendConfig
    → (LoggerBackend T.Text → m α)
    → m α
withHandleBackend = withHandleBackend_ id
{-# INLINE withHandleBackend #-}

-- | A version of 'withHandleBackend' that is generic in the type
-- of the log message.
--
-- @since 0.2.2
--
withHandleBackend_
    ∷ (MonadIO m, MonadBaseControl IO m)
    ⇒ (msg → T.Text)
        -- ^ formatting function for the log message
    → HandleBackendConfig
    → (LoggerBackend msg → m α)
    → m α
withHandleBackend_ format conf inner =
    case conf ^. handleBackendConfigHandle of
        StdErr → run stderr
        StdOut → run stdout
        FileHandle f → liftBaseOp (withFile f AppendMode) run
  where
    run h = do
        colored ← liftIO $ useColor (conf ^. handleBackendConfigColor) h
        inner $ handleBackend_ format h colored

handleBackend
    ∷ Handle
    → Bool
        -- ^ whether to use ANSI color escape codes
    → LoggerBackend T.Text
handleBackend = handleBackend_ id
{-# INLINE handleBackend #-}

-- | A version of 'handleBackend' that is generic in the type of
-- the log message.
--
-- @since 0.2.2
--
handleBackend_
    ∷ (msg → T.Text)
        -- ^ formatting function for the log message
    → Handle
    → Bool
        -- ^ whether to use ANSI color escape codes
    → LoggerBackend msg
handleBackend_ format h colored eitherMsg = do
    T.hPutStrLn h
        $ formatIso8601Milli (msg ^. logMsgTime) ⊕ " "
        ⊕ inLevelColor colored ("[" ⊕ sshow level ⊕ "] ")
        ⊕ inScopeColor colored ("[" ⊕ formatedScope ⊕ "] ")
        ⊕ (msg ^. logMsg)
  where
    msg = either id (logMsg %~ format) eitherMsg
    level = msg ^. logMsgLevel

    formatedScope = T.intercalate "|" ∘ L.map formatLabel ∘ reverse $ msg ^. logMsgScope
    formatLabel (key, val) = key ⊕ "=" ⊕ val

    inScopeColor True = inBlue
    inScopeColor False = id

    inLevelColor True = case level of
        Error → inRed
        Warn → inOrange
        Info → inGreen
        _ → id
    inLevelColor False = id

    inColor ∷ A.ColorIntensity → A.Color → T.Text → T.Text
    inColor i c t = T.pack (A.setSGRCode [A.SetColor A.Foreground i c]) ⊕ t ⊕ T.pack (A.setSGRCode [A.Reset])

    inRed ∷ T.Text → T.Text
    inRed = inColor A.Vivid A.Red

    inOrange ∷ T.Text → T.Text
    inOrange = inColor A.Dull A.Red

    inGreen ∷ T.Text → T.Text
    inGreen = inColor A.Dull A.Green

    inBlue ∷ T.Text → T.Text
    inBlue = inColor A.Dull A.Blue
{-# INLINEABLE handleBackend_ #-}