    {-# 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 = openlog_local "/var/run/syslog"
    #else
    openlog :: String -> [Option] -> Facility -> Priority -> IO SyslogHandler
    openlog = String
    -> String -> [Option] -> Facility -> Priority -> IO SyslogHandler
    openlog_local String
    "/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 (s, 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

                        s <- Family -> SocketType -> ProtocolNumber -> IO Socket
    S.socket Family
    S.AF_UNIX SocketType
    S.Stream ProtocolNumber
    0
                        tryStream s `E.catch` (onIOException (fallbackToDgram s))
           openlog_generic s (S.SockAddrUnix fifopath) t ident options' fac 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
                   d <- Family -> SocketType -> ProtocolNumber -> IO Socket
    S.socket Family
    S.AF_UNIX SocketType
    S.Datagram ProtocolNumber
    0
                   return (d, 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
        he <- String -> IO HostEntry
    S.getHostByName String
    hostname
        s <- S.socket fam S.Datagram 0
        let addr = PortNumber -> HostAddress -> SockAddr
    S.SockAddrInet PortNumber
    port ([HostAddress] -> HostAddress
    forall a. HasCallStack => [a] -> a
    head (HostEntry -> [HostAddress]
    S.hostAddresses HostEntry
    he))
        openlog_generic s addr S.Datagram ident options' fac 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)
          pidPart <- IO String
    getPidPart
          void $ sendstr (toSyslogFormat msg 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
              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
                        SocketType
    _ -> IO Int
    forall a. HasCallStack => a
    undefined
              sendstr (genericDrop sent 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)