module System.Log.Handler.Simple(streamHandler, fileHandler,
GenericHandler (..),
verboseStreamHandler)
where
import Control.Exception (tryJust)
import Control.DeepSeq
import Data.Char (ord)
import System.Log
import System.Log.Handler
import System.Log.Formatter
import System.IO
import System.IO.Error
import Control.Concurrent.MVar
data GenericHandler a = GenericHandler {forall a. GenericHandler a -> Priority
priority :: Priority,
forall a. GenericHandler a -> LogFormatter (GenericHandler a)
formatter :: LogFormatter (GenericHandler a),
forall a. GenericHandler a -> a
privData :: a,
forall a. GenericHandler a -> a -> String -> IO ()
writeFunc :: a -> String -> IO (),
forall a. GenericHandler a -> a -> IO ()
closeFunc :: a -> IO () }
instance LogHandler (GenericHandler a) where
setLevel :: GenericHandler a -> Priority -> GenericHandler a
setLevel GenericHandler a
sh Priority
p = GenericHandler a
sh{priority :: Priority
priority = Priority
p}
getLevel :: GenericHandler a -> Priority
getLevel GenericHandler a
sh = forall a. GenericHandler a -> Priority
priority GenericHandler a
sh
setFormatter :: GenericHandler a
-> LogFormatter (GenericHandler a) -> GenericHandler a
setFormatter GenericHandler a
sh LogFormatter (GenericHandler a)
f = GenericHandler a
sh{formatter :: LogFormatter (GenericHandler a)
formatter = LogFormatter (GenericHandler a)
f}
getFormatter :: GenericHandler a -> LogFormatter (GenericHandler a)
getFormatter GenericHandler a
sh = forall a. GenericHandler a -> LogFormatter (GenericHandler a)
formatter GenericHandler a
sh
emit :: GenericHandler a -> LogRecord -> String -> IO ()
emit GenericHandler a
sh (Priority
_,String
msg) String
_ = (forall a. GenericHandler a -> a -> String -> IO ()
writeFunc GenericHandler a
sh) (forall a. GenericHandler a -> a
privData GenericHandler a
sh) String
msg
close :: GenericHandler a -> IO ()
close GenericHandler a
sh = (forall a. GenericHandler a -> a -> IO ()
closeFunc GenericHandler a
sh) (forall a. GenericHandler a -> a
privData GenericHandler a
sh)
streamHandler :: Handle -> Priority -> IO (GenericHandler Handle)
streamHandler :: Handle -> Priority -> IO (GenericHandler Handle)
streamHandler Handle
h Priority
pri =
do MVar ()
lock <- forall a. a -> IO (MVar a)
newMVar ()
let mywritefunc :: Handle -> String -> IO ()
mywritefunc Handle
hdl String
msg =
String
msg forall a b. NFData a => a -> b -> b
`deepseq`
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock (\()
_ -> do Handle -> String -> IO ()
writeToHandle Handle
hdl String
msg
Handle -> IO ()
hFlush Handle
hdl
)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenericHandler {priority :: Priority
priority = Priority
pri,
formatter :: LogFormatter (GenericHandler Handle)
formatter = forall a. LogFormatter a
nullFormatter,
privData :: Handle
privData = Handle
h,
writeFunc :: Handle -> String -> IO ()
writeFunc = Handle -> String -> IO ()
mywritefunc,
closeFunc :: Handle -> IO ()
closeFunc = \Handle
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()})
where
writeToHandle :: Handle -> String -> IO ()
writeToHandle Handle
hdl String
msg = do
Either IOError ()
rv <- forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust IOError -> Maybe IOError
myException (Handle -> String -> IO ()
hPutStrLn Handle
hdl String
msg)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall {p}. Show p => Handle -> String -> p -> IO ()
handleWriteException Handle
hdl String
msg) forall (m :: * -> *) a. Monad m => a -> m a
return Either IOError ()
rv
myException :: IOError -> Maybe IOError
myException IOError
e
| IOError -> Bool
isDoesNotExistError IOError
e = forall a. a -> Maybe a
Just IOError
e
| Bool
otherwise = forall a. Maybe a
Nothing
handleWriteException :: Handle -> String -> p -> IO ()
handleWriteException Handle
hdl String
msg p
e =
let msg' :: String
msg' = String
"Error writing log message: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show p
e forall a. [a] -> [a] -> [a]
++
String
" (original message: " forall a. [a] -> [a] -> [a]
++ String
msg forall a. [a] -> [a] -> [a]
++ String
")"
in Handle -> String -> IO ()
hPutStrLn Handle
hdl (String -> String
encodingSave String
msg')
encodingSave :: String -> String
encodingSave = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Char
c -> if Char -> Int
ord Char
c forall a. Ord a => a -> a -> Bool
> Int
127
then String
"\\" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Char -> Int
ord Char
c)
else [Char
c])
fileHandler :: FilePath -> Priority -> IO (GenericHandler Handle)
fileHandler :: String -> Priority -> IO (GenericHandler Handle)
fileHandler String
fp Priority
pri = do
Handle
h <- String -> IOMode -> IO Handle
openFile String
fp IOMode
AppendMode
GenericHandler Handle
sh <- Handle -> Priority -> IO (GenericHandler Handle)
streamHandler Handle
h Priority
pri
forall (m :: * -> *) a. Monad m => a -> m a
return (GenericHandler Handle
sh{closeFunc :: Handle -> IO ()
closeFunc = Handle -> IO ()
hClose})
verboseStreamHandler :: Handle -> Priority -> IO (GenericHandler Handle)
verboseStreamHandler :: Handle -> Priority -> IO (GenericHandler Handle)
verboseStreamHandler Handle
h Priority
pri = let fmt :: LogFormatter a
fmt = forall a. String -> LogFormatter a
simpleLogFormatter String
"[$loggername/$prio] $msg"
in do GenericHandler Handle
hndlr <- Handle -> Priority -> IO (GenericHandler Handle)
streamHandler Handle
h Priority
pri
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. LogHandler a => a -> LogFormatter a -> a
setFormatter GenericHandler Handle
hndlr forall a. LogFormatter a
fmt