[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 51ec3dfcc98f67f3c458ec035523d3ad8e2e652b
Author: John Goerzen <jgoerzen at complete.org>
Date:   Wed Dec 22 00:21:22 2004 +0100

    Checkpointing
    
    Keywords:
    
    
    (jgoerzen at complete.org--projects/missingh--head--0.7--patch-127)

diff --git a/ChangeLog b/ChangeLog
index 052ec55..d0ef643 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,19 @@
 # arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.7
 #
 
+2004-12-21 17:21:22 GMT	John Goerzen <jgoerzen at complete.org>	patch-127
+
+    Summary:
+      Checkpointing
+    Revision:
+      missingh--head--0.7--patch-127
+
+
+    modified files:
+     ChangeLog TODO libsrc/MissingH/Network/FTP/ParserServer.hs
+     libsrc/MissingH/Network/FTP/Server.hs
+
+
 2004-12-21 16:37:11 GMT	John Goerzen <jgoerzen at complete.org>	patch-126
 
     Summary:
diff --git a/TODO b/TODO
index 91d0b89..c55555f 100644
--- a/TODO
+++ b/TODO
@@ -9,3 +9,6 @@ HVFStest:
   test all sorts of exceptions
   test .. et al
 
+FTP server:
+  timeouts
+
diff --git a/libsrc/MissingH/Network/FTP/ParserServer.hs b/libsrc/MissingH/Network/FTP/ParserServer.hs
index 994914f..9b2b361 100644
--- a/libsrc/MissingH/Network/FTP/ParserServer.hs
+++ b/libsrc/MissingH/Network/FTP/ParserServer.hs
@@ -35,6 +35,7 @@ Written by John Goerzen, jgoerzen\@complete.org
 -}
 
 module MissingH.Network.FTP.ParserServer(
+                                         parseCommand
                                         )
 where
 import MissingH.Network.FTP.ParserClient
@@ -50,7 +51,7 @@ import System.IO(hGetLine)
 import Text.Regex
 import Data.Word
 import MissingH.Hsemail.Rfc2234(alpha)
-type FTPResult = (Int, [String])
+import Data.Char
 
 logit :: String -> IO ()
 logit m = debugM "MissingH.Network.FTP.ParserServer" ("FTP received: " ++ m)
@@ -74,14 +75,12 @@ command = do
           x <- word
           y <- args
           eof
-          return (x, y)
+          return (map toUpper x, y)
 
 
-parseCommand :: Handle -> IO (String, String)
+parseCommand :: Handle -> IO (Either ParseError (String, String))
 parseCommand h =
     do input <- hGetLine h
-       case parse command "(unknown)" (rstrip input) of
-          Left err -> fail ("FTP: " ++ (show err))
-          Right reply -> return reply
+       return $ parse command "(unknown)" (rstrip input)
 
        
\ No newline at end of file
diff --git a/libsrc/MissingH/Network/FTP/Server.hs b/libsrc/MissingH/Network/FTP/Server.hs
index 98e6130..3673991 100644
--- a/libsrc/MissingH/Network/FTP/Server.hs
+++ b/libsrc/MissingH/Network/FTP/Server.hs
@@ -34,6 +34,7 @@ Written by John Goerzen, jgoerzen\@complete.org
 -}
 
 module MissingH.Network.FTP.Server(
+                                   ftpHandler
                                   )
 where
 import MissingH.Network.FTP.ParserServer
@@ -46,11 +47,14 @@ import MissingH.Network
 import MissingH.Str
 import MissingH.Printf
 import MissingH.IO.HVIO
+import Data.Char
+import MissingH.Printf
 
 s_crlf = "\r\n"
 ftpPutStrLn :: Handle -> String -> IO ()
 ftpPutStrLn h text =
-    hPutStr h (text ++ s_crlf)
+    do hPutStr h (text ++ s_crlf)
+       hFlush h
 
 {- | Send a reply code, handling multi-line text as necessary. -}
 sendReply :: Handle -> Int -> String -> IO ()
@@ -62,3 +66,81 @@ sendReply h codei text =
                                  writethis xs
         in 
         writethis (map (rstrip) (lines text))
+
+{- | Main FTP handler; pass this to 
+'MissingH.Network.SocketServer.handleHandler' -}
+
+ftpHandler :: Handle -> SockAddr -> IO ()
+ftpHandler h sa =
+    traplogging "MissingH.Network.FTP.Server" NOTICE "" $
+       do sendReply h 220 "Welcome to MissingH.Network.FTP.Server."
+          commandLoop h sa
+
+type CommandHandler = Handle -> SockAddr -> String -> IO Bool
+
+commands :: [(String, (CommandHandler, (String, String)))]
+commands =
+    [("HELP", (cmd_help, help_help))
+    ]
+
+commandLoop :: Handle -> SockAddr -> IO ()
+commandLoop h sa =
+    let errorhandler e = do noticeM "MissingH.Network.FTP.Server"
+                                    ("Closing due to error: " ++ (show e))
+                            hClose h
+                            return False
+        in do continue <- (flip catch) errorhandler 
+               (do x <- parseCommand h
+                   case x of
+                     Left err -> do sendReply h 500 $
+                                      "Couldn't parse command: " ++ (show err)
+                                    return True
+                     Right (cmd, args) -> 
+                         case lookup cmd commands of
+                            Nothing -> do sendReply h 500 $
+                                           "Unrecognized command " ++ cmd
+                                          return True
+                            Just hdlr -> (fst hdlr) h sa args
+               )
+              if continue
+                 then commandLoop h sa
+                 else return ()
+
+help_help =
+    ("Display help on available commands",
+     "When called without arguments, shows a summary of available system\n"
+     ++ "commands.  When called with an argument, shows detailed information\n"
+     ++ "on that specific command.")
+
+cmd_help :: CommandHandler
+cmd_help h sa args =
+    let genericreply addr = unlines $
+          ["Welcome to the FTP server, " ++ addr ++ "."
+          ,"This server is implemented as the MissingH.Network.FTP.Server"
+          ,"component of the MissingH library.  The MissingH library"
+          ,"is available from http://quux.org/devel/missingh."
+          ,""
+          ,""
+          ,"I know of the following commands:"
+          ,concatMap (\ (name, (_, (summary, _))) -> vsprintf "%-10s %s\n" name summary)
+              commands
+          ,""
+          ,"You may type \"HELP command\" for more help on a specific command."
+          ]
+        in
+        if args == ""
+           then do sastr <- showSockAddr sa
+                   sendReply h 214 (genericreply sastr)
+                   return True
+           else let newargs = map toUpper args
+                    in case lookup newargs commands of
+                         Nothing -> do 
+                                    sendReply h 214 $ "No help for \"" ++ newargs
+                                      ++ "\" is available.\nPlese send HELP"
+                                      ++ " without arguments for a list of\n"
+                                      ++ "valid commands."
+                                    return True
+                         Just (_, (summary, detail)) ->
+                             do sendReply h 214 $ newargs ++ ": " ++ summary ++ 
+                                               "\n\n" ++ detail
+                                return True

-- 
haskell-testpack