[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 3b296fe5b066db8c34ecc32a13e35b162a7cd294
Author: John Goerzen <jgoerzen at complete.org>
Date:   Thu Dec 23 05:43:42 2004 +0100

    Upload works
    
    Keywords:
    
    
    (jgoerzen at complete.org--projects/missingh--head--0.7--patch-150)

diff --git a/ChangeLog b/ChangeLog
index 1fa1164..f13cf32 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,18 @@
 # arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.7
 #
 
+2004-12-22 22:43:42 GMT	John Goerzen <jgoerzen at complete.org>	patch-150
+
+    Summary:
+      Upload works
+    Revision:
+      missingh--head--0.7--patch-150
+
+
+    modified files:
+     ChangeLog libsrc/MissingH/Network/FTP/Server.hs
+
+
 2004-12-22 22:23:24 GMT	John Goerzen <jgoerzen at complete.org>	patch-149
 
     Summary:
diff --git a/libsrc/MissingH/Network/FTP/Server.hs b/libsrc/MissingH/Network/FTP/Server.hs
index 3f97c89..21d6db4 100644
--- a/libsrc/MissingH/Network/FTP/Server.hs
+++ b/libsrc/MissingH/Network/FTP/Server.hs
@@ -164,6 +164,7 @@ commands =
     ,("PASV", (forceLogin cmd_pasv,  help_pasv))
     ,("PORT", (forceLogin cmd_port,  help_port))
     ,("RETR", (forceLogin cmd_retr,  help_retr))
+    ,("STOR", (forceLogin cmd_stor,  help_stor))
     ]
 
 commandLoop :: FTPServer -> IO ()
@@ -354,6 +355,44 @@ cmd_rnfr h@(FTPServer _ _ state) args =
                sendReply h 350 "Noted rename from name; please send RNTO."
                return True
 
+help_stor = ("Upload a file", "")
+cmd_stor :: CommandHandler
+cmd_stor h@(FTPServer _ fs state) args =
+    let datamap :: [String] -> [String]
+        datamap instr =
+            let linemap :: String -> String
+                linemap x = if endswith "\r" x
+                              then take ((length x) - 1) x
+                              else x
+                in map linemap instr
+        runit fhencap _ sock =
+            case fhencap of
+              HVFSOpenEncap fh ->
+                  do readh <- socketToHandle sock ReadMode
+                     mode <- readIORef (datatype state)
+                     case mode of
+                      ASCII -> finally (hLineInteract readh fh datamap)
+                                       (hClose readh)
+                      Binary -> finally (do vSetBuffering fh (BlockBuffering (Just 4096))
+                                            hCopy readh fh
+                                        ) (hClose readh)
+        in
+        if length args < 1
+           then do sendReply h 501 "Filename required"
+                   return True
+           else trapIOError h (vOpen fs args WriteMode) 
+                  (\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
+                                   )
+                   )
+
 help_retr = ("Retrieve a file", "")
 cmd_retr :: CommandHandler
 cmd_retr h@(FTPServer _ fs state) args =

-- 
haskell-testpack