[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 15:20:39 UTC 2010
The following commit has been merged in the master branch:
commit ec7721f0e14dda8fa5d940eccba088e404c1e56c
Author: John Goerzen <jgoerzen at complete.org>
Date: Thu Dec 7 02:45:32 2006 +0100
Removed Network.FTP.*; it's going to haskell-ftp
diff --git a/MissingH.cabal b/MissingH.cabal
index a904c40..58fcc26 100644
--- a/MissingH.cabal
+++ b/MissingH.cabal
@@ -22,10 +22,6 @@ Exposed-Modules: Data.String, System.IO.Utils, System.IO.Binary, Data.List.Utils
System.Path.WildMatch, System.Path.Glob,
System.Time.Utils, System.Time.ParseDate,
Network.Utils,
- Network.FTP.Client,
- Network.FTP.Client.Parser,
- Network.FTP.Server,
- Network.FTP.Server.Parser,
Network.SocketServer,
Data.Either.Utils,
Data.Maybe.Utils,
diff --git a/src/Network/FTP/Client.hs b/src/Network/FTP/Client.hs
deleted file mode 100644
index 5e1f138..0000000
--- a/src/Network/FTP/Client.hs
+++ /dev/null
@@ -1,522 +0,0 @@
-{- arch-tag: FTP client support
-Copyright (C) 2004-2005 John Goerzen <jgoerzen at complete.org>
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or
-(at your option) any later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
--}
-
-{- |
- Module : Network.FTP.Client
- Copyright : Copyright (C) 2004-2005 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : experimental
- Portability: systems with networking
-
-This module provides a client-side interface to the File Transfer Protocol
-as defined by RFC959 and RFC1123.
-
-Written by John Goerzen, jgoerzen\@complete.org
-
-Welcome to the FTP module for Haskell.
-
-Here is a quick usage example to get you started. This is a log of a real
-session with ghci:
-
-(This would be similar in a "do" block. You could also save it to a file and
-run that with Hugs.)
-
-> Prelude> :l Network.FTP.Client
-> ...
-
-The above loads the module.
-
-Next, we enable the debugging. This will turn on all the @FTP sent@ and
- at FTP received@ messages you'll see.
-
-> Prelude Network.FTP.Client> enableFTPDebugging
-
-Now, connect to the server on @ftp.kernel.org at .
-
-> *Network.FTP.Client> h <- easyConnectFTP "ftp.kernel.org"
-> FTP received: 220 Welcome to ftp.kernel.org.
-
-And log in anonymously.
-
-> *Network.FTP.Client> loginAnon h
-> FTP sent: USER anonymous
-> FTP received: 331 Please specify the password.
-> FTP sent: PASS anonymous@
-> ...
-> FTP received: 230 Login successful.
-
-Change the directory...
-
-> Prelude Network.FTP.Client> cwd h "/pub/linux/kernel/Historic"
-> FTP sent: CWD /pub/linux/kernel/Historic
-> FTP received: 250 Directory successfully changed.
-
-Let's look at the directory. 'nlst' returns a list of strings, each string
-corresponding to a filename. Here, @putStrLn . unlines@ will simply
-print them out, one per line.
-
-> Prelude Network.FTP.Client> nlst h Nothing >>= putStrLn . unlines
-> FTP sent: TYPE A
-> FTP received: 200 Switching to ASCII mode.
-> FTP sent: PASV
-> FTP received: 227 Entering Passive Mode (204,152,189,116,130,143)
-> FTP sent: NLST
-> FTP received: 150 Here comes the directory listing.
-> linux-0.01.tar.bz2
-> linux-0.01.tar.bz2.sign
-> linux-0.01.tar.gz
-> linux-0.01.tar.gz.sign
-> linux-0.01.tar.sign
-> old-versions
-> v0.99
-> FTP received: 226 Directory send OK.
-
-Let's try downloading something and print it to the screen. Again, we use
- at putStrLn@. We use @fst@ here because 'getbinary' returns a tuple consisting
-of a string representing the data and a 'FTPResult' code.
-
-> Prelude Network.FTP.Client> getbinary h "linux-0.01.tar.gz.sign" >>= putStrLn . fst
-> FTP sent: TYPE I
-> FTP received: 200 Switching to Binary mode.
-> FTP sent: PASV
-> FTP received: 227 Entering Passive Mode (204,152,189,116,121,121)
-> FTP sent: RETR linux-0.01.tar.gz.sign
-> FTP received: 150 Opening BINARY mode data connection for linux-0.01.tar.gz.sign (248 bytes).
-> -----BEGIN PGP SIGNATURE-----
-> Version: GnuPG v1.0.0 (GNU/Linux)
-> Comment: See http://www.kernel.org/signature.html for info
->
-> iD8DBQA54rf0yGugalF9Dw4RAqelAJ9lafFni4f/QyJ2IqDXzW2nz/ZIogCfRPtg
-> uYpWffOhkyByfhUt8Lcelec=
-> =KnLA
-> -----END PGP SIGNATURE-----
-> FTP received: 226 File send OK.
-
-Here's an example showing you what the result code looks like.
-
-> Prelude Network.FTP.Client> getbinary h "linux-0.01.tar.gz.sign" >>= print . snd
-> ...
-> (226,["File send OK."])
-
-The first component of the 'FTPResult' object is the numeric status code from
-the server. The second component is a list of message lines from the server.
-
-Now, let's get a more detailed directory listing:
-
-> Prelude Network.FTP.Client> dir h Nothing >>= putStrLn . unlines
-> ...
-> -r--r--r-- 1 536 536 63362 Oct 30 1993 linux-0.01.tar.bz2
-> -r--r--r-- 1 536 536 248 Oct 30 1993 linux-0.01.tar.bz2.sign
-> -r--r--r-- 1 536 536 73091 Oct 30 1993 linux-0.01.tar.gz
-> -r--r--r-- 1 536 536 248 Oct 30 1993 linux-0.01.tar.gz.sign
-> -r--r--r-- 1 536 536 248 Oct 30 1993 linux-0.01.tar.sign
-> drwxrwsr-x 5 536 536 4096 Mar 20 2003 old-versions
-> drwxrwsr-x 2 536 536 4096 Mar 20 2003 v0.99
-> FTP received: 226 Directory send OK.
-
-And finally, log out:
-
-> Prelude Network.FTP.Client> quit h
-> FTP sent: QUIT
-> FTP received: 221 Goodbye.
-
-Here is one big important caution:
-
-/You MUST consume all data from commands that return file data before you
-issue any other FTP commands./
-
-That's due to the lazy nature of Haskell. This means that, for instance,
-you can't just iterate over the items 'nlst' returns, trying to 'getbinary'
-each one of them -- the system is still transferring 'nlst' data while you
-are trying that, and confusion will ensue. Either open two FTP connections
-or make sure you consume the 'nlst' data first.
-
-Here is a partial list of commands effected: 'nlst', 'dir', 'getbinary',
-'getlines', 'downloadbinary'.
-
-The 'Data.List.Utils.seqList' function could be quite helpful here. For instance:
-
-> x <- nlst h Nothing
-> map (\fn -> ...download files from FTP... ) (seqList x)
-
-If you omit the call to 'Data.List.Utils.seqList', commands to download files
-will be issued before the entire directory listing is read. FTP cannot handle
-this.
-
-The corrolary is:
-
-/Actions that yield lazy data for data uploading must not issue FTP
-commands themselves./
-
-This will be fairly rare. Just be aware of this.
-
-This module logs messages under @Network.FTP.Client@ for outgoing
-traffic and @Network.FTP.Client.Parser@ for incoming traffic, all with the
-'System.Log.DEBUG' priority, so by default, no log messages are seen.
-The 'enableFTPDebugging' function will adjust the priorities of these
-two handlers so debug messages are seen. Only control channel conversations
-are logged. Data channel conversations are never logged.
-
-All exceptions raised by this module have a string beginning with
-@\"FTP: \"@. Most errors will be IO userErrors. In a few extremely rare
-cases, errors may be raised by the Prelude error function, though these
-will also have a string beginning with @\"FTP: \"@. Exceptions raised by
-the underlying networking code will be passed on to you unmodified.
-
-Useful standards:
-
-* RFC959, <http://www.cse.ohio-state.edu/cgi-bin/rfc/rfc0959.html>
-
-* Passive mode, RFC1579, <http://www.cse.ohio-state.edu/cgi-bin/rfc/rfc1579.html>
-
-* Extended passive mode, IPv6, RFC2428 <http://www.cse.ohio-state.edu/cgi-bin/rfc/rfc2428.html>
-
-* Feature negotiation, RFC2389, <http://www.cse.ohio-state.edu/cgi-bin/rfc/rfc2389.html>
-
-* Internationalization of FTP, RFC2640, <http://www.cse.ohio-state.edu/cgi-bin/rfc/rfc2640.html>
-
-* FTP security considerations, RFC2577, <http://www.cse.ohio-state.edu/cgi-bin/rfc/rfc2577.html>
-
-* FTP URLs, RFC1738, <http://www.cse.ohio-state.edu/cgi-bin/rfc/rfc1738.html>
-
--}
-
-module Network.FTP.Client(-- * Establishing\/Removing connections
- easyConnectFTP, connectFTP,
- loginAnon, login, quit,
- -- * Configuration
- setPassive, isPassive, enableFTPDebugging,
- -- * Directory listing
- nlst, dir,
- -- * File downloads
- getlines, getbinary,
- downloadbinary,
- -- * File uploads
- putlines, putbinary,
- uploadbinary,
- -- * File manipulation
- rename, delete, size,
- -- * Directory manipulation
- cwd, mkdir, rmdir, pwd,
- -- * Low-level advanced commands
- FTPConnection,
- transfercmd, ntransfercmd,
- retrlines, storlines
- )
-where
-import Network.FTP.Client.Parser
-import Network.BSD
-import Network.Socket
-import System.IO.Binary
-import qualified Network
-import System.IO
-import System.IO.Unsafe
-import System.Log.Logger
-import Network.Utils
-import Data.String
-data FTPConnection = FTPConnection {readh :: IO String,
- writeh :: Handle,
- socket_internal :: Socket,
- isPassive :: Bool}
-
-getresp h = do
- c <- (readh h)
- debugParseGoodReply c
-
-
-logsend m = debugM "Network.FTP.Client" ("FTP sent: " ++ m)
-sendcmd h c = do logsend c
- hPutStr (writeh 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. -}
-easyConnectFTP :: Network.HostName -> IO FTPConnection
-easyConnectFTP h = do x <- connectFTP h 21
- return (fst x)
-
-{- | Enable logging of FTP messages through 'System.Log.Logger'.
-This sets the log levels of @Network.FTP.Client.Parser@ and
- at Network.FTP.Client@ to DEBUG. By default, this means that
-full protocol dumps will be sent to stderr.
-
-The effect is global and persists until changed.
--}
-enableFTPDebugging :: IO ()
-enableFTPDebugging =
- do
- updateGlobalLogger "Network.FTP.Client.Parser" (setLevel DEBUG)
- updateGlobalLogger "Network.FTP.Client" (setLevel DEBUG)
-
-{- | Connect to remote FTP server and read the welcome. -}
-connectFTP :: Network.HostName -> PortNumber -> IO (FTPConnection, FTPResult)
-connectFTP h p =
- let readchars :: Handle -> IO String
- readchars h = do
- c <- hGetChar h
- next <- unsafeInterleaveIO $ readchars h
- return (c : next)
- in
- do
- s <- connectTCP h p
- newh <- socketToHandle s ReadWriteMode
- hSetBuffering newh LineBuffering
- let h = FTPConnection {readh = readchars newh,
- socket_internal = s,
- writeh = newh, isPassive = True}
- resp <- getresp h
- forceioresp 200 resp
- return (h, resp)
-
-{- | 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 -> fail "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 -> fail "FTP: server demands account, but no account given"
- Just a -> do ar <- sendcmd h ("ACCT " ++ a)
- forceioresp 200 ar
- return ar
- else return $! forcexresp 200 pr
- else return $! forcexresp 200 ur
-
-{- | Sets whether passive mode is used (returns new
-connection object reflecting this) -}
-setPassive :: FTPConnection -> Bool -> FTPConnection
-setPassive f b = f{isPassive = b}
-
-{- | Finds the addres sof the remote. -}
-makepasv :: FTPConnection -> IO SockAddr
-makepasv h =
- do
- r <- sendcmd h "PASV"
- respToSockAddr r
-
-{- | Opens a port and sends it to the remote. -}
-makeport :: FTPConnection -> IO (Socket, FTPResult)
-makeport h =
- let listenaddr (SockAddrInet _ h) = SockAddrInet aNY_PORT h
- listenaddr _ = error "FTP: Can't use port mode to non-TCP server"
- in
- do addr <- getSocketName (socket_internal h)
- mastersock <- listenTCPAddr (listenaddr addr) 1
- newaddr <- getSocketName mastersock
- ps <- toPortString newaddr
- result <- sendcmd h ("PORT " ++ ps)
- return (mastersock, result)
-
-{- | Establishes a connection to the remote.
-
-FIXME: need support for rest
--}
-ntransfercmd :: FTPConnection -> String -> IO (Handle, Maybe Integer)
-ntransfercmd h cmd =
- let sock = if isPassive h
- then do
- addr <- makepasv h
- s <- connectTCPAddr addr
- r <- sendcmd h cmd
- forceioresp 100 r
- return s
- else do
- masterresult <- makeport h
- r <- sendcmd h cmd
- forceioresp 100 r
- acceptres <- accept (fst masterresult)
- sClose (fst masterresult)
- return (fst acceptres)
- in do
- s <- sock
- newh <- socketToHandle s ReadWriteMode
- hSetBuffering newh (BlockBuffering (Just 4096))
- return (newh, Nothing)
-
-{- | Returns the socket part from calling 'ntransfercmd'. -}
-transfercmd :: FTPConnection -> String -> IO Handle
-transfercmd h cmd = do x <- ntransfercmd h cmd
- return (fst x)
-
-{- | Stores the lines of data to the remote. The string gives the
-commands to issue. -}
-storlines :: FTPConnection -> String -> [String] -> IO FTPResult
-storlines h cmd input =
- do
- sendcmd h "TYPE A"
- newh <- transfercmd h cmd
- hPutStr newh (concatMap (++ "\r\n") input)
- hClose newh
- getresp h
-
-{- | Stores the binary data to the remote. The first string gives the
-commands to issue. -}
-storbinary :: FTPConnection -> String -> String -> IO FTPResult
-storbinary h cmd input =
- do sendcmd h "TYPE I"
- newh <- transfercmd h cmd
- hPutStr newh input
- hClose newh
- getresp h
-
-{- | Retrieves lines of data from the remote. The string gives
-the command to issue. -}
-retrlines :: FTPConnection -> String -> IO ([String], FTPResult)
-retrlines h cmd =
- -- foo returns the empty last item and closes the handle when done
- let foo theh [] = do hClose theh
- r <- getresp h
- return ([], r)
- foo theh ("" : []) = foo theh []
- foo theh (x:xs) = do next <- unsafeInterleaveIO $ foo theh xs
- return $ (x : fst next, snd next)
- in do
- sendcmd h "TYPE A"
- newh <- transfercmd h cmd
- c <- hGetContents newh
- foo newh (split "\r\n" $ c)
-
-{- | Retrieves binary data from the remote. The string gives the command
-to issue. -}
-retrbinary :: FTPConnection -> String -> IO (String, FTPResult)
-retrbinary h cmd =
- let foo h2 [] = do hClose h2
- r <- getresp h
- return ([], r)
- foo h2 (x:xs) = do next <- unsafeInterleaveIO $ foo h2 xs
- return $ (x : fst next, snd next)
- in do
- sendcmd h "TYPE I"
- newh <- transfercmd h cmd
- c <- hGetContents newh
- foo newh c
-
-{- | Retrieves the specified file in text mode. -}
-getlines :: FTPConnection -> String -> IO ([String], FTPResult)
-getlines h fn = retrlines h ("RETR " ++ fn)
-
-{- | Retrieves the specified file in binary mode. -}
-getbinary :: FTPConnection -> String -> IO (String, FTPResult)
-getbinary h fn = retrbinary h ("RETR " ++ fn)
-
-{- | Puts data in the specified file in text mode. The first string
-is the filename. -}
-putlines :: FTPConnection -> String -> [String] -> IO FTPResult
-putlines h fn input = storlines h ("STOR " ++ fn) input
-
-{- | Puts data in the specified file in binary. The first string is the filename. -}
-putbinary :: FTPConnection -> String -> String -> IO FTPResult
-putbinary h fn input = storbinary h ("STOR " ++ fn) input
-
-{- | Uploads a file from disk in binary mode. Note: filename is used for both local and remote. -}
-uploadbinary :: FTPConnection -> String -> IO FTPResult
-uploadbinary h fn = do input <- readBinaryFile fn
- putbinary h fn input
-
-{- | Downloads a file from remote and saves to disk in binary mode. Note: filename is used for both local and remote. -}
-downloadbinary :: FTPConnection -> String -> IO FTPResult
-downloadbinary h fn = do r <- getbinary h fn
- writeBinaryFile fn (fst r)
- return (snd r)
-
-{- | Retrieves a list of files in the given directory.
-
-FIXME: should this take a list of dirs? -}
-nlst :: FTPConnection
- -> Maybe String -- ^ The directory to list. If Nothing, list the current directory.
- -> IO [String]
-nlst h Nothing = retrlines h "NLST" >>= return . fst
-nlst h (Just dirname) = retrlines h ("NLST " ++ dirname) >>= return . fst
-
-{- | Retrieve the system-specific long form of a directory list.
-
-FIXME: should this take a list of dirs? -}
-dir :: FTPConnection
- -> Maybe String -- ^ The directory to list. If Nothing, list the current directory.
- -> IO [String]
-dir h Nothing = retrlines h "LIST" >>= return . fst
-dir h (Just dirname) = retrlines h ("LIST " ++ dirname) >>= return . fst
-
-{- | Rename or move a file. -}
-rename :: FTPConnection
- -> String -- ^ Old name
- -> String -- ^ New name
- -> IO FTPResult
-rename h old new = do
- r <- sendcmd h ("RNFR " ++ old)
- forceioresp 300 r
- sendcmd h ("RNTO " ++ new)
-
-{- | Delete (unlink) a file. -}
-delete :: FTPConnection -> String -> IO FTPResult
-delete h fn = sendcmd h ("DELE " ++ fn)
-
-{- | Change the working directory. -}
-cwd :: FTPConnection -> String -> IO FTPResult
-cwd h ".." = sendcmd h "CDUP"
-cwd h "" = cwd h "."
-cwd h newdir = sendcmd h ("CWD " ++ newdir)
-
-{- | Get the size of a file.
-
-This command is non-standard and may possibly fail.
--}
-size :: (Num a, Read a) => FTPConnection -> String -> IO a
-size h fn = do
- r <- sendcmd h ("SIZE " ++ fn)
- forceioresp 200 r
- return (read . head . snd $ r)
-
--- | Make new directory. Returns the absolute name of the
--- new directory if possible.
-mkdir :: FTPConnection -> String -> IO (Maybe String, FTPResult)
-mkdir h fn = do x <- sendcmd h ("MKD " ++ fn)
- return (parseDirName x, x)
-
--- | Remove a directory.
-rmdir :: FTPConnection -> String -> IO FTPResult
-rmdir h fn = sendcmd h ("RMD " ++ fn)
-
--- | Print the current working directory. The first component of the result
--- is the parsed directory name, if the servers response was parsable.
-pwd :: FTPConnection -> IO (Maybe String, FTPResult)
-pwd h = do x <- sendcmd h ("PWD")
- return (parseDirName x, x)
-
--- | Log off the server and quit.
-quit :: FTPConnection -> IO FTPResult
-quit h = do
- r <- sendcmd h "QUIT"
- hClose (writeh h)
- -- hClose (readh_internal h)
- return r
diff --git a/src/Network/FTP/Client/Parser.hs b/src/Network/FTP/Client/Parser.hs
deleted file mode 100644
index cdc2506..0000000
--- a/src/Network/FTP/Client/Parser.hs
+++ /dev/null
@@ -1,259 +0,0 @@
-{- arch-tag: FTP protocol parser
-Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or
-(at your option) any later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
--}
-
-{- |
- Module : Network.FTP.Client.Parser
- Copyright : Copyright (C) 2004 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: systems with networking
-
-This module provides a parser that is used internally by
-"Network.FTP.Client". You almost certainly do not want to use
-this module directly. Use "Network.FTP.Client" instead.
-
-Written by John Goerzen, jgoerzen\@complete.org
-
--}
-
-module Network.FTP.Client.Parser(parseReply, parseGoodReply,
- toPortString, fromPortString,
- debugParseGoodReply,
- respToSockAddr,
- FTPResult,
- -- * Utilities
- unexpectedresp, isxresp,
- forcexresp,
- forceioresp,
- parseDirName)
-where
-
-import Text.ParserCombinators.Parsec
-import Text.ParserCombinators.Parsec.Utils
-import Data.List.Utils
-import Data.Bits.Utils
-import Data.String
-import System.Log.Logger
-import Network.Socket(SockAddr(..), PortNumber(..), inet_addr, inet_ntoa)
-import System.IO(Handle, hGetContents)
-import System.IO.Unsafe
-import Text.Regex
-import Data.Word
-type FTPResult = (Int, [String])
-
--- import Control.Exception(Exception(PatternMatchFail), throw)
-
-logit :: String -> IO ()
-logit m = debugM "Network.FTP.Client.Parser" ("FTP received: " ++ m)
-
-----------------------------------------------------------------------
--- Utilities
-----------------------------------------------------------------------
-
-unexpectedresp m r = "FTP: Expected " ++ m ++ ", got " ++ (show r)
-
-isxresp desired (r, _) = r >= desired && r < (desired + 100)
-
-forcexresp desired r = if isxresp desired r
- then r
- else error ((unexpectedresp (show desired)) r)
-
-forceioresp :: Int -> FTPResult -> IO ()
-forceioresp desired r = if isxresp desired r
- then return ()
- else fail (unexpectedresp (show desired) r)
-
-
-crlf :: Parser String
-crlf = string "\r\n" <?> "CRLF"
-
-sp :: Parser Char
-sp = char ' '
-
-code :: Parser Int
-code = do
- s <- codeString
- return (read s)
-
-codeString :: Parser String
-codeString = do
- first <- oneOf "123456789" <?> "3-digit reply code"
- remaining <- count 2 digit <?> "3-digit reply code"
- return (first : remaining)
-
-specificCode :: Int -> Parser Int
-specificCode exp = do
- s <- string (show exp) <?> ("Code " ++ (show exp))
- return (read s)
-
-line :: Parser String
-line = do
- x <- many (noneOf "\r\n")
- crlf
- -- return $ unsafePerformIO $ putStrLn ("line: " ++ x)
- return x
-
-----------------------------------------------------------------------
--- The parsers
-----------------------------------------------------------------------
-
-singleReplyLine :: Parser (Int, String)
-singleReplyLine = do
- x <- code
- sp
- text <- line
- return (x, text)
-
-expectedReplyLine :: Int -> Parser (Int, String)
-expectedReplyLine expectedcode = do
- x <- specificCode expectedcode
- sp
- text <- line
- return (x, text)
-
-startOfMultiReply :: Parser (Int, String)
-startOfMultiReply = do
- x <- code
- char '-'
- text <- line
- return (x, text)
-
-multiReplyComponent :: Parser [String]
-multiReplyComponent = (try (do
- notMatching (do
- codeString
- sp
- ) "found unexpected code"
- thisLine <- line
- -- return $ unsafePerformIO (putStrLn ("MRC: got " ++ thisLine))
- remainder <- multiReplyComponent
- return (thisLine : remainder)
- )
- ) <|> return []
-
-multiReply :: Parser FTPResult
-multiReply = try (do
- x <- singleReplyLine
- return (fst x, [snd x])
- )
- <|> (do
- start <- startOfMultiReply
- component <- multiReplyComponent
- end <- expectedReplyLine (fst start)
- return (fst start, snd start : (component ++ [snd end]))
- )
-
-----------------------------------------------------------------------
--- The real code
-----------------------------------------------------------------------
-
--- | Parse a FTP reply. Returns a (result code, text) pair.
-
-parseReply :: String -> FTPResult
-parseReply input =
- case parse multiReply "(unknown)" input of
- Left err -> error ("FTP: " ++ (show err))
- Right reply -> reply
-
--- | Parse a FTP reply. Returns a (result code, text) pair.
--- If the result code indicates an error, raise an exception instead
--- of just passing it back.
-
-parseGoodReply :: String -> IO FTPResult
-parseGoodReply input =
- let reply = parseReply input
- in
- if (fst reply) >= 400
- then fail ("FTP:" ++ (show (fst reply)) ++ ": " ++ (join "\n" (snd reply)))
- else return reply
-
--- | Parse a FTP reply. Logs debug messages.
-debugParseGoodReply :: String -> IO FTPResult
-debugParseGoodReply contents =
- let logPlugin :: String -> String -> IO String
- logPlugin [] [] = return []
- logPlugin [] accum = do
- logit accum
- return []
- logPlugin (x:xs) accum =
- case x of
- '\n' -> do logit (strip (accum))
- next <- unsafeInterleaveIO $ logPlugin xs []
- return (x : next)
- y -> do
- next <- unsafeInterleaveIO $ logPlugin xs (accum ++ [x])
- return (x : next)
- in
- do
- loggedStr <- logPlugin contents []
- parseGoodReply loggedStr
-
-{- | Converts a socket address to a string suitable for a PORT command.
-
-Example:
-
-> toPortString (SockAddrInet (PortNum 0x1234) (0xaabbccdd)) ->
-> "170,187,204,221,18,52"
--}
-toPortString :: SockAddr -> IO String
-toPortString (SockAddrInet port hostaddr) =
- let wport = (fromIntegral (port))::Word16
- in do
- hn <- inet_ntoa hostaddr
- return ((replace "." "," hn) ++ "," ++
- (genericJoin "," . getBytes $ wport))
-toPortString _ =
- error "toPortString only works on AF_INET addresses"
-
--- | Converts a port string to a socket address. This is the inverse calculation of 'toPortString'.
-fromPortString :: String -> IO SockAddr
-fromPortString instr =
- let inbytes = split "," instr
- hostname = join "." (take 4 inbytes)
- portbytes = map read (drop 4 inbytes)
- in
- do
- addr <- inet_addr hostname
- return $ SockAddrInet (fromInteger $ fromBytes portbytes) addr
-
-respToSockAddrRe = mkRegex("([0-9]+,){5}[0-9]+")
--- | Converts a response code to a socket address
-respToSockAddr :: FTPResult -> IO SockAddr
-respToSockAddr f =
- do
- forceioresp 200 f
- if (fst f) /= 227 then
- fail ("Not a 227 response: " ++ show f)
- else case matchRegexAll respToSockAddrRe (head (snd f)) of
- Nothing -> fail ("Could not find remote endpoint in " ++ (show f))
- Just (_, x, _, _) -> fromPortString x
-
-
-parseDirName :: FTPResult -> Maybe String
-parseDirName (257, name:_) =
- let procq [] = []
- procq ['"'] = []
- procq ('"' : '"' : xs) = '"' : procq xs
- procq (x:xs) = x : procq xs
- in
- if head name /= '"'
- then Nothing
- else Just (procq (tail name))
-
diff --git a/src/Network/FTP/Server.hs b/src/Network/FTP/Server.hs
deleted file mode 100644
index 7d82607..0000000
--- a/src/Network/FTP/Server.hs
+++ /dev/null
@@ -1,652 +0,0 @@
-{- arch-tag: FTP server support
-Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or
-(at your option) any later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
--}
-
-{- |
- Module : Network.FTP.Server
- Copyright : Copyright (C) 2004 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : experimental
- Portability: systems with networking
-
-This module provides a server-side interface to the File Transfer Protocol
-as defined by:
-
- * RFC959, basic protocol
-
- * RFC1123, clarifications
-
- * RFC1579, passive mode discussion
-
-Written by John Goerzen, jgoerzen\@complete.org
-
-This is a modular FTP server implementation in pure Haskell. It is highly
-adaptable to many different tasks, and can serve up not only real files
-and directories, but also virtually any data structure you could represent
-as a filesystem. It does this by using the
-"System.IO.HVFS" and "System.IO.HVIO" modules.
-
-In addition, basic networking and multitasking configuration is handled
-via "Network.SocketServer" and logging via
-"System.Log.Logger".
-
-This module is believed to be secure, but it not believed to be robust enough
-for use on a public FTP server. In particular, it may be vulnerable to denial
-of service attacks due to no timeouts or restrictions on data size, and
-error catching is not yet completely pervasive. These will be fixed in time.
-Your patches would also be welcomed.
-
-Here is an example server that serves up the entire local filesystem
-in a read-only manner:
-
->import Network.FTP.Server
->import Network.SocketServer
->import System.Log.Logger
->import System.IO.HVFS
->import System.IO.HVFS.Combinators
->
->main = do
-> updateGlobalLogger "" (setLevel DEBUG)
-> updateGlobalLogger "Network.FTP.Server" (setLevel DEBUG)
-> let opts = (simpleTCPOptions 12345) {reuse = True}
-> serveTCPforever opts $
-> threadedHandler $
-> loggingHandler "" INFO $
-> handleHandler $
-> anonFtpHandler (HVFSReadOnly SystemFS)
-
-Hint: if you wantto serve up only part of a filesystem, see
-'System.IO.HVFS.Combinators.newHVFSChroot'.
--}
-
-module Network.FTP.Server(
- anonFtpHandler
- )
-where
-import Network.FTP.Server.Parser
-import Network.FTP.Client.Parser
-import Network.BSD
-import Network.Socket
-import qualified Network
-import System.IO.Utils
-import System.IO.Error
-import System.Log.Logger
-import Network.Utils
-import Network.SocketServer
-import Data.String
-import System.IO.HVIO
-import System.IO.HVFS
-import System.IO.HVFS.InstanceHelpers
-import System.IO.HVFS.Utils
-import Text.Printf
-import Data.Char
-import Data.IORef
-import Data.List
-import Control.Exception(finally)
-import System.IO
-
-data DataType = ASCII | Binary
- deriving (Eq, Show)
-data AuthState = NoAuth
- | User String
- | Authenticated String
- deriving (Eq, Show)
-data DataChan = NoChannel
- | PassiveMode SocketServer
- | PortMode SockAddr
-data FTPState = FTPState
- { auth :: IORef AuthState,
- datatype :: IORef DataType,
- rename :: IORef (Maybe String),
- datachan :: IORef DataChan,
- local :: SockAddr,
- remote :: SockAddr}
-
-data FTPServer = forall a. HVFSOpenable a => FTPServer Handle a FTPState
-
-s_crlf = "\r\n"
-logname = "Network.FTP.Server"
-ftpPutStrLn :: FTPServer -> String -> IO ()
-ftpPutStrLn (FTPServer h _ _) text =
- do hPutStr h (text ++ s_crlf)
- hFlush h
-
-{- | Send a reply code, handling multi-line text as necessary. -}
-sendReply :: FTPServer -> Int -> String -> IO ()
-sendReply h codei text =
- let codes = printf "%03d" codei
- writethis [] = ftpPutStrLn h (codes ++ " ")
- writethis [item] = ftpPutStrLn h (codes ++ " " ++ item)
- writethis (item:xs) = do ftpPutStrLn h (codes ++ "-" ++ item)
- writethis xs
- in
- writethis (map (rstrip) (lines text))
-
-{- | Main FTP handler; pass the result of applying this to one argument to
-'Network.SocketServer.handleHandler' -}
-
-anonFtpHandler :: forall a. HVFSOpenable a => a -> Handle -> SockAddr -> SockAddr -> IO ()
-anonFtpHandler f h saremote salocal =
- let serv r = FTPServer h f r
- in
- traplogging logname NOTICE "" $
- do authr <- newIORef (NoAuth)
- typer <- newIORef ASCII
- renamer <- newIORef (Nothing::Maybe String)
- chanr <- newIORef (NoChannel)
- let s = serv (FTPState {auth = authr, datatype = typer,
- rename = renamer, datachan = chanr,
- local = salocal, remote = saremote})
- sendReply s 220 "Welcome to Network.FTP.Server."
- commandLoop s
-
-type CommandHandler = FTPServer -> String -> IO Bool
-data Command = Command String (CommandHandler, (String, String))
-
-instance Eq Command where
- (Command x _) == (Command y _) = x == y
-instance Ord Command where
- compare (Command x _) (Command y _) = compare x 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 _ _ state) args =
- do state <- readIORef (auth state)
- case state of
- Authenticated _ -> func h args
- x -> do sendReply h 530 "Command not possible in non-authenticated state."
- return True
-
-commands :: [Command]
-commands =
- [(Command "HELP" (cmd_help, help_help))
- ,(Command "QUIT" (cmd_quit, help_quit))
- ,(Command "USER" (cmd_user, help_user))
- ,(Command "PASS" (cmd_pass, help_pass))
- ,(Command "CWD" (forceLogin cmd_cwd, help_cwd))
- ,(Command "CDUP" (forceLogin cmd_cdup, help_cdup))
- ,(Command "TYPE" (forceLogin cmd_type, help_type))
- ,(Command "NOOP" (forceLogin cmd_noop, help_noop))
- ,(Command "RNFR" (forceLogin cmd_rnfr, help_rnfr))
- ,(Command "RNTO" (forceLogin cmd_rnto, help_rnto))
- ,(Command "DELE" (forceLogin cmd_dele, help_dele))
- ,(Command "RMD" (forceLogin cmd_rmd, help_rmd))
- ,(Command "MKD" (forceLogin cmd_mkd, help_mkd))
- ,(Command "PWD" (forceLogin cmd_pwd, help_pwd))
- ,(Command "MODE" (forceLogin cmd_mode, help_mode))
- ,(Command "STRU" (forceLogin cmd_stru, help_stru))
- ,(Command "PASV" (forceLogin cmd_pasv, help_pasv))
- ,(Command "PORT" (forceLogin cmd_port, help_port))
- ,(Command "RETR" (forceLogin cmd_retr, help_retr))
- ,(Command "STOR" (forceLogin cmd_stor, help_stor))
- ,(Command "STAT" (forceLogin cmd_stat, help_stat))
- ,(Command "SYST" (forceLogin cmd_syst, help_syst))
- ,(Command "NLST" (forceLogin cmd_nlst, help_nlst))
- ,(Command "LIST" (forceLogin cmd_list, help_list))
- ]
-
-commandLoop :: FTPServer -> IO ()
-commandLoop h@(FTPServer fh _ _) =
- let errorhandler e = do noticeM logname
- ("Closing due to error: " ++ (show e))
- hClose fh
- return False
- in do continue <- (flip catch) errorhandler
- (do x <- parseCommand fh
- case x of
- Left err -> do sendReply h 500 $
- " Couldn't parse command: " ++ (show err)
- return True
- Right (cmd, args) ->
- case lookupC cmd commands of
- Nothing -> do sendReply h 502 $
- "Unrecognized command " ++ cmd
- return True
- Just (Command _ hdlr) -> (fst hdlr) h args
- )
- if continue
- then commandLoop h
- else return ()
-
-lookupC cmd cl = find (\(Command x _) -> x == cmd) cl
-
-help_quit =
- ("Terminate the session",
- "")
-
-cmd_quit :: CommandHandler
-cmd_quit h args =
- do sendReply h 221 "OK, Goodbye."
- return False
-
-help_user =
- ("Provide a username",
- unlines $
- ["USER username will provide the username for authentication."
- ,"It should be followed by a PASS command to finish the authentication."
- ])
-
-cmd_user :: CommandHandler
-cmd_user h@(FTPServer _ _ state) passedargs =
- let args = strip passedargs
- in
- case args of
- "anonymous" -> do sendReply h 331 "User name accepted; send password."
- writeIORef (auth state) (User args)
- return True
- _ -> do sendReply h 530 "Unrecognized user name; please try \"anonymous\""
- writeIORef (auth state) NoAuth
- return True
-
-help_pass =
- ("Provide a password",
- "PASS password will provide the password for authentication.")
-cmd_pass :: CommandHandler
-cmd_pass h@(FTPServer _ _ state) passedargs =
- do curstate <- readIORef (auth state)
- case curstate of
- User "anonymous" ->
- do sendReply h 230 "Anonymous login successful."
- writeIORef (auth state) (Authenticated "anonymous")
- infoM logname "Anonymous authentication successful"
- return True
- _ -> do sendReply h 530 "Out of sequence PASS command"
- return True
-
-help_cwd =
- ("Change working directory",
- unlines $
- ["Syntax: CWD cwd"
- ,""
- ,"Changes the working directory to the specified item"])
-
-cmd_cwd :: CommandHandler
-cmd_cwd h@(FTPServer _ fs _) args =
- do trapIOError h (vSetCurrentDirectory fs args)
- $ \_ -> do
- newdir <- vGetCurrentDirectory fs
- sendReply h 250 $ "New directory now " ++ newdir
- return True
-
-help_cdup =
- ("Change to parent directory", "Same as CWD ..")
-cmd_cdup h _ = cmd_cwd h ".."
-
-help_type =
- ("Change the type of data transfer", "Valid args are A, AN, and I")
-cmd_type :: CommandHandler
-cmd_type h@(FTPServer _ _ state) args =
- let changetype newt =
- do oldtype <- readIORef (datatype state)
- writeIORef (datatype state) newt
- sendReply h 200 $ "Type changed from " ++ show oldtype ++
- " to " ++ show newt
- return True
- in case args of
- "I" -> changetype Binary
- "L 8" -> changetype Binary
- "A" -> changetype ASCII
- "AN" -> changetype ASCII
- "AT" -> changetype ASCII
- _ -> do sendReply h 504 $ "Type \"" ++ args ++ "\" not supported."
- return True
-
-closeconn :: FTPServer -> IO ()
-closeconn h@(FTPServer _ _ state) =
- do dc <- readIORef (datachan state)
- writeIORef (datachan state) NoChannel
-
-help_port = ("Initiate a port-mode connection", "")
-cmd_port :: CommandHandler
-cmd_port h@(FTPServer _ _ state) args =
- let doIt clientsa =
- do writeIORef (datachan state) (PortMode clientsa)
- str <- showSockAddr clientsa
- sendReply h 200 $ "OK, later I will connect to " ++ str
- return True
- in
- do closeconn h -- Close any existing connection
- trapIOError h (fromPortString args) $ (\clientsa ->
- case clientsa of
- SockAddrInet _ ha ->
- case (local state) of
- SockAddrInet _ ha2 -> if ha /= ha2
- then do sendReply h 501 "Will only connect to same client as command channel."
- return True
- else doIt clientsa
- _ -> do sendReply h 501 "Require IPv4 on client"
- 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 =
- do closeconn h -- Close any existing connection
- addr <- case (local state) of
- (SockAddrInet _ ha) -> return ha
- _ -> fail "Require IPv4 sockets"
- let ssopts = InetServerOptions
- { listenQueueSize = 1,
- portNumber = aNY_PORT,
- interface = addr,
- reuse = False,
- family = AF_INET,
- sockType = Stream,
- protoStr = "tcp"
- }
- ss <- setupSocketServer ssopts
- sa <- getSocketName (sockSS ss)
- portstring <- toPortString sa
- sendReply h 227 $ "Entering passive mode (" ++ portstring ++ ")"
- writeIORef (datachan state) (PassiveMode ss)
- return True
-
-
-
-help_noop = ("Do nothing", "")
-cmd_noop :: CommandHandler
-cmd_noop h _ =
- do sendReply h 200 "OK"
- return True
-
-help_rnfr = ("Specify FROM name for a file rename", "")
-cmd_rnfr :: CommandHandler
-cmd_rnfr h@(FTPServer _ _ state) args =
- if length args < 1
- then do sendReply h 501 "Filename required"
- return True
- else do writeIORef (rename state) (Just 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
- )
- )
-
-rtransmitString :: String -> FTPServer -> Socket -> IO ()
-rtransmitString thestr (FTPServer _ _ state) sock =
- let fixlines :: [String] -> [String]
- fixlines x = map (\y -> y ++ "\r") x
- copyit h =
- hPutStr h $ unlines . fixlines . lines $ thestr
- in
- do writeh <- socketToHandle sock WriteMode
- hSetBuffering writeh (BlockBuffering (Just 4096))
- mode <- readIORef (datatype state)
- case mode of
- ASCII -> finally (copyit writeh)
- (hClose writeh)
- Binary -> finally (hPutStr writeh thestr)
- (hClose writeh)
-
-rtransmitH :: HVFSOpenEncap -> FTPServer -> Socket -> IO ()
-rtransmitH fhencap h sock =
- case fhencap of
- HVFSOpenEncap fh ->
- finally (do c <- vGetContents fh
- rtransmitString c h sock
- ) (vClose fh)
-
-genericTransmit :: FTPServer -> a -> (a -> FTPServer -> Socket -> IO ()) -> IO Bool
-genericTransmit h dat func =
- trapIOError h
- (do sendReply h 150 "I'm going to open the data channel now."
- runDataChan h (func dat)
- ) (\_ ->
- do sendReply h 226 "Closing data connection; transfer complete."
- return True
- )
-
-genericTransmitHandle :: FTPServer -> HVFSOpenEncap -> IO Bool
-genericTransmitHandle h dat =
- genericTransmit h dat rtransmitH
-
-genericTransmitString :: FTPServer -> String -> IO Bool
-genericTransmitString h dat =
- genericTransmit h dat rtransmitString
-
-
-help_retr = ("Retrieve a file", "")
-cmd_retr :: CommandHandler
-cmd_retr h@(FTPServer _ fs state) args =
- if length args < 1
- then do sendReply h 501 "Filename required"
- return True
- else trapIOError h (vOpen fs args ReadMode)
- (\fhencap -> genericTransmitHandle h fhencap)
-
-help_rnto = ("Specify TO name for a file name", "")
-cmd_rnto :: CommandHandler
-cmd_rnto h@(FTPServer _ fs state) args =
- if length args < 1
- then do sendReply h 501 "Filename required"
- return True
- else do fr <- readIORef (rename state)
- case fr of
- Nothing -> do sendReply h 503 "RNFR required before RNTO"
- return True
- Just fromname ->
- do writeIORef (rename state) Nothing
- trapIOError h (vRenameFile fs fromname args)
- $ \_ -> do sendReply h 250
- ("File " ++ fromname ++
- " renamed to " ++ args)
- return True
-
-help_dele = ("Delete files", "")
-cmd_dele :: CommandHandler
-cmd_dele h@(FTPServer _ fs _) args =
- if length args < 1
- then do sendReply h 501 "Filename required"
- return True
- else trapIOError h (vRemoveFile fs args) $
- \_ -> do sendReply h 250 $ "File " ++ args ++ " deleted."
- return True
-
-help_nlst = ("Get plain listing of files", "")
-cmd_nlst :: CommandHandler
-cmd_nlst h@(FTPServer _ fs _) args =
- let fn = case args of
- "" -> "."
- x -> x
- in
- trapIOError h (vGetDirectoryContents fs fn)
- (\l -> genericTransmitString h (unlines l))
-
-help_list = ("Get an annotated listing of files", "")
-cmd_list :: CommandHandler
-cmd_list h@(FTPServer _ fs _) args =
- let fn = case args of
- "" -> "."
- x -> x
- in
- trapIOError h (lsl fs fn)
- (\l -> genericTransmitString h l)
-
-help_rmd = ("Remove directory", "")
-cmd_rmd :: CommandHandler
-cmd_rmd h@(FTPServer _ fs _) args =
- if length args < 1
- then do sendReply h 501 "Filename required"
- return True
- else trapIOError h (vRemoveDirectory fs args) $
- \_ -> do sendReply h 250 $ "Directory " ++ args ++ " removed."
- return True
-
-help_mkd = ("Make directory", "")
-cmd_mkd :: CommandHandler
-cmd_mkd h@(FTPServer _ fs _) args =
- if length args < 1
- then do sendReply h 501 "Filename required"
- return True
- else trapIOError h (vCreateDirectory fs args) $
- \_ -> do newname <- getFullPath fs args
- sendReply h 257 $ "\"" ++ newname ++ "\" created."
- return True
-
-help_pwd = ("Print working directory", "")
-cmd_pwd :: CommandHandler
-cmd_pwd h@(FTPServer _ fs _) _ =
- do d <- vGetCurrentDirectory fs
- sendReply h 257 $ "\"" ++ d ++ "\" is the current working directory."
- return True
-
-help_mode = ("Provided for compatibility only", "")
-cmd_mode :: CommandHandler
-cmd_mode h args =
- case args of
- "S" -> do sendReply h 200 "Mode is Stream."
- return True
- x -> do sendReply h 504 $ "Mode \"" ++ x ++ "\" not supported."
- return True
-
-help_stru = ("Provided for compatibility only", "")
-cmd_stru :: CommandHandler
-cmd_stru h args =
- case args of
- "F" -> do sendReply h 200 "Structure is File."
- return True
- x -> do sendReply h 504 $ "Structure \"" ++ x ++ "\" not supported."
- return True
-
-help_syst = ("Display system type", "")
-cmd_syst :: CommandHandler
-cmd_syst h _ =
- -- I have no idea what this L8 means, but everyone else seems to do
- -- this, so I do too..
- do sendReply h 215 "UNIX Type: L8"
- return True
-
-help_stat = ("Display sever statistics", "")
-cmd_stat :: CommandHandler
-cmd_stat h@(FTPServer _ _ state) _ =
- do loc <- showSockAddr (local state)
- rem <- showSockAddr (remote state)
- auth <- readIORef (auth state)
- datm <- readIORef (datatype state)
- sendReply h 211 $ unlines $
- [" *** Sever statistics and information"
- ," *** Please type HELP for more details"
- ,""
- ,"Server Software : MissingH, http://quux.org/devel/missingh"
- ,"Connected From : " ++ rem
- ,"Connected To : " ++ loc
- ,"Data Transfer Type : " ++ (show datm)
- ,"Auth Status : " ++ (show auth)
- ,"End of status."]
- return True
-
-
-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@(FTPServer _ _ state) args =
- let genericreply addr = unlines $
- [" --- General Help Response ---"
- ,""
- ,"Welcome to the FTP server, " ++ addr ++ "."
- ,"This server is implemented as the 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 (\ (Command name (_, (summary, _))) -> printf "%-10s %s\n" name summary)
- (sort commands)
- ,""
- ,"You may type \"HELP command\" for more help on a specific command."
- ]
- in
- if args == ""
- then do sastr <- showSockAddr (remote state)
- sendReply h 214 (genericreply sastr)
- return True
- else let newargs = map toUpper args
- in case lookupC 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 (Command _ (_, (summary, detail))) ->
- do sendReply h 214 $ newargs ++ ": " ++ summary ++
- "\n\n" ++ detail
- return True
diff --git a/src/Network/FTP/Server/Parser.hs b/src/Network/FTP/Server/Parser.hs
deleted file mode 100644
index 465caad..0000000
--- a/src/Network/FTP/Server/Parser.hs
+++ /dev/null
@@ -1,84 +0,0 @@
-{- arch-tag: FTP protocol parser for servers
-Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or
-(at your option) any later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
--}
-
-{- |
- Module : Network.FTP.Server.Parser
- Copyright : Copyright (C) 2004 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: systems with networking
-
-This module provides a parser that is used internally by
-"Network.FTP.Server". You almost certainly do not want to use
-this module directly. Use "Network.FTP.Server" instead.
-
-Written by John Goerzen, jgoerzen\@complete.org
-
--}
-
-module Network.FTP.Server.Parser(
- parseCommand
- )
-where
-import Network.FTP.Client.Parser
-import Text.ParserCombinators.Parsec
-import Text.ParserCombinators.Parsec.Utils
-import Data.List.Utils
-import Data.Bits.Utils
-import Data.String
-import System.Log.Logger
-import Network.Socket(SockAddr(..), PortNumber(..), inet_addr, inet_ntoa)
-import System.IO(Handle, hGetContents)
-import System.IO(hGetLine)
-import Text.Regex
-import Data.Word
-import Data.Char
-
-logit :: String -> IO ()
-logit m = debugM "Network.FTP.Server.Parser" ("FTP received: " ++ m)
-
-----------------------------------------------------------------------
--- Utilities
-----------------------------------------------------------------------
-
-alpha = oneOf (['A'..'Z'] ++ ['a'..'z']) <?> "alphabetic character"
-
-word = many1 alpha
-
-args :: Parser String
-args = try (do char ' '
- r <- many anyChar
- eof
- return r)
- <|> return ""
-
-
-command :: Parser (String, String)
-command = do
- x <- word
- y <- args
- eof
- return (map toUpper x, y)
-
-
-parseCommand :: Handle -> IO (Either ParseError (String, String))
-parseCommand h =
- do input <- hGetLine h
- return $ parse command "(unknown)" (rstrip input)
diff --git a/testsrc/Network/FTP/Parsertest.hs b/testsrc/Network/FTP/Parsertest.hs
deleted file mode 100644
index 9be0b89..0000000
--- a/testsrc/Network/FTP/Parsertest.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-{- arch-tag: Network.Utils.FTP.Parser tests main file
-Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or
-(at your option) any later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
--}
-
-module Network.FTP.Parsertest(tests) where
-import Test.HUnit
-import Network.FTP.Client.Parser
-import Test.HUnit.Utils
-import Network.Socket
-
-test_parseReply =
- let f inp exp = exp @=? parseReply inp in
- do
- f "200 Welcome to this server.\r\n" (200, ["Welcome to this server."])
- f "230-Foo\r\n230 Foo2\r\n" (230, ["Foo", "Foo2"])
- f "240-Foo\r\n240-Foo2\r\n240 Foo3\r\n" (240, ["Foo", "240-Foo2", "Foo3"])
- f "230-Test\r\nLine2\r\n 230 Line3\r\n230 Done\r\n"
- (230, ["Test", "Line2", " 230 Line3", "Done"])
-
-{-
-test_toPortString =
- let f inp exp = exp @=? toPortString inp in
- do
- f (SockAddrInet (PortNum 0x1234) 0xaabbccdd) "170,187,204,221,18,52"
-
-test_fromPortString =
- let f inp exp = exp @=? case fromPortString inp of
- SockAddrInet (PortNum x) y -> (x, y)
- _ -> (0, 0)
- in
- do
- f "170,187,204,221,18,52" (0x1234, 0xaabbccdd)
--}
-tests = TestList [TestLabel "parseReply" (TestCase test_parseReply)
- --TestLabel "toPortString" (TestCase test_toPortString),
- --TestLabel "fromPortString" (TestCase test_fromPortString)
-
- ]
diff --git a/testsrc/Tests.hs b/testsrc/Tests.hs
index 0c0bb77..643dee9 100644
--- a/testsrc/Tests.hs
+++ b/testsrc/Tests.hs
@@ -26,7 +26,6 @@ import qualified Pathtest
import qualified Strtest
import qualified IOtest
import qualified Bitstest
-import qualified Network.FTP.Parsertest
import qualified Eithertest
import qualified ConfigParser.Parsertest
import qualified ConfigParser.Maintest
@@ -58,7 +57,6 @@ tests = TestList [TestLabel "test1" test1,
TestLabel "Glob" Globtest.tests,
TestLabel "MIMETypes" MIMETypestest.tests,
TestLabel "Bitstest" Bitstest.tests,
- TestLabel "Network.FTP.Parser" Network.FTP.Parsertest.tests,
TestLabel "Eithertest" Eithertest.tests,
TestLabel "ConfigParser.RunParser" ConfigParser.Parsertest.tests,
TestLabel "ConfigParser.Main" ConfigParser.Maintest.tests,
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list