[Assorted-commits] SF.net SVN: assorted:[1431] auto-mirror/trunk

[<yan...@us...>]

Revision: 1431
          http://assorted.svn.sourceforge.net/assorted/?rev=1431&view=rev
Author:   yangzhang
Date:     2009-05-25 18:22:18 +0000 (Mon, 25 May 2009)

Log Message:
-----------
dumping some more old code here

Added Paths:
-----------
    auto-mirror/trunk/README
    auto-mirror/trunk/src/Main.hs
    auto-mirror/trunk/src/Makefile
    auto-mirror/trunk/src/download.bash

Added: auto-mirror/trunk/README
===================================================================
--- auto-mirror/trunk/README	                        (rev 0)
+++ auto-mirror/trunk/README	2009-05-25 18:22:18 UTC (rev 1431)
@@ -0,0 +1,2 @@
+This was originally used in the CarTel project, but I thought it might be
+useful on its own.

Added: auto-mirror/trunk/src/Main.hs
===================================================================
--- auto-mirror/trunk/src/Main.hs	                        (rev 0)
+++ auto-mirror/trunk/src/Main.hs	2009-05-25 18:22:18 UTC (rev 1431)
@@ -0,0 +1,241 @@
+module Main where
+
+{-
+
+To follow up on my previous post ("Asynchronous Exceptions and the
+RealWorld"), I've decided to put together something more concrete in
+the hopes of eliciting response.
+
+I'm trying to write a library of higher-level concurrency
+abstractions, in particular for asynchronous systems programming.
+
+There are a number of immediate goals:
+
+- Composability and safety (intentionally vague).
+
+- Currently, the focus is on building synchronous combinators
+  (asynchronous primitives for later).
+
+- Ideally, be able to apply combinators on any existing (IO a), not
+  just procedures written for this library.
+
+Below, the running theme is process orchestration. (I've put TODOs at
+places where I'm blocked.)
+
+I'm currently worried that what I'm trying to do is impossible in
+Concurrent Haskell. I'm bewildered by the design decisions in the
+asynchronous exceptions paper. I'm also wondering if there are any
+efforts under way to reform this situation. I found some relevant
+posts below hinting at this, but I'm not sure what the status is
+today.
+
+(Something like this is straightforward to build if I abandon
+Concurrent Haskell and use cooperative threading, and if the
+operations I wanted to perform could be done asynchronously.)
+
+Relevant papers:
+
+http://citeseer.ist.psu.edu/415348.html
+http://research.microsoft.com/users/simonpj/papers/concurrent-haskell.ps.gz
+http://www.haskell.org/~simonmar/papers/web-server.ps.gz
+
+Relevant posts/threads:
+
+http://osdir.com/ml/lang.haskell.prime/2006-04/msg00032.html
+http://osdir.com/ml/lang.haskell.general/2001-11/msg00131.html
+http://www.haskell.org/pipermail/haskell-prime/2006-April/001280.html
+http://www.haskell.org/pipermail/haskell-prime/2006-April/001290.html
+http://www.nabble.com/throwTo---block-statements-considered-harmful-tf2780268.html#a7758038
+http://www.nabble.com/What-guarantees-(if-any)-do-interruptible-operations-have-in-presence-of-asynchronous-exceptions--tf2761696.html#a7699555
+
+Misc
+
+http://lambda-the-ultimate.org/node/1570
+Advanced Exception Handling Mechanisms
+http://www.springerlink.com/content/3723wg2t81248027/
+http://64.233.169.104/search?q=cache:c4pS0FDKMXcJ:www.cs.ioc.ee/tfp-icfp-gpce05/tfp-proc/06num.pdf+concurrency+interrupts+abort+safe+asynchronous+exceptions+threads&h
+http://64.233.169.104/search?q=cache:hmC-jl-iNkoJ:www.jot.fm/issues/issue_2007_11/article4.pdf+concurrency+interrupts+abort+safe+asynchronous+exceptions+threads&hl=en
+http://www.mathematik.uni-marburg.de/~eden/paper/edenEuropar03.pdf
+
+-}
+
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Control.Exception
+import Control.Monad
+import Prelude hiding (log)
+import System.IO
+import System.Posix.Signals
+import System.Process
+
+log = putStrLn
+
+startProc cmd = runCommand cmd
+stopProc  p   = terminateProcess p
+waitProc  p   = waitForProcess p
+
+-- Run a process, blocking on it until it exits. If we're interrupted,
+-- terminate the process. (IIRC, terminateProcess issues SIGTERM, and
+-- the documentation is buggy; more detailed code should go here later
+-- to retry with SIGKILL.)
+runProc cmd = do
+  log "launching proc"
+  p <- startProc cmd
+  waitProc p                -- TODO allow interrupts only at this point
+    `finally` ( log "stopping" >> stopProc p >> log "stopped" )
+
+-- Sleep for n seconds.
+timeout n = do
+  log "sleeping"
+  threadDelay (n * 1000000) -- TODO allow interrupts only at this point
+  log "waking"
+
+-- TODO is there any way to block *only* the Cancel exception? (Even
+-- if this could be done, though, it's still not a modular approach.)
+spawn :: IO a -> (a -> IO ()) -> IO ThreadId
+spawn f y = forkIO (block (f >>= y))
+
+-- The any/sum/choice combinator. On return, guarantee that both tasks
+-- have stopped.
+(<|>) :: IO a -> IO b -> IO (Either a b)
+a <|> b = do
+  result <- newEmptyMVar :: IO (MVar (Either a b))
+  tida   <- newEmptyMVar :: IO (MVar ThreadId)
+  tidb   <- newEmptyMVar :: IO (MVar ThreadId)
+
+  let yield lr x = do let name = case lr x of
+                                   Left  _ -> "a"
+                                   Right _ -> "b"
+                      log $ "saving result of " ++ name
+                      putMVar result (lr x)
+                      log $ "saved result of " ++ name
+
+                      let other = case lr x of
+                                    Left  _ -> tidb
+                                    Right _ -> tida
+                      log "taking other"
+                      t <- takeMVar other
+                      log "killing other"
+                      -- Later: replace the following with a throwTo
+                      -- so as to notify (rather than kill) the thread
+                      -- with a Cancel
+                      killThread t
+
+  ta <- spawn a (yield Left)
+  tb <- spawn b (yield Right)
+  putMVar tida ta
+  putMVar tidb tb
+
+  log "waiting for result"
+  res <- takeMVar result
+
+  -- TODO wait for both tasks to have stopped
+
+  log "returning result"
+  return res
+
+-- simple test --
+
+cmd1 = "for i in `seq 1`; do sleep 1; echo hello; done"
+cmd2 = "for i in `seq 3`; do sleep 1; echo world; done"
+
+main = do
+  -- TODO for some reason, the other 
+  result <- runProc cmd1 <|> runProc cmd2
+  case result of
+    Left  _ -> putStrLn "finished process"
+    Right _ -> putStrLn "got exception"
+
+
+
+
+---
+
+
+
+{-
+run cmd = do
+  forkProcess
+  executeFile ""
+
+pollStatus = getProcessStatus False False
+
+running p = do
+  status <- pollStatus p
+  return status == Nothing
+-}
+
+waitSignal sig yield = putStrLn "waitSig" >>
+  -- installHandler sig Ignore Nothing
+  installHandler sig (Catch (yield ())) Nothing >> return ()
+
+
+
+
+
+
+-- cmd = "wget -N -P dldir --no-remove-listing 'ftp://ftpuser:password@128.30.76.78/icedb/*'"
+-- cmd = "wget ftp://ftp.ibiblio.org/pub/linux/distributions/archlinux/iso/2007.08/x86_64/Archlinux-x86_64-2007.08-2.core.iso"
+
+
+{-
+
+main = do
+  tid <- forkIO $ sleepIO -- netIO -- spinIO
+  threadDelay 1000000
+  putStrLn "killing"
+  killThread tid
+
+sleepIO = do
+  threadDelay 10000000
+  putStrLn "awake"
+
+netIO = do
+  block $ do
+    h <- connectTo "127.0.0.1" (PortNumber 9876)
+    putStrLn "connected"
+    forM_ [1..] $ \_ -> do
+      hPutStr h "." -- this is not interruptible, yet...
+      -- hPutStr h $ replicate 8192 '.' -- this is interruptible!
+      hFlush h
+    putStrLn "wrote"
+    s <- hGetContents h
+    print (length s)
+
+spinIO = do
+  block $ do
+    spin
+    x <- connectTo "1.1.1.1" (PortNumber 1)
+    putStrLn "connect done (should not be here)"
+
+spin = do
+  print $ length $ map (**2) [1.0 .. 9999999.0]
+  putStrLn "spin done"
+
+-}
+
+{-
+import Control.Concurrent
+import Network.FTP.Client
+
+main = do
+--  installHandler
+  tid <- myThreadId
+  forkIO $ watchdog tid
+  beta
+
+watchdog tid = do
+  threadDelay 1000000
+  putStrLn "killing"
+  killThread tid
+
+beta = do
+  enableFTPDebugging
+  h <- easyConnectFTP "1.1.1.1" -- "ftp.kernel.org"
+  loginAnon h
+  cwd h "/pub/linux/kernel/Historic"
+  nlst h Nothing >>= putStrLn . unlines
+  getbinary h "linux-0.01.tar.gz.sign" >>= putStrLn . fst
+  dir h Nothing >>= putStrLn . unlines
+  quit h
+-}
\ No newline at end of file

Added: auto-mirror/trunk/src/Makefile
===================================================================
--- auto-mirror/trunk/src/Makefile	                        (rev 0)
+++ auto-mirror/trunk/src/Makefile	2009-05-25 18:22:18 UTC (rev 1431)
@@ -0,0 +1,7 @@
+all: Main
+
+Main: Main.hs
+	ghc --make -threaded Main.hs
+
+clean:
+	rm -f Main

Added: auto-mirror/trunk/src/download.bash
===================================================================
--- auto-mirror/trunk/src/download.bash	                        (rev 0)
+++ auto-mirror/trunk/src/download.bash	2009-05-25 18:22:18 UTC (rev 1431)
@@ -0,0 +1,29 @@
+#!/usr/bin/env bash
+
+trap '' USR1
+
+set -o errexit
+set -o nounset
+
+url='ftp://ftpuser:password@128.30.76.78/icedb/*'
+killed=
+
+handle() {
+  echo 'handling sigusr1' $wget
+  kill $wget
+  killed=1
+}
+
+while true ; do
+  trap '' USR1
+  wget -q -N --no-remove-listing -P /dldir "$url" &
+  wget=$!
+  trap handle USR1
+  wait $wget
+  break
+  # trap - USR1
+done
+
+echo done
+
+# vim:et:sw=2:ts=2


Property changes on: auto-mirror/trunk/src/download.bash
___________________________________________________________________
Added: svn:executable
   + *


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.