gale client

root / ErrorLog.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
{-# LANGUAGE ScopedTypeVariables #-}
-- Copyright (c) 2002 John Meacham (john@foo.net)
--
-- Permission is hereby granted, free of charge, to any person obtaining a
-- copy of this software and associated documentation files (the
-- "Software"), to deal in the Software without restriction, including
-- without limitation the rights to use, copy, modify, merge, publish,
-- distribute, sublicense, and/or sell copies of the Software, and to
-- permit persons to whom the Software is furnished to do so, subject to
-- the following conditions:
--
-- The above copyright notice and this permission notice shall be included
-- in all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
-- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
-- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
-- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
-- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.


-- | Manages an error log with proper locking. has a number of useful routines for detecting
-- and reporting erronious conditions.

module ErrorLog(
    -- * Log handling
    LogLevel(..),
    withErrorLog,
    withStartEndEntrys,
    withErrorMessage,
    setLogLevel,
    setErrorLogPutStr,
    -- ** adding log entries
    putLogLn,putLog,
    putLogException,
    -- ** annotating exceptions
    -- emapM, eannM,
    -- ** exception-aware composition
    retryIO,
    firstIO,
    tryMapM,
    trySeveral,
    -- ** random functions
    attemptIO, tryIO,
    indent
    ) where

import Control.Exception as E
import Data.Either
import System.IO
import System.IO.Unsafe
import Control.Monad
import Control.Concurrent
import System.Time(getClockTime)
import Data.List(delete)

------------
-- Error log
------------

data LogLevel = LogEmergency | LogAlert | LogCritical | LogError | LogWarning | LogNotice | LogInfo | LogDebug
    deriving (Eq, Enum, Ord)

{-# NOINLINE ior #-}
ior :: MVar Handle
ior = unsafePerformIO $ newMVar stderr

{-# NOINLINE log_level #-}
log_level :: MVar LogLevel
log_level = unsafePerformIO $ newMVar LogNotice

{-# NOINLINE hPutStr_v #-}
hPutStr_v :: MVar (Handle -> String -> IO ())
hPutStr_v = unsafePerformIO $ newMVar hPutStr

-- | open file for logging and run action, with errors being logged to the file.
-- This will reinstall the old errorlog handle when it finishes, by default stderr
-- is used and this routine need not be called unless you wish to log somewhere else.
-- the filename consisting of a single dash is treated specially and sets the errorlog
-- to stderr. note, that while the errorlog will function properly with concurrent
-- applications, a single errorlog is shared by all threads.
withErrorLog :: String    -- ^ filename of log
                -> IO a      -- ^ action to execute with logging to file
                -> IO a
withErrorLog "-" action = bracket (swapMVar ior stderr) (swapMVar ior) (\_ -> action)
withErrorLog fn action = E.bracket (openFile fn WriteMode) hClose $ \h -> do
        hSetBuffering h LineBuffering
        bracket (swapMVar ior h) (swapMVar ior) (\_ -> action)

-- | sets log level to new value, returns old log level.
setLogLevel :: LogLevel -> IO LogLevel
setLogLevel ll = swapMVar log_level ll

-- | add entries to log at the start and end of action with timestamp.
-- If the action throws an exception, it will be logged along with the
-- exit entry.
withStartEndEntrys :: String  -- ^ title to use in log entries
                      -> IO a    -- ^ action to execute
                      -> IO a
withStartEndEntrys n action = do
    gct >>= \ct -> putLogLn (ct ++ " " ++ n ++ " Starting")
    handle
        (\(e :: SomeException) -> gct >>= \ct -> putLogException (ct ++ " " ++ n ++ " Ending due to Exception:" ) e >> throw e)
        (action >>= \r -> gct >>= \ct -> putLogLn (ct ++ " " ++ n ++ " Ending") >> return r) where
            gct = getClockTime >>= \ct -> return $ "[" ++ show ct ++ "]"


-- | run an action, printing an error message to the log if it ends with an exception.
-- this is similar to 'withStartEndEntrys' but only adds an entry on error.
withErrorMessage :: String -> IO a -> IO a
withErrorMessage n action = do
    handle
        (\(e :: SomeException) -> gct >>= \ct -> putLogLn (normalize n ++ ct ++ " Ending due to Exception:\n" ++ indent 4 (show e) ) >> throw e )
        action  where
            gct = getClockTime >>= \ct -> return $ "[" ++ show ct ++ "]"


-- | set routine with same signature as 'hPutStr' to use for writing to log.
-- useful for charset conversions which might be necisarry. By default the
-- haskell 98 'IO.hPutStr' is used.
setErrorLogPutStr :: (Handle -> String -> IO ()) -> IO ()
setErrorLogPutStr hp = swapMVar hPutStr_v hp >> return ()



normalize :: String -> String
normalize = unlines . lines

-- | place log entry, normalize string to always have a single \'\n\' at the end
-- of the string. A single log entry is created for each 'putLogLn', do not
-- split entrys among calls to this function.
putLogLn :: String -> IO ()
putLogLn s = do
    hp <- readMVar hPutStr_v
    withMVar ior (\h -> hp h (normalize s))
    withMVar ior (\h -> hFlush h)

{-
-- | log entry, depreciated. will be used for more general logging interface at some point.
putLog :: String -> IO ()
putLog s = do
    hp <- readMVar hPutStr_v
    withMVar ior (\h -> hp h s)

-}

-- | create log entry with given loglevel. entry is normalized as in 'putLogLn'.
putLog :: LogLevel -> String -> IO ()
putLog ll s = do
    cll <- readMVar log_level
    when (ll <= cll) $ putLogLn s

{-
-- | transform an exception with a function.
emapM :: (Exception -> Exception) -> IO a -> IO a
emapM f action = do
    handle (\e -> throw (f e)) action


-- | annotates an exception using emapM, the original
-- type of the error cannot be recovered so this should only be used
-- if the exception is not meant to be caught later.
eannM :: String -> IO a -> IO a
eannM s action = emapM f action where
    f (ErrorCall es) = ErrorCall $ normalize s ++ normalize es
    f e = ErrorCall $ normalize s ++ normalize (show e)
-}

-- | attempt an action, add a log entry with the exception if it
-- fails
attemptIO :: IO a -> IO ()
attemptIO action = E.catch (action >> return ())
  (\(e :: IOException) -> putLogException "attempt ExceptionCaught" e)

tryMapM :: (a -> IO b) -> [a] -> IO [b]
tryMapM f xs = do
    ys <- mapM (tryIO . f) xs
    return $ rights ys

tryIO :: IO a -> IO (Either IOException a)
tryIO = E.try

-- | return the first non-excepting action. if all actions throw exceptions,
-- the last actions exception is rethrown.
firstIO :: [IO a] -> IO a
firstIO [] = fail "empty argument to first"
firstIO [x] = x
firstIO (x:xs) = E.try x >>= either (\(_ :: IOException) -> firstIO xs) return

indent :: Int -> String -> String
indent n s = unlines $ map (replicate n ' ' ++)$ lines s

-- | Retry an action until it succeeds.
retryIO :: Float      -- ^ number of seconds to pause between trys
         -> String  -- ^ string to annotate log entries with when retrying
         -> IO a    -- ^ action to retry
         -> IO a
retryIO delay n action = do
    handle (\(e :: IOException) -> putLogException (n ++ " (retrying in " ++ show delay ++ "s):") e >> threadDelay (floor $ 1000000 * delay) >> retryIO delay n action) action


putLogException :: Exception e => String -> e -> IO ()
putLogException n e =  putLog LogError (n ++ "\n" ++ indent 4 (show e))


-- | concurrently try several IO actions, returning the result of the first to finish.
-- if all actions throw exceptions, one is passed on non-deterministically
trySeveral :: [IO a] -> IO a
trySeveral [] = error "trySeveral has nothing to try!"
trySeveral arms = do
    v <- newEmptyMVar
    ts <- mapM (forkIO . f v) arms
    g v ts where
        f v arm = do
            t <- myThreadId
            r <- tryIO arm
            putMVar v (t,r)
        g v ts = do
            (t,r) <- takeMVar v
            let ts' = delete t ts
            case r of
                Left e -> if null ts' then throw e else g v ts'
                Right x -> do
                    mapM_ killThread ts'
                    return x