[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 71fdf23623c6d9e93692800046eb923692f87f82
Author: John Goerzen <jgoerzen at complete.org>
Date:   Wed Dec 22 03:42:42 2004 +0100

    Now traps errors
    
    Keywords:
    
    
    (jgoerzen at complete.org--projects/missingh--head--0.7--patch-133)

diff --git a/ChangeLog b/ChangeLog
index 042e402..e80a5f2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,18 @@
 # arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.7
 #
 
+2004-12-21 20:42:42 GMT	John Goerzen <jgoerzen at complete.org>	patch-133
+
+    Summary:
+      Now traps errors
+    Revision:
+      missingh--head--0.7--patch-133
+
+
+    modified files:
+     ChangeLog libsrc/MissingH/Network/FTP/Server.hs
+
+
 2004-12-21 20:01:55 GMT	John Goerzen <jgoerzen at complete.org>	patch-132
 
     Summary:
diff --git a/libsrc/MissingH/Network/FTP/Server.hs b/libsrc/MissingH/Network/FTP/Server.hs
index f306535..41bac89 100644
--- a/libsrc/MissingH/Network/FTP/Server.hs
+++ b/libsrc/MissingH/Network/FTP/Server.hs
@@ -97,6 +97,14 @@ instance Eq Command where
 instance Ord Command where
     compare x y = compare (fst x) (fst y)
 
+trapIOError :: FTPServer -> IO a -> (a -> IO Bool) -> IO Bool
+trapIOError h testAction remainingAction =
+    do result <- try testAction
+       case result of
+         Left err -> do sendReply h 550 (show err)
+                        return True
+         Right result -> remainingAction result
+
 forceLogin :: CommandHandler -> CommandHandler
 forceLogin func h@(FTPServer _ _ stateref) sa args =
     do state <- readIORef stateref
@@ -128,7 +136,7 @@ commandLoop h@(FTPServer fh _ _) sa =
                                     return True
                      Right (cmd, args) -> 
                          case lookup cmd commands of
-                            Nothing -> do sendReply h 500 $
+                            Nothing -> do sendReply h 502 $
                                            "Unrecognized command " ++ cmd
                                           return True
                             Just hdlr -> (fst hdlr) h sa args
@@ -189,10 +197,11 @@ help_cwd =
 
 cmd_cwd :: CommandHandler
 cmd_cwd h@(FTPServer _ fs _) _ args =
-    do vSetCurrentDirectory fs args
-       newdir <- vGetCurrentDirectory fs
-       sendReply h 250 $ "New directory now " ++ newdir
-       return True
+    do trapIOError h (vSetCurrentDirectory fs args)
+         $ \_ -> do
+                 newdir <- vGetCurrentDirectory fs
+                 sendReply h 250 $ "New directory now " ++ newdir
+                 return True
 
 help_help =
     ("Display help on available commands",

-- 
haskell-testpack