[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 cf76e365d365cfa61ed9ecafb93b7c6800dbd2b7
Author: John Goerzen <jgoerzen at complete.org>
Date:   Sat Oct 23 22:57:55 2004 +0100

    Checkpointing for fix
    
    Keywords:
    
    
    (jgoerzen at complete.org--projects/missingh--head--1.0--patch-106)

diff --git a/ChangeLog b/ChangeLog
index e6a5364..adb0302 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,18 @@
 # arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--1.0
 #
 
+2004-10-23 16:57:55 GMT	John Goerzen <jgoerzen at complete.org>	patch-106
+
+    Summary:
+      Checkpointing for fix
+    Revision:
+      missingh--head--1.0--patch-106
+
+
+    modified files:
+     ChangeLog Makefile libsrc/MissingH/Network/FTP/Client.hs
+
+
 2004-10-23 16:06:52 GMT	John Goerzen <jgoerzen at complete.org>	patch-105
 
     Summary:
diff --git a/Makefile b/Makefile
index 8485646..7d74cc5 100644
--- a/Makefile
+++ b/Makefile
@@ -56,6 +56,9 @@ test-hugs:
 interact-hugs:
 	hugs -98 -P:$(PWD)/libsrc
 
+interact-ghci: all
+	ghci -ilibsrc
+
 interact: interact-hugs
 
 test: test-ghc6 test-hugs
diff --git a/libsrc/MissingH/Network/FTP/Client.hs b/libsrc/MissingH/Network/FTP/Client.hs
index 8b93ae5..ee147a9 100644
--- a/libsrc/MissingH/Network/FTP/Client.hs
+++ b/libsrc/MissingH/Network/FTP/Client.hs
@@ -48,7 +48,8 @@ Useful standards:
 
 -}
 
-module MissingH.Network.FTP.Client(
+module MissingH.Network.FTP.Client(easyConnectTo, connectTo,
+                                   loginAnon, login
                        )
 where
 import MissingH.Network.FTP.Parser
@@ -65,23 +66,65 @@ getresp h = do c <- hGetContents h
 -}
 
 getresp = debugParseGoodReplyHandle
+unexpectedresp m r = error ("Expected " ++ m ++ ", got " ++ (show r))
 
-sendcmd h c = hPutStr h (c ++ "\r\n")
+isxresp desired (r, _) = r >= desired && r < (desired + 100)
+
+forcexresp desired r = if isxresp desired r
+                       then r
+                       else error (show desired)
+
+sendcmd h c = do hPutStr h (c ++ "\r\n")
+                 getresp h
 
 {- | Connect to the remote FTP server and read but discard
    the welcome.  Assumes
    default FTP port, 21, on remote. -}
-easyConnectTo :: Network.HostName -> IO Handle
+easyConnectTo :: Network.HostName -> IO FTPConnection
 easyConnectTo h = do x <- connectTo h (Network.PortNumber 21)
-                     return (fst x)
+                     let h = (fst x)
+                     -- hPutStr h "foo"
+                     return h
 
 {- | Connect to remote FTP server and read the welcome. -}
-connectTo :: Network.HostName -> Network.PortID -> IO (Handle, FTPResult)
+connectTo :: Network.HostName -> Network.PortID -> IO (FTPConnection, FTPResult)
 connectTo h p =
     do
     updateGlobalLogger "MissingH.Network.FTP.Parser" (setLevel DEBUG)
     h <- Network.connectTo h p
-    hSetBuffering h LineBuffering
+    --hIsReadable h >>= print
+    --hIsWritable h >>= print
+    -- hSetBuffering h LineBuffering
     r <- getresp h
-    --r `seq` return (h, r)
-    return (h, r)
+    -- hPutStr h "foo"
+    r `seq` return (h, r)
+    --return (h, r)
+
+{- | Log in anonymously. -}
+loginAnon :: FTPConnection -> IO FTPResult
+loginAnon h = login h "anonymous" (Just "anonymous@") Nothing
+
+{- | Log in to an FTP account. -}
+login :: FTPConnection                  -- ^ Connection
+         -> String                         -- ^ Username
+         -> Maybe String                -- ^ Password
+         -> Maybe String                -- ^ Account (rarely used)
+         -> IO FTPResult
+login h user pass acct =
+    do
+    ur <- sendcmd h ("USER " ++ user)
+    if isxresp 300 ur then
+       case pass of
+            Nothing -> error "FTP server demands password, but no password given"
+            Just p -> do pr <- sendcmd h ("PASS " ++ p)
+                         if isxresp 300 pr then
+                            case acct of
+                                Nothing -> error "FTP server demands account, but no account given"
+                                Just a -> do ar <- sendcmd h ("ACCT " ++ a)
+                                             return (forcexresp 200 ar)
+                                             return ar
+                            else return $ forcexresp 200 pr
+       else return $ forcexresp 200 ur
+
+            
+      
\ No newline at end of file

-- 
haskell-testpack