epass (empty) → 0.1
raw patch · 10 files changed
+699/−0 lines, 10 filesdep +basedep +timesetup-changed
Dependencies added: base, time
Files
- CONTRIB +7/−0
- LICENSE +30/−0
- README +2/−0
- Setup.hs +4/−0
- demo/Message.hs +24/−0
- demo/TestClient.hs +39/−0
- demo/TestServer.hs +39/−0
- epass.cabal +44/−0
- src/Control/Concurrent/Mailbox.hs +325/−0
- src/Control/Concurrent/Mailbox/Wrapper.hs +185/−0
+ CONTRIB view
@@ -0,0 +1,7 @@+Bug reports, patches, comments, etc. are appreciated. Contact me by mail+(Andreas Baldeau <andreas@baldeau.net>) or use the bugtracker.++At this place, I would like to thank all contributers (in order of+contribution):++* Daniel Ehlers
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2010 Andreas Baldeau++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,2 @@+To get an idea of how to use epass, have a look at the files in demo/ and the+haddock docs.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main = defaultMain+
+ demo/Message.hs view
@@ -0,0 +1,24 @@+module Message+ ( Message (..)+ , Event (..)+ , Command (..)+ )+where++import Control.Concurrent.Mailbox.Wrapper++data Message = MsgEvent Event+ | MsgCommand Command+ | M Int+ deriving (Read, Show)++data Event = EvKey Char+ deriving (Read, Show)++data Command = CmdQuit+ deriving (Read, Show)++instance Wrappable Message where+ toString = show+ fromStringReadS = reads+
+ demo/TestClient.hs view
@@ -0,0 +1,39 @@+module Main where++import Message+import Control.Concurrent.Mailbox+import Control.Concurrent.Mailbox.Wrapper++import Network+import System.IO++main :: IO ()+main = do+ hdl <- connectTo "" $ UnixSocket "test.socket"++ hPutStr hdl "Test123\n"+ hFlush hdl++ inBox <- wrapReadHandle hdl+ (\inBox e -> inBox <! (error $ "Handled: " ++ show e))+ outBox <- wrapWriteHandle hdl+ (\_ e -> inBox <! (error $ "Handled: " ++ show e))++ loop inBox outBox 1+ mapM close [inBox, outBox]+ hClose hdl++loop :: MailboxClass mb => mb Message -> mb Message -> Int -> IO ()+loop _inBox outBox 1000000 = outBox <! MsgCommand CmdQuit+loop inBox outBox n = do+ outBox <! M n++ receive inBox+ [ \(M 10) -> handler $ do+ putStrLn "received 10"+ loop inBox outBox (n + 1)+ , \m -> handler $ do+ print m+ loop inBox outBox (n + 1)+ ]+
+ demo/TestServer.hs view
@@ -0,0 +1,39 @@+module Main where++import Message+import Control.Concurrent.Mailbox+import Control.Concurrent.Mailbox.Wrapper++import Network+import System.IO++main :: IO ()+main = do+ sock <- listenOn $ UnixSocket "test.socket"+ (hdl, _, _) <- accept sock++ inBox <- wrapReadHandle hdl+ (\inBox e -> inBox <! (error $ "Handled: " ++ show e))+ outBox <- wrapWriteHandle hdl+ (\_ e -> inBox <! (error $ "Handled: " ++ show e))++ loop inBox outBox+ mapM close [inBox, outBox]+ hClose hdl++loop :: MailboxClass mb => mb Message -> mb Message -> IO ()+loop inBox outBox = do+ receiveNonBlocking inBox+ [ \ (MsgCommand CmdQuit) -> handler $ return ()+ , \ m -> handler $ do+ putStrLn $ "Matched " ++ show m ++ " non-blocking."+ outBox <! M (-1)+ loop inBox outBox+ ] $ receive inBox+ [ \ (M (n + 1)) -> handler $ do+ outBox <! M (n * 2)+ loop inBox outBox+ , \ m -> handler $ do+ print m+ loop inBox outBox+ ]
+ epass.cabal view
@@ -0,0 +1,44 @@+Name: epass+Version: 0.1+Stability: Alpha+Synopsis: Baisc, Erlang-like message passing supporting sockets.+Description: This package provides Erlang-like mailboxes for message passing.+ It also supports wrapping communication via e.g. sockets.+License: BSD3+License-File: LICENSE+Build-Type: Simple+Author: Andreas Baldeau+Maintainer: Andreas Baldeau <andreas@baldeau.net>+Homepage: http://github.com/baldo/epass+Bug-Reports: http://github.com/baldo/epass/issues+Category: Concurrency, Network+Tested-With: GHC == 6.12.3+Cabal-Version: >= 1.8++Extra-Source-Files:+ Setup.hs+ CONTRIB+ README+ demo/Message.hs+ demo/TestClient.hs+ demo/TestServer.hs++Source-Repository head+ Type: git+ Location: git://github.com/baldo/epass.git++Library+ Build-Depends:+ base == 4.*,+ time == 1.1.*++ Ghc-Options:+ -Wall++ Hs-Source-Dirs:+ src++ Exposed-Modules:+ Control.Concurrent.Mailbox+ Control.Concurrent.Mailbox.Wrapper+
+ src/Control/Concurrent/Mailbox.hs view
@@ -0,0 +1,325 @@+{- | This module provides Erlang like functionality for message passing.++ Instead of mailboxes attached to each process you have to create the needed+ mailboxes yourself. This means that messages cannot be send to processes+ or threads directly, but only to mailboxes. On the other hand multiple+ threads may share a mailbox and one thread may have multiple mailboxes.++ For a simple example on how to receive messages have a look at the+ 'MsgHandler' type.+-}++module Control.Concurrent.Mailbox+ ( + -- * Mailbox+ MailboxClass (..)+ , Mailbox++ , newMailbox++ -- * Sending messages+ , send+ , (<!)++ -- * Receiving messages+ , receive+ , receiveNonBlocking+ , receiveTimeout++ -- * Message handlers+ , MsgHandler+ , Handler++ , handler++ -- * Message handler combinators+ , (.>)+ , (<|>)+ )+where++import Prelude hiding (catch)++import Control.Concurrent+import Control.Exception hiding (Handler)+import Data.Time+import System.Timeout+++-- Mailbox ---------------------------------------------------------------------++{- | Any instance of 'MailboxClass' may be used as a mailbox for message+ passing. @b@ is the mailbox type and m is the message type.+-}+class MailboxClass b where+ -- | Get a message from the mailbox (with 'Mailbox' it is the first one).+ getMessage+ :: b m -- ^ the mailbox+ -> IO m -- ^ the message++ {- | Put a message back to the mailbox (with 'Mailbox' it will be placed+ at the beginning of the mailbox).+ -}+ unGetMessage+ :: b m -- ^ the mailbox+ -> m -- ^ the message+ -> IO ()++ {- | Add a new message to the mailbox (with 'Mailbox' it will be placed at+ the end of the mailbox).+ -}+ putMessage+ :: b m -- ^ the mailbox+ -> m -- ^ the message+ -> IO ()++ -- | Checks wether the mailbox is empty.+ isEmpty+ :: b m -- ^ the mailbox+ -> IO Bool -- ^ 'True' if empty++ {- | Call this function to cleanup before exit or when the mailbox is no+ longer needed.+ -}+ close+ :: b m+ -> IO ()++-- | A 'Chan' based mailbox.+newtype Mailbox m = MBox { unMBox :: Chan m }++-- | Creates a new mailbox.+newMailbox :: IO (Mailbox m)+newMailbox = fmap MBox newChan++instance MailboxClass Mailbox where+ getMessage = readChan . unMBox+ unGetMessage = unGetChan . unMBox+ putMessage = writeChan . unMBox+ isEmpty = isEmptyChan . unMBox+ close = const $ return ()+++-- Sending messages ------------------------------------------------------------++-- | Send the given message to the given mailbox.+send+ :: MailboxClass b+ => b m -- ^ the mailbox+ -> m -- ^ the message+ -> IO ()+send mbox msg = do+ putMessage mbox msg+ yield++-- | An alias for 'send' in the flavor of Erlang's @!@.+(<!) :: MailboxClass b => b m -> m -> IO ()+(<!) = send+++-- Timeout calculations (internal) ---------------------------------------------++timeoutFactor :: Num a => a+timeoutFactor = 1000000++calcEndTime :: Int -> IO UTCTime+calcEndTime to = do+ curTime <- getCurrentTime+ let dt = fromIntegral to / timeoutFactor+ return $ addUTCTime dt curTime++calcTimeLeft :: UTCTime -> IO Int+calcTimeLeft endTime = do+ curTime <- getCurrentTime+ return $ round $ (diffUTCTime endTime curTime) * timeoutFactor+++-- Receiving messages ----------------------------------------------------------++{- | Receive messages in the flavour of Erlang's @receive@.++ For each message in the mailbox all message handlers are matched until a+ matching message is found. It will be removed from the mailbox and the+ matching message handler's action will be performed.++ If no message matches any of the message handler, 'receive' will block and+ check new incoming messages until a match is found.+-}+receive+ :: MailboxClass b+ => b m -- ^ mailbox to receive on+ -> [MsgHandler m a] -- ^ message handlers+ -> IO a+receive _ [] = error "No message handler given! Cannot match."+receive mbox handlers = do+ a <- matchAll mbox handlers+ a++{- | Like 'receive', but times out after a given time. In case of timeout the+ timeout handler is executed.+-}+receiveTimeout+ :: MailboxClass b+ => b m -- ^ the mailbox+ -> Int -- ^ timeout in us+ -> [MsgHandler m a] -- ^ message handlers+ -> IO a -- ^ timeout handler+ -> IO a+receiveTimeout _ _ [] toa = toa+receiveTimeout mbox 0 handlers toa = receiveNonBlocking mbox handlers toa+receiveTimeout mbox to handlers toa = do+ endTime <- calcEndTime to+ ma <- matchAllTimeout mbox endTime handlers+ case ma of+ Just a -> a+ Nothing -> toa++{- | Like 'receive', but doesn't block. If no match was found, the default+ handler is executed.+-}+receiveNonBlocking+ :: MailboxClass b+ => b m -- ^ the mailbox+ -> [MsgHandler m a] -- ^ message handlers+ -> IO a -- ^ default handler+ -> IO a+receiveNonBlocking mbox handlers na = do+ ma <- matchCurrent mbox handlers+ case ma of+ Just a -> a+ Nothing -> na+++-- Matching messages (internal) ------------------------------------------------++matchAll :: MailboxClass b => b m -> [MsgHandler m a] -> IO (IO a)+matchAll mbox hs = do+ m <- getMessage mbox+ ma <- match m hs++ case ma of+ Just a ->+ return a++ Nothing -> do+ r <- matchAll mbox hs+ unGetMessage mbox m+ return r++matchAllTimeout :: MailboxClass b => b m -> UTCTime -> [MsgHandler m a] -> IO (Maybe (IO a))+matchAllTimeout mbox endTime hs = do+ timeLeft <- calcTimeLeft endTime++ if timeLeft <= 0+ then return Nothing+ else do+ mm <- timeout timeLeft $ getMessage mbox++ case mm of+ Just m -> do+ matched <- matchTimeout m endTime hs+ case matched of+ Left Nothing -> do+ r <- matchAllTimeout mbox endTime hs+ unGetMessage mbox m+ return r++ Left (Just a) ->+ return $ Just a++ Right () -> do+ unGetMessage mbox m+ return Nothing+ Nothing ->+ return Nothing++matchCurrent :: MailboxClass b => b m -> [MsgHandler m a] -> IO (Maybe (IO a))+matchCurrent mbox hs = do+ empty <- isEmpty mbox + if empty+ then return Nothing+ else do+ m <- getMessage mbox+ ma <- match m hs+ case ma of+ Just a ->+ return $ Just a++ Nothing -> do+ r <- matchCurrent mbox hs+ unGetMessage mbox m+ return r++match :: m -> [MsgHandler m a] -> IO (Maybe (IO a))+match _ [] = return Nothing+match m (h : hs) = do+ ma <- catch (case h m of (Handler a) -> return $ Just a)+ handlePatternMatchFail+ case ma of+ Just action -> return $ Just action+ Nothing -> match m hs++matchTimeout :: m -> UTCTime -> [MsgHandler m a] -> IO (Either (Maybe (IO a)) ())+matchTimeout _ _ [] = return $ Left Nothing+matchTimeout m endTime (h : hs) = do+ timeLeft <- calcTimeLeft endTime+ if timeLeft <= 0+ then return $ Right ()+ else do+ ma <- timeout timeLeft $+ catch (case h m of (Handler a) -> return $ Just a)+ handlePatternMatchFail+ case ma of+ Just (Just action) -> return $ Left $ Just action+ Just Nothing -> matchTimeout m endTime hs+ Nothing -> return $ Right ()++handlePatternMatchFail :: PatternMatchFail -> IO (Maybe (IO a))+handlePatternMatchFail _ = return Nothing+++-- Message handlers ------------------------------------------------------------++{- | A function that matches a given message and returns the corresponding+ handler.++ In case of an pattern matching error 'receive' will continue matching+ the next 'MsgHandler' / message.++ For example you may write somthing like this:++ > receive mbox+ > [ \ True -> handler $ return 1+ > , \ False -> handler $ return 2+ > ]+-}+type MsgHandler m a = m -> Handler a++-- | The action to perfom in case of successful matching.+data Handler a = Handler (IO a)++-- | Generate a handler from an 'IO' action.+handler :: IO a -> Handler a+handler = Handler+++-- Message handler combinators -------------------------------------------------++-- | Apply a function to the result of an message handler.+(.>)+ :: MsgHandler m a -- ^ message handler+ -> (a -> b) -- ^ function+ -> MsgHandler m b -- ^ new message handler+(h .> f) m = + let Handler a = h m + in handler $ a >>= return . f++{- | Combine to lists of message handlers into one list. The results of the+ message handler will be wrapped in 'Either'.+-}+(<|>)+ :: [MsgHandler m a] -- ^ message handlers+ -> [MsgHandler m b] -- ^ more message handlers+ -> [MsgHandler m (Either a b)] -- ^ combined message handlers+has <|> hbs = (map (.> Left) has) ++ (map (.> Right) hbs)+
+ src/Control/Concurrent/Mailbox/Wrapper.hs view
@@ -0,0 +1,185 @@+-- | This module provides a wrapping mechanism for file handles (e.g. sockets)+module Control.Concurrent.Mailbox.Wrapper+ (+ -- * Wrapping types+ Wrappable (..)+ , WrapBox+ , ErrorHandler++ -- * Wrapping functions+ , wrapReadHandle+ , wrapWriteHandle++ , wrapReadHandleWithMailbox+ , wrapWriteHandleWithMailbox+ )+where++import Control.Concurrent.Mailbox++import Control.Concurrent+import System.IO+++-- Wrapping types --------------------------------------------------------------++{- | Messages send over wrapped handles must be instance of this class.++ You only need to implement either 'fromString' or 'fromStringReadS'.+-}+class Wrappable m where+ -- | Convert a message to a 'String'+ toString+ :: m -- ^ the message+ -> String -- ^ its 'String' representation++ -- | Convert a 'String' to the represented message.+ fromString+ :: String -- ^ 'String' representation of a message+ -> Maybe m -- ^ 'Just' the message or 'Nothing' in case of parse error+ fromString str =+ case fromStringReadS str of+ [(msg, "")] -> Just msg+ _ -> Nothing++ -- | Same as 'fromString' but using 'ReadS' type.+ fromStringReadS :: ReadS m+ fromStringReadS str =+ case fromString str of+ Just msg -> [(msg, "")]+ Nothing -> []++{- | Wrapper around 'Mailbox'. For now the only 'MailboxClass' instance allowed+ for wrapping.+-}+data WrapBox m = WBox+ { mBox :: Mailbox m+ , tId :: ThreadId+ }++instance MailboxClass WrapBox where+ getMessage = getMessage . mBox+ unGetMessage = unGetMessage . mBox+ putMessage = putMessage . mBox+ isEmpty = isEmpty . mBox++ close wbox = do+ killThread $ tId wbox+ close $ mBox wbox++{- | Function to be called in case of error. 'WrapBox' is the mailbox the error+ occured on.+-}+type ErrorHandler m = WrapBox m -> IOError -> IO ()+++-- Wrapping functions ----------------------------------------------------------++{- | Wrap the given 'Handle' for reading. The returned 'WrapBox' can be used+ to receive messages from the 'Handle'.++ Notice: The 'ErrorHandler' will be given the returned 'WrapBox'. Writing to+ may not be what you want to do. Instead you might first call+ 'wrapWriteHandle' and then use its 'WrapBox' in 'wrapReadHandle's+ 'ErrorHandler'.+-}+wrapReadHandle+ :: Wrappable m+ => Handle -- ^ handle to wrap+ -> ErrorHandler m -- ^ error handler+ -> IO (WrapBox m) -- ^ the wrapped mailbox+wrapReadHandle = wrapHandle inWrapper++{- | Wrap the given 'Handle' for writing. The returned 'WrapBox' can be used to+ send messages through the 'Handle'.+-}+wrapWriteHandle+ :: Wrappable m+ => Handle -- ^ handle to wrap+ -> ErrorHandler m -- ^ error handler+ -> IO (WrapBox m) -- ^ the wrapped mailbox+wrapWriteHandle = wrapHandle outWrapper++-- | Same as 'wrapReadHandle' but use an existing 'Mailbox' for wrapping.+wrapReadHandleWithMailbox+ :: Wrappable m+ => Handle -- ^ the handle to wrap+ -> Mailbox m -- ^ the mailbox to use+ -> ErrorHandler m -- ^ error handler+ -> IO (WrapBox m) -- ^ the wrapped mailbox+wrapReadHandleWithMailbox = wrapHandleWithMailbox inWrapper++-- | Same as 'wrapWriteHandle' but use an existing 'Mailbox' for wrapping.+wrapWriteHandleWithMailbox+ :: Wrappable m+ => Handle -- ^ the handle to wrap+ -> Mailbox m -- ^ the mailbox to use+ -> ErrorHandler m -- ^ error handler+ -> IO (WrapBox m) -- ^ the wrapped mailbox+wrapWriteHandleWithMailbox = wrapHandleWithMailbox outWrapper++-- Wrapping (internal) ---------------------------------------------------------++type Wrapper m = (Handle -> Mailbox m -> ErrorHandler m -> IO ())++wrapHandle+ :: Wrappable m+ => Wrapper m+ -> Handle+ -> ErrorHandler m+ -> IO (WrapBox m)+wrapHandle wrapper hdl errHandler = do+ mbox <- newMailbox+ tid <- forkIO $ wrapper hdl mbox errHandler+ return WBox { mBox = mbox, tId = tid }++wrapHandleWithMailbox+ :: Wrappable m+ => Wrapper m+ -> Handle+ -> Mailbox m+ -> ErrorHandler m+ -> IO (WrapBox m)+wrapHandleWithMailbox wrapper hdl mbox errHandler = do+ tid <- forkIO $ wrapper hdl mbox errHandler+ return WBox { mBox = mbox, tId = tid }++inWrapper+ :: Wrappable m+ => Wrapper m+inWrapper hdl mbox errHandler = do+ eline <- catch (fmap Left $ hGetLine hdl) (return . Right)++ case eline of+ Left line -> do+ case fromString line of+ Just msg -> mbox <! msg+ Nothing -> putStrLn $ "Error: Cannot parse message: " ++ show line++ inWrapper hdl mbox errHandler+ Right e -> do+ tid <- myThreadId+ errHandler WBox { mBox = mbox, tId = tid } e++outWrapper+ :: Wrappable m+ => Wrapper m+outWrapper hdl mbox errHandler = do+ receive mbox+ [ \msg -> handler $ do+ let smsg = toString msg++ me <- catch (do+ hPutStr hdl smsg+ hPutChar hdl '\n'+ hFlush hdl+ return Nothing)+ (return . Just)++ case me of+ Nothing -> outWrapper hdl mbox errHandler+ Just e -> do+ tid <- myThreadId+ errHandler WBox { mBox = mbox, tId = tid } e+ ]+