diff --git a/System/Posix/Syslog.hsc b/System/Posix/Syslog.hsc deleted file mode 100644 --- a/System/Posix/Syslog.hsc +++ /dev/null @@ -1,283 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE DeriveGeneric #-} -#endif -{- | - Module : System.Posix.Syslog - Maintainer : simons@cryp.to - Stability : provisional - Portability : Posix - - FFI bindings to syslog(3) from - . --} - -module System.Posix.Syslog where - -import Control.Exception ( bracket_ ) -import Data.Bits -import Foreign.C -#if __GLASGOW_HASKELL__ >= 706 -import GHC.Generics -#endif - -#include -#ifndef LOG_AUTHPRIV -#define LOG_AUTHPRIV LOG_AUTH -#endif - -#ifndef LOG_FTP -#define LOG_FTP LOG_DAEMON -#endif - -#ifndef LOG_PERROR -#define LOG_PERROR 0 -#endif - --- * Marshaled Data Types - --- |Log messages are prioritized. --- --- Note that the 'Enum' instance for this class is incomplete. We abuse --- 'toEnum' and 'fromEnum' to map these constructors to their --- corresponding bit-mask value in C, but not all uses cases provided by --- of enumerating that class are fully supported --- (). - -data Priority - = Emergency -- ^ system is unusable - | Alert -- ^ action must be taken immediately - | Critical -- ^ critical conditions - | Error -- ^ error conditions - | Warning -- ^ warning conditions - | Notice -- ^ normal but significant condition - | Info -- ^ informational - | Debug -- ^ debug-level messages - deriving ( Eq, Bounded, Show, Read -#if __GLASGOW_HASKELL__ >= 706 - , Generic -#endif - ) - -instance Enum Priority where - toEnum #{const LOG_EMERG} = Emergency - toEnum #{const LOG_ALERT} = Alert - toEnum #{const LOG_CRIT} = Critical - toEnum #{const LOG_ERR} = Error - toEnum #{const LOG_WARNING} = Warning - toEnum #{const LOG_NOTICE} = Notice - toEnum #{const LOG_INFO} = Info - toEnum #{const LOG_DEBUG} = Debug - toEnum i = error (showString "Syslog.Priority cannot be mapped from value " (show i)) - - fromEnum Emergency = #{const LOG_EMERG} - fromEnum Alert = #{const LOG_ALERT} - fromEnum Critical = #{const LOG_CRIT} - fromEnum Error = #{const LOG_ERR} - fromEnum Warning = #{const LOG_WARNING} - fromEnum Notice = #{const LOG_NOTICE} - fromEnum Info = #{const LOG_INFO} - fromEnum Debug = #{const LOG_DEBUG} - --- |Syslog distinguishes various system facilities. Most --- applications should log in 'USER'. - -data Facility - = KERN -- ^ kernel messages - | USER -- ^ user-level messages (default unless set otherwise) - | MAIL -- ^ mail system - | DAEMON -- ^ system daemons - | AUTH -- ^ security\/authorization messages - | SYSLOG -- ^ messages generated internally by syslogd - | LPR -- ^ line printer subsystem - | NEWS -- ^ network news subsystem - | UUCP -- ^ UUCP subsystem - | CRON -- ^ clock daemon - | AUTHPRIV -- ^ security\/authorization messages (effectively equals 'AUTH' on some systems) - | FTP -- ^ ftp daemon (effectively equals 'DAEMON' on some systems) - | LOCAL0 -- ^ reserved for local use - | LOCAL1 -- ^ reserved for local use - | LOCAL2 -- ^ reserved for local use - | LOCAL3 -- ^ reserved for local use - | LOCAL4 -- ^ reserved for local use - | LOCAL5 -- ^ reserved for local use - | LOCAL6 -- ^ reserved for local use - | LOCAL7 -- ^ reserved for local use - deriving (Eq, Bounded, Show, Read) - -instance Enum Facility where - toEnum #{const LOG_KERN} = KERN - toEnum #{const LOG_USER} = USER - toEnum #{const LOG_MAIL} = MAIL - toEnum #{const LOG_DAEMON} = DAEMON - toEnum #{const LOG_AUTH} = AUTH - toEnum #{const LOG_SYSLOG} = SYSLOG - toEnum #{const LOG_LPR} = LPR - toEnum #{const LOG_NEWS} = NEWS - toEnum #{const LOG_UUCP} = UUCP - toEnum #{const LOG_CRON} = CRON - toEnum #{const LOG_AUTHPRIV} = AUTHPRIV - toEnum #{const LOG_FTP} = FTP - toEnum #{const LOG_LOCAL0} = LOCAL0 - toEnum #{const LOG_LOCAL1} = LOCAL1 - toEnum #{const LOG_LOCAL2} = LOCAL2 - toEnum #{const LOG_LOCAL3} = LOCAL3 - toEnum #{const LOG_LOCAL4} = LOCAL4 - toEnum #{const LOG_LOCAL5} = LOCAL5 - toEnum #{const LOG_LOCAL6} = LOCAL6 - toEnum #{const LOG_LOCAL7} = LOCAL7 - toEnum i = error ("Syslog.Facility cannot be mapped to value " ++ show i) - - fromEnum KERN = #{const LOG_KERN} - fromEnum USER = #{const LOG_USER} - fromEnum MAIL = #{const LOG_MAIL} - fromEnum DAEMON = #{const LOG_DAEMON} - fromEnum AUTH = #{const LOG_AUTH} - fromEnum SYSLOG = #{const LOG_SYSLOG} - fromEnum LPR = #{const LOG_LPR} - fromEnum NEWS = #{const LOG_NEWS} - fromEnum UUCP = #{const LOG_UUCP} - fromEnum CRON = #{const LOG_CRON} - fromEnum AUTHPRIV = #{const LOG_AUTHPRIV} - fromEnum FTP = #{const LOG_FTP} - fromEnum LOCAL0 = #{const LOG_LOCAL0} - fromEnum LOCAL1 = #{const LOG_LOCAL1} - fromEnum LOCAL2 = #{const LOG_LOCAL2} - fromEnum LOCAL3 = #{const LOG_LOCAL3} - fromEnum LOCAL4 = #{const LOG_LOCAL4} - fromEnum LOCAL5 = #{const LOG_LOCAL5} - fromEnum LOCAL6 = #{const LOG_LOCAL6} - fromEnum LOCAL7 = #{const LOG_LOCAL7} - --- |Options for the syslog service. Set with 'withSyslog'. - -data Option - = PID -- ^ log the pid with each message - | CONS -- ^ log on the console if errors in sending - | ODELAY -- ^ delay open until first @syslog()@ (default) - | NDELAY -- ^ don't delay open - | NOWAIT -- ^ don't wait for console forks: DEPRECATED - | PERROR -- ^ log to 'stderr' as well (might be a no-op on some systems) - deriving (Eq, Bounded, Show) - -instance Enum Option where - toEnum #{const LOG_PID} = PID - toEnum #{const LOG_CONS} = CONS - toEnum #{const LOG_ODELAY} = ODELAY - toEnum #{const LOG_NDELAY} = NDELAY - toEnum #{const LOG_NOWAIT} = NOWAIT - toEnum #{const LOG_PERROR} = PERROR - toEnum i = error ("Syslog.Option cannot be mapped to value " ++ show i) - - fromEnum PID = #{const LOG_PID} - fromEnum CONS = #{const LOG_CONS} - fromEnum ODELAY = #{const LOG_ODELAY} - fromEnum NDELAY = #{const LOG_NDELAY} - fromEnum NOWAIT = #{const LOG_NOWAIT} - fromEnum PERROR = #{const LOG_PERROR} - --- * Haskell API to syslog - --- |Bracket an 'IO' computation between calls to '_openlog', --- '_setlogmask', and '_closelog'. The function can be used as follows: --- --- > main = withSyslog "my-ident" [PID, PERROR] USER (logUpTo Debug) $ do --- > putStrLn "huhu" --- > syslog Debug "huhu" --- --- Note that these are /process-wide/ settings, so multiple calls to --- this function will interfere with each other in unpredictable ways. - -withSyslog :: String -> [Option] -> Facility -> [Priority] -> IO a -> IO a -withSyslog ident opts facil prio f = withCString ident $ \p -> - bracket_ (_openlog p opt fac >> _setlogmask pri) (_closelog) f - where - fac = toEnum . fromEnum $ facil - pri = toEnum . foldl1 (.|.) . map (shift 1 . fromEnum) $ if null prio - then [minBound .. maxBound] - else prio - opt = toEnum . sum . map fromEnum $ opts - --- |Log a message with the given priority. --- --- Note that the API of this function is somewhat unsatisfactory and is --- likely to change in the future: --- --- 1. The function should accept a @['Facility']@ argument so that --- messages can be logged to certain facilities without depending on --- the process-wide global default value set by 'openlog' --- (). --- --- 2. The 'Priority' argument should be @['Priority']@. --- --- 3. Accepting a 'ByteString' instead of 'String' would be preferrable --- because we can log those more efficiently, i.e. without --- marshaling. On top of that, we can provide a wrapper for this --- function that accepts anything that can be marshaled into a --- 'ByteString' (). - -syslog :: Priority -> String -> IO () -syslog l msg = - withCString (safeMsg msg) - (\p -> _syslog (toEnum (fromEnum l)) p) - --- |Returns the list of priorities up to and including the argument. --- Note that the syslog priority 'Debug' is considered the highest one --- in this context, which may counter-intuitive for some. --- --- >>> logUpTo(Debug) --- [Emergency,Alert,Critical,Error,Warning,Notice,Info,Debug] --- --- >>> logUpTo(Emergency) --- [Emergency] - -logUpTo :: Priority -> [Priority] -logUpTo p = [minBound .. p] - --- * Helpers - --- |Escape any occurances of \'@%@\' in a string, so that it is safe to --- pass it to '_syslog'. The 'syslog' wrapper does this automatically. --- --- Unfortunately, the application of this function to every single --- syslog message is a performence nightmare. Instead, we should call --- syslog the existence of this function is a kludge, in a way that --- doesn't require any escaping --- (). - -safeMsg :: String -> String -safeMsg [] = [] -safeMsg ('%':xs) = '%' : '%' : safeMsg xs -safeMsg ( x :xs) = x : safeMsg xs - --- * Low-level C functions - --- |Open a connection to the system logger for a program. The string --- identifier passed as the first argument is prepended to every --- message, and is typically set to the program name. The behavior is --- unspecified by POSIX.1-2008 if that identifier is 'nullPtr'. - -foreign import ccall unsafe "openlog" _openlog :: CString -> CInt -> CInt -> IO () - --- |Close the descriptor being used to write to the system logger. - -foreign import ccall unsafe "closelog" _closelog :: IO () - --- |A process has a log priority mask that determines which calls to --- 'syslog' may be logged. All other calls will be ignored. Logging is --- enabled for the priorities that have the corresponding bit set in --- mask. The initial mask is such that logging is enabled for all --- priorities. This function sets this logmask for the calling process, --- and returns the previous mask. If the mask argument is 0, the current --- logmask is not modified. - -foreign import ccall unsafe "setlogmask" _setlogmask :: CInt -> IO CInt - --- |Generate a log message, which will be distributed by @syslogd(8)@. --- The priority argument is formed by ORing the facility and the level --- values (explained below). The remaining arguments are a format, as in --- printf(3) and any arguments required by the format, except that the --- two character sequence %m will be replaced by the error message --- string strerror(errno). A trailing newline may be added if needed. - -foreign import ccall unsafe "syslog" _syslog :: CInt -> CString -> IO () diff --git a/doctest.hs b/doctest.hs deleted file mode 100644 --- a/doctest.hs +++ /dev/null @@ -1,8 +0,0 @@ --- doctest.hs - -module Main ( main ) where - -import Test.DocTest - -main :: IO () -main = doctest [ "dist/build/System/Posix/Syslog.hs" ] diff --git a/hsyslog.cabal b/hsyslog.cabal --- a/hsyslog.cabal +++ b/hsyslog.cabal @@ -1,9 +1,9 @@ Name: hsyslog -Version: 2.0 -Copyright: Peter Simons +Version: 3 +Copyright: Copyright (c) 2004-2016 by Peter Simons License: BSD3 License-File: LICENSE -Author: Peter Simons +Author: Peter Simons, John Lato, Jonathan Childress Maintainer: Peter Simons Homepage: http://github.com/peti/hsyslog Bug-Reports: http://github.com/peti/hsyslog/issues @@ -14,20 +14,26 @@ further details. Cabal-Version: >= 1.8 Build-Type: Simple -Tested-With: GHC >= 6.10.4 && <= 7.8.3 +Tested-With: GHC > 7.6 && < 8.1 Source-Repository head Type: git Location: git://github.com/peti/hsyslog.git Library + Hs-Source-Dirs: src Build-Depends: base >= 3 && < 5 - Extensions: ForeignFunctionInterface + , bytestring == 0.10.* + Extensions: CApiFFI + , ForeignFunctionInterface + , OverloadedStrings Exposed-Modules: System.Posix.Syslog - Ghc-Options: -Wall -Test-Suite self-test - type: exitcode-stdio-1.0 - main-is: doctest.hs - Build-Depends: base, doctest - Ghc-Options: -Wall +Test-Suite tests + Hs-Source-Dirs: test + Main-Is: Main.hs + Type: exitcode-stdio-1.0 + Build-Depends: base + , bytestring + , hsyslog + , QuickCheck diff --git a/src/System/Posix/Syslog.hsc b/src/System/Posix/Syslog.hsc new file mode 100644 --- /dev/null +++ b/src/System/Posix/Syslog.hsc @@ -0,0 +1,369 @@ +{-# LANGUAGE + CApiFFI + , ForeignFunctionInterface + , OverloadedStrings + #-} + +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DeriveGeneric #-} +#endif + +{- | + Module : System.Posix.Syslog + Maintainer : simons@cryp.to + Stability : provisional + Portability : Posix + + FFI bindings to syslog(3) from + . +-} + +module System.Posix.Syslog + ( -- * Marshaled Data Types + Priority (..) + , toPriority + , fromPriority + , Facility (..) + , toFacility + , fromFacility + , Option (..) + , toOption + , fromOption + , PriorityMask (..) + , fromPriorityMask + -- * Configuring syslog + , SyslogConfig (..) + , defaultConfig + -- * The preferred Haskell API to syslog + -- | These are also the most performant calls to syslog, with the minimum + -- amount of 'CString' copying necessary. + , withSyslog + , SyslogFn + , withSyslogTo + , SyslogToFn + -- * The unsafe Haskell API to syslog + -- | Using these functions provides no guarantee that a call to '_openlog' + -- has been made. + , syslogUnsafe + , syslogToUnsafe + -- * Low-level C functions + , _openlog + , _closelog + , _setlogmask + , _syslog + -- ** Low-level C macros + -- | See the + -- + -- for their intended usage. + , _LOG_MASK + , _LOG_UPTO + , _LOG_MAKEPRI + ) where + +import Control.Exception (bracket_) +import Data.Bits (Bits, (.|.)) +import Data.ByteString (ByteString, useAsCString) +import Data.List (foldl') +import Foreign.C (CInt (..), CString (..)) + +#if __GLASGOW_HASKELL__ >= 706 +import GHC.Generics (Generic) +#endif + +#include +#ifndef LOG_AUTHPRIV +#define LOG_AUTHPRIV LOG_AUTH +#endif + +#ifndef LOG_FTP +#define LOG_FTP LOG_DAEMON +#endif + +#ifndef LOG_PERROR +#define LOG_PERROR 0 +#endif + +-- |Log messages have a priority attached. + +data Priority + = Emergency -- ^ system is unusable + | Alert -- ^ action must be taken immediately + | Critical -- ^ critical conditions + | Error -- ^ error conditions + | Warning -- ^ warning conditions + | Notice -- ^ normal but significant condition + | Info -- ^ informational + | Debug -- ^ debug-level messages + deriving ( Bounded, Enum, Eq, Show, Read +#if __GLASGOW_HASKELL__ >= 706 + , Generic +#endif + ) + +toPriority :: CInt -> Priority +toPriority #{const LOG_EMERG} = Emergency +toPriority #{const LOG_ALERT} = Alert +toPriority #{const LOG_CRIT} = Critical +toPriority #{const LOG_ERR} = Error +toPriority #{const LOG_WARNING} = Warning +toPriority #{const LOG_NOTICE} = Notice +toPriority #{const LOG_INFO} = Info +toPriority #{const LOG_DEBUG} = Debug +toPriority i = error (shows i " is not a valid syslog priority value") + +fromPriority :: Priority -> CInt +fromPriority Emergency = #{const LOG_EMERG} +fromPriority Alert = #{const LOG_ALERT} +fromPriority Critical = #{const LOG_CRIT} +fromPriority Error = #{const LOG_ERR} +fromPriority Warning = #{const LOG_WARNING} +fromPriority Notice = #{const LOG_NOTICE} +fromPriority Info = #{const LOG_INFO} +fromPriority Debug = #{const LOG_DEBUG} + +-- |Syslog distinguishes various system facilities. Most +-- applications should log in 'USER'. + +data Facility + = KERN -- ^ kernel messages + | USER -- ^ user-level messages (default unless set otherwise) + | MAIL -- ^ mail system + | DAEMON -- ^ system daemons + | AUTH -- ^ security\/authorization messages + | SYSLOG -- ^ messages generated internally by syslogd + | LPR -- ^ line printer subsystem + | NEWS -- ^ network news subsystem + | UUCP -- ^ UUCP subsystem + | CRON -- ^ clock daemon + | AUTHPRIV -- ^ security\/authorization messages (effectively equals 'AUTH' on some systems) + | FTP -- ^ ftp daemon (effectively equals 'DAEMON' on some systems) + | LOCAL0 -- ^ reserved for local use + | LOCAL1 -- ^ reserved for local use + | LOCAL2 -- ^ reserved for local use + | LOCAL3 -- ^ reserved for local use + | LOCAL4 -- ^ reserved for local use + | LOCAL5 -- ^ reserved for local use + | LOCAL6 -- ^ reserved for local use + | LOCAL7 -- ^ reserved for local use + deriving (Bounded, Enum, Eq, Show, Read) + +toFacility :: CInt -> Facility +toFacility #{const LOG_KERN} = KERN +toFacility #{const LOG_USER} = USER +toFacility #{const LOG_MAIL} = MAIL +toFacility #{const LOG_DAEMON} = DAEMON +toFacility #{const LOG_AUTH} = AUTH +toFacility #{const LOG_SYSLOG} = SYSLOG +toFacility #{const LOG_LPR} = LPR +toFacility #{const LOG_NEWS} = NEWS +toFacility #{const LOG_UUCP} = UUCP +toFacility #{const LOG_CRON} = CRON +toFacility #{const LOG_AUTHPRIV} = AUTHPRIV +toFacility #{const LOG_FTP} = FTP +toFacility #{const LOG_LOCAL0} = LOCAL0 +toFacility #{const LOG_LOCAL1} = LOCAL1 +toFacility #{const LOG_LOCAL2} = LOCAL2 +toFacility #{const LOG_LOCAL3} = LOCAL3 +toFacility #{const LOG_LOCAL4} = LOCAL4 +toFacility #{const LOG_LOCAL5} = LOCAL5 +toFacility #{const LOG_LOCAL6} = LOCAL6 +toFacility #{const LOG_LOCAL7} = LOCAL7 +toFacility i = error (shows i " is not a valid syslog facility value") + +fromFacility :: Facility -> CInt +fromFacility KERN = #{const LOG_KERN} +fromFacility USER = #{const LOG_USER} +fromFacility MAIL = #{const LOG_MAIL} +fromFacility DAEMON = #{const LOG_DAEMON} +fromFacility AUTH = #{const LOG_AUTH} +fromFacility SYSLOG = #{const LOG_SYSLOG} +fromFacility LPR = #{const LOG_LPR} +fromFacility NEWS = #{const LOG_NEWS} +fromFacility UUCP = #{const LOG_UUCP} +fromFacility CRON = #{const LOG_CRON} +fromFacility AUTHPRIV = #{const LOG_AUTHPRIV} +fromFacility FTP = #{const LOG_FTP} +fromFacility LOCAL0 = #{const LOG_LOCAL0} +fromFacility LOCAL1 = #{const LOG_LOCAL1} +fromFacility LOCAL2 = #{const LOG_LOCAL2} +fromFacility LOCAL3 = #{const LOG_LOCAL3} +fromFacility LOCAL4 = #{const LOG_LOCAL4} +fromFacility LOCAL5 = #{const LOG_LOCAL5} +fromFacility LOCAL6 = #{const LOG_LOCAL6} +fromFacility LOCAL7 = #{const LOG_LOCAL7} + +-- |'withSyslog' options for the syslog service. + +data Option + = PID -- ^ log the pid with each message + | CONS -- ^ log on the console if errors in sending + | ODELAY -- ^ delay open until first @syslog()@ (default) + | NDELAY -- ^ don't delay open + | NOWAIT -- ^ don't wait for console forks: DEPRECATED + | PERROR -- ^ log to 'stderr' as well (might be a no-op on some systems) + deriving (Bounded, Enum, Eq, Show) + +toOption :: CInt -> Option +toOption #{const LOG_PID} = PID +toOption #{const LOG_CONS} = CONS +toOption #{const LOG_ODELAY} = ODELAY +toOption #{const LOG_NDELAY} = NDELAY +toOption #{const LOG_NOWAIT} = NOWAIT +toOption #{const LOG_PERROR} = PERROR +toOption i = error (shows i " is not a valid syslog option value") + +fromOption :: Option -> CInt +fromOption PID = #{const LOG_PID} +fromOption CONS = #{const LOG_CONS} +fromOption ODELAY = #{const LOG_ODELAY} +fromOption NDELAY = #{const LOG_NDELAY} +fromOption NOWAIT = #{const LOG_NOWAIT} +fromOption PERROR = #{const LOG_PERROR} + +-- |`withSyslog` options for the priority mask + +data PriorityMask + = NoMask -- ^ allow all messages thru + | Mask [Priority] -- ^ allow only messages with the priorities listed + | UpTo Priority -- ^ allow only messages down to and including the specified priority + deriving (Eq, Show) + +fromPriorityMask :: PriorityMask -> CInt +fromPriorityMask (Mask pris) = bitsOrWith (_LOG_MASK . fromPriority) pris +fromPriorityMask (UpTo pri) = _LOG_UPTO $ fromPriority pri +fromPriorityMask NoMask = 0 + +data SyslogConfig = SyslogConfig + { identifier :: ByteString -- ^ string appended to each log message + , options :: [Option] -- ^ options for syslog behavior + , defaultFacilities :: [Facility] -- ^ facilities logged to when none are provided + , priorityMask :: PriorityMask -- ^ filter by priority which messages are logged + } + deriving (Eq, Show) + +-- |A practical default syslog config. You'll at least want to change the +-- identifier. + +defaultConfig :: SyslogConfig +defaultConfig = SyslogConfig "hsyslog" [ODELAY] [USER] NoMask + +-- |Bracket an 'IO' computation between calls to '_openlog', '_setlogmask', and +-- '_closelog', and provide a logging function which can be used as follows: +-- +-- > main = withSyslog defaultConfig $ \syslog -> do +-- > putStrLn "huhu" +-- > syslog [Debug] "huhu" +-- +-- Note that these are /process-wide/ settings, so multiple calls to +-- this function will interfere with each other in unpredictable ways. + +withSyslog :: SyslogConfig -> (SyslogFn -> IO ()) -> IO () +withSyslog config f = + withinOpenCloseSyslog config $ do + useAsCString escape (f . flip syslogEscaped []) + return () + +-- |The type of logging function provided by 'withSyslog'. + +type SyslogFn + = [Priority] -- ^ the priorities under which to log + -> ByteString -- ^ the message to log + -> IO () + +-- |Like 'withSyslog' but provides a function for logging to specific +-- facilities per message rather than the default facilities in your +-- 'SyslogConfig'. + +withSyslogTo :: SyslogConfig -> (SyslogToFn -> IO ()) -> IO () +withSyslogTo config f = + withinOpenCloseSyslog config $ do + useAsCString escape (f . syslogEscaped) + return () + +-- |The type of function provided by 'withSyslogTo'. + +type SyslogToFn + = [Facility] -- ^ the facilities to log to + -> [Priority] -- ^ the priorities under which to log + -> ByteString -- ^ the message to log + -> IO () + +syslogUnsafe :: SyslogFn +syslogUnsafe = syslogToUnsafe [] + +syslogToUnsafe :: SyslogToFn +syslogToUnsafe facs pris msg = useAsCString msg (_syslog (makePri facs pris)) + +-- |Open a connection to the system logger for a program. The string +-- identifier passed as the first argument is prepended to every +-- message, and is typically set to the program name. The behavior is +-- unspecified by POSIX.1-2008 if that identifier is 'nullPtr'. + +foreign import ccall unsafe "openlog" _openlog :: CString -> CInt -> CInt -> IO () + +-- |Close the descriptor being used to write to the system logger. + +foreign import ccall unsafe "closelog" _closelog :: IO () + +-- |A process has a log priority mask that determines which calls to +-- syslog may be logged. All other calls will be ignored. Logging is +-- enabled for the priorities that have the corresponding bit set in +-- mask. The initial mask is such that logging is enabled for all +-- priorities. This function sets this logmask for the calling process, +-- and returns the previous mask. If the mask argument is 0, the current +-- logmask is not modified. + +foreign import ccall unsafe "setlogmask" _setlogmask :: CInt -> IO CInt + +-- |Generate a log message, which will be distributed by @syslogd(8)@. +-- The priority argument is formed by ORing the facility and the level +-- values (explained below). The remaining arguments are a format, as in +-- printf(3) and any arguments required by the format, except that the +-- two character sequence %m will be replaced by the error message +-- string strerror(errno). A trailing newline may be added if needed. + +_syslog :: CInt -> CString -> IO () +_syslog int msg = useAsCString escape $ \e -> _syslogEscaped int e msg + +foreign import capi "syslog.h LOG_MASK" _LOG_MASK :: CInt -> CInt +foreign import capi "syslog.h LOG_UPTO" _LOG_UPTO :: CInt -> CInt +foreign import capi "syslog.h LOG_MAKEPRI" _LOG_MAKEPRI :: CInt -> CInt -> CInt + +-- internal functions + +bitsOrWith :: (Bits b, Num b) => (a -> b) -> [a] -> b +bitsOrWith f = foldl' (\bits x -> f x .|. bits) 0 + +makePri :: [Facility] -> [Priority] -> CInt +makePri facs pris = + _LOG_MAKEPRI (bitsOrWith fromFacility facs) (bitsOrWith fromPriority pris) + +foreign import ccall unsafe "syslog" _syslogEscaped + :: CInt -> CString -> CString -> IO () + +syslogEscaped :: CString -> [Facility] -> [Priority] -> ByteString -> IO () +syslogEscaped esc facs pris msg = + useAsCString msg (_syslogEscaped (makePri facs pris) esc) + +escape :: ByteString +escape = "%s" + +withinOpenCloseSyslog :: SyslogConfig -> IO () -> IO () +withinOpenCloseSyslog config run = + useAsCString (identifier config) $ \cIdent -> + let + + open :: IO () + open = do + _openlog cIdent cOpts cFacs + _setlogmask cMask + return () + where + cFacs = bitsOrWith fromFacility $ defaultFacilities config + cMask = fromPriorityMask $ priorityMask config + cOpts = bitsOrWith fromOption $ options config + + close :: IO () + close = _closelog + + in bracket_ open close run diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Data.ByteString.Char8 +import System.Posix.Syslog +import Test.QuickCheck +import Test.QuickCheck.Property + +instance Arbitrary Priority where + arbitrary = arbitraryBoundedEnum + +instance Arbitrary Facility where + arbitrary = arbitraryBoundedEnum + +instance Arbitrary ByteString where + arbitrary = fmap pack arbitrary + +main :: IO () +main = do + dontExplodeTest + outputTest + +{-- + This isn't a true test. Instead, we're passing the PERROR option (meaning + syslog will also send messages to STDERR), sending a message that should be + whitelisted by the priority mask, and sending a message that should be + blacklisted by the priority mask. If hsyslog is working correctly, then only + "hsyslog is working" should appear in your test log output. +--} +outputTest :: IO () +outputTest = withSyslog config $ \syslog -> do + syslog [Debug, Error] "%s%d hsyslog is working :)" + syslog [Error] "hsyslog is not working :(" + where + config = defaultConfig + { options = [PERROR, NDELAY] + , priorityMask = Mask [Debug, Alert] + } + +dontExplodeTest :: IO () +dontExplodeTest = withSyslogTo defaultConfig $ \syslogTo -> do + let + prop_dontExplode :: [Facility] -> [Priority] -> ByteString -> Property + prop_dontExplode facs pris msg = ioProperty $ do + syslogTo facs pris msg + return succeeded + quickCheck prop_dontExplode