{-# LANGUAGE CPP #-}
module System.Log.Handler.Syslog(
SyslogHandler,
openlog,
#ifndef mingw32_HOST_OS
openlog_local,
#endif
openlog_remote,
openlog_generic,
Facility(..),
Option(..)
) where
import qualified Control.Exception as E
import System.Log
import System.Log.Formatter
import System.Log.Handler
import Data.Bits
import qualified Network.Socket as S
import qualified Network.Socket.ByteString as SBS
import qualified Network.BSD as S
import Data.List (genericDrop)
#ifndef mingw32_HOST_OS
import System.Posix.Process(getProcessID)
#endif
import System.IO
import Control.Monad (void, when)
import UTF8
send :: S.Socket -> String -> IO Int
send :: Socket -> String -> IO Int
send s :: Socket
s = Socket -> ByteString -> IO Int
SBS.send Socket
s (ByteString -> IO Int)
-> (String -> ByteString) -> String -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
toUTF8BS
sendTo :: S.Socket -> String -> S.SockAddr -> IO Int
sendTo :: Socket -> String -> SockAddr -> IO Int
sendTo s :: Socket
s str :: String
str = Socket -> ByteString -> SockAddr -> IO Int
SBS.sendTo Socket
s (String -> ByteString
toUTF8BS String
str)
code_of_pri :: Priority -> Int
code_of_pri :: Priority -> Int
code_of_pri p :: Priority
p = case Priority
p of
EMERGENCY -> 0
ALERT -> 1
CRITICAL -> 2
ERROR -> 3
WARNING -> 4
NOTICE -> 5
INFO -> 6
DEBUG -> 7
data Facility =
KERN
| USER
| MAIL
| DAEMON
| AUTH
| SYSLOG
| LPR
| NEWS
| UUCP
| CRON
| AUTHPRIV
| FTP
| LOCAL0
| LOCAL1
| LOCAL2
| LOCAL3
| LOCAL4
| LOCAL5
| LOCAL6
| LOCAL7
deriving (Facility -> Facility -> Bool
(Facility -> Facility -> Bool)
-> (Facility -> Facility -> Bool) -> Eq Facility
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Facility -> Facility -> Bool
$c/= :: Facility -> Facility -> Bool
== :: Facility -> Facility -> Bool
$c== :: Facility -> Facility -> Bool
Eq, Int -> Facility -> ShowS
[Facility] -> ShowS
Facility -> String
(Int -> Facility -> ShowS)
-> (Facility -> String) -> ([Facility] -> ShowS) -> Show Facility
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Facility] -> ShowS
$cshowList :: [Facility] -> ShowS
show :: Facility -> String
$cshow :: Facility -> String
showsPrec :: Int -> Facility -> ShowS
$cshowsPrec :: Int -> Facility -> ShowS
Show, ReadPrec [Facility]
ReadPrec Facility
Int -> ReadS Facility
ReadS [Facility]
(Int -> ReadS Facility)
-> ReadS [Facility]
-> ReadPrec Facility
-> ReadPrec [Facility]
-> Read Facility
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Facility]
$creadListPrec :: ReadPrec [Facility]
readPrec :: ReadPrec Facility
$creadPrec :: ReadPrec Facility
readList :: ReadS [Facility]
$creadList :: ReadS [Facility]
readsPrec :: Int -> ReadS Facility
$creadsPrec :: Int -> ReadS Facility
Read)
code_of_fac :: Facility -> Int
code_of_fac :: Facility -> Int
code_of_fac f :: Facility
f = case Facility
f of
KERN -> 0
USER -> 1
MAIL -> 2
DAEMON -> 3
AUTH -> 4
SYSLOG -> 5
LPR -> 6
NEWS -> 7
UUCP -> 8
CRON -> 9
AUTHPRIV -> 10
FTP -> 11
LOCAL0 -> 16
LOCAL1 -> 17
LOCAL2 -> 18
LOCAL3 -> 19
LOCAL4 -> 20
LOCAL5 -> 21
LOCAL6 -> 22
LOCAL7 -> 23
makeCode :: Facility -> Priority -> Int
makeCode :: Facility -> Priority -> Int
makeCode fac :: Facility
fac pri :: Priority
pri =
let faccode :: Int
faccode = Facility -> Int
code_of_fac Facility
fac
pricode :: Int
pricode = Priority -> Int
code_of_pri Priority
pri in
(Int
faccode Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` 3) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
pricode
data Option = PID
| PERROR
deriving (Option -> Option -> Bool
(Option -> Option -> Bool)
-> (Option -> Option -> Bool) -> Eq Option
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Option -> Option -> Bool
$c/= :: Option -> Option -> Bool
== :: Option -> Option -> Bool
$c== :: Option -> Option -> Bool
Eq,Int -> Option -> ShowS
[Option] -> ShowS
Option -> String
(Int -> Option -> ShowS)
-> (Option -> String) -> ([Option] -> ShowS) -> Show Option
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Option] -> ShowS
$cshowList :: [Option] -> ShowS
show :: Option -> String
$cshow :: Option -> String
showsPrec :: Int -> Option -> ShowS
$cshowsPrec :: Int -> Option -> ShowS
Show,ReadPrec [Option]
ReadPrec Option
Int -> ReadS Option
ReadS [Option]
(Int -> ReadS Option)
-> ReadS [Option]
-> ReadPrec Option
-> ReadPrec [Option]
-> Read Option
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Option]
$creadListPrec :: ReadPrec [Option]
readPrec :: ReadPrec Option
$creadPrec :: ReadPrec Option
readList :: ReadS [Option]
$creadList :: ReadS [Option]
readsPrec :: Int -> ReadS Option
$creadsPrec :: Int -> ReadS Option
Read)
data SyslogHandler = SyslogHandler {SyslogHandler -> [Option]
options :: [Option],
SyslogHandler -> Facility
facility :: Facility,
SyslogHandler -> String
identity :: String,
SyslogHandler -> Socket
logsocket :: S.Socket,
SyslogHandler -> SockAddr
address :: S.SockAddr,
SyslogHandler -> SocketType
sock_type :: S.SocketType,
SyslogHandler -> Priority
priority :: Priority,
SyslogHandler -> LogFormatter SyslogHandler
formatter :: LogFormatter SyslogHandler
}
openlog :: String
-> [Option]
-> Facility
-> Priority
-> IO SyslogHandler
#ifdef mingw32_HOST_OS
openlog = openlog_remote S.AF_INET "localhost" 514
#elif darwin_HOST_OS
openlog = openlog_local "/var/run/syslog"
#else
openlog :: String -> [Option] -> Facility -> Priority -> IO SyslogHandler
openlog = String
-> String -> [Option] -> Facility -> Priority -> IO SyslogHandler
openlog_local "/dev/log"
#endif
#ifndef mingw32_HOST_OS
openlog_local :: String
-> String
-> [Option]
-> Facility
-> Priority
-> IO SyslogHandler
openlog_local :: String
-> String -> [Option] -> Facility -> Priority -> IO SyslogHandler
openlog_local fifopath :: String
fifopath ident :: String
ident options' :: [Option]
options' fac :: Facility
fac pri :: Priority
pri =
do (s :: Socket
s, t :: SocketType
t) <- do
Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
S.socket Family
S.AF_UNIX SocketType
S.Stream 0
Socket -> IO (Socket, SocketType)
tryStream Socket
s IO (Socket, SocketType)
-> (IOException -> IO (Socket, SocketType))
-> IO (Socket, SocketType)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (IO (Socket, SocketType) -> IOException -> IO (Socket, SocketType)
forall a. IO a -> IOException -> IO a
onIOException (Socket -> IO (Socket, SocketType)
fallbackToDgram Socket
s))
Socket
-> SockAddr
-> SocketType
-> String
-> [Option]
-> Facility
-> Priority
-> IO SyslogHandler
openlog_generic Socket
s (String -> SockAddr
S.SockAddrUnix String
fifopath) SocketType
t String
ident [Option]
options' Facility
fac Priority
pri
where onIOException :: IO a -> E.IOException -> IO a
onIOException :: IO a -> IOException -> IO a
onIOException a :: IO a
a _ = IO a
a
tryStream :: S.Socket -> IO (S.Socket, S.SocketType)
tryStream :: Socket -> IO (Socket, SocketType)
tryStream s :: Socket
s =
do Socket -> SockAddr -> IO ()
S.connect Socket
s (String -> SockAddr
S.SockAddrUnix String
fifopath)
(Socket, SocketType) -> IO (Socket, SocketType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
s, SocketType
S.Stream)
fallbackToDgram :: S.Socket -> IO (S.Socket, S.SocketType)
fallbackToDgram :: Socket -> IO (Socket, SocketType)
fallbackToDgram s :: Socket
s =
do Socket -> IO ()
S.close Socket
s
Socket
d <- Family -> SocketType -> ProtocolNumber -> IO Socket
S.socket Family
S.AF_UNIX SocketType
S.Datagram 0
(Socket, SocketType) -> IO (Socket, SocketType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
d, SocketType
S.Datagram)
#endif
openlog_remote :: S.Family
-> S.HostName
-> S.PortNumber
-> String
-> [Option]
-> Facility
-> Priority
-> IO SyslogHandler
openlog_remote :: Family
-> String
-> PortNumber
-> String
-> [Option]
-> Facility
-> Priority
-> IO SyslogHandler
openlog_remote fam :: Family
fam hostname :: String
hostname port :: PortNumber
port ident :: String
ident options' :: [Option]
options' fac :: Facility
fac pri :: Priority
pri =
do
HostEntry
he <- String -> IO HostEntry
S.getHostByName String
hostname
Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
S.socket Family
fam SocketType
S.Datagram 0
let addr :: SockAddr
addr = PortNumber -> HostAddress -> SockAddr
S.SockAddrInet PortNumber
port ([HostAddress] -> HostAddress
forall a. [a] -> a
head (HostEntry -> [HostAddress]
S.hostAddresses HostEntry
he))
Socket
-> SockAddr
-> SocketType
-> String
-> [Option]
-> Facility
-> Priority
-> IO SyslogHandler
openlog_generic Socket
s SockAddr
addr SocketType
S.Datagram String
ident [Option]
options' Facility
fac Priority
pri
openlog_generic :: S.Socket
-> S.SockAddr
-> S.SocketType
-> String
-> [Option]
-> Facility
-> Priority
-> IO SyslogHandler
openlog_generic :: Socket
-> SockAddr
-> SocketType
-> String
-> [Option]
-> Facility
-> Priority
-> IO SyslogHandler
openlog_generic sock :: Socket
sock addr :: SockAddr
addr sock_t :: SocketType
sock_t ident :: String
ident opt :: [Option]
opt fac :: Facility
fac pri :: Priority
pri =
SyslogHandler -> IO SyslogHandler
forall (m :: * -> *) a. Monad m => a -> m a
return (SyslogHandler :: [Option]
-> Facility
-> String
-> Socket
-> SockAddr
-> SocketType
-> Priority
-> LogFormatter SyslogHandler
-> SyslogHandler
SyslogHandler {options :: [Option]
options = [Option]
opt,
facility :: Facility
facility = Facility
fac,
identity :: String
identity = String
ident,
logsocket :: Socket
logsocket = Socket
sock,
address :: SockAddr
address = SockAddr
addr,
sock_type :: SocketType
sock_type = SocketType
sock_t,
priority :: Priority
priority = Priority
pri,
formatter :: LogFormatter SyslogHandler
formatter = LogFormatter SyslogHandler
syslogFormatter
})
syslogFormatter :: LogFormatter SyslogHandler
syslogFormatter :: LogFormatter SyslogHandler
syslogFormatter sh :: SyslogHandler
sh (p :: Priority
p,msg :: String
msg) logname :: String
logname =
let format :: String
format = "[$loggername/$prio] $msg"
in [(String, IO String)] -> String -> LogFormatter SyslogHandler
forall a. [(String, IO String)] -> String -> LogFormatter a
varFormatter [] String
format SyslogHandler
sh (Priority
p,String
msg) String
logname
instance LogHandler SyslogHandler where
setLevel :: SyslogHandler -> Priority -> SyslogHandler
setLevel sh :: SyslogHandler
sh p :: Priority
p = SyslogHandler
sh{priority :: Priority
priority = Priority
p}
getLevel :: SyslogHandler -> Priority
getLevel sh :: SyslogHandler
sh = SyslogHandler -> Priority
priority SyslogHandler
sh
setFormatter :: SyslogHandler -> LogFormatter SyslogHandler -> SyslogHandler
setFormatter sh :: SyslogHandler
sh f :: LogFormatter SyslogHandler
f = SyslogHandler
sh{formatter :: LogFormatter SyslogHandler
formatter = LogFormatter SyslogHandler
f}
getFormatter :: SyslogHandler -> LogFormatter SyslogHandler
getFormatter sh :: SyslogHandler
sh = SyslogHandler -> LogFormatter SyslogHandler
formatter SyslogHandler
sh
emit :: SyslogHandler -> LogRecord -> String -> IO ()
emit sh :: SyslogHandler
sh (prio :: Priority
prio, msg :: String
msg) _ = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Option -> [Option] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Option
PERROR (SyslogHandler -> [Option]
options SyslogHandler
sh)) (Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg)
String
pidPart <- IO String
getPidPart
IO String -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
sendstr (String -> ShowS
toSyslogFormat String
msg String
pidPart)
where
sendstr :: String -> IO String
sendstr :: String -> IO String
sendstr [] = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return []
sendstr omsg :: String
omsg = do
Int
sent <- case SyslogHandler -> SocketType
sock_type SyslogHandler
sh of
S.Datagram -> Socket -> String -> SockAddr -> IO Int
sendTo (SyslogHandler -> Socket
logsocket SyslogHandler
sh) String
omsg (SyslogHandler -> SockAddr
address SyslogHandler
sh)
S.Stream -> Socket -> String -> IO Int
send (SyslogHandler -> Socket
logsocket SyslogHandler
sh) String
omsg
String -> IO String
sendstr (Int -> ShowS
forall i a. Integral i => i -> [a] -> [a]
genericDrop Int
sent String
omsg)
toSyslogFormat :: String -> ShowS
toSyslogFormat msg' :: String
msg' pidPart :: String
pidPart =
"<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
code String -> ShowS
forall a. [a] -> [a] -> [a]
++ ">" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
identity' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pidPart String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg' String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\0"
code :: String
code = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Facility -> Priority -> Int
makeCode (SyslogHandler -> Facility
facility SyslogHandler
sh) Priority
prio
identity' :: String
identity' = SyslogHandler -> String
identity SyslogHandler
sh
getPidPart :: IO String
getPidPart = if Option -> [Option] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Option
PID (SyslogHandler -> [Option]
options SyslogHandler
sh)
then IO String
getPid IO String -> (String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \pid :: String
pid -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return ("[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pid String -> ShowS
forall a. [a] -> [a] -> [a]
++ "]")
else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return ""
getPid :: IO String
getPid :: IO String
getPid =
#ifndef mingw32_HOST_OS
IO ProcessID
getProcessID IO ProcessID -> (ProcessID -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String)
-> (ProcessID -> String) -> ProcessID -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessID -> String
forall a. Show a => a -> String
show
#else
return "windows"
#endif
close :: SyslogHandler -> IO ()
close sh :: SyslogHandler
sh = Socket -> IO ()
S.close (SyslogHandler -> Socket
logsocket SyslogHandler
sh)