[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:53:41 UTC 2010
The following commit has been merged in the master branch:
commit ee39f53755296ecc06a1943506cfd6fffa4f2bfa
Author: John Goerzen <jgoerzen at complete.org>
Date: Thu Dec 23 09:53:10 2004 +0100
Checkpointing nlst
Keywords:
(jgoerzen at complete.org--projects/missingh--head--0.7--patch-152)
diff --git a/ChangeLog b/ChangeLog
index 02160be..89abf8c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,18 @@
# arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.7
#
+2004-12-23 02:53:10 GMT John Goerzen <jgoerzen at complete.org> patch-152
+
+ Summary:
+ Checkpointing nlst
+ Revision:
+ missingh--head--0.7--patch-152
+
+
+ modified files:
+ ChangeLog libsrc/MissingH/Network/FTP/Server.hs
+
+
2004-12-23 01:52:48 GMT John Goerzen <jgoerzen at complete.org> patch-151
Summary:
diff --git a/libsrc/MissingH/Network/FTP/Server.hs b/libsrc/MissingH/Network/FTP/Server.hs
index b039022..011238f 100644
--- a/libsrc/MissingH/Network/FTP/Server.hs
+++ b/libsrc/MissingH/Network/FTP/Server.hs
@@ -167,6 +167,7 @@ commands =
,("STOR", (forceLogin cmd_stor, help_stor))
,("STAT", (forceLogin cmd_stat, help_stat))
,("SYST", (forceLogin cmd_syst, help_syst))
+ ,("NLST", (forceLogin cmd_nlst, help_nlst))
]
commandLoop :: FTPServer -> IO ()
@@ -395,37 +396,57 @@ cmd_stor h@(FTPServer _ fs state) args =
)
)
+rtransmitString :: String -> FTPServer -> Socket -> IO ()
+rtransmitString thestr (FTPServer _ _ state) sock =
+ let fixlines :: [String] -> [String]
+ fixlines x = map (\y -> y ++ "\r") x
+ copyit h =
+ hPutStrLn h $ unlines . fixlines . lines $ thestr
+ in
+ do writeh <- socketToHandle sock WriteMode
+ hSetBuffering writeh (BlockBuffering (Just 4096))
+ mode <- readIORef (datatype state)
+ case mode of
+ ASCII -> finally (copyit writeh)
+ (hClose writeh)
+ Binary -> finally (hPutStr writeh thestr)
+ (hClose writeh)
+
+rtransmitH :: HVFSOpenEncap -> FTPServer -> Socket -> IO ()
+rtransmitH fhencap h sock =
+ case fhencap of
+ HVFSOpenEncap fh ->
+ finally (do c <- vGetContents fh
+ rtransmitString c h sock
+ ) (vClose fh)
+
+genericTransmit :: FTPServer -> a -> (a -> FTPServer -> Socket -> IO ()) -> IO Bool
+genericTransmit h dat func =
+ trapIOError h
+ (do sendReply h 150 "I'm going to open the data channel now."
+ runDataChan h (func dat)
+ ) (\_ ->
+ do sendReply h 226 "Closing data connection; transfer complete."
+ return True
+ )
+
+genericTransmitHandle :: FTPServer -> HVFSOpenEncap -> IO Bool
+genericTransmitHandle h dat =
+ genericTransmit h dat rtransmitH
+
+genericTransmitString :: FTPServer -> String -> IO Bool
+genericTransmitString h dat =
+ genericTransmit h dat rtransmitString
+
+
help_retr = ("Retrieve a file", "")
cmd_retr :: CommandHandler
cmd_retr h@(FTPServer _ fs state) args =
- let runit fhencap _ sock =
- case fhencap of
- HVFSOpenEncap fh ->
- do writeh <- socketToHandle sock WriteMode
- mode <- readIORef (datatype state)
- case mode of
- ASCII -> finally (hLineInteract fh writeh
- (\x -> map (\y -> y ++ "\r") x))
- (hClose writeh)
- Binary -> finally (do vSetBuffering fh (BlockBuffering (Just 4096))
- hCopy fh writeh
- ) (hClose writeh)
- in
if length args < 1
then do sendReply h 501 "Filename required"
return True
- else trapIOError h (vOpen fs args ReadMode) (\fhencap ->
- trapIOError h (do sendReply h 150 "File OK; about to open data channel"
- (runDataChan h (runit fhencap))) $
- (\_ ->
- do case fhencap of
- HVFSOpenEncap fh -> vClose fh
- sendReply h 226 "Closing data connection; transfer complete."
- return True
- )
- )
-
-
+ else trapIOError h (vOpen fs args ReadMode)
+ (\fhencap -> genericTransmitHandle h fhencap)
help_rnto = ("Specify TO name for a file name", "")
cmd_rnto :: CommandHandler
@@ -455,6 +476,16 @@ cmd_dele h@(FTPServer _ fs _) args =
\_ -> do sendReply h 250 $ "File " ++ args ++ " deleted."
return True
+help_nlst = ("Get plain listing of files", "")
+cmd_nlst :: CommandHandler
+cmd_nlst h@(FTPServer _ fs _) args =
+ let fn = case args of
+ "" -> "."
+ x -> x
+ in
+ trapIOError h (vGetDirectoryContents fs fn)
+ (\l -> genericTransmitString h (unlines l))
+
help_rmd = ("Remove directory", "")
cmd_rmd :: CommandHandler
cmd_rmd h@(FTPServer _ fs _) args =
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list