{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

{- arch-tag: Generic Server Support
Copyright (c) 2004-2011 John Goerzen <jgoerzen@complete.org>

All rights reserved.

For license and copyright information, see the file LICENSE
-}

{- |
   Module     : Network.SocketServer
   Copyright  : Copyright (C) 2004-2011 John Goerzen
   SPDX-License-Identifier: BSD-3-Clause

   Stability  : experimental
   Portability: systems with networking

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.

This module is presently under-documented.  For an example of usage, please
see the description of "Network.FTP.Server".
-}

module Network.SocketServer(-- * Generic Options and Types
                                     InetServerOptions(..),
                                     simpleTCPOptions,
                                     SocketServer(..),
                                     HandlerT,
                                     -- * TCP server convenient setup
                                     serveTCPforever,
                                     -- * Lower-Level Processing
                                     setupSocketServer,
                                     handleOne,
                                     serveForever,
                                     closeSocketServer,
                                     -- * Combinators
                                     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

{- | Options for your server. -}
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)

{- | The main handler type.

The first parameter is the socket itself.

The second is the address of the remote endpoint.

The third is the address of the local endpoint.
-}
type HandlerT = Socket -> SockAddr -> SockAddr -> IO ()

{- | Get Default options.  You can always modify it later. -}
simpleTCPOptions :: Int                -- ^ Port Number
                 -> 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)

{- | 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 :: 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}

{- | Close the socket server.  Does not terminate active
handlers, if any. -}
closeSocketServer :: SocketServer -> IO ()
closeSocketServer :: SocketServer -> IO ()
closeSocketServer SocketServer
ss =
    Socket -> IO ()
close (SocketServer -> Socket
sockSS SocketServer
ss)

{- | Handle one incoming request from the given 'SocketServer'. -}
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

{- | Handle all incoming requests from the given 'SocketServer'. -}
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))

{- | 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 :: 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

----------------------------------------------------------------------
-- Combinators
----------------------------------------------------------------------

{- | Log each incoming connection using the interface in
"System.Log.Logger".

Log when the incoming connection disconnects.

Also, log any failures that may occur in the child handler. -}

loggingHandler :: String                -- ^ Name of logger to use
               -> System.Log.Logger.Priority -- ^ Priority of logged messages
               -> HandlerT              -- ^ Handler to call after logging
               -> HandlerT              -- ^ Resulting handler
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")


-- | Handle each incoming connection in its own thread to
-- make the server multi-tasking.
threadedHandler :: HandlerT             -- ^ Handler to call in the new thread
                -> HandlerT             -- ^ Resulting handler
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)

{- | Give your handler function a Handle instead of a Socket.

The Handle will be opened with ReadWriteMode (you use one handle for both
directions of the Socket).  Also, it will be initialized with LineBuffering.

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 -> SockAddr -> IO ())      -- ^ Handler to call
              -> 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