diff --git a/System/Posix/Syslog.hsc b/System/Posix/Syslog.hsc --- a/System/Posix/Syslog.hsc +++ b/System/Posix/Syslog.hsc @@ -4,20 +4,18 @@ #endif {- | Module : System.Posix.Syslog - Copyright : (c) 2008 Peter Simons - License : BSD3 - Maintainer : simons@cryp.to Stability : provisional Portability : Posix - FFI bindings to Unix's @syslog(3)@. Process this file - with @hsc2hs@ to obtain a Haskell module. + 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 @@ -39,6 +37,12 @@ -- * 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 @@ -49,7 +53,7 @@ | Notice -- ^ normal but significant condition | Info -- ^ informational | Debug -- ^ debug-level messages - deriving ( Eq, Bounded, Show + deriving ( Eq, Bounded, Show, Read #if __GLASGOW_HASKELL__ >= 706 , Generic #endif @@ -99,7 +103,7 @@ | LOCAL5 -- ^ reserved for local use | LOCAL6 -- ^ reserved for local use | LOCAL7 -- ^ reserved for local use - deriving (Eq, Bounded, Show) + deriving (Eq, Bounded, Show, Read) instance Enum Facility where toEnum #{const LOG_KERN} = KERN @@ -174,41 +178,72 @@ -- * Haskell API to syslog --- |Bracket an 'IO' computation between calls to '_openlog' --- and '_closelog'. Since these settings are for the --- /process/, multiple calls to this function will, --- unfortunately, overwrite each other. --- --- Example: +-- |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 $ do +-- > 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 -> IO a -> IO a -withSyslog ident opts facil f = do - let opt = toEnum . sum . map fromEnum $ opts - let fac = toEnum . fromEnum $ facil - withCString ident $ \p -> - bracket_ (_openlog p opt fac) (_closelog) f +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) --- * Helpers +-- |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] --- | @useSyslog ident@ @=@ @withSyslog ident [PID, PERROR] USER@ +logUpTo :: Priority -> [Priority] +logUpTo p = [minBound .. p] -useSyslog :: String -> IO a -> IO a -useSyslog ident = withSyslog ident [PID, PERROR] USER +-- * Helpers --- |Escape any occurances of \'@%@\' in a string, so that it --- is safe to pass it to '_syslog'. The 'syslog' wrapper --- does this automatically. +-- |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 [] = [] @@ -217,14 +252,32 @@ -- * Low-level C functions -foreign import ccall unsafe "closelog" _closelog :: - IO () +-- |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 () +foreign import ccall unsafe "openlog" _openlog :: CString -> CInt -> CInt -> IO () -foreign import ccall unsafe "setlogmask" _setlogmask :: - CInt -> IO CInt +-- |Close the descriptor being used to write to the system logger. -foreign import ccall unsafe "syslog" _syslog :: - CInt -> CString -> IO () +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 new file mode 100644 --- /dev/null +++ b/doctest.hs @@ -0,0 +1,8 @@ +-- 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,5 +1,5 @@ Name: hsyslog -Version: 1.6 +Version: 2.0 Copyright: Peter Simons License: BSD3 License-File: LICENSE @@ -12,9 +12,9 @@ Description: This library provides FFI bindings to syslog(3) from POSIX.1-2001. See for further details. -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.8 Build-Type: Simple -Tested-With: GHC >= 6.10.4 && <= 7.6.3 +Tested-With: GHC >= 6.10.4 && <= 7.8.3 Source-Repository head Type: git @@ -24,4 +24,10 @@ Build-Depends: base >= 3 && < 5 Extensions: ForeignFunctionInterface 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