{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Network.SocketServer(
InetServerOptions(..),
simpleTCPOptions,
SocketServer(..),
HandlerT,
serveTCPforever,
setupSocketServer,
handleOne,
serveForever,
closeSocketServer,
loggingHandler,
threadedHandler,
handleHandler
)
where
import Control.Concurrent ( forkIO )
import Data.Functor (void)
import Network.BSD
( getProtocolNumber, Family(AF_INET), HostAddress, PortNumber )
import Network.Socket
( socketToHandle,
setSocketOption,
accept,
bind,
getSocketName,
listen,
socket,
close,
SocketOption(ReuseAddr),
SockAddr(SockAddrInet),
Socket,
SocketType(Stream) )
import Network.Utils ( showSockAddr )
import System.IO
( Handle,
hClose,
hSetBuffering,
BufferMode(LineBuffering),
IOMode(ReadWriteMode) )
import qualified System.Log.Logger
data InetServerOptions = InetServerOptions {InetServerOptions -> Int
listenQueueSize :: Int,
InetServerOptions -> PortNumber
portNumber :: PortNumber,
InetServerOptions -> HostAddress
interface :: HostAddress,
InetServerOptions -> Bool
reuse :: Bool,
InetServerOptions -> Family
family :: Family,
InetServerOptions -> SocketType
sockType :: SocketType,
InetServerOptions -> String
protoStr :: String
}
deriving (InetServerOptions -> InetServerOptions -> Bool
(InetServerOptions -> InetServerOptions -> Bool)
-> (InetServerOptions -> InetServerOptions -> Bool)
-> Eq InetServerOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InetServerOptions -> InetServerOptions -> Bool
$c/= :: InetServerOptions -> InetServerOptions -> Bool
== :: InetServerOptions -> InetServerOptions -> Bool
$c== :: InetServerOptions -> InetServerOptions -> Bool
Eq, Int -> InetServerOptions -> ShowS
[InetServerOptions] -> ShowS
InetServerOptions -> String
(Int -> InetServerOptions -> ShowS)
-> (InetServerOptions -> String)
-> ([InetServerOptions] -> ShowS)
-> Show InetServerOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InetServerOptions] -> ShowS
$cshowList :: [InetServerOptions] -> ShowS
show :: InetServerOptions -> String
$cshow :: InetServerOptions -> String
showsPrec :: Int -> InetServerOptions -> ShowS
$cshowsPrec :: Int -> InetServerOptions -> ShowS
Show)
type HandlerT = Socket -> SockAddr -> SockAddr -> IO ()
simpleTCPOptions :: Int
-> InetServerOptions
simpleTCPOptions :: Int -> InetServerOptions
simpleTCPOptions Int
p = InetServerOptions :: Int
-> PortNumber
-> HostAddress
-> Bool
-> Family
-> SocketType
-> String
-> InetServerOptions
InetServerOptions {listenQueueSize :: Int
listenQueueSize = Int
5,
portNumber :: PortNumber
portNumber = (Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p),
interface :: HostAddress
interface = HostAddress
0,
reuse :: Bool
reuse = Bool
False,
family :: Family
family = Family
AF_INET,
sockType :: SocketType
sockType = SocketType
Stream,
protoStr :: String
protoStr = String
"tcp"
}
data SocketServer = SocketServer {SocketServer -> InetServerOptions
optionsSS :: InetServerOptions,
SocketServer -> Socket
sockSS :: Socket}
deriving (SocketServer -> SocketServer -> Bool
(SocketServer -> SocketServer -> Bool)
-> (SocketServer -> SocketServer -> Bool) -> Eq SocketServer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SocketServer -> SocketServer -> Bool
$c/= :: SocketServer -> SocketServer -> Bool
== :: SocketServer -> SocketServer -> Bool
$c== :: SocketServer -> SocketServer -> Bool
Eq, Int -> SocketServer -> ShowS
[SocketServer] -> ShowS
SocketServer -> String
(Int -> SocketServer -> ShowS)
-> (SocketServer -> String)
-> ([SocketServer] -> ShowS)
-> Show SocketServer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SocketServer] -> ShowS
$cshowList :: [SocketServer] -> ShowS
show :: SocketServer -> String
$cshow :: SocketServer -> String
showsPrec :: Int -> SocketServer -> ShowS
$cshowsPrec :: Int -> SocketServer -> ShowS
Show)
setupSocketServer :: InetServerOptions -> IO SocketServer
setupSocketServer :: InetServerOptions -> IO SocketServer
setupSocketServer InetServerOptions
opts =
do ProtocolNumber
proto <- String -> IO ProtocolNumber
getProtocolNumber (InetServerOptions -> String
protoStr InetServerOptions
opts)
Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket (InetServerOptions -> Family
family InetServerOptions
opts) (InetServerOptions -> SocketType
sockType InetServerOptions
opts) ProtocolNumber
proto
Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
s SocketOption
ReuseAddr (case (InetServerOptions -> Bool
reuse InetServerOptions
opts) of
Bool
True -> Int
1
Bool
False -> Int
0)
Socket -> SockAddr -> IO ()
bind Socket
s (PortNumber -> HostAddress -> SockAddr
SockAddrInet (InetServerOptions -> PortNumber
portNumber InetServerOptions
opts)
(InetServerOptions -> HostAddress
interface InetServerOptions
opts))
Socket -> Int -> IO ()
listen Socket
s (InetServerOptions -> Int
listenQueueSize InetServerOptions
opts)
SocketServer -> IO SocketServer
forall (m :: * -> *) a. Monad m => a -> m a
return (SocketServer -> IO SocketServer)
-> SocketServer -> IO SocketServer
forall a b. (a -> b) -> a -> b
$ SocketServer :: InetServerOptions -> Socket -> SocketServer
SocketServer {optionsSS :: InetServerOptions
optionsSS = InetServerOptions
opts, sockSS :: Socket
sockSS = Socket
s}
closeSocketServer :: SocketServer -> IO ()
closeSocketServer :: SocketServer -> IO ()
closeSocketServer SocketServer
ss =
Socket -> IO ()
close (SocketServer -> Socket
sockSS SocketServer
ss)
handleOne :: SocketServer -> HandlerT -> IO ()
handleOne :: SocketServer -> HandlerT -> IO ()
handleOne SocketServer
ss HandlerT
func = do
(Socket, SockAddr)
a <- Socket -> IO (Socket, SockAddr)
accept (SocketServer -> Socket
sockSS SocketServer
ss)
SockAddr
localaddr <- Socket -> IO SockAddr
getSocketName ((Socket, SockAddr) -> Socket
forall a b. (a, b) -> a
fst (Socket, SockAddr)
a)
HandlerT
func ((Socket, SockAddr) -> Socket
forall a b. (a, b) -> a
fst (Socket, SockAddr)
a) ((Socket, SockAddr) -> SockAddr
forall a b. (a, b) -> b
snd (Socket, SockAddr)
a) SockAddr
localaddr
serveForever :: SocketServer -> HandlerT -> IO ()
serveForever :: SocketServer -> HandlerT -> IO ()
serveForever SocketServer
ss HandlerT
func =
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (IO () -> [IO ()]
forall a. a -> [a]
repeat (SocketServer -> HandlerT -> IO ()
handleOne SocketServer
ss HandlerT
func))
serveTCPforever :: InetServerOptions
-> HandlerT
-> IO ()
serveTCPforever :: InetServerOptions -> HandlerT -> IO ()
serveTCPforever InetServerOptions
options HandlerT
func =
do SocketServer
sockserv <- InetServerOptions -> IO SocketServer
setupSocketServer InetServerOptions
options
SocketServer -> HandlerT -> IO ()
serveForever SocketServer
sockserv HandlerT
func
loggingHandler :: String
-> System.Log.Logger.Priority
-> HandlerT
-> HandlerT
loggingHandler :: String -> Priority -> HandlerT -> HandlerT
loggingHandler String
hname Priority
prio HandlerT
nexth Socket
socket SockAddr
r_sockaddr SockAddr
l_sockaddr =
do String
sockStr <- SockAddr -> IO String
showSockAddr SockAddr
r_sockaddr
String -> Priority -> String -> IO ()
System.Log.Logger.logM String
hname Priority
prio
(String
"Received connection from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sockStr)
String -> Priority -> String -> IO () -> IO ()
forall a. String -> Priority -> String -> IO a -> IO a
System.Log.Logger.traplogging String
hname
Priority
System.Log.Logger.WARNING String
"" (HandlerT
nexth Socket
socket SockAddr
r_sockaddr
SockAddr
l_sockaddr)
String -> Priority -> String -> IO ()
System.Log.Logger.logM String
hname Priority
prio
(String
"Connection " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sockStr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" disconnected")
threadedHandler :: HandlerT
-> HandlerT
threadedHandler :: HandlerT -> HandlerT
threadedHandler HandlerT
nexth Socket
socket SockAddr
r_sockaddr SockAddr
l_sockaddr = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$
IO () -> IO ThreadId
forkIO (HandlerT
nexth Socket
socket SockAddr
r_sockaddr SockAddr
l_sockaddr)
handleHandler :: (Handle -> SockAddr -> SockAddr -> IO ())
-> HandlerT
handleHandler :: (Handle -> SockAddr -> SockAddr -> IO ()) -> HandlerT
handleHandler Handle -> SockAddr -> SockAddr -> IO ()
func Socket
socket SockAddr
r_sockaddr SockAddr
l_sockaddr =
do Handle
h <- Socket -> IOMode -> IO Handle
socketToHandle Socket
socket IOMode
ReadWriteMode
Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
Handle -> SockAddr -> SockAddr -> IO ()
func Handle
h SockAddr
r_sockaddr SockAddr
l_sockaddr
Handle -> IO ()
hClose Handle
h