https://wiki.haskell.org/index.php?title=Concurrency_demos/Graceful_exit&feed=atom&action=history
Concurrency demos/Graceful exit - Revision history
2024-03-28T10:32:51Z
Revision history for this page on the wiki
MediaWiki 1.35.5
https://wiki.haskell.org/index.php?title=Concurrency_demos/Graceful_exit&diff=33742&oldid=prev
Newacct at 06:19, 21 February 2010
2010-02-21T06:19:07Z
<p></p>
<table class="diff diff-contentalign-left diff-editfont-monospace" data-mw="interface">
<col class="diff-marker" />
<col class="diff-content" />
<col class="diff-marker" />
<col class="diff-content" />
<tr class="diff-title" lang="en">
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">← Older revision</td>
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">Revision as of 06:19, 21 February 2010</td>
</tr><tr>
<td colspan="2" class="diff-lineno">Line 90:</td>
<td colspan="2" class="diff-lineno">Line 90:</td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>> -- connectionHandler throws an exception, but</div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>> -- connectionHandler throws an exception, but</div></td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>> -- for now we'll at least display the exception.</div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>> -- for now we'll at least display the exception.</div></td>
</tr>
<tr>
<td class="diff-marker">−</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #ffe49c; vertical-align: top; white-space: pre-wrap;"><div>> (\e -><del class="diffchange diffchange-inline"> do {</del> print e<del class="diffchange diffchange-inline">; return () }</del>)</div></td>
<td class="diff-marker">+</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #a3d3ff; vertical-align: top; white-space: pre-wrap;"><div>> (\e -> print e)</div></td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div></haskell></div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div></haskell></div></td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"></td>
</tr>
</table>
Newacct
https://wiki.haskell.org/index.php?title=Concurrency_demos/Graceful_exit&diff=32461&oldid=prev
Newacct at 07:54, 13 December 2009
2009-12-13T07:54:27Z
<p></p>
<table class="diff diff-contentalign-left diff-editfont-monospace" data-mw="interface">
<col class="diff-marker" />
<col class="diff-content" />
<col class="diff-marker" />
<col class="diff-content" />
<tr class="diff-title" lang="en">
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">← Older revision</td>
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">Revision as of 07:54, 13 December 2009</td>
</tr><tr>
<td colspan="2" class="diff-lineno">Line 90:</td>
<td colspan="2" class="diff-lineno">Line 90:</td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>> -- connectionHandler throws an exception, but</div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>> -- connectionHandler throws an exception, but</div></td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>> -- for now we'll at least display the exception.</div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>> -- for now we'll at least display the exception.</div></td>
</tr>
<tr>
<td class="diff-marker">−</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #ffe49c; vertical-align: top; white-space: pre-wrap;"><div>> (\e -> do { <del class="diffchange diffchange-inline">putStrLn $ show</del> e; return () })</div></td>
<td class="diff-marker">+</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #a3d3ff; vertical-align: top; white-space: pre-wrap;"><div>> (\e -> do { <ins class="diffchange diffchange-inline">print</ins> e; return () })</div></td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div></haskell></div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div></haskell></div></td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"></td>
</tr>
</table>
Newacct
https://wiki.haskell.org/index.php?title=Concurrency_demos/Graceful_exit&diff=23625&oldid=prev
ChrisKuklewicz: Fix bug, (`mod` 10 == 0) changed to (`mod` 10 /= 0)
2008-10-23T09:36:48Z
<p>Fix bug, (`mod` 10 == 0) changed to (`mod` 10 /= 0)</p>
<table class="diff diff-contentalign-left diff-editfont-monospace" data-mw="interface">
<col class="diff-marker" />
<col class="diff-content" />
<col class="diff-marker" />
<col class="diff-content" />
<tr class="diff-title" lang="en">
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">← Older revision</td>
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">Revision as of 09:36, 23 October 2008</td>
</tr><tr>
<td colspan="2" class="diff-lineno">Line 183:</td>
<td colspan="2" class="diff-lineno">Line 183:</td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div> writeIORef counter $! (succ count)</div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div> writeIORef counter $! (succ count)</div></td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div> modifyMVar_ childrenList $ \kids -> fmap (cInfo:) $</div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div> modifyMVar_ childrenList $ \kids -> fmap (cInfo:) $</div></td>
</tr>
<tr>
<td class="diff-marker">−</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #ffe49c; vertical-align: top; white-space: pre-wrap;"><div> if count `mod` 10 <del class="diffchange diffchange-inline">=</del>= 0 -- 10 is arbitrary frequency for cleaning list</div></td>
<td class="diff-marker">+</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #a3d3ff; vertical-align: top; white-space: pre-wrap;"><div> if count `mod` 10 <ins class="diffchange diffchange-inline">/</ins>= 0 -- 10 is arbitrary frequency for cleaning list</div></td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div> then return kids</div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div> then return kids</div></td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div> else atomically $ filterM (isEmptyTMVar . fst) kids</div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div> else atomically $ filterM (isEmptyTMVar . fst) kids</div></td>
</tr>
<!-- diff cache key wikidb_haskell:diff:wikidiff2:1.12:old-8957:rev-23625:1.10.0 -->
</table>
ChrisKuklewicz
https://wiki.haskell.org/index.php?title=Concurrency_demos/Graceful_exit&diff=8957&oldid=prev
CatDancer: Add info on where to get the AcceptLoop code
2006-12-07T13:55:22Z
<p>Add info on where to get the AcceptLoop code</p>
<table class="diff diff-contentalign-left diff-editfont-monospace" data-mw="interface">
<col class="diff-marker" />
<col class="diff-content" />
<col class="diff-marker" />
<col class="diff-content" />
<tr class="diff-title" lang="en">
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">← Older revision</td>
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">Revision as of 13:55, 7 December 2006</td>
</tr><tr>
<td colspan="2" class="diff-lineno">Line 198:</td>
<td colspan="2" class="diff-lineno">Line 198:</td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>retry'until'true tv = (readTVar tv >>= cond (return ()) retry)</div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>retry'until'true tv = (readTVar tv >>= cond (return ()) retry)</div></td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div></haskell></div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div></haskell></div></td>
</tr>
<tr>
<td colspan="2" class="diff-empty"> </td>
<td class="diff-marker">+</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #a3d3ff; vertical-align: top; white-space: pre-wrap;"></td>
</tr>
<tr>
<td colspan="2" class="diff-empty"> </td>
<td class="diff-marker">+</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #a3d3ff; vertical-align: top; white-space: pre-wrap;"></td>
</tr>
<tr>
<td colspan="2" class="diff-empty"> </td>
<td class="diff-marker">+</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #a3d3ff; vertical-align: top; white-space: pre-wrap;"><div>== AcceptLoop Library ==</div></td>
</tr>
<tr>
<td colspan="2" class="diff-empty"> </td>
<td class="diff-marker">+</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #a3d3ff; vertical-align: top; white-space: pre-wrap;"></td>
</tr>
<tr>
<td colspan="2" class="diff-empty"> </td>
<td class="diff-marker">+</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #a3d3ff; vertical-align: top; white-space: pre-wrap;"><div>Work has started on a library module to implement just the "accepting a network connection with graceful shutdown" part, with a goal of creating code that is both correct and reusable. Details and source code can be found at [http://code.catdancer.ws/acceptloop/ AcceptLoop].</div></td>
</tr>
</table>
CatDancer
https://wiki.haskell.org/index.php?title=Concurrency_demos/Graceful_exit&diff=8852&oldid=prev
BrettGiles: Concurrency demos/Graceful Exit moved to Concurrency demos/Graceful exit
2006-12-04T02:52:01Z
<p>Concurrency demos/Graceful Exit moved to Concurrency demos/Graceful exit</p>
<table class="diff diff-contentalign-left diff-editfont-monospace" data-mw="interface">
<col class="diff-marker" />
<col class="diff-content" />
<col class="diff-marker" />
<col class="diff-content" />
<tr class="diff-title" lang="en">
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">← Older revision</td>
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">Revision as of 02:52, 4 December 2006</td>
</tr>
<!-- diff cache key wikidb_haskell:diff:wikidiff2:1.12:old-8848:rev-8852:1.10.0 -->
</table>
BrettGiles
https://wiki.haskell.org/index.php?title=Concurrency_demos/Graceful_exit&diff=8848&oldid=prev
ChrisKuklewicz: add category:code
2006-12-03T23:38:04Z
<p>add category:code</p>
<table class="diff diff-contentalign-left diff-editfont-monospace" data-mw="interface">
<col class="diff-marker" />
<col class="diff-content" />
<col class="diff-marker" />
<col class="diff-content" />
<tr class="diff-title" lang="en">
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">← Older revision</td>
<td colspan="2" style="background-color: #fff; color: #202122; text-align: center;">Revision as of 23:38, 3 December 2006</td>
</tr><tr>
<td colspan="2" class="diff-lineno">Line 1:</td>
<td colspan="2" class="diff-lineno">Line 1:</td>
</tr>
<tr>
<td colspan="2" class="diff-empty"> </td>
<td class="diff-marker">+</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #a3d3ff; vertical-align: top; white-space: pre-wrap;"><div>[[Category:Code]]</div></td>
</tr>
<tr>
<td colspan="2" class="diff-empty"> </td>
<td class="diff-marker">+</td>
<td style="color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #a3d3ff; vertical-align: top; white-space: pre-wrap;"></td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>__TOC__</div></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"><div>__TOC__</div></td>
</tr>
<tr>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"></td>
<td class="diff-marker"> </td>
<td style="background-color: #f8f9fa; color: #202122; font-size: 88%; border-style: solid; border-width: 1px 1px 1px 4px; border-radius: 0.33em; border-color: #eaecf0; vertical-align: top; white-space: pre-wrap;"></td>
</tr>
</table>
ChrisKuklewicz
https://wiki.haskell.org/index.php?title=Concurrency_demos/Graceful_exit&diff=8846&oldid=prev
ChrisKuklewicz: New page (from mailing list)
2006-12-03T23:36:03Z
<p>New page (from mailing list)</p>
<p><b>New page</b></p><div>__TOC__<br />
<br />
== Problem ==<br />
<br />
This was put the haskell mailing list by [http://www.haskell.org/pipermail/haskell/2006-December/018802.html Cat Dancer].<br />
<br />
"I'd like to write a server accepting incoming network connections that<br />
can be gracefully shutdown.<br />
<br />
When the server is asked to shutdown, it should stop accepting new<br />
connections, finish processing any current connections, and then<br />
terminate."<br />
<br />
I could not solve the problem that a new thread made by forkIO did not immediately have my finally/catch exception handler installed. Therefore there was a time after forkIO returned and before the thread started running in which it could be killed with killThread without this getting caught. The "fork" operation in the STM example works hard to ensure the thread is running with the handler in place before returning.<br />
<br />
== Using throwTo ==<br />
<br />
By Chris Kuklewicz <haskell at list dot mightyreason dot com><br />
<br />
<haskell><br />
> import Control.Concurrent<br />
> import Control.Concurrent.MVar<br />
> import Control.Exception as Exception<br />
> import Network.Socket<br />
> import Data.Typeable<br />
> import System.IO<br />
><br />
> -- A ConnectionHandler is a function which handles an incoming<br />
> -- client connection. The handler is run in its own thread, and is<br />
> -- passed a handle to the client socket. The handler does whatever<br />
> -- communication it wants to do with the client, and when it returns,<br />
> -- the client socket handle is closed and the thread terminates.<br />
> -- A list of active handlers is kept, and the client connection is<br />
> -- also marked as finished when the handler returns.<br />
><br />
> type ConnectionHandler = Handle -> IO ()<br />
><br />
> example_connection_handler :: ConnectionHandler<br />
><br />
> example_connection_handler handle = do<br />
> hPutStrLn handle "Hello."<br />
> hPutStrLn handle "Goodbye."<br />
><br />
><br />
> type ChildrenDone = MVar [MVar ()]<br />
><br />
> data ExitGracefully = ExitGracefully deriving Typeable<br />
><br />
><br />
> waitForChildren :: ChildrenDone -> IO ()<br />
><br />
> waitForChildren childrenDone = do<br />
> cs <- takeMVar childrenDone<br />
> mapM_ takeMVar cs<br />
><br />
> shutdownServer :: MVar () -> ChildrenDone -> ThreadId -> IO ()<br />
><br />
> shutdownServer acceptLoopDone childrenDone acceptThreadId = do<br />
> throwDynTo acceptThreadId ExitGracefully<br />
> takeMVar acceptLoopDone<br />
> -- There can be no more changes to childrenDone<br />
> waitForChildren childrenDone<br />
> return ()<br />
><br />
> acceptConnections :: MVar () -> ChildrenDone -> ConnectionHandler -> Socket -> IO ()<br />
><br />
> acceptConnections acceptLoopDone childrenDone connectionHandler sock = <br />
> finially (acceptConnections' acceptLoopDone childrenDone connectionHandler sock)<br />
> (putStrLn "accept loop exiting" >> putMVar acceptLoopDone () ) -- run last<br />
><br />
> -- This only looks for exceptions when "accept sock" is executed<br />
> acceptConnections' acceptLoopDone childrenDone connectionHandler sock = block loop<br />
> where loop = do<br />
> unblock (return ()) -- safe point to be interrupted, so unblock<br />
> (clientSocket, addr) <- accept sock -- may or may not unblock and wait<br />
> clientHandle <- socketToHandle clientSocket ReadWriteMode<br />
> childDone <- newEmptyMVar<br />
> forkIO $ handleConnection childDone connectionHandler clientHandle<br />
> modifyMVar_ childrenDone (return . (childDone:)) -- non-blocking atomic change to MVar<br />
> loop<br />
><br />
> handleConnection childDone connectionHandler clientHandle = do<br />
> Exception.catch<br />
> (finially (connectionHandler clientHandle)<br />
> (hClose clientHandle >> putMVar childDone () )<br />
><br />
> -- TODO we'll want to do something better when<br />
> -- connectionHandler throws an exception, but<br />
> -- for now we'll at least display the exception.<br />
> (\e -> do { putStrLn $ show e; return () })<br />
</haskell><br />
<br />
<br />
== Using STM ==<br />
<br />
<haskell><br />
{-<br />
<br />
The main accepting thread spawns this a slave thread to run accept and<br />
stuffs the result into a TMVar. The main loop then atomically checks<br />
the TVar used for graceful shutdown and the TMVar. These two checks<br />
are combined by `orElse` which gives the semantics one wants: on each<br />
loop either the TVar has been set to True or the the slave thread has<br />
accepted a client into the TMVar.<br />
<br />
There is still the possibility that a busy server could accept a<br />
connection from the last client and put it in the TMVar where the main<br />
loop will miss it when it exits. This is handled by the finally<br />
action which waits for the slave thread to be well and truly dead and<br />
then looks for that last client in the TMVar.<br />
<br />
The list of child threads is cleaned periodically (currently every<br />
10th child), which allows the garbage collected to remove the dead<br />
threads' structures.<br />
<br />
By Chris Kuklewicz <haskell at list dot mightyreason dot com><br />
<br />
-}<br />
<br />
-- Example using STM and orElse to compose a solution<br />
import Control.Monad<br />
import Control.Concurrent<br />
import Control.Exception<br />
import Control.Concurrent.STM<br />
import Data.IORef<br />
import Network<br />
import System.IO<br />
<br />
forever x = x >> forever x<br />
<br />
runExampleFor socket seconds = do<br />
tv <- newTVarIO False -- Set to True to indicate graceful exit requested<br />
sInfo <- startServer socket tv<br />
threadDelay (1000*1000*seconds)<br />
shutdownServer tv sInfo<br />
<br />
startServer socket tv = do<br />
childrenList <- newMVar []<br />
tInfo <- fork (acceptUntil socket exampleReceiver childrenList (retry'until'true tv))<br />
return (tInfo,childrenList)<br />
<br />
shutdownServer tv ((acceptLoopDone,_),childrenList) = do<br />
atomically (writeTVar tv True)<br />
atomically (readTMVar acceptLoopDone)<br />
withMVar childrenList (mapM_ (atomically . readTMVar . fst))<br />
<br />
-- Capture idiom of notifying a new TMVar when a thread is finished<br />
fork todo = block $ do<br />
doneVar <- atomically (newEmptyTMVar)<br />
let putStarted = atomically (putTMVar doneVar False)<br />
putStopped = atomically (tryTakeTMVar doneVar >> putTMVar doneVar True)<br />
tid <- forkIO $ block $ (finally (putStarted >> unblock todo) putStopped)<br />
yield<br />
atomically $ do<br />
value <- takeTMVar doneVar<br />
when value (putTMVar doneVar True)<br />
return (doneVar,tid)<br />
<br />
cond true false test = if test then true else false<br />
<br />
-- This is an asychronous exception safe way to use accept to get one<br />
-- client at a time and pass them to the parent thread via a TMVar.<br />
acceptInto socket chan = block . forever $ do<br />
unblock . atomically $<br />
isEmptyTMVar chan >>= cond (return ()) retry<br />
client <- accept socket<br />
atomically (putTMVar chan client)<br />
<br />
-- This demonstrates how to use acceptInto to spawn client thread<br />
-- running "receiver". It ends when checker commits instead of using<br />
-- retry.<br />
acceptUntil socket receiver childrenList checker = do<br />
counter <- newIORef (0::Int) -- who cares if it rolls over?<br />
chan <- atomically (newEmptyTMVar)<br />
(mv,tid) <- fork (acceptInto socket chan)<br />
let loop = atomically (fmap Left checker `orElse` fmap Right (takeTMVar chan))<br />
>>= either (const (return ())) (\client -> spawn client >> loop)<br />
spawn client@(handle,_,_) = do<br />
cInfo <- fork (finally (receiver client) (hClose handle))<br />
count <- readIORef counter<br />
writeIORef counter $! (succ count)<br />
modifyMVar_ childrenList $ \kids -> fmap (cInfo:) $<br />
if count `mod` 10 == 0 -- 10 is arbitrary frequency for cleaning list<br />
then return kids<br />
else atomically $ filterM (isEmptyTMVar . fst) kids<br />
end = do<br />
killThread tid<br />
atomically (readTMVar mv)<br />
atomically (tryTakeTMVar chan) >>= maybe (return ()) spawn<br />
finally (handle (\e -> throwTo tid e >> throw e) loop) end<br />
<br />
exampleReceiver (handle,_,_) = do<br />
hPutStrLn handle "Hello."<br />
hPutStrLn handle "Goodbye."<br />
<br />
retry'until'true tv = (readTVar tv >>= cond (return ()) retry)<br />
</haskell></div>
ChrisKuklewicz