[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:29 UTC 2010
The following commit has been merged in the master branch:
commit 69e95c273b0c3dfbbd27113ac83ee3d86736b36f
Author: John Goerzen <jgoerzen at complete.org>
Date: Wed Dec 22 23:41:05 2004 +0100
Made SocketServer more versatile
Keywords:
(jgoerzen at complete.org--projects/missingh--head--0.7--patch-141)
diff --git a/ChangeLog b/ChangeLog
index ff40c96..fe8f7dd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,22 @@
# arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.7
#
+2004-12-22 16:41:05 GMT John Goerzen <jgoerzen at complete.org> patch-141
+
+ Summary:
+ Made SocketServer more versatile
+ Revision:
+ missingh--head--0.7--patch-141
+
+
+ new files:
+ ftptest.hs
+
+ modified files:
+ ChangeLog libsrc/MissingH/Network/FTP/Server.hs
+ libsrc/MissingH/Network/SocketServer.hs
+
+
2004-12-22 02:58:04 GMT John Goerzen <jgoerzen at complete.org> patch-140
Summary:
diff --git a/ftptest.hs b/ftptest.hs
new file mode 100644
index 0000000..1a3de78
--- /dev/null
+++ b/ftptest.hs
@@ -0,0 +1,15 @@
+-- arch-tag: FTP test
+import MissingH.Network.FTP.Server
+import MissingH.Network.SocketServer
+import MissingH.Logging.Logger
+import MissingH.IO.HVFS
+
+main = do
+ updateGlobalLogger "" (setLevel DEBUG)
+ updateGlobalLogger "MissingH.Network.FTP.Server" (setLevel DEBUG)
+ let opts = (simpleInetOptions 12345) {reuse = True}
+ serveTCPforever opts $
+ threadedHandler $
+ loggingHandler "" INFO $
+ handleHandler $
+ anonFtpHandler (SystemFS)
diff --git a/libsrc/MissingH/Network/FTP/Server.hs b/libsrc/MissingH/Network/FTP/Server.hs
index 4a93c78..73b8f7c 100644
--- a/libsrc/MissingH/Network/FTP/Server.hs
+++ b/libsrc/MissingH/Network/FTP/Server.hs
@@ -27,7 +27,13 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Portability: systems with networking
This module provides a server-side interface to the File Transfer Protocol
-as defined by RFC959 and RFC1123.
+as defined by:
+
+ * RFC959, basic protocol
+
+ * RFC1123, clarifications
+
+ * RFC1579, passive mode discussion
Written by John Goerzen, jgoerzen\@complete.org
@@ -242,8 +248,10 @@ cmd_type h@(FTPServer _ _ state) _ args =
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
diff --git a/libsrc/MissingH/Network/SocketServer.hs b/libsrc/MissingH/Network/SocketServer.hs
index c5ec8f6..1c6fe96 100644
--- a/libsrc/MissingH/Network/SocketServer.hs
+++ b/libsrc/MissingH/Network/SocketServer.hs
@@ -29,14 +29,22 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
This module provides an infrastructure to simplify server design.
Written by John Goerzen, jgoerzen\@complete.org
+
+Please note: this module is designed to work with TCP, UDP, and Unix domain
+sockets, but only TCP sockets have been tested to date.
-}
module MissingH.Network.SocketServer(-- * Generic Options and Types
InetServerOptions(..),
- simpleInetOptions,
+ simpleTCPOptions,
+ SocketServer,
HandlerT,
- -- * TCP server handlers
+ -- * TCP server convenient setup
serveTCPforever,
+ -- * Lower-Level Processing
+ setupSocketServer,
+ handleOne,
+ serveForever,
-- * Combinators
loggingHandler,
threadedHandler,
@@ -55,37 +63,75 @@ data InetServerOptions = InetServerOptions {listenQueueSize :: Int,
portNumber :: Int,
interface :: HostAddress,
reuse :: Bool,
- family :: Family
+ family :: Family,
+ sockType :: SocketType,
+ protoStr :: String
}
deriving (Eq, Show)
-type HandlerT = (Socket -> SockAddr -> IO ())
+type HandlerT = Socket -- ^ The socket to use for communication
+ -> SockAddr -- ^ Address of the remote
+ -> SockAddr -- ^ Local address
+ -> IO ()
{- | Get Default options. You can always modify it later. -}
-simpleInetOptions :: Int -- ^ Port Number
+simpleTCPOptions :: Int -- ^ Port Number
-> InetServerOptions
-simpleInetOptions p = InetServerOptions {listenQueueSize = 5,
+simpleTCPOptions p = InetServerOptions {listenQueueSize = 5,
portNumber = p,
interface = iNADDR_ANY,
reuse = False,
- family = AF_INET
+ family = AF_INET,
+ sockType = Stream,
+ protoStr = "tcp"
}
+data SocketServer = SocketServer {options :: InetServerOptions,
+ sock :: Socket}
+ deriving (Eq, Show)
+
+{- | Takes some options and sets up the 'SocketServer'. I will bind
+and begin listening, but will not accept any connections itself. -}
+setupSocketServer :: InetServerOptions -> IO SocketServer
+setupSocketServer opts =
+ do proto <- getProtocolNumber (protoStr opts)
+ s <- socket (family opts) (sockType opts) proto
+ setSocketOption s ReuseAddr (case (reuse opts) of
+ True -> 1
+ False -> 0)
+ bindSocket s (SockAddrInet (fromIntegral (portNumber opts))
+ (interface opts))
+ listen s (listenQueueSize opts)
+ return $ SocketServer {options = opts, sock = s}
+
+{- | Handle one incoming request from the given 'SocketServer'. -}
+handleOne :: SocketServer -> HandlerT -> IO ()
+handleOne ss func =
+ let opts = (options ss)
+ in do a <- accept (sock ss)
+ localaddr <- getSocketName (fst a)
+ func (fst a) (snd a) localaddr
+
+{- | Handle all incoming requests from the given 'SocketServer'. -}
+serveForever :: SocketServer -> HandlerT -> IO ()
+serveForever ss func =
+ sequence_ (repeat (handleOne ss func))
+
+{- | Convenience function to completely set up a TCP
+'SocketServer' and handle all incoming requests.
+
+This function is literally this:
+
+>serveTCPforever options func =
+> do sockserv <- setupSocketServer options
+> serveForever sockserv func
+ -}
serveTCPforever :: InetServerOptions -- ^ Server options
-> HandlerT -- ^ Handler function
-> IO ()
serveTCPforever options func =
- do proto <- getProtocolNumber "tcp"
- s <- socket (family options) Stream proto
- setSocketOption s ReuseAddr (case (reuse options) of
- True -> 1
- False -> 0)
- bindSocket s (SockAddrInet (fromIntegral (portNumber options))
- (interface options))
- listen s (listenQueueSize options)
- let run = do a <- accept s
- func (fst a) (snd a)
- sequence_ (repeat run)
+ do sockserv <- setupSocketServer options
+ serveForever sockserv func
----------------------------------------------------------------------
-- Combinators
@@ -102,12 +148,13 @@ loggingHandler :: String -- ^ Name of logger to use
-> MissingH.Logging.Logger.Priority -- ^ Priority of logged messages
-> HandlerT -- ^ Handler to call after logging
-> HandlerT -- ^ Resulting handler
-loggingHandler hname prio nexth socket sockaddr =
- do sockStr <- showSockAddr sockaddr
+loggingHandler hname prio nexth socket r_sockaddr l_sockaddr =
+ do sockStr <- showSockAddr r_sockaddr
MissingH.Logging.Logger.logM hname prio
("Received connection from " ++ sockStr)
MissingH.Logging.Logger.traplogging hname
- MissingH.Logging.Logger.WARNING "" (nexth socket sockaddr)
+ MissingH.Logging.Logger.WARNING "" (nexth socket r_sockaddr
+ l_sockaddr)
MissingH.Logging.Logger.logM hname prio
("Connection " ++ sockStr ++ " disconnected")
@@ -116,8 +163,8 @@ loggingHandler hname prio nexth socket sockaddr =
-- make the server multi-tasking.
threadedHandler :: HandlerT -- ^ Handler to call in the new thread
-> HandlerT -- ^ Resulting handler
-threadedHandler nexth socket sockaddr =
- do forkIO (nexth socket sockaddr)
+threadedHandler nexth socket r_sockaddr l_sockaddr=
+ do forkIO (nexth socket r_sockaddr l_sockaddr)
return ()
{- | Give your handler function a Handle instead of a Socket.
@@ -129,10 +176,10 @@ Unlike other handlers, the handle will be closed when the function returns.
Therefore, if you are doing threading, you should to it before you call this
handler.
-}
-handleHandler :: (Handle -> SockAddr -> IO ()) -- ^ Handler to call
+handleHandler :: (Handle -> SockAddr -> SockAddr -> IO ()) -- ^ Handler to call
-> HandlerT
-handleHandler func socket sockaddr =
+handleHandler func socket r_sockaddr l_sockaddr =
do h <- socketToHandle socket ReadWriteMode
hSetBuffering h LineBuffering
- func h sockaddr
+ func h r_sockaddr l_sockaddr
hClose h
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list