Commit fdf92554349bc64a0f19c4ad7207608cc5482386
-
- Peter Simons (Committer)
-
- Peter Simons <simons @cr…p.tyo> (Author)
- Diff rendering mode:
- inline
- side by side
Postmaster/IO.hs
(5 / 22)
| 13 | 13 | ||
| 14 | 14 | import Data.List | |
| 15 | 15 | import Data.Maybe | |
| 16 | import Data.Dynamic ( Typeable, fromDynamic ) | ||
| 17 | import Data.Unique ( Unique, newUnique ) | ||
| 18 | import Control.Concurrent ( forkIO, threadDelay, myThreadId, killThread ) | ||
| 16 | import Data.Dynamic ( Typeable ) | ||
| 17 | import Control.Concurrent ( forkIO ) | ||
| 19 | 18 | import Control.Exception | |
| 20 | 19 | import Control.Monad.RWS hiding ( local ) | |
| 21 | 20 | import System.IO | |
| 22 | 21 | import System.IO.Error | |
| 22 | import System.Timeout | ||
| 23 | 23 | import Network ( listenOn, PortID(..) ) | |
| 24 | 24 | import Network.Socket | |
| 25 | 25 | import Text.ParserCombinators.Parsec.Rfc2821 | |
| … | … | ||
| 52 | 52 | when (len' > 0) (copyArray ptr ptr' len') | |
| 53 | 53 | return (Buf cap ptr (fromIntegral len')) | |
| 54 | 54 | ||
| 55 | -- |Timeouts are represented in microseconds. | ||
| 56 | |||
| 55 | 57 | type Timeout = Int | |
| 56 | 58 | ||
| 57 | 59 | -- |If there is space, read and append more octets; then | |
| … | … | ||
| 228 | 228 | ||
| 229 | 229 | safeFlush :: WriteHandle -> Smtpd () | |
| 230 | 230 | safeFlush hOut = safeWrite (hFlush hOut) | |
| 231 | |||
| 232 | |||
| 233 | |||
| 234 | |||
| 235 | data TimeoutEvent = TimeoutEvent Unique deriving (Eq, Typeable) | ||
| 236 | |||
| 237 | |||
| 238 | timeout :: Int -> IO a -> IO (Maybe a) | ||
| 239 | timeout n f | ||
| 240 | | n < 0 = fmap Just f | ||
| 241 | | n == 0 = return Nothing | ||
| 242 | | otherwise = do | ||
| 243 | pid <- myThreadId | ||
| 244 | ex <- fmap TimeoutEvent newUnique | ||
| 245 | handleJust (\e -> dynExceptions e >>= fromDynamic >>= guard . (ex ==)) | ||
| 246 | (\_ -> return Nothing) | ||
| 247 | (bracket (forkIO (threadDelay n >> throwDynTo pid ex)) | ||
| 248 | (killThread) | ||
| 249 | (\_ -> fmap Just f)) |
