{-# LANGUAGE CPP #-}

{- |
   Module     : System.Log.Handler.Syslog
   Copyright  : Copyright (C) 2004-2011 John Goerzen
   License    : BSD3

   Portability: portable

Syslog handler for the Haskell Logging Framework

Written by John Goerzen, jgoerzen\@complete.org

This module implements an interface to the Syslog service commonly
found in Unix\/Linux systems.  This interface is primarily of interest to
developers of servers, as Syslog does not typically display messages in
an interactive fashion.

This module is written in pure Haskell and is capable of logging to a local
or remote machine using the Syslog protocol.

You can create a new Syslog 'LogHandler' by calling 'openlog'.

More information on the Haskell Logging Framework can be found at
"System.Log.Logger".  This module can also be used outside
of the rest of that framework for those interested in that.
-}

module System.Log.Handler.Syslog(
                                       SyslogHandler, -- No constructors.
                                       -- * Handler Initialization
                                       openlog,
                                       -- * Advanced handler initialization
#ifndef mingw32_HOST_OS
                                       openlog_local,
#endif
                                       openlog_remote,
                                       openlog_generic,
                                       -- * Data Types
                                       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 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 Socket
s 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 Priority
p = case Priority
p of
                       Priority
EMERGENCY -> Int
0
                       Priority
ALERT -> Int
1
                       Priority
CRITICAL -> Int
2
                       Priority
ERROR -> Int
3
                       Priority
WARNING -> Int
4
                       Priority
NOTICE -> Int
5
                       Priority
INFO -> Int
6
                       Priority
DEBUG -> Int
7

{- | Facilities are used by the system to determine where messages
are sent. -}

data Facility =
              KERN                      -- ^ Kernel messages; you should likely never use this in your programs
              | USER                    -- ^ General userland messages.  Use this if nothing else is appropriate
              | MAIL                    -- ^ E-Mail system
              | DAEMON                  -- ^ Daemon (server process) messages
              | AUTH                    -- ^ Authentication or security messages
              | SYSLOG                  -- ^ Internal syslog messages; you should likely never use this in your programs
              | LPR                     -- ^ Printer messages
              | NEWS                    -- ^ Usenet news
              | UUCP                    -- ^ UUCP messages
              | CRON                    -- ^ Cron messages
              | AUTHPRIV                -- ^ Private authentication messages
              | FTP                     -- ^ FTP messages
              | LOCAL0                  -- ^ LOCAL0 through LOCAL7 are reserved for you to customize as you wish
              | 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
$c== :: Facility -> Facility -> Bool
== :: Facility -> Facility -> Bool
$c/= :: Facility -> Facility -> Bool
/= :: 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
$cshowsPrec :: Int -> Facility -> ShowS
showsPrec :: Int -> Facility -> ShowS
$cshow :: Facility -> String
show :: Facility -> String
$cshowList :: [Facility] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS Facility
readsPrec :: Int -> ReadS Facility
$creadList :: ReadS [Facility]
readList :: ReadS [Facility]
$creadPrec :: ReadPrec Facility
readPrec :: ReadPrec Facility
$creadListPrec :: ReadPrec [Facility]
readListPrec :: ReadPrec [Facility]
Read)

code_of_fac :: Facility -> Int
code_of_fac :: Facility -> Int
code_of_fac Facility
f = case Facility
f of
                       Facility
KERN -> Int
0
                       Facility
USER -> Int
1
                       Facility
MAIL -> Int
2
                       Facility
DAEMON -> Int
3
                       Facility
AUTH -> Int
4
                       Facility
SYSLOG -> Int
5
                       Facility
LPR -> Int
6
                       Facility
NEWS -> Int
7
                       Facility
UUCP -> Int
8
                       Facility
CRON -> Int
9
                       Facility
AUTHPRIV -> Int
10
                       Facility
FTP -> Int
11
                       Facility
LOCAL0 -> Int
16
                       Facility
LOCAL1 -> Int
17
                       Facility
LOCAL2 -> Int
18
                       Facility
LOCAL3 -> Int
19
                       Facility
LOCAL4 -> Int
20
                       Facility
LOCAL5 -> Int
21
                       Facility
LOCAL6 -> Int
22
                       Facility
LOCAL7 -> Int
23

makeCode :: Facility -> Priority -> Int
makeCode :: Facility -> Priority -> Int
makeCode Facility
fac 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` Int
3) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
pricode

{- | Options for 'openlog'. -}

data Option = PID                       -- ^ Automatically log process ID (PID) with each message
            | PERROR                    -- ^ Send a copy of each message to stderr
            deriving (Option -> Option -> Bool
(Option -> Option -> Bool)
-> (Option -> Option -> Bool) -> Eq Option
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Option -> Option -> Bool
== :: Option -> Option -> Bool
$c/= :: Option -> Option -> Bool
/= :: 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
$cshowsPrec :: Int -> Option -> ShowS
showsPrec :: Int -> Option -> ShowS
$cshow :: Option -> String
show :: Option -> String
$cshowList :: [Option] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS Option
readsPrec :: Int -> ReadS Option
$creadList :: ReadS [Option]
readList :: ReadS [Option]
$creadPrec :: ReadPrec Option
readPrec :: ReadPrec Option
$creadListPrec :: ReadPrec [Option]
readListPrec :: ReadPrec [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
                                   }

{- | Initialize the Syslog system using the local system's default interface,
\/dev\/log.  Will return a new 'System.Log.Handler.LogHandler'.

On Windows, instead of using \/dev\/log, this will attempt to send
UDP messages to something listening on the syslog port (514) on localhost.

Use 'openlog_remote' if you need more control.
-}

openlog :: String                       -- ^ The name of this program -- will be prepended to every log message
        -> [Option]                     -- ^ A list of 'Option's.  The list [] is perfectly valid.  ['PID'] is probably most common here.
        -> Facility                     -- ^ The 'Facility' value to pass to the syslog system for every message logged
        -> Priority                     -- ^ Messages logged below this priority will be ignored.  To include every message, set this to 'DEBUG'.
        -> IO SyslogHandler             -- ^ Returns the new handler

#ifdef mingw32_HOST_OS
openlog = openlog_remote S.AF_INET "localhost" 514
#elif darwin_HOST_OS
openlog :: String -> [Option] -> Facility -> Priority -> IO SyslogHandler
openlog = String
-> String -> [Option] -> Facility -> Priority -> IO SyslogHandler
openlog_local String
"/var/run/syslog"
#else
openlog = openlog_local "/dev/log"
#endif

{- | Initialize the Syslog system using an arbitrary Unix socket (FIFO).

Not supported under Windows.
-}

#ifndef mingw32_HOST_OS
openlog_local :: String                 -- ^ Path to FIFO
              -> String                 -- ^ Program name
              -> [Option]               -- ^ 'Option's
              -> Facility               -- ^ Facility value
              -> Priority               -- ^ Priority limit
              -> IO SyslogHandler
openlog_local :: String
-> String -> [Option] -> Facility -> Priority -> IO SyslogHandler
openlog_local String
fifopath String
ident [Option]
options' Facility
fac Priority
pri =
    do (Socket
s, SocketType
t) <- do -- "/dev/log" is usually Datagram,
                    -- but most of syslog loggers allow it to be
                    -- of Stream type. glibc's" openlog()"
                    -- does roughly the similar thing:
                    --     http://www.gnu.org/software/libc/manual/html_node/openlog.html

                    Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
S.socket Family
S.AF_UNIX SocketType
S.Stream ProtocolNumber
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 :: forall a. IO a -> IOException -> IO a
onIOException IO a
a IOException
_ = IO a
a

        tryStream :: S.Socket -> IO (S.Socket, S.SocketType)
        tryStream :: Socket -> IO (Socket, SocketType)
tryStream Socket
s =
            do Socket -> SockAddr -> IO ()
S.connect Socket
s (String -> SockAddr
S.SockAddrUnix String
fifopath)
               (Socket, SocketType) -> IO (Socket, SocketType)
forall a. a -> IO a
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 Socket
s =
            do Socket -> IO ()
S.close Socket
s -- close Stream variant
               Socket
d <- Family -> SocketType -> ProtocolNumber -> IO Socket
S.socket Family
S.AF_UNIX SocketType
S.Datagram ProtocolNumber
0
               (Socket, SocketType) -> IO (Socket, SocketType)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
d, SocketType
S.Datagram)
#endif

{- | Log to a remote server via UDP. -}
openlog_remote :: S.Family              -- ^ Usually AF_INET or AF_INET6; see Network.Socket
               -> S.HostName            -- ^ Remote hostname.  Some use @localhost@
               -> S.PortNumber          -- ^ 514 is the default for syslog
               -> String                -- ^ Program name
               -> [Option]              -- ^ 'Option's
               -> Facility              -- ^ Facility value
               -> Priority              -- ^ Priority limit
               -> IO SyslogHandler
openlog_remote :: Family
-> String
-> PortNumber
-> String
-> [Option]
-> Facility
-> Priority
-> IO SyslogHandler
openlog_remote Family
fam String
hostname PortNumber
port String
ident [Option]
options' Facility
fac 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 ProtocolNumber
0
    let addr :: SockAddr
addr = PortNumber -> HostAddress -> SockAddr
S.SockAddrInet PortNumber
port ([HostAddress] -> HostAddress
forall a. HasCallStack => [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

{- | The most powerful initialization mechanism.  Takes an open datagram
socket. -}
openlog_generic :: S.Socket             -- ^ A datagram socket
                -> S.SockAddr           -- ^ Address for transmissions
                -> S.SocketType         -- ^ socket connection mode (stream / datagram)
                -> String               -- ^ Program name
                -> [Option]             -- ^ 'Option's
                -> Facility             -- ^ Facility value
                -> Priority             -- ^ Priority limit
                -> IO SyslogHandler
openlog_generic :: Socket
-> SockAddr
-> SocketType
-> String
-> [Option]
-> Facility
-> Priority
-> IO SyslogHandler
openlog_generic Socket
sock SockAddr
addr SocketType
sock_t String
ident [Option]
opt Facility
fac Priority
pri =
    SyslogHandler -> IO SyslogHandler
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (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 SyslogHandler
sh (Priority
p,String
msg) String
logname =
    let format :: String
format = String
"[$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 SyslogHandler
sh Priority
p = SyslogHandler
sh{priority = p}
    getLevel :: SyslogHandler -> Priority
getLevel SyslogHandler
sh = SyslogHandler -> Priority
priority SyslogHandler
sh
    setFormatter :: SyslogHandler -> LogFormatter SyslogHandler -> SyslogHandler
setFormatter SyslogHandler
sh LogFormatter SyslogHandler
f = SyslogHandler
sh{formatter = f}
    getFormatter :: SyslogHandler -> LogFormatter SyslogHandler
getFormatter SyslogHandler
sh = SyslogHandler -> LogFormatter SyslogHandler
formatter SyslogHandler
sh
    emit :: SyslogHandler -> (Priority, String) -> String -> IO ()
emit SyslogHandler
sh (Priority
prio, String
msg) String
_ = do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Option -> [Option] -> Bool
forall a. Eq a => a -> [a] -> 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        sendstr String
omsg = do
          Int
sent <- case SyslogHandler -> SocketType
sock_type SyslogHandler
sh of
                    SocketType
S.Datagram -> Socket -> String -> SockAddr -> IO Int
sendTo (SyslogHandler -> Socket
logsocket SyslogHandler
sh) String
omsg (SyslogHandler -> SockAddr
address SyslogHandler
sh)
                    SocketType
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 String
msg' String
pidPart =
            String
"<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
code String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">" 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
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\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 a. Eq a => a -> [a] -> 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
pid -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pid String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]")
                     else String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
        getPid :: IO String
        getPid :: IO String
getPid =
#ifndef mingw32_HOST_OS
          IO ProcessID
getProcessID IO ProcessID -> (ProcessID -> IO String) -> IO String
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO String
forall a. a -> IO a
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 SyslogHandler
sh = Socket -> IO ()
S.close (SyslogHandler -> Socket
logsocket SyslogHandler
sh)