module Stack.Types.StackT
(StackT
,StackLoggingT
,runStackT
,runStackLoggingT
,newTLSManager
,logSticky
,logStickyDone)
where
import Control.Applicative
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Control
import qualified Data.ByteString.Char8 as S8
import Data.Char
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import Data.Time
import Language.Haskell.TH
import Network.HTTP.Client.Conduit (HasHttpManager(..))
import Network.HTTP.Conduit
import Prelude
import Stack.Types.Internal
import System.IO
import System.Log.FastLogger
#ifndef MIN_VERSION_time
#define MIN_VERSION_time(x, y, z) 0
#endif
#if !MIN_VERSION_time(1, 5, 0)
import System.Locale
#endif
newtype StackT config m a =
StackT {unStackT :: ReaderT (Env config) m a}
deriving (Functor,Applicative,Monad,MonadIO,MonadReader (Env config),MonadThrow,MonadCatch,MonadMask,MonadTrans)
deriving instance (MonadBase b m) => MonadBase b (StackT config m)
instance MonadBaseControl b m => MonadBaseControl b (StackT config m) where
type StM (StackT config m) a = ComposeSt (StackT config) m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
instance MonadTransControl (StackT config) where
type StT (StackT config) a = StT (ReaderT (Env config)) a
liftWith = defaultLiftWith StackT unStackT
restoreT = defaultRestoreT StackT
instance (MonadIO m) => MonadLogger (StackT config m) where
monadLoggerLog = stickyLoggerFunc
runStackT :: (MonadIO m,MonadBaseControl IO m)
=> Manager -> LogLevel -> config -> Bool -> StackT config m a -> m a
runStackT manager logLevel config terminal m =
withSticky
terminal
(\sticky ->
runReaderT
(unStackT m)
(Env config logLevel terminal manager sticky))
newtype StackLoggingT m a =
StackLoggingT {unStackLoggingT :: ReaderT (LogLevel,Manager,Sticky) m a}
deriving (Functor,Applicative,Monad,MonadIO,MonadThrow,MonadReader (LogLevel,Manager,Sticky),MonadCatch,MonadMask,MonadTrans)
deriving instance (MonadBase b m) => MonadBase b (StackLoggingT m)
instance MonadBaseControl b m => MonadBaseControl b (StackLoggingT m) where
type StM (StackLoggingT m) a = ComposeSt StackLoggingT m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
instance MonadTransControl StackLoggingT where
type StT StackLoggingT a = StT (ReaderT (LogLevel,Manager,Sticky)) a
liftWith = defaultLiftWith StackLoggingT unStackLoggingT
restoreT = defaultRestoreT StackLoggingT
instance (MonadIO m) => MonadLogger (StackLoggingT m) where
monadLoggerLog = stickyLoggerFunc
instance HasSticky (LogLevel,Manager,Sticky) where
getSticky (_,_,s) = s
instance HasLogLevel (LogLevel,Manager,Sticky) where
getLogLevel (l,_,_) = l
instance HasHttpManager (LogLevel,Manager,Sticky) where
getHttpManager (_,m,_) = m
runStackLoggingT :: MonadIO m
=> Manager -> LogLevel -> Bool -> StackLoggingT m a -> m a
runStackLoggingT manager logLevel terminal m =
withSticky
terminal
(\sticky ->
runReaderT
(unStackLoggingT m)
(logLevel, manager, sticky))
newTLSManager :: MonadIO m => m Manager
newTLSManager = liftIO $ newManager conduitManagerSettings
stickyLoggerFunc :: (HasSticky r, HasLogLevel r, ToLogStr msg, MonadReader r (t m), MonadTrans t, MonadIO (t m))
=> Loc -> LogSource -> LogLevel -> msg -> t m ()
stickyLoggerFunc loc src level msg = do
Sticky mref <- asks getSticky
case mref of
Nothing ->
loggerFunc
loc
src
(case level of
LevelOther "sticky-done" -> LevelInfo
LevelOther "sticky" -> LevelInfo
_ -> level)
msg
Just ref -> do
sticky <- liftIO (takeMVar ref)
let backSpaceChar =
'\8'
repeating =
S8.replicate
(maybe 0 T.length sticky)
clear =
liftIO
(S8.putStr
(repeating backSpaceChar <>
repeating ' ' <>
repeating backSpaceChar))
maxLogLevel <- asks getLogLevel
newState <-
case level of
LevelOther "sticky-done" -> do
clear
let text =
T.decodeUtf8 msgBytes
liftIO (T.putStrLn text)
return Nothing
LevelOther "sticky" -> do
clear
let text =
T.decodeUtf8 msgBytes
liftIO (T.putStr text)
return (Just text)
_
| level >= maxLogLevel -> do
clear
loggerFunc loc src level msg
case sticky of
Nothing ->
return Nothing
Just line -> do
liftIO (T.putStr line)
return sticky
| otherwise ->
return sticky
liftIO (putMVar ref newState)
where
msgBytes =
fromLogStr
(toLogStr msg)
loggerFunc :: (MonadIO m,ToLogStr msg,MonadReader r m,HasLogLevel r)
=> Loc -> Text -> LogLevel -> msg -> m ()
loggerFunc loc _src level msg =
do maxLogLevel <- asks getLogLevel
when (level >= maxLogLevel)
(liftIO (do out <- getOutput maxLogLevel
S8.putStrLn (S8.pack out)))
where getOutput maxLogLevel =
do date <- getDate
l <- getLevel
lc <- getLoc
return (date ++ l ++ S8.unpack (fromLogStr (toLogStr msg)) ++ lc)
where getDate
| maxLogLevel <= LevelDebug =
do now <- getCurrentTime
return (formatTime defaultTimeLocale "%Y-%m-%d %T%Q" now ++
": ")
| otherwise = return ""
getLevel
| maxLogLevel <= LevelDebug =
return ("[" ++
map toLower (drop 5 (show level)) ++
"] ")
| otherwise = return ""
getLoc
| maxLogLevel <= LevelDebug =
return (" @(" ++ fileLocStr ++ ")")
| otherwise = return ""
fileLocStr =
(loc_package loc) ++
':' :
(loc_module loc) ++
' ' :
(loc_filename loc) ++
':' :
(line loc) ++
':' :
(char loc)
where line = show . fst . loc_start
char = show . snd . loc_start
withSticky :: (MonadIO m)
=> Bool -> (Sticky -> m b) -> m b
withSticky terminal m = do
if terminal
then do state <- liftIO (newMVar Nothing)
originalMode <- liftIO (hGetBuffering stdout)
liftIO (hSetBuffering stdout NoBuffering)
a <- m (Sticky (Just state))
state' <- liftIO (takeMVar state)
liftIO (when (isJust state') (S8.putStr "\n"))
liftIO (hSetBuffering stdout originalMode)
return a
else m (Sticky Nothing)
logSticky :: Q Exp
logSticky =
logOther "sticky"
logStickyDone :: Q Exp
logStickyDone =
logOther "sticky-done"