module Network.Connection
( ClientOptions(..)
, clientOpts
, Connection(..)
, ConnectionOptions(..)
, defaultConnectionOptions
, clientConnection
, Server
, ServerOptions(..)
, serverOpts
, newServer
, acceptConnection
, closeConnection
, closeSession
) where
import Network.Socket as S hiding ( connect )
import qualified Network.Socket as S ( connect )
import Network.BSD as BSD ( HostEntry, getHostByName, hostAddresses )
import Control.Concurrent
import System.IO
import Data.Maybe
data Connection
= Connection
{ coHandle :: Handle
, coSocket :: Socket
, coServer :: Maybe Server
}
data ConnectionOptions
= ConnectionOptions
{ connMode :: Bool
, ioMode :: IOMode
, bufMode :: BufferMode
}
defaultConnectionOptions :: ConnectionOptions
defaultConnectionOptions = ConnectionOptions
{ connMode = True
, ioMode = ReadWriteMode
, bufMode = LineBuffering
}
data ClientOptions
= ClientOptions
{ host :: String
, port :: Maybe PortNumber
, cliProto :: Maybe ProtocolNumber
, localEnd :: Maybe PortNumber
, cliOpts :: ConnectionOptions
}
clientOpts :: ClientOptions
clientOpts = ClientOptions
{ host = ""
, port = Nothing
, cliProto = Nothing
, localEnd = Nothing
, cliOpts = defaultConnectionOptions
}
clientConnection :: ClientOptions -> IO Connection
clientConnection opts = catch (do
s <- socket AF_INET (if connMode $ cliOpts opts then Stream else Datagram)
(fromMaybe S.defaultProtocol (cliProto opts))
setSocketOption s KeepAlive 1
hst <- getHostAddr (host opts)
let srcAddr = SockAddrInet (fromMaybe S.aNY_PORT (localEnd opts))
S.iNADDR_ANY
catch (S.bindSocket s srcAddr) (\ e -> sClose s >> ioError e)
resetSocketStatus s
let tgtAddr = SockAddrInet (fromMaybe S.aNY_PORT (port opts)) hst
catch (S.connect s tgtAddr) (\ e -> sClose s >> ioError e)
h <- socketToHandle s (ioMode $ cliOpts opts)
hSetBuffering h (bufMode $ cliOpts opts)
return (Connection{coHandle=h,coSocket=s,coServer=Nothing})) (errHandler opts)
where
errHandler o e = do
mapM_ (hPutStrLn stderr)
[ "clientConnection failed for: "
, show o
, "Details: "
, show e
]
ioError e
resetSocketStatus :: Socket -> IO ()
resetSocketStatus (MkSocket _ _ _ _ s) = do
modifyMVar_ s $ \ status -> do
case status of
Bound -> return NotConnected
_ -> return status
data ServerOptions
= ServerOptions
{ servInterface :: Maybe String
, servPort :: Maybe PortNumber
, servProto :: Maybe ProtocolNumber
, servOpts :: ConnectionOptions
}
serverOpts :: ServerOptions
serverOpts = ServerOptions
{ servInterface = Nothing
, servPort = Nothing
, servProto = Nothing
, servOpts = defaultConnectionOptions
}
data Server
= Server
{ servSocket :: Socket
, servOptions :: ConnectionOptions
, servSessions :: MVar [Connection]
}
newServer :: ServerOptions -> IO Server
newServer opts = do
s <- socket AF_INET (if connMode $ servOpts opts then Stream else Datagram)
(fromMaybe S.defaultProtocol (servProto opts))
setSocketOption s KeepAlive 1
setSocketOption s ReuseAddr 1
hst <- maybe (return iNADDR_ANY) getHostAddr (servInterface opts)
let srcAddr = SockAddrInet (fromMaybe S.aNY_PORT (servPort opts)) hst
catch (S.bindSocket s srcAddr) (\ e -> sClose s >> ioError e)
S.listen s 1024
sessVar <- newMVar []
return Server{ servSocket = s
, servOptions = servOpts opts
, servSessions = sessVar
}
acceptConnection :: Server -> IO (Connection, SockAddr)
acceptConnection s = catch (do
(sc,sa) <- S.accept (servSocket s)
let opts = servOptions s
h <- socketToHandle sc (ioMode opts)
hSetBuffering h (bufMode opts)
let conn =
Connection{ coHandle=h
, coSocket=sc
, coServer=Just s
}
modifyMVar_ (servSessions s) (\ ls -> return (conn:ls))
return (conn, sa))
(errHandler (servOptions s))
where
errHandler o e = do
mapM_ (hPutStrLn stderr)
[ "acceptConnection failed for: "
, show o
, "Details: "
, show e
]
ioError e
closeSession :: Connection -> Server -> IO ()
closeSession co s = modifyMVar_ (servSessions s) $ \ ls ->
case break (\ c -> coSocket c == coSocket co) ls of
(_,[]) -> return ls
(as,_:bs) -> return (as++bs)
closeServer :: Server -> IO ()
closeServer s = do
ls <- readMVar (servSessions s)
mapM_ closeConnection ls
_ls <- modifyMVar (servSessions s) (\ s -> return ([],s))
let sock = servSocket s
shutdown sock ShutdownSend
shutdown sock ShutdownReceive
sClose sock
return ()
closeConnection :: Connection -> IO ()
closeConnection co = do
let h = coHandle co
let s = coSocket co
hFlush h
shutdown s ShutdownSend
catch (hClose h) (\ _ -> return ())
shutdown s ShutdownReceive
sClose s
maybe (return ()) (closeSession co) (coServer co)
return ()
getHostAddr :: String -> IO HostAddress
getHostAddr h = do
catch (inet_addr h)
(\ _ -> do
hst <- getHostByName_safe h
case hostAddresses hst of
[] -> fail ("getHostAddr: no addresses in host entry for " ++ show h)
(ha:_) -> return ha)
getHostByName_safe :: HostName -> IO BSD.HostEntry
getHostByName_safe h =
catch (getHostByName h)
(\ _ -> fail ("Redis.connect: host lookup failure for " ++ show h))
instance Show ClientOptions where
show x =
unlines [ "ClientOptions: "
, " hostName = " ++ host x
, " portNumber = " ++ show (port x)
, " connection-oriented = " ++ show (connMode $ cliOpts x)
, " direction = " ++ show (ioMode $ cliOpts x)
, " buffering = " ++ show (bufMode $ cliOpts x)
]
instance Show ConnectionOptions where
show x =
unlines [ "ConnectionOptions: "
, " connection-oriented = " ++ show (connMode x)
, " direction = " ++ show (ioMode x)
, " buffering = " ++ show (bufMode x)
]