happstack-server-0.2.1: src/Happstack/Server/HTTPClient/TCP.hs
{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}
-----------------------------------------------------------------------------
-- |
-- Module : Happstack.Server.HTTPClient.TCP
-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004
-- License : BSD
--
-- Maintainer : bjorn@bringert.net
-- Stability : experimental
-- Portability : non-portable (not tested)
--
-- An easy access TCP library. Makes the use of TCP in Haskell much easier.
-- This was originally part of Gray's\/Bringert's HTTP module.
--
-- * Changes by Simon Foster:
-- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules
--
-----------------------------------------------------------------------------
module Happstack.Server.HTTPClient.TCP (
-- ** Connections
Conn(..),
Connection(..),
openTCP,
openTCPPort,
isConnectedTo
) where
import Control.Exception.Extensible as Exception
-- Networking
import Network.BSD
import Network.Socket
import Happstack.Server.HTTPClient.Stream
import Data.List (elemIndex)
import Data.Char
import Data.IORef
import System.IO
-----------------------------------------------------------------
------------------ TCP Connections ------------------------------
-----------------------------------------------------------------
-- | The 'Connection' newtype is a wrapper that allows us to make
-- connections an instance of the StreamIn\/Out classes, without ghc extensions.
-- While this looks sort of like a generic reference to the transport
-- layer it is actually TCP specific, which can be seen in the
-- implementation of the 'Stream Connection' instance.
newtype Connection = ConnRef {getRef :: IORef Conn}
-- | The 'Conn' object allows input buffering, and maintenance of
-- some admin-type data.
data Conn = MkConn { connSock :: ! Socket
, connAddr :: ! SockAddr
, connBffr :: ! String
, connHost :: String
}
| ConnClosed
deriving(Eq)
-- | Open a connection to port 80 on a remote host.
openTCP :: String -> IO Connection
openTCP host = openTCPPort host 80
-- | This function establishes a connection to a remote
-- host, it uses "getHostByName" which interrogates the
-- DNS system, hence may trigger a network connection.
--
-- Add a "persistant" option? Current persistant is default.
-- Use "Result" type for synchronous exception reporting?
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) -- handles ascii IP numbers
(\(_::SomeException) -> getHostByName uri >>= \host -> -- _shrug_ this will catch _any_ exception FIXME
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::SomeException) -> 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)
}
-- This function uses a buffer, at this time the buffer is just 1000 characters.
-- (however many bytes this is is left to the user to decypher)
readLine ref =
readIORef (getRef ref) >>= \conn -> case conn of
ConnClosed -> return (Left ErrorClosed)
(MkConn sk _addr bfr _)
| null bfr -> {- read in buffer -}
do { str <- myrecv sk 1000 -- DON'T use "readBlock sk 1000" !!
-- ... since that call will loop.
; let len = length str
; if len == 0 {- indicates a closed connection -}
then return (Right "")
else modifyIORef (getRef ref) (\c -> c { connBffr=str })
>> readLine ref -- recursion
}
| otherwise ->
case elemIndex '\n' bfr of
Nothing -> {- need recursion to finish line -}
do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })
; more <- readLine ref -- contains extra recursion
; return $ more `bindE` \str -> Right (bfr++str)
}
Just i -> {- end of line found -}
let (bgn,end) = splitAt i bfr in
do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop 1 end) })
; return (Right (bgn++['\n']))
}
-- The 'Connection' object allows no outward buffering,
-- since in general messages are serialised in their entirety.
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 ()) -- done
| 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)
-- Closes a Connection. Connection will no longer
-- allow any of the other Stream functions. Notice that a Connection may close
-- at any time before a call to this function. This function is idempotent.
-- (I think the behaviour here is TCP specific)
close ref =
do { c <- readIORef (getRef ref)
; closeConn c `Exception.catch` (\(_::SomeException) -> return ()) -- FIXME see above
; writeIORef (getRef ref) ConnClosed
}
where
-- Be kind to peer & close gracefully.
closeConn (ConnClosed) = return ()
closeConn (MkConn sk _addr [] _) =
do { shutdown sk ShutdownSend
; suck ref
; shutdown sk ShutdownReceive
; sClose sk
}
closeConn (MkConn _ _ _ _) = error "Case in closeConn not supported"
suck :: Connection -> IO ()
suck cn = readLine cn >>=
either (\_ -> return ()) -- catch errors & ignore
(\x -> if null x then return () else suck cn)
-- | Checks both that the underlying Socket is connected
-- and that the connection peer matches the given
-- host name (which is recorded locally).
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
}