module System.Wlog.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 Control.Monad (void, when)
import Data.Bits (shiftL, (.|.))
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Text.Lazy.Builder as B
import Network.BSD (getHostByName, hostAddresses)
import Network.Socket (Family, Family (..), HostName,
PortNumber, SockAddr (..), Socket,
SocketType (Datagram, Stream),
connect, socket)
import qualified Network.Socket as S
import qualified Network.Socket.ByteString as NBS
#ifndef mingw32_HOST_OS
import System.Posix.Process (getProcessID)
#endif
import qualified Data.Text.Lazy.IO as TIO
import System.IO ()
import Universum hiding (Option, identity)
import System.Wlog.Formatter (LogFormatter, varFormatter)
import System.Wlog.Handler (LogHandler (..),
LogHandlerTag (HandlerOther))
import System.Wlog.Severity (Severity (..))
code_of_pri :: Severity -> Int
code_of_pri p =
case p of
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 (Eq, Show, Read)
code_of_fac :: Facility -> Int
code_of_fac f = case 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 -> Severity -> Int
makeCode fac pri =
let faccode = code_of_fac fac
pricode = code_of_pri pri
in (faccode `shiftL` 3) .|. pricode
data Option
= PID
| PERROR
deriving (Eq, Show, Read)
data SyslogHandler = SyslogHandler
{ options :: [Option]
, facility :: Facility
, identity :: String
, logsocket :: Socket
, address :: SockAddr
, sock_type :: SocketType
, priority :: Severity
, formatter :: LogFormatter SyslogHandler
}
openlog :: String
-> [Option]
-> Facility
-> Severity
-> IO SyslogHandler
#ifdef mingw32_HOST_OS
openlog = openlog_remote AF_INET "localhost" 514
#elif darwin_HOST_OS
openlog = openlog_local "/var/run/syslog"
#else
openlog = openlog_local "/dev/log"
#endif
#ifndef mingw32_HOST_OS
openlog_local :: String
-> String
-> [Option]
-> Facility
-> Severity
-> IO SyslogHandler
openlog_local fifopath ident options fac pri =
do (s, t) <- do
s <- socket AF_UNIX Stream 0
tryStream s `E.catch` (onIOException (fallbackToDgram s))
openlog_generic s (SockAddrUnix fifopath) t ident options fac pri
where onIOException :: IO a -> E.IOException -> IO a
onIOException a _ = a
tryStream :: Socket -> IO (Socket, SocketType)
tryStream s =
do connect s (SockAddrUnix fifopath)
return (s, Stream)
fallbackToDgram :: Socket -> IO (Socket, SocketType)
fallbackToDgram s =
do S.close s
d <- socket AF_UNIX Datagram 0
return (d, Datagram)
#endif
openlog_remote
:: Family
-> HostName
-> PortNumber
-> String
-> [Option]
-> Facility
-> Severity
-> IO SyslogHandler
openlog_remote fam hostname port ident options fac pri =
do
he <- getHostByName hostname
s <- socket fam Datagram 0
let addr = SockAddrInet port (fromMaybe (error "head in openlog_remote") $
head (hostAddresses he))
openlog_generic s addr Datagram ident options fac pri
openlog_generic :: Socket
-> SockAddr
-> SocketType
-> String
-> [Option]
-> Facility
-> Severity
-> IO SyslogHandler
openlog_generic sock addr sock_t ident opt fac pri =
return (SyslogHandler {options = opt,
facility = fac,
identity = ident,
logsocket = sock,
address = addr,
sock_type = sock_t,
priority = pri,
formatter = syslogFormatter
})
syslogFormatter :: LogFormatter SyslogHandler
syslogFormatter sh lr logname =
let format = "[$loggername/$prio] $msg"
in varFormatter [] format sh lr logname
instance LogHandler SyslogHandler where
getTag = const $ HandlerOther "SyslogHandlerTag"
setLevel sh p = sh{priority = p}
getLevel sh = priority sh
setFormatter sh f = sh{formatter = f}
getFormatter sh = formatter sh
readBack _ _ = pure []
emit sh bldr _ = do
when (elem PERROR (options sh)) (TIO.hPutStrLn stderr (B.toLazyText bldr))
pidPart <- getPidPart
void $ sendstr (toSyslogFormat (toText $ B.toLazyText bldr) pidPart)
where
prio = getLevel sh
sendstr :: Text -> IO ()
sendstr t | T.null t = pass
sendstr omsg = do
let omsg' = TE.encodeUtf8 omsg
sent <- case sock_type sh of
Datagram -> NBS.sendTo (logsocket sh) omsg' (address sh)
Stream -> NBS.send (logsocket sh) omsg'
sck ->
error $ "sysloghandler: unsupported socket type " <> show sck <>
" only datagram/stream sockets are supported"
sendstr $ T.drop (fromIntegral sent) omsg
toSyslogFormat m pidPart =
"<" <> code <> ">" <> T.pack identity' <> T.pack pidPart <> ": " <> m <> "\0"
code = show $ makeCode (facility sh) prio
identity' = identity sh
getPidPart = if elem PID (options sh)
then getPid >>= \pid -> return ("[" ++ pid ++ "]")
else return ""
getPid :: IO String
getPid =
#ifndef mingw32_HOST_OS
getProcessID >>= return . show
#else
return "windows"
#endif
close sh = S.close (logsocket sh)