[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:46:04 UTC 2010
The following commit has been merged in the master branch:
commit b84e8e2d7eeb8b5f094e0a676fb5d3fbf0052da1
Author: John Goerzen <jgoerzen at complete.org>
Date: Wed Oct 27 02:13:17 2004 +0100
Checkpointing sendmail support
Keywords:
(jgoerzen at complete.org--projects/missingh--head--0.5--patch-8)
diff --git a/ChangeLog b/ChangeLog
index a9a3835..51fd788 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,25 @@
# arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.5
#
+2004-10-26 20:13:17 GMT John Goerzen <jgoerzen at complete.org> patch-8
+
+ Summary:
+ Checkpointing sendmail support
+ Revision:
+ missingh--head--0.5--patch-8
+
+
+ new files:
+ libsrc/MissingH/Email/.arch-ids/=id
+ libsrc/MissingH/Email/Sendmail.hs
+
+ modified files:
+ ChangeLog Setup.description libsrc/MissingH/Cmd.hs
+
+ new directories:
+ libsrc/MissingH/Email libsrc/MissingH/Email/.arch-ids
+
+
2004-10-25 19:51:57 GMT John Goerzen <jgoerzen at complete.org> patch-7
Summary:
diff --git a/Setup.description b/Setup.description
index 0154d46..bcaf3e3 100644
--- a/Setup.description
+++ b/Setup.description
@@ -10,6 +10,7 @@ Modules: MissingH.IO, MissingH.IO.Binary, MissingH.List,
MissingH.Logging.Handler.Simple, MissingH.Logging.Handler.Syslog,
MissingH.Logging.Logger,
MissingH.Threads,
+ MissingH.Email.Sendmail,
MissingH.Hsemail.Rfc2234, MissingH.Hsemail.Rfc2821,
MissingH.Hsemail.Rfc2822,
MissingH.Str,
diff --git a/libsrc/MissingH/Cmd.hs b/libsrc/MissingH/Cmd.hs
index f22360a..e0419b8 100644
--- a/libsrc/MissingH/Cmd.hs
+++ b/libsrc/MissingH/Cmd.hs
@@ -31,12 +31,20 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Written by John Goerzen, jgoerzen\@complete.org
-}
-module MissingH.Cmd(safeSystem)
+module MissingH.Cmd(PipeMode(..),
+ safeSystem,
+ pOpen, pOpen3)
where
import System.Exit
import System.Cmd
import MissingH.Logging.Logger
+import System.Posix.IO
+import System.Posix.Process
+import System.Posix.Types
+import System.IO
+
+data PipeMode = ReadFromPipe | WriteToPipe
logbase = "MissingH.Cmd"
@@ -47,6 +55,7 @@ raises a userError with the problem.
Command lines executed will be logged using "MissingH.Logging.Logger" at the
DEBUG level. Failure messages will be logged at the WARNING level in addition
to being raised as an exception. Both are logged under
+\"MissingH.Cmd.funcname\" -- for instance,
\"MissingH.Cmd.safeSystem\". If you wish to suppress these messages
globally, you can simply run:
@@ -68,7 +77,7 @@ safeSystem command args =
ExitSuccess -> return ()
ExitFailure fc -> cmdfailed command args fc
-cmdfailed :: FilePath -> [String] -> Int -> IO ()
+cmdfailed :: FilePath -> [String] -> Int -> IO a
cmdfailed command args failcode = do
let errormsg = "Command " ++ command ++ " " ++ (show args) ++
" failed; exit code " ++ (show failcode)
@@ -76,4 +85,83 @@ cmdfailed command args failcode = do
warningM (logbase ++ ".safeSystem") errormsg
ioError e
+{- | Open a pipe to the specified command.
+
+Passes the handle on to the specified function.
+The 'PipeMode' specifies what you will be doing. That is, specifing 'ReadFromPipe'
+sets up a pipe from stdin, and 'WriteToPipe' sets up a pipe from stdout.
+
+FIXME: this slowly leaks FDs!
+ -}
+pOpen :: PipeMode -> FilePath -> [String] ->
+ (Handle -> IO a) -> IO a
+pOpen pm fp args func =
+ do
+ pipepair <- createPipe
+ print pipepair
+ fsth <- fdToHandle (fst pipepair)
+ sndh <- fdToHandle (snd pipepair)
+ case pm of
+ ReadFromPipe -> do
+ let callfunc = do
+ --hClose sndh
+ x <- func fsth
+ hClose fsth
+ return x
+ pOpen3 Nothing (Just (snd pipepair)) Nothing fp args
+ callfunc
+ WriteToPipe -> do
+ let callfunc = do
+ print 112
+ --hClose fsth
+ print 114
+ x <- func sndh
+ print 116
+ hClose sndh
+ print 118
+ return x
+ pOpen3 (Just (fst pipepair)) Nothing Nothing fp args
+ callfunc
+
+{- | Runs a command, redirecting things to pipes. -}
+pOpen3 :: Maybe Fd -- ^ Send stdin to this fd
+ -> Maybe Fd -- ^ Get stdout from this fd
+ -> Maybe Fd -- ^ Get stderr from this fd
+ -> FilePath -- ^ Command to run
+ -> [String] -- ^ Command args
+ -> IO a -- ^ Action to run
+ -> IO a
+pOpen3 pin pout perr fp args func =
+ let mayberedir Nothing _ = return ()
+ mayberedir (Just fromfd) tofd = do
+ dupTo fromfd tofd
+ return ()
+ childstuff = do
+ putStrLn "child 123"
+ putStrLn ("child " ++ fp)
+ mayberedir pin stdInput
+ mayberedir pout stdOutput
+ mayberedir perr stdError
+ putStrLn "child 127"
+ debugM (logbase ++ ".pOpen3")
+ ("Running: " ++ fp ++ " " ++ (show args))
+ putStrLn "child 130"
+ executeFile fp True args Nothing
+ putStrLn "child 132"
+ exitFailure
+ in
+ do
+ pid <- forkProcess childstuff
+ putStrLn "Parent 138"
+ retval <- func
+ putStrLn "Parent 140"
+ status <- getProcessStatus True False pid
+ putStrLn "Parent 142"
+ case status of
+ Nothing -> fail "Got no process status back"
+ Just (Exited (ExitSuccess)) -> return retval
+ Just (Exited (ExitFailure fc)) -> cmdfailed fp args fc
+ Just (Terminated sig) -> fail ("Command terminated by signal" ++ show sig)
+ Just (Stopped sig) -> fail ("Command stopped by signal" ++ show sig)
+
\ No newline at end of file
diff --git a/libsrc/MissingH/Email/Sendmail.hs b/libsrc/MissingH/Email/Sendmail.hs
new file mode 100644
index 0000000..cc83a43
--- /dev/null
+++ b/libsrc/MissingH/Email/Sendmail.hs
@@ -0,0 +1,97 @@
+{- arch-tag: Sendmail utility
+Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+-}
+
+{- |
+ Module : MissingH.Email.Sendmail
+ Copyright : Copyright (C) 2004 John Goerzen
+ License : GNU GPL, version 2 or above
+
+ Maintainer : John Goerzen,
+ Maintainer : jgoerzen at complete.org
+ Stability : provisional
+ Portability: portable
+
+This Haskell module provides an interface to transmitting a mail message.
+
+Written by John Goerzen, jgoerzen\@complete.org
+-}
+
+module MissingH.Email.Sendmail(sendmail)
+where
+
+import MissingH.Cmd
+import System.Directory
+import System.IO
+
+sendmails = ["/usr/sbin/sendmail",
+ "/usr/local/sbin/sendmail",
+ "/usr/local/bin/sendmail",
+ "/usr/bin/sendmail",
+ "/etc/sendmail",
+ "/usr/etc/sendmail"]
+
+findsendmail :: IO String
+findsendmail =
+ let worker [] = return "sendmail"
+ worker (this:next) =
+ do
+ e <- doesFileExist this
+ if e then
+ do
+ p <- getPermissions this
+ if executable p then
+ return this
+ else worker next
+ else worker next
+ in
+ worker sendmails
+
+{- | Transmits an e-mail message using the system's mail transport agent.
+
+This function takes a message, a list of recipients, and an optional sender,
+and transmits it using the system's MTA, sendmail.
+
+If @sendmail@ is on the @PATH@, it will be used; otherwise, a list of system
+default locations will be searched.
+
+A failure will be logged, since this function uses 'MissingH.Cmd.safeSystem'
+internally. -}
+sendmail :: Maybe String -- ^ The envelope from address. If not specified, takes the system's default, which is usually based on the effective userid of the current process. This is not necessarily what you want, so I recommend specifying it.
+ -> [String] -- ^ A list of recipients for your message. An empty list is an error.
+ -> String -- ^ The message itself.
+ -> IO ()
+sendmail _ [] _ = fail "sendmail: no recipients specified"
+sendmail Nothing recipients msg = sendmail_worker recipients msg
+sendmail (Just from) recipients msg =
+ sendmail_worker (("-f" ++ from) : recipients) msg
+
+sendmail_worker :: [String] -> String -> IO ()
+sendmail_worker args msg =
+ let func h = do
+ print "I am the func!"
+ hPutStr h msg
+ print "Func ending!"
+ in
+ do
+ pOpen WriteToPipe "/usr/sbin/sendmail" args func
+ {-
+ catch (pOpen WriteToPipe "sendmail" args func)
+ (\_ -> do
+ sn <- findsendmail
+ pOpen WriteToPipe sn args func) -}
+
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list