[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