[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36

[John Goerzen]

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