[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36
John Goerzen
jgoerzen at complete.org
Fri Apr 23 14:53:34 UTC 2010
The following commit has been merged in the master branch:
commit 5c721d2c136843b6f5686e71c0f86075b6f19656
Author: John Goerzen <jgoerzen at complete.org>
Date: Thu Dec 23 05:17:09 2004 +0100
Got RETR written!
Keywords:
(jgoerzen at complete.org--projects/missingh--head--0.7--patch-148)
diff --git a/ChangeLog b/ChangeLog
index dd4a501..0a4cdd2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,20 @@
# arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.7
#
+2004-12-22 22:17:09 GMT John Goerzen <jgoerzen at complete.org> patch-148
+
+ Summary:
+ Got RETR written!
+ Revision:
+ missingh--head--0.7--patch-148
+
+
+ modified files:
+ ChangeLog TODO libsrc/MissingH/IO.hs
+ libsrc/MissingH/IO/HVIO.hs
+ libsrc/MissingH/Network/FTP/Server.hs
+
+
2004-12-22 19:49:29 GMT John Goerzen <jgoerzen at complete.org> patch-147
Summary:
diff --git a/TODO b/TODO
index c55555f..c3e8431 100644
--- a/TODO
+++ b/TODO
@@ -11,4 +11,5 @@ HVFStest:
FTP server:
timeouts
+ Proper error checking lots of places, esp. runDataChan
diff --git a/libsrc/MissingH/IO.hs b/libsrc/MissingH/IO.hs
index acb5492..7fd6056 100644
--- a/libsrc/MissingH/IO.hs
+++ b/libsrc/MissingH/IO.hs
@@ -52,13 +52,14 @@ module MissingH.IO(-- * Entire File\/Handle Utilities
import System.IO.Unsafe
import System.IO
import Data.List
+import MissingH.IO.HVIO
{- | Given a list of strings, output a line containing each item, adding
newlines as appropriate. The list is not expected to have newlines already.
-}
-hPutStrLns :: Handle -> [String] -> IO ()
-hPutStrLns h = mapM_ $ hPutStrLn h
+hPutStrLns :: HVIO a => a -> [String] -> IO ()
+hPutStrLns h = mapM_ $ vPutStrLn h
{- | Given a handle, returns a list of all the lines in that handle.
Thanks to lazy evaluation, this list does not have to be read all at once.
@@ -75,13 +76,13 @@ Example:
-}
-- FIXME does hGetContents h >>= return.lines not work?
-hGetLines :: Handle -> IO [String]
+hGetLines :: HVIO a => a -> IO [String]
hGetLines h = unsafeInterleaveIO (do
- ieof <- hIsEOF h
+ ieof <- vIsEOF h
if (ieof)
then return []
else do
- line <- hGetLine h
+ line <- vGetLine h
remainder <- hGetLines h
return (line : remainder)
)
@@ -131,7 +132,7 @@ Though the actual implementation is this for efficiency:
> hPutStrLns foutput (func lines)
-}
-hLineInteract :: Handle -> Handle -> ([String] -> [String]) -> IO ()
+hLineInteract :: (HVIO a, HVIO b) => a -> b -> ([String] -> [String]) -> IO ()
hLineInteract finput foutput func =
do
lines <- hGetLines finput
@@ -140,10 +141,10 @@ hLineInteract finput foutput func =
{- | Copies from one handle to another in raw mode (using
hGetContents).
-}
-hCopy :: Handle -> Handle -> IO ()
+hCopy :: (HVIO a, HVIO b) => a -> b -> IO ()
hCopy hin hout = do
- c <- hGetContents hin
- hPutStr hout c
+ c <- vGetContents hin
+ vPutStr hout c
{- | Copies from one handle to another in raw mode (using hGetContents).
Takes a function to provide progress updates to the user.
diff --git a/libsrc/MissingH/IO/HVIO.hs b/libsrc/MissingH/IO/HVIO.hs
index f92dfe1..1c0af1b 100644
--- a/libsrc/MissingH/IO/HVIO.hs
+++ b/libsrc/MissingH/IO/HVIO.hs
@@ -242,6 +242,15 @@ class (Show a) => HVIO a where
-- | Indicate whether this instance supports seeking.
vIsSeekable :: a -> IO Bool
+ -- | Set buffering; the default action is a no-op.
+ vSetBuffering :: a -> BufferMode -> IO ()
+
+ -- | Get buffering; the default action always returns NoBuffering.
+ vGetBuffering :: a -> IO BufferMode
+
+ vSetBuffering x _ = return ()
+ vGetBuffering x = return NoBuffering
+
vShow x = return (show x)
vMkIOError _ et desc mfp =
@@ -345,6 +354,8 @@ instance HVIO Handle where
vSeek = hSeek
vTell = hTell
vIsSeekable = hIsSeekable
+ vSetBuffering = hSetBuffering
+ vGetBuffering = hGetBuffering
----------------------------------------------------------------------
-- VIO Support
@@ -417,8 +428,7 @@ instance HVIO StreamReader where
{- | A 'MemoryBuffer' simulates true I\/O, but uses an in-memory buffer instead
of on-disk storage.
-
- It provides
+It provides
a full interface like Handle (it implements 'HVIOReader', 'HVIOWriter',
and 'HVIOSeeker'). However, it maintains an in-memory buffer with the
contents of the file, rather than an actual on-disk file. You can access
diff --git a/libsrc/MissingH/Network/FTP/Server.hs b/libsrc/MissingH/Network/FTP/Server.hs
index fb6ff73..21ba474 100644
--- a/libsrc/MissingH/Network/FTP/Server.hs
+++ b/libsrc/MissingH/Network/FTP/Server.hs
@@ -61,6 +61,8 @@ import Data.Char
import MissingH.Printf
import Data.IORef
import Data.List
+import Control.Exception(finally)
+import MissingH.IO
data DataType = ASCII | Binary
deriving (Eq, Show)
@@ -71,7 +73,6 @@ data AuthState = NoAuth
data DataChan = NoChannel
| PassiveMode SocketServer
| PortMode SockAddr
- | ActivePort Socket
data FTPState = FTPState
{ auth :: IORef AuthState,
datatype :: IORef DataType,
@@ -80,7 +81,7 @@ data FTPState = FTPState
local :: SockAddr,
remote :: SockAddr}
-data FTPServer = forall a. HVFS a => FTPServer Handle a FTPState
+data FTPServer = forall a. HVFSOpenable a => FTPServer Handle a FTPState
s_crlf = "\r\n"
logname = "MissingH.Network.FTP.Server"
@@ -103,7 +104,7 @@ sendReply h codei text =
{- | Main FTP handler; pass the result of applying this to one argument to
'MissingH.Network.SocketServer.handleHandler' -}
-anonFtpHandler :: forall a. HVFS a => a -> Handle -> SockAddr -> SockAddr -> IO ()
+anonFtpHandler :: forall a. HVFSOpenable a => a -> Handle -> SockAddr -> SockAddr -> IO ()
anonFtpHandler f h saremote salocal =
let serv r = FTPServer h f r
in
@@ -162,6 +163,7 @@ commands =
,("STRU", (forceLogin cmd_stru, help_stru))
,("PASV", (forceLogin cmd_pasv, help_pasv))
,("PORT", (forceLogin cmd_port, help_port))
+ ,("RETR", (forceLogin cmd_retr, help_retr))
]
commandLoop :: FTPServer -> IO ()
@@ -271,11 +273,6 @@ cmd_type h@(FTPServer _ _ state) args =
closeconn :: FTPServer -> IO ()
closeconn h@(FTPServer _ _ state) =
do dc <- readIORef (datachan state)
- case dc of
- NoChannel -> return ()
- PassiveMode ss -> closeSocketServer ss
- PortMode _ -> return ()
- ActivePort sock -> sClose sock
writeIORef (datachan state) NoChannel
help_port = ("Initiate a port-mode connection", "")
@@ -289,7 +286,6 @@ cmd_port h@(FTPServer _ _ state) args =
in
do closeconn h -- Close any existing connection
trapIOError h (fromPortString args) $ (\clientsa ->
- do closeconn h
case clientsa of
SockAddrInet _ ha ->
case (local state) of
@@ -301,7 +297,22 @@ cmd_port h@(FTPServer _ _ state) args =
return True
_ -> do sendReply h 501 "Require IPv4 in specified address"
return True
- )
+ )
+
+runDataChan :: FTPServer -> (FTPServer -> Socket -> IO ()) -> IO ()
+runDataChan h@(FTPServer _ _ state) func =
+ do chan <- readIORef (datachan state)
+ case chan of
+ NoChannel -> fail "Can't connect when no data channel exists"
+ PassiveMode ss -> do finally (handleOne ss (\sock _ _ -> func h sock))
+ (do closeSocketServer ss
+ closeconn h
+ )
+ PortMode sa -> do proto <- getProtocolNumber "tcp"
+ s <- socket AF_INET Stream proto
+ connect s sa
+ finally (func h s) $ closeconn h
+
help_pasv = ("Initiate a passive-mode connection", "")
cmd_pasv :: CommandHandler
cmd_pasv h@(FTPServer _ _ state) args =
@@ -343,6 +354,36 @@ cmd_rnfr h@(FTPServer _ _ state) args =
sendReply h 350 "Noted rename from name; please send RNTO."
return True
+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 (runDataChan h (runit fhencap)) $
+ (\_ ->
+ do case fhencap of
+ HVFSOpenEncap fh -> vClose fh
+ sendReply h 226 "Closing data connection; transfer complete."
+ return True
+ )
+ )
+
+
help_rnto = ("Specify TO name for a file name", "")
cmd_rnto :: CommandHandler
cmd_rnto h@(FTPServer _ fs state) args =
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list