[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36
John Goerzen
jgoerzen at complete.org
Fri Apr 23 14:50:22 UTC 2010
The following commit has been merged in the master branch:
commit 9e31fa8ebe08bc973609e1118a246c2bd4091c98
Author: John Goerzen <jgoerzen at complete.org>
Date: Tue Dec 7 01:05:56 2004 +0100
Imported blockio 2004-11-12
Keywords:
(jgoerzen at complete.org--projects/missingh--head--0.7--patch-50)
diff --git a/COPYRIGHT b/COPYRIGHT
index 27cbf67..424d60d 100644
--- a/COPYRIGHT
+++ b/COPYRIGHT
@@ -54,6 +54,22 @@ I (John Goerzen) have made these modifications:
and were removed.
----------------------------------------------------
+The MissingH.Threads.Child and MissingH.IO.BlockIO modules from from
+blockio 2004-11-12 from http://cryp.to/blockio/.
+
+Copyright/License:
+
+ Copyright (c) 2004 Peter Simons <simons at cryp.to>. All rights reserved. This
+ software is released under the terms of the GNU General Public License.
+
+I (John Goerzen) have made these modifications:
+
+ * Module names adjusted to work with MissingH
+
+ * Some files from the source distribution are not relevant to MissingH
+ and were removed.
+
+----------------------------------------------------
The Wash modules come from WashNGo 2.0.5. Mail is version 0.3.7. Utility
is version 0.3.11. They are available from
http://www.informatik.uni-freiburg.de/~thiemann/haskell/WASH/.
diff --git a/ChangeLog b/ChangeLog
index bb0f4ce..7db6d28 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,28 @@
# arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.7
#
+2004-12-06 18:05:56 GMT John Goerzen <jgoerzen at complete.org> patch-50
+
+ Summary:
+ Imported blockio 2004-11-12
+ Revision:
+ missingh--head--0.7--patch-50
+
+
+ new files:
+ libsrc/MissingH/IO/.arch-ids/BlockIO.hs.id
+ libsrc/MissingH/IO/BlockIO.hs
+ libsrc/MissingH/Threads/.arch-ids/=id
+ libsrc/MissingH/Threads/.arch-ids/Child.hs.id
+ libsrc/MissingH/Threads/Child.hs
+
+ modified files:
+ COPYRIGHT ChangeLog Setup.description debian/changelog
+
+ new directories:
+ libsrc/MissingH/Threads libsrc/MissingH/Threads/.arch-ids
+
+
2004-12-06 17:58:14 GMT John Goerzen <jgoerzen at complete.org> patch-49
Summary:
diff --git a/Setup.description b/Setup.description
index 44e2802..dbe35a7 100644
--- a/Setup.description
+++ b/Setup.description
@@ -30,6 +30,8 @@ Modules: MissingH.IO, MissingH.IO.Binary, MissingH.List,
MissingH.Checksum.CRC32.Posix, MissingH.Checksum.CRC32.GZip,
MissingH.Compression.Inflate,
MissingH.FileArchive.GZip,
+ MissingH.Threads.Child,
+ MissingH.IO.BlockIO,
MissingH.Wash.Mail.Email,
MissingH.Wash.Mail.EmailConfig,
MissingH.Wash.Mail.HeaderField,
diff --git a/debian/changelog b/debian/changelog
index bb28166..9861492 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,6 +1,7 @@
missingh (0.7.4) unstable; urgency=low
* Revved hsemail to 2004-11-01.
+ * Imported blockio 2004-11-12.
-- John Goerzen <jgoerzen at complete.org> Mon, 6 Dec 2004 11:57:20 -0600
diff --git a/libsrc/MissingH/IO/BlockIO.hs b/libsrc/MissingH/IO/BlockIO.hs
new file mode 100644
index 0000000..27570a5
--- /dev/null
+++ b/libsrc/MissingH/IO/BlockIO.hs
@@ -0,0 +1,271 @@
+{- |
+ Module : BlockIO
+ Copyright : (c) 2004-11-12 by Peter Simons
+ License : GPL2
+
+ Maintainer : simons at cryp.to
+ Stability : provisional
+ Portability : Haskell 2-pre
+
+ All you need from this module is the 'runLoop' function
+ and the 'Handler' type definition. It's no
+ breath-takingly inventive concept, actually: @runLoop@
+ will read blocks of 'Word8' from a 'Handle' into a static
+ buffer on the heap, and every time new input has arrived,
+ it will call a handler with a 'Ptr' into the buffer, so
+ that the handler can do stuff with the data. Then, the
+ handler returns either: I need more data before I can do
+ anything ('Nothing'), or I have consumed @n@ bytes,
+ please flush them (@'Just' (a,Int)@).
+
+ Basically, 'runLoop' drives the handler with the data
+ read from the input stream until 'hIsEOF' ensues.
+ Everything else has to be done by the handler -- the
+ 'BlockIO' monad just does the I\/O. But it does it
+ /fast/.
+-}
+
+module MissingH.IO.BlockIO where
+
+import Prelude hiding ( rem )
+import System.IO
+import System.IO.Error
+import Foreign hiding ( new )
+import Control.Monad.State
+import Control.Exception ( assert, bracket )
+import MissingH.Threads.Child ( Timeout, timeout )
+
+-- * I\/O Buffer
+
+-- |Capacity, pointer into the heap, and length of contents;
+-- all sizes are in bytes, naturally.
+
+data Buffer = Buf !Int !(Ptr Word8) !Int
+ deriving (Show)
+
+-- |Initialize a 'Buffer' of capacity @n > 0@ and run the
+-- given 'IO' computation with it. The buffer will be
+-- destroyed when the computation returns.
+
+withBuffer :: Int -> (Buffer -> IO a) -> IO a
+withBuffer n f = assert (n > 0) bracket (cons) (dest) f
+ where
+ cons = mallocArray n >>= \p -> return (Buf n p 0)
+ dest = \(Buf _ p _) -> free p
+
+-- |Drop the first @0 <= n <= size@ octets from the buffer.
+
+flushBuffer :: Int -> Buffer -> IO Buffer
+flushBuffer n (Buf cap ptr len) =
+ assert (n >= 0) $
+ assert (n <= len) $ do
+ let ptr' = ptr `plusPtr` n
+ len' = len - n
+ when (len' > 0) (copyArray ptr ptr' len')
+ return (Buf cap ptr len')
+
+-- |If there is space in the 'Buffer', read and append more
+-- octets, then return the modified buffer. In case of
+-- @EOF@, 'Nothing' is returned. If the buffer is full
+-- already, raise an 'IOError'. Use the 'isBufferOverflow'
+-- predicate to test an exception you caught for this
+-- condition.
+
+readBuffer :: Handle -> Buffer -> IO (Maybe Buffer)
+readBuffer h (Buf cap ptr len)
+ | cap <= len = fail "BlockIO: buffer overflow"
+ | otherwise = handleEOF wrap
+ where
+ wrap = do let ptr' = (ptr `plusPtr` len)
+ n = (cap - len)
+ rc <- hGetBufNonBlocking h ptr' n
+ if rc > 0
+ then return (Buf cap ptr (len + rc))
+ else hWaitForInput h (-1) >> wrap
+
+-- * BlockIO Monad
+
+-- |The internal state of a block-I\/O execution thread.
+
+data BIOState st = BIO !Handle !Buffer !st
+ deriving (Show)
+
+-- |A block-I\/O execution thread.
+
+type BlockIO st a = StateT (BIOState st) IO a
+
+-- |Run a 'BlockIO' computation in the 'IO' monad. The
+-- contents of the I\/O buffer is lost when 'runBlockIO'
+-- returns. If you need more control, use 'withBuffer' to
+-- construct your own 'BIOState' and run the monad with
+-- 'runStateT'.
+
+runBlockIO :: Handle
+ -> Int -- ^ buffer capacity
+ -> BlockIO st a -- ^ computation to run
+ -> st -- ^ initial state
+ -> IO (a, st)
+runBlockIO h size f st =
+ withBuffer size $ \buf -> do
+ (a, BIO _ _ st') <- runStateT f (BIO h buf st)
+ return (a,st')
+
+-- ** Primitives
+
+-- |Read some more input data into the I\/O buffer. Returns
+-- 'True' if there is more, 'False' when @EOF@ occurs. May
+-- raise an 'isBufferOverflow' or 'isTimeout' exception.
+
+slurp :: Timeout -> BlockIO st Bool
+slurp to = do
+ BIO h b st <- get
+ r <- liftIO $ timeout to (readBuffer h b)
+ >>= maybe (fail "BlockIO: read timeout") return
+ case r of
+ Nothing -> return False
+ Just b' -> put (BIO h b' st) >> return True
+
+-- |Drop the first @0 <= n <= size@ octets from the I\/O
+-- buffer.
+
+flush :: Int -> BlockIO st ()
+flush 0 = return ()
+flush n = do
+ BIO h b st <- get
+ b' <- liftIO (flushBuffer n b)
+ put (BIO h b' st)
+
+-- ** Handler and I\/O Driver
+
+-- |A handler is a stateful 'IO' computation which the I\/O
+-- driver 'consume' calls every time new input has arrived.
+-- If the buffer contains enough data to do something useful
+-- with it, it should do it, and signal how many octets have
+-- been consumed with the returned @Int at . These will be
+-- flushed from the beginning of buffer when the handler is
+-- called the next time. The handler itself should /not/
+-- modify the buffer.
+
+type Handler st a = (Ptr Word8, Int)
+ -> StateT st IO (Maybe (a,Int))
+
+-- |A handler which can be run in an I\/O loop without ever
+-- needing to return values to the main program, for
+-- instance with 'runLoop'.
+
+type LoopHandler st = Handler st ()
+
+-- |Use the given handler to consume a token from the I\/O
+-- buffer. Returns 'Nothing' in case of @EOF at . May raise an
+-- 'isBufferOverflow' or 'isTimeout' exception.
+
+consume :: Timeout -> Handler st a -> BlockIO st (Maybe a)
+consume to f = do
+ more <- slurp to
+ BIO h b@(Buf _ ptr len) st <- get
+ (tok, st') <- liftIO (runStateT (f (ptr,len)) st)
+ put (BIO h b st')
+ case (tok,more) of
+ (Just (a,n), _) -> flush n >> return (Just a)
+ (Nothing, True) -> consume to f
+ (Nothing, False) -> return Nothing
+
+-- |Repeated 'consume' until @EOF at . The handler may only
+-- return @()@ to prevent space leaks. Use @st@ instead.
+-- @:-)@
+
+loop :: (st -> Timeout) -> LoopHandler st -> BlockIO st ()
+loop to f = get >>= \(BIO _ _ st) ->
+ consume (to st) f >>= maybe (return ()) (const (loop to f))
+
+-- |Iterate a handle until @EOF@ and use the given 'Handler'
+-- to do stuff with the data we've read. The @(st ->
+-- Timeout)@ function will be used to to determine the read
+-- timeout from the current handler state.
+
+runLoopNB :: (st -> Timeout) -- ^ user state provides timeout
+ -> Handle -- ^ read from here
+ -> Int -- ^ buffer size to allocate
+ -> LoopHandler st -- ^ call-back to handle the data
+ -> st -- ^ initial handler state
+ -> IO st -- ^ the state at time of @EOF@
+runLoopNB to h size f st =
+ fmap snd (runBlockIO h size (loop to f) st)
+
+-- | @runLoop@ @=@ @'runLoopNB' (const (-1))@
+
+runLoop :: Handle -> Int -> LoopHandler st -> st -> IO st
+runLoop = runLoopNB (const (-1))
+
+-- * Handler Combinators
+
+-- ** Lines
+
+-- |Wrap an integer signifying the front gap of the buffer
+-- into the user state. Initialize it to @0 at .
+
+type LineHandler st a = Handler (Int,st) [a]
+
+-- |Split the input buffer into lines using \'@\\n@\' as
+-- end-of-line marker. The \'@\\n@\' is /not/ stripped. Then
+-- call the given 'IO' computation line-by-line until all
+-- lines have been consumed.
+
+handleLines :: (String -> StateT st IO a) -> LineHandler st a
+handleLines f (ptr,len) = do
+ (gap,st) <- get
+ when (len < gap) (fail "BlockIO.handleLines: inconsistent buffer")
+ if len == gap
+ then return Nothing
+ else do
+ buf <- liftIO (peekArray len ptr)
+ let buf' = map (toEnum . fromEnum) buf
+ (old,new) = splitAt gap buf'
+ (ls,rem) = splitBy (=='\n') new
+ gap' = length rem
+ case ls of
+ [] -> do put (len,st) >> return Nothing
+ (x:xs) -> do
+ (as,st') <- liftIO (runStateT (mapM f ((old++x):xs)) st)
+ put (gap',st')
+ return (Just (as,len-gap'))
+
+-- * Error Handling
+
+-- |Predicate to determine whether a caught 'IOError' was
+-- caused by a buffer overflow.
+
+isBufferOverflow :: IOError -> Bool
+isBufferOverflow e =
+ (isUserError e) && (ioeGetErrorString e == "BlockIO: buffer overflow")
+
+-- |Determine whether a given exception is a read timeout
+-- error raised by the BlockIO code.
+
+isTimeout :: IOError -> Bool
+isTimeout e =
+ (isUserError e) && (ioeGetErrorString e == "BlockIO: read timeout")
+
+-- * Internal Helper Functions
+
+-- |Return 'Nothing' if the given computation throws an
+-- 'isEOFError' exception. Used by 'readBuffer'.
+
+handleEOF :: IO a -> IO (Maybe a)
+handleEOF f =
+ catch (f >>= return . Just)
+ (\e -> case isEOFError e of True -> return Nothing
+ False -> ioError e)
+
+splitBy :: (a -> Bool) -> [a] -> ([[a]], [a])
+splitBy f as = foldr coll ([],[]) (splitBy' [] as)
+ where
+ coll (Right x) (ls, rem) = (x : ls, rem)
+ coll (Left x) (ls, rem) = (ls, rem ++ x)
+
+ splitBy' [] [] = []
+ splitBy' acc [] = Left acc : []
+ splitBy' acc (x:xs) =
+ if f x
+ then Right (acc++[x]) : splitBy' [] xs
+ else splitBy' (acc++[x]) xs
diff --git a/libsrc/MissingH/Threads/Child.hs b/libsrc/MissingH/Threads/Child.hs
new file mode 100644
index 0000000..33a066f
--- /dev/null
+++ b/libsrc/MissingH/Threads/Child.hs
@@ -0,0 +1,137 @@
+{- |
+ Module : Child
+ Copyright : (c) 2004-10-14 by Peter Simons
+ License : GPL2
+
+ Maintainer : simons at cryp.to
+ Stability : provisional
+ Portability : Haskell 2-pre
+
+ "Control.Concurrent"'s 'forkIO' is as low-level as it
+ gets: once you have forked an 'IO' thread, it is
+ basically /gone/; all @forkIO@ returns is @()@. If you
+ need more sophisticated control, you have to do it
+ yourself. This is what this library does.
+-}
+
+module MissingH.Threads.Child
+ ( Child(..) -- = Child ThreadId (MVar a)
+ , mkChild -- :: Monoid a => ThreadId -> MVar a -> IO a -> IO ()
+ , spawn -- :: Monoid a => IO a -> IO (Child a)
+ , wait -- :: Child a -> IO a
+ , send -- :: Child a -> Exception -> IO ()
+ , kill -- :: Child a -> IO ()
+ , par -- :: Monoid a => IO a -> IO a -> IO a
+ , Timeout -- = Int
+ , timeout -- :: Timeout -> IO a -> IO (Maybe a)
+ , sleep -- :: Int -> IO ()
+ )
+ where
+
+import Prelude hiding ( catch )
+import Control.Exception
+import Control.Concurrent
+import Control.Monad
+import Data.Monoid
+
+-- |A @Child@ is a cutely named data type which contains the
+-- 'ThreadId' of a forked computation and an 'MVar' into
+-- which the computation will put its return value once it
+-- has terminated. Thus, you can wait for your children to
+-- terminate by getting the value from that 'MVar'. Another
+-- property of children is that uncaught exceptions in them
+-- will be propagated to your thread. So either you 'catch'
+-- them, or a failure in any however deeply nested child
+-- will go right up to @main at .
+
+data Child a = Child ThreadId (MVar a)
+
+-- |Wrap an 'IO' computation so that (1) uncaught exceptions
+-- are re-thrown to the given 'ThreadId', and that (2) it
+-- will put the @a@ it returns into the 'MVar'. The value
+-- has to be a 'Monoid' because in case of (1) the wrapper
+-- still needs /some/ value to put into that 'MVar', so it
+-- uses 'mempty'. Popular monoids are @()@ and @[]@.
+
+mkChild :: (Monoid a) => ThreadId -> MVar a -> IO a -> IO ()
+mkChild parent mv f = catch (f >>= sync) h `finally` sync mempty
+ where
+ sync x = tryPutMVar mv x >> return ()
+ h (AsyncException ThreadKilled) = return ()
+ h e = throwTo parent e
+
+-- |Start an 'IO' computation with the properties described
+-- above.
+
+spawn :: (Monoid a) => IO a -> IO (Child a)
+spawn f = do
+ self <- myThreadId
+ sync <- newEmptyMVar
+ pid <- forkIO (mkChild self sync f)
+ return (Child pid sync)
+
+-- |Get the value returned by a \"child process\"; may be
+-- 'mempty'. But in case it is, you have just received an
+-- asynchronous 'Exception' anyway, so you have other things
+-- to do. The function does not return until the child has
+-- terminated. If /your/ thread receives an exception while
+-- it waits for the child, the child will be terminated
+-- before 'wait' returns. So once 'wait' returns, the child
+-- is guaranteed to be gone, one way or another.
+
+wait :: Child a -> IO a
+wait (Child pid sync) = readMVar sync `finally` killThread pid
+
+-- |A fancy wrapper for 'throwTo'.
+
+send :: Child a -> Exception -> IO ()
+send (Child pid _) = throwTo pid
+
+-- |Wraps 'killThread'.
+
+kill :: Child a -> IO ()
+kill (Child pid _) = killThread pid
+
+-- |Run both computations with 'spawn' and return the value
+-- of the child which terminates /first/. Both children are
+-- guaranteed to be gone when 'par' returns. Exceptions in
+-- either child are propagated. So if either child fails,
+-- 'par' fails.
+
+par :: (Monoid a) => IO a -> IO a -> IO a
+par f g = do
+ self <- myThreadId
+ sync <- newEmptyMVar
+ bracket
+ (forkIO (mkChild self sync f))
+ (killThread)
+ (\_ -> bracket
+ (forkIO (mkChild self sync g))
+ (killThread)
+ (\_ -> takeMVar sync))
+
+-- |Timeouts are given in microseconds (@1\/10^6@ seconds).
+-- Negative values generally mean \"wait indefinitely\".
+-- Make sure you don't exceed @maxBound :: Int@ when
+-- specifying large timeouts!
+
+type Timeout = Int
+
+-- |Wrap an 'IO' computation to timeout and return 'Nothing'
+-- after @n@ microseconds, otherwise @'Just' a@ is returned.
+
+timeout :: Timeout -> IO a -> IO (Maybe a)
+timeout n f
+ | n < 0 = fmap Just f
+ | n == 0 = return Nothing
+ | otherwise = do -- a => [a]
+ r <- par (threadDelay n >> return []) (fmap return f)
+ case r of [] -> return Nothing
+ (a:_) -> return (Just a)
+ -- We do this so that @a@ doesn't have
+ -- to be a monoid.
+
+-- |@sleep n@ @=@ @threadDelay (abs(n) * 1000000)@
+
+sleep :: Int -> IO ()
+sleep n = threadDelay (abs(n) * 1000000)
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list