module Network.TCP
( Connection
, openTCPPort
, isConnectedTo
) where
import Network.BSD (getHostByName, hostAddresses)
import Network.Socket
( Socket, SockAddr(SockAddrInet), SocketOption(KeepAlive, SoError)
, SocketType(Stream), inet_addr, connect, sendTo
, shutdown, ShutdownCmd(ShutdownSend, ShutdownReceive)
, sClose, sIsConnected, setSocketOption, getSocketOption
, socket, Family(AF_INET)
)
import Network.Stream
( Stream(readBlock, readLine, writeBlock, close)
, ConnError(ErrorMisc, ErrorReset, ErrorClosed)
, bindE
)
import Network.StreamSocket (myrecv, handleSocketError)
import Control.Exception as Exception (catch, catchJust, finally, ioErrors, throw)
import Data.List (elemIndex)
import Data.Char (toLower)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
newtype Connection = ConnRef {getRef :: IORef Conn}
data Conn = MkConn { connSock :: ! Socket
, connAddr :: ! SockAddr
, connBffr :: ! String
, connHost :: String
}
| ConnClosed
deriving(Eq)
openTCPPort :: String -> Int -> IO Connection
openTCPPort uri port =
do { s <- socket AF_INET Stream 6
; setSocketOption s KeepAlive 1
; host <- Exception.catch (inet_addr uri)
(\_ -> getHostByName uri >>= \host ->
case hostAddresses host of
[] -> return (error "no addresses in host entry")
(h:_) -> return h)
; let a = SockAddrInet (toEnum port) host
; Exception.catch (connect s a) (\e -> sClose s >> throw e)
; v <- newIORef (MkConn s a [] uri)
; return (ConnRef v)
}
instance Stream Connection where
readBlock ref n =
readIORef (getRef ref) >>= \conn -> case conn of
ConnClosed -> return (Left ErrorClosed)
(MkConn sk addr bfr hst)
| length bfr >= n ->
do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop n bfr) })
; return (Right $ take n bfr)
}
| otherwise ->
do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })
; more <- readBlock sk (n length bfr)
; return $ case more of
Left _ -> more
Right s -> (Right $ bfr ++ s)
}
readLine ref =
readIORef (getRef ref) >>= \conn -> case conn of
ConnClosed -> return (Left ErrorClosed)
(MkConn sk addr bfr _)
| null bfr ->
do { str <- myrecv sk 1000
; let len = length str
; if len == 0
then return (Right "")
else modifyIORef (getRef ref) (\c -> c { connBffr=str })
>> readLine ref
}
| otherwise ->
case elemIndex '\n' bfr of
Nothing ->
do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })
; more <- readLine ref
; return $ more `bindE` \str -> Right (bfr++str)
}
Just i ->
let (bgn,end) = splitAt i bfr in
do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop 1 end) })
; return (Right (bgn++['\n']))
}
writeBlock ref str =
readIORef (getRef ref) >>= \conn -> case conn of
ConnClosed -> return (Left ErrorClosed)
(MkConn sk addr _ _) -> fn sk addr str `Exception.catch` (handleSocketError sk)
where
fn sk addr s
| null s = return (Right ())
| otherwise =
getSocketOption sk SoError >>= \se ->
if se == 0
then sendTo sk s addr >>= \i -> fn sk addr (drop i s)
else writeIORef (getRef ref) ConnClosed >>
if se == 10054
then return (Left ErrorReset)
else return (Left $ ErrorMisc $ show se)
close ref =
do { c <- readIORef (getRef ref)
; Exception.catchJust Exception.ioErrors (closeConn c) (\_ -> return ())
; writeIORef (getRef ref) ConnClosed
}
where
closeConn (ConnClosed) = return ()
closeConn (MkConn sk addr [] _) =
(`Exception.finally` sClose sk) $
do { shutdown sk ShutdownSend
; suck ref
; shutdown sk ShutdownReceive
}
suck :: Connection -> IO ()
suck cn = readLine cn >>=
either (\_ -> return ())
(\x -> if null x then return () else suck cn)
isConnectedTo :: Connection -> String -> IO Bool
isConnectedTo conn name =
do { v <- readIORef (getRef conn)
; case v of
ConnClosed -> return False
(MkConn sk _ _ h) ->
if (map toLower h == map toLower name)
then sIsConnected sk
else return False
}