{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Network.TCP
-- Copyright   :  See LICENSE file
-- License     :  BSD
--
-- Maintainer  :  Ganesh Sittampalam <ganesh@earth.li>
-- Stability   :  experimental
-- Portability :  non-portable (not tested)
--
-- Some utility functions for working with the Haskell @network@ package. Mostly
-- for internal use by the @Network.HTTP@ code.
--
-----------------------------------------------------------------------------
module Network.TCP
   ( Connection
   , EndPoint(..)
   , openTCPPort
   , isConnectedTo

   , openTCPConnection
   , socketConnection
   , isTCPConnectedTo

   , HandleStream
   , HStream(..)

   , StreamHooks(..)
   , nullHooks
   , setStreamHooks
   , getStreamHooks
   , hstreamToConnection

   ) where

import Network.Socket
   ( Socket, SocketOption(KeepAlive)
   , SocketType(Stream), connect
   , shutdown, ShutdownCmd(..)
   , setSocketOption, getPeerName
   , socket, Family(AF_UNSPEC), defaultProtocol, getAddrInfo
   , defaultHints, addrFamily, withSocketsDo
   , addrSocketType, addrAddress
   )
import qualified Network.Socket
   ( close )
import qualified Network.Stream as Stream
   ( Stream(readBlock, readLine, writeBlock, close, closeOnEnd) )
import Network.Stream
   ( ConnError(..)
   , Result
   , failWith
   , failMisc
   )
import Network.BufferType

import Network.HTTP.Base ( catchIO )
import Network.Socket ( socketToHandle )

import Data.Char  ( toLower )
import Data.Word  ( Word8 )
import Control.Concurrent
import Control.Exception ( IOException, bracketOnError, try )
import Control.Monad ( liftM, when )
import System.IO ( Handle, hFlush, IOMode(..), hClose )
import System.IO.Error ( isEOFError )

import qualified Data.ByteString      as Strict
import qualified Data.ByteString.Lazy as Lazy

-----------------------------------------------------------------
------------------ TCP Connections ------------------------------
-----------------------------------------------------------------

-- | The 'Connection' newtype is a wrapper that allows us to make
-- connections an instance of the Stream class, 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 = Connection (HandleStream String)

newtype HandleStream a = HandleStream {forall a. HandleStream a -> MVar (Conn a)
getRef :: MVar (Conn a)}

data EndPoint = EndPoint { EndPoint -> String
epHost :: String, EndPoint -> Int
epPort :: Int }

instance Eq EndPoint where
   EndPoint String
host1 Int
port1 == :: EndPoint -> EndPoint -> Bool
== EndPoint String
host2 Int
port2 =
     forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
host1 forall a. Eq a => a -> a -> Bool
== forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
host2 Bool -> Bool -> Bool
&& Int
port1 forall a. Eq a => a -> a -> Bool
== Int
port2

data Conn a
 = MkConn { forall a. Conn a -> Socket
connSock      :: !Socket
          , forall a. Conn a -> Handle
connHandle    :: Handle
          , forall a. Conn a -> BufferOp a
connBuffer    :: BufferOp a
          , forall a. Conn a -> Maybe a
connInput     :: Maybe a
          , forall a. Conn a -> EndPoint
connEndPoint  :: EndPoint
          , forall a. Conn a -> Maybe (StreamHooks a)
connHooks     :: Maybe (StreamHooks a)
          , forall a. Conn a -> Bool
connCloseEOF  :: Bool -- True => close socket upon reaching end-of-stream.
          }
 | ConnClosed
   deriving(Conn a -> Conn a -> Bool
forall a. Eq a => Conn a -> Conn a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Conn a -> Conn a -> Bool
$c/= :: forall a. Eq a => Conn a -> Conn a -> Bool
== :: Conn a -> Conn a -> Bool
$c== :: forall a. Eq a => Conn a -> Conn a -> Bool
Eq)

hstreamToConnection :: HandleStream String -> Connection
hstreamToConnection :: HandleStream String -> Connection
hstreamToConnection HandleStream String
h = HandleStream String -> Connection
Connection HandleStream String
h

connHooks' :: Conn a -> Maybe (StreamHooks a)
connHooks' :: forall a. Conn a -> Maybe (StreamHooks a)
connHooks' ConnClosed{} = forall a. Maybe a
Nothing
connHooks' Conn a
x = forall a. Conn a -> Maybe (StreamHooks a)
connHooks Conn a
x

-- all of these are post-op hooks
data StreamHooks ty
 = StreamHooks
     { forall ty. StreamHooks ty -> (ty -> String) -> Result ty -> IO ()
hook_readLine   :: (ty -> String) -> Result ty -> IO ()
     , forall ty.
StreamHooks ty -> (ty -> String) -> Int -> Result ty -> IO ()
hook_readBlock  :: (ty -> String) -> Int -> Result ty -> IO ()
     , forall ty.
StreamHooks ty -> (ty -> String) -> ty -> Result () -> IO ()
hook_writeBlock :: (ty -> String) -> ty  -> Result () -> IO ()
     , forall ty. StreamHooks ty -> IO ()
hook_close      :: IO ()
     , forall ty. StreamHooks ty -> String
hook_name       :: String -- hack alert: name of the hook itself.
     }

instance Eq ty => Eq (StreamHooks ty) where
  == :: StreamHooks ty -> StreamHooks ty -> Bool
(==) StreamHooks ty
_ StreamHooks ty
_ = Bool
True

nullHooks :: StreamHooks ty
nullHooks :: forall ty. StreamHooks ty
nullHooks = StreamHooks
     { hook_readLine :: (ty -> String) -> Result ty -> IO ()
hook_readLine   = \ ty -> String
_ Result ty
_   -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
     , hook_readBlock :: (ty -> String) -> Int -> Result ty -> IO ()
hook_readBlock  = \ ty -> String
_ Int
_ Result ty
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
     , hook_writeBlock :: (ty -> String) -> ty -> Result () -> IO ()
hook_writeBlock = \ ty -> String
_ ty
_ Result ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
     , hook_close :: IO ()
hook_close      = forall (m :: * -> *) a. Monad m => a -> m a
return ()
     , hook_name :: String
hook_name       = String
""
     }

setStreamHooks :: HandleStream ty -> StreamHooks ty -> IO ()
setStreamHooks :: forall ty. HandleStream ty -> StreamHooks ty -> IO ()
setStreamHooks HandleStream ty
h StreamHooks ty
sh = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (forall a. HandleStream a -> MVar (Conn a)
getRef HandleStream ty
h) (\ Conn ty
c -> forall (m :: * -> *) a. Monad m => a -> m a
return Conn ty
c{connHooks :: Maybe (StreamHooks ty)
connHooks=forall a. a -> Maybe a
Just StreamHooks ty
sh})

getStreamHooks :: HandleStream ty -> IO (Maybe (StreamHooks ty))
getStreamHooks :: forall ty. HandleStream ty -> IO (Maybe (StreamHooks ty))
getStreamHooks HandleStream ty
h = forall a. MVar a -> IO a
readMVar (forall a. HandleStream a -> MVar (Conn a)
getRef HandleStream ty
h) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
returnforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Conn a -> Maybe (StreamHooks a)
connHooks

-- | @HStream@ overloads the use of 'HandleStream's, letting you
-- overload the handle operations over the type that is communicated
-- across the handle. It comes in handy for @Network.HTTP@ 'Request'
-- and 'Response's as the payload representation isn't fixed, but overloaded.
--
-- The library comes with instances for @ByteString@s and @String@, but
-- should you want to plug in your own payload representation, defining
-- your own @HStream@ instance _should_ be all that it takes.
--
class BufferType bufType => HStream bufType where
  openStream       :: String -> Int -> IO (HandleStream bufType)
  openSocketStream :: String -> Int -> Socket -> IO (HandleStream bufType)
  readLine         :: HandleStream bufType -> IO (Result bufType)
  readBlock        :: HandleStream bufType -> Int -> IO (Result bufType)
  writeBlock       :: HandleStream bufType -> bufType -> IO (Result ())
  close            :: HandleStream bufType -> IO ()
  closeQuick       :: HandleStream bufType -> IO ()
  closeOnEnd       :: HandleStream bufType -> Bool -> IO ()

instance HStream Strict.ByteString where
  openStream :: String -> Int -> IO (HandleStream ByteString)
openStream       = forall ty. BufferType ty => String -> Int -> IO (HandleStream ty)
openTCPConnection
  openSocketStream :: String -> Int -> Socket -> IO (HandleStream ByteString)
openSocketStream = forall ty.
BufferType ty =>
String -> Int -> Socket -> IO (HandleStream ty)
socketConnection
  readBlock :: HandleStream ByteString -> Int -> IO (Result ByteString)
readBlock HandleStream ByteString
c Int
n    = forall a. HStream a => HandleStream a -> Int -> IO (Result a)
readBlockBS HandleStream ByteString
c Int
n
  readLine :: HandleStream ByteString -> IO (Result ByteString)
readLine HandleStream ByteString
c       = forall a. HStream a => HandleStream a -> IO (Result a)
readLineBS HandleStream ByteString
c
  writeBlock :: HandleStream ByteString -> ByteString -> IO (Result ())
writeBlock HandleStream ByteString
c ByteString
str = forall a. HandleStream a -> a -> IO (Result ())
writeBlockBS HandleStream ByteString
c ByteString
str
  close :: HandleStream ByteString -> IO ()
close HandleStream ByteString
c          = forall ty.
HStream ty =>
HandleStream ty -> (ty -> Bool) -> Bool -> IO ()
closeIt HandleStream ByteString
c ByteString -> Bool
Strict.null Bool
True
  closeQuick :: HandleStream ByteString -> IO ()
closeQuick HandleStream ByteString
c     = forall ty.
HStream ty =>
HandleStream ty -> (ty -> Bool) -> Bool -> IO ()
closeIt HandleStream ByteString
c ByteString -> Bool
Strict.null Bool
False
  closeOnEnd :: HandleStream ByteString -> Bool -> IO ()
closeOnEnd HandleStream ByteString
c Bool
f   = forall ty. HandleStream ty -> Bool -> IO ()
closeEOF HandleStream ByteString
c Bool
f

instance HStream Lazy.ByteString where
    openStream :: String -> Int -> IO (HandleStream ByteString)
openStream       = \ String
a Int
b -> forall ty.
BufferType ty =>
String -> Int -> Bool -> IO (HandleStream ty)
openTCPConnection_ String
a Int
b Bool
True
    openSocketStream :: String -> Int -> Socket -> IO (HandleStream ByteString)
openSocketStream = \ String
a Int
b Socket
c -> forall ty.
BufferType ty =>
String -> Int -> Socket -> Bool -> IO (HandleStream ty)
socketConnection_ String
a Int
b Socket
c Bool
True
    readBlock :: HandleStream ByteString -> Int -> IO (Result ByteString)
readBlock HandleStream ByteString
c Int
n    = forall a. HStream a => HandleStream a -> Int -> IO (Result a)
readBlockBS HandleStream ByteString
c Int
n
    readLine :: HandleStream ByteString -> IO (Result ByteString)
readLine HandleStream ByteString
c       = forall a. HStream a => HandleStream a -> IO (Result a)
readLineBS HandleStream ByteString
c
    writeBlock :: HandleStream ByteString -> ByteString -> IO (Result ())
writeBlock HandleStream ByteString
c ByteString
str = forall a. HandleStream a -> a -> IO (Result ())
writeBlockBS HandleStream ByteString
c ByteString
str
    close :: HandleStream ByteString -> IO ()
close HandleStream ByteString
c          = forall ty.
HStream ty =>
HandleStream ty -> (ty -> Bool) -> Bool -> IO ()
closeIt HandleStream ByteString
c ByteString -> Bool
Lazy.null Bool
True
    closeQuick :: HandleStream ByteString -> IO ()
closeQuick HandleStream ByteString
c     = forall ty.
HStream ty =>
HandleStream ty -> (ty -> Bool) -> Bool -> IO ()
closeIt HandleStream ByteString
c ByteString -> Bool
Lazy.null Bool
False
    closeOnEnd :: HandleStream ByteString -> Bool -> IO ()
closeOnEnd HandleStream ByteString
c Bool
f   = forall ty. HandleStream ty -> Bool -> IO ()
closeEOF HandleStream ByteString
c Bool
f

instance Stream.Stream Connection where
  readBlock :: Connection -> Int -> IO (Result String)
readBlock (Connection HandleStream String
c)     = forall a. HStream a => HandleStream a -> Int -> IO (Result a)
Network.TCP.readBlock HandleStream String
c
  readLine :: Connection -> IO (Result String)
readLine (Connection HandleStream String
c)      = forall a. HStream a => HandleStream a -> IO (Result a)
Network.TCP.readLine HandleStream String
c
  writeBlock :: Connection -> String -> IO (Result ())
writeBlock (Connection HandleStream String
c)    = forall bufType.
HStream bufType =>
HandleStream bufType -> bufType -> IO (Result ())
Network.TCP.writeBlock HandleStream String
c
  close :: Connection -> IO ()
close (Connection HandleStream String
c)         = forall bufType. HStream bufType => HandleStream bufType -> IO ()
Network.TCP.close HandleStream String
c
  closeOnEnd :: Connection -> Bool -> IO ()
closeOnEnd (Connection HandleStream String
c) Bool
f  = forall ty. HandleStream ty -> Bool -> IO ()
Network.TCP.closeEOF HandleStream String
c Bool
f

instance HStream String where
    openStream :: String -> Int -> IO (HandleStream String)
openStream      = forall ty. BufferType ty => String -> Int -> IO (HandleStream ty)
openTCPConnection
    openSocketStream :: String -> Int -> Socket -> IO (HandleStream String)
openSocketStream = forall ty.
BufferType ty =>
String -> Int -> Socket -> IO (HandleStream ty)
socketConnection
    readBlock :: HandleStream String -> Int -> IO (Result String)
readBlock HandleStream String
ref Int
n = forall a. HStream a => HandleStream a -> Int -> IO (Result a)
readBlockBS HandleStream String
ref Int
n

    -- 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 :: HandleStream String -> IO (Result String)
readLine HandleStream String
ref = forall a. HStream a => HandleStream a -> IO (Result a)
readLineBS HandleStream String
ref
    -- The 'Connection' object allows no outward buffering,
    -- since in general messages are serialised in their entirety.
    writeBlock :: HandleStream String -> String -> IO (Result ())
writeBlock HandleStream String
ref String
str = forall a. HandleStream a -> a -> IO (Result ())
writeBlockBS HandleStream String
ref String
str -- (stringToBuf str)

    -- 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 :: HandleStream String -> IO ()
close HandleStream String
c = forall ty.
HStream ty =>
HandleStream ty -> (ty -> Bool) -> Bool -> IO ()
closeIt HandleStream String
c forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bool
True

    -- Closes a Connection without munching the rest of the stream.
    closeQuick :: HandleStream String -> IO ()
closeQuick HandleStream String
c = forall ty.
HStream ty =>
HandleStream ty -> (ty -> Bool) -> Bool -> IO ()
closeIt HandleStream String
c forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bool
False

    closeOnEnd :: HandleStream String -> Bool -> IO ()
closeOnEnd HandleStream String
c Bool
f = forall ty. HandleStream ty -> Bool -> IO ()
closeEOF HandleStream String
c Bool
f

-- | @openTCPPort uri port@  establishes a connection to a remote
-- host, using 'getHostByName' which possibly queries the DNS system, hence
-- may trigger a network connection.
openTCPPort :: String -> Int -> IO Connection
openTCPPort :: String -> Int -> IO Connection
openTCPPort String
uri Int
port = forall ty. BufferType ty => String -> Int -> IO (HandleStream ty)
openTCPConnection String
uri Int
port forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
returnforall b c a. (b -> c) -> (a -> b) -> a -> c
.HandleStream String -> Connection
Connection

-- Add a "persistent" option?  Current persistent is default.
-- Use "Result" type for synchronous exception reporting?
openTCPConnection :: BufferType ty => String -> Int -> IO (HandleStream ty)
openTCPConnection :: forall ty. BufferType ty => String -> Int -> IO (HandleStream ty)
openTCPConnection String
uri Int
port = forall ty.
BufferType ty =>
String -> Int -> Bool -> IO (HandleStream ty)
openTCPConnection_ String
uri Int
port Bool
False

openTCPConnection_ :: BufferType ty => String -> Int -> Bool -> IO (HandleStream ty)
openTCPConnection_ :: forall ty.
BufferType ty =>
String -> Int -> Bool -> IO (HandleStream ty)
openTCPConnection_ String
uri Int
port Bool
stashInput = do
    -- HACK: uri is sometimes obtained by calling Network.URI.uriRegName, and this includes
    -- the surrounding square brackets for an RFC 2732 host like [::1]. It's not clear whether
    -- it should, or whether all call sites should be using something different instead, but
    -- the simplest short-term fix is to strip any surrounding square brackets here.
    -- It shouldn't affect any as this is the only situation they can occur - see RFC 3986.
    let fixedUri :: String
fixedUri =
         case String
uri of
            Char
'[':(rest :: String
rest@(Char
c:String
_)) | forall a. [a] -> a
last String
rest forall a. Eq a => a -> a -> Bool
== Char
']'
              -> if Char
c forall a. Eq a => a -> a -> Bool
== Char
'v' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'V'
                     then forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unsupported post-IPv6 address " forall a. [a] -> [a] -> [a]
++ String
uri
                     else forall a. [a] -> [a]
init String
rest
            String
_ -> String
uri


    -- use withSocketsDo here in case the caller hasn't used it, which would make getAddrInfo fail on Windows
    -- although withSocketsDo is supposed to wrap the entire program, in practice it is safe to use it locally
    -- like this as it just does a once-only installation of a shutdown handler to run at program exit,
    -- rather than actually shutting down after the action
    [AddrInfo]
addrinfos <- forall a. IO a -> IO a
withSocketsDo forall a b. (a -> b) -> a -> b
$ Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AddrInfo
defaultHints { addrFamily :: Family
addrFamily = Family
AF_UNSPEC, addrSocketType :: SocketType
addrSocketType = SocketType
Stream }) (forall a. a -> Maybe a
Just String
fixedUri) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Int
port)

    let
      connectAddrInfo :: AddrInfo -> IO (HandleStream ty)
connectAddrInfo AddrInfo
a = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
a) SocketType
Stream ProtocolNumber
defaultProtocol)  -- acquire
        Socket -> IO ()
Network.Socket.close                            -- release
        ( \Socket
s -> do
            Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
s SocketOption
KeepAlive Int
1
            Socket -> SockAddr -> IO ()
connect Socket
s (AddrInfo -> SockAddr
addrAddress AddrInfo
a)
            forall ty.
BufferType ty =>
String -> Int -> Socket -> Bool -> IO (HandleStream ty)
socketConnection_ String
fixedUri Int
port Socket
s Bool
stashInput )

      -- try multiple addresses; return Just connected socket or Nothing
      tryAddrInfos :: [AddrInfo] -> IO (Maybe (HandleStream ty))
tryAddrInfos [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      tryAddrInfos (AddrInfo
h:[AddrInfo]
t) =
        let next :: IOException -> IO (Maybe (HandleStream ty))
next = \(IOException
_ :: IOException) -> [AddrInfo] -> IO (Maybe (HandleStream ty))
tryAddrInfos [AddrInfo]
t
        in  forall e a. Exception e => IO a -> IO (Either e a)
try (forall {ty}. BufferType ty => AddrInfo -> IO (HandleStream ty)
connectAddrInfo AddrInfo
h) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IOException -> IO (Maybe (HandleStream ty))
next (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)

    case [AddrInfo]
addrinfos of
        [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"openTCPConnection: getAddrInfo returned no address information"

        -- single AddrInfo; call connectAddrInfo directly so that specific
        -- exception is thrown in event of failure
        [AddrInfo
ai] -> forall {ty}. BufferType ty => AddrInfo -> IO (HandleStream ty)
connectAddrInfo AddrInfo
ai forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (\IOException
e -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
                  String
"openTCPConnection: failed to connect to "
                  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (AddrInfo -> SockAddr
addrAddress AddrInfo
ai) forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOException
e)

        -- multiple AddrInfos; try each until we get a connection, or run out
        [AddrInfo]
ais ->
          let
            err :: IO a
err = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"openTCPConnection: failed to connect; tried addresses: "
                         forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AddrInfo -> SockAddr
addrAddress [AddrInfo]
ais)
          in forall {ty}.
BufferType ty =>
[AddrInfo] -> IO (Maybe (HandleStream ty))
tryAddrInfos [AddrInfo]
ais forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. IO a
err forall (m :: * -> *) a. Monad m => a -> m a
return

-- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'.
socketConnection :: BufferType ty
                 => String
                 -> Int
                 -> Socket
                 -> IO (HandleStream ty)
socketConnection :: forall ty.
BufferType ty =>
String -> Int -> Socket -> IO (HandleStream ty)
socketConnection String
hst Int
port Socket
sock = forall ty.
BufferType ty =>
String -> Int -> Socket -> Bool -> IO (HandleStream ty)
socketConnection_ String
hst Int
port Socket
sock Bool
False

-- Internal function used to control the on-demand streaming of input
-- for /lazy/ streams.
socketConnection_ :: BufferType ty
                  => String
                  -> Int
                  -> Socket
                  -> Bool
                  -> IO (HandleStream ty)
socketConnection_ :: forall ty.
BufferType ty =>
String -> Int -> Socket -> Bool -> IO (HandleStream ty)
socketConnection_ String
hst Int
port Socket
sock Bool
stashInput = do
    Handle
h <- Socket -> IOMode -> IO Handle
socketToHandle Socket
sock IOMode
ReadWriteMode
    Maybe ty
mb <- case Bool
stashInput of { Bool
True -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. BufferOp a -> Handle -> IO a
buf_hGetContents forall bufType. BufferType bufType => BufferOp bufType
bufferOps Handle
h; Bool
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing }
    let conn :: Conn ty
conn = MkConn
         { connSock :: Socket
connSock     = Socket
sock
         , connHandle :: Handle
connHandle   = Handle
h
         , connBuffer :: BufferOp ty
connBuffer   = forall bufType. BufferType bufType => BufferOp bufType
bufferOps
         , connInput :: Maybe ty
connInput    = Maybe ty
mb
         , connEndPoint :: EndPoint
connEndPoint = String -> Int -> EndPoint
EndPoint String
hst Int
port
         , connHooks :: Maybe (StreamHooks ty)
connHooks    = forall a. Maybe a
Nothing
         , connCloseEOF :: Bool
connCloseEOF = Bool
False
         }
    MVar (Conn ty)
v <- forall a. a -> IO (MVar a)
newMVar Conn ty
conn
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. MVar (Conn a) -> HandleStream a
HandleStream MVar (Conn ty)
v)

closeConnection :: HStream a => HandleStream a -> IO Bool -> IO ()
closeConnection :: forall a. HStream a => HandleStream a -> IO Bool -> IO ()
closeConnection HandleStream a
ref IO Bool
readL = do
    -- won't hold onto the lock for the duration
    -- we are draining it...ToDo: have Connection
    -- into a shutting-down state so that other
    -- threads will simply back off if/when attempting
    -- to also close it.
  Conn a
c <- forall a. MVar a -> IO a
readMVar (forall a. HandleStream a -> MVar (Conn a)
getRef HandleStream a
ref)
  forall {a}. Conn a -> IO ()
closeConn Conn a
c forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (\IOException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
  forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (forall a. HandleStream a -> MVar (Conn a)
getRef HandleStream a
ref) (\ Conn a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Conn a
ConnClosed)
 where
   -- Be kind to peer & close gracefully.
  closeConn :: Conn a -> IO ()
closeConn Conn a
ConnClosed = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  closeConn Conn a
conn = do
    let sk :: Socket
sk = forall a. Conn a -> Socket
connSock Conn a
conn
    Handle -> IO ()
hFlush (forall a. Conn a -> Handle
connHandle Conn a
conn)
    Socket -> ShutdownCmd -> IO ()
shutdown Socket
sk ShutdownCmd
ShutdownSend
    IO Bool -> IO ()
suck IO Bool
readL
    Handle -> IO ()
hClose (forall a. Conn a -> Handle
connHandle Conn a
conn)
    Socket -> ShutdownCmd -> IO ()
shutdown Socket
sk ShutdownCmd
ShutdownReceive
    Socket -> IO ()
Network.Socket.close Socket
sk

  suck :: IO Bool -> IO ()
  suck :: IO Bool -> IO ()
suck IO Bool
rd = do
    Bool
f <- IO Bool
rd
    if Bool
f then forall (m :: * -> *) a. Monad m => a -> m a
return () else IO Bool -> IO ()
suck IO Bool
rd

-- | Checks both that the underlying Socket is connected
-- and that the connection peer matches the given
-- host name (which is recorded locally).
isConnectedTo :: Connection -> EndPoint -> IO Bool
isConnectedTo :: Connection -> EndPoint -> IO Bool
isConnectedTo (Connection HandleStream String
conn) EndPoint
endPoint = forall ty. HandleStream ty -> EndPoint -> IO Bool
isTCPConnectedTo HandleStream String
conn EndPoint
endPoint

isTCPConnectedTo :: HandleStream ty -> EndPoint -> IO Bool
isTCPConnectedTo :: forall ty. HandleStream ty -> EndPoint -> IO Bool
isTCPConnectedTo HandleStream ty
conn EndPoint
endPoint = do
   Conn ty
v <- forall a. MVar a -> IO a
readMVar (forall a. HandleStream a -> MVar (Conn a)
getRef HandleStream ty
conn)
   case Conn ty
v of
     Conn ty
ConnClosed -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
     Conn ty
_
      | forall a. Conn a -> EndPoint
connEndPoint Conn ty
v forall a. Eq a => a -> a -> Bool
== EndPoint
endPoint ->
          forall a. IO a -> (IOException -> IO a) -> IO a
catchIO (Socket -> IO SockAddr
getPeerName (forall a. Conn a -> Socket
connSock Conn ty
v) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
      | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

readBlockBS :: HStream a => HandleStream a -> Int -> IO (Result a)
readBlockBS :: forall a. HStream a => HandleStream a -> Int -> IO (Result a)
readBlockBS HandleStream a
ref Int
n = forall a b.
HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b)
onNonClosedDo HandleStream a
ref forall a b. (a -> b) -> a -> b
$ \ Conn a
conn -> do
   Result a
x <- forall a. HStream a => HandleStream a -> Int -> IO (Result a)
bufferGetBlock HandleStream a
ref Int
n
   forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ())
         (\ StreamHooks a
h -> forall ty.
StreamHooks ty -> (ty -> String) -> Int -> Result ty -> IO ()
hook_readBlock StreamHooks a
h (forall a. BufferOp a -> a -> String
buf_toStr forall a b. (a -> b) -> a -> b
$ forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) Int
n Result a
x)
         (forall a. Conn a -> Maybe (StreamHooks a)
connHooks' Conn a
conn)
   forall (m :: * -> *) a. Monad m => a -> m a
return Result a
x

-- This function uses a buffer, at this time the buffer is just 1000 characters.
-- (however many bytes this is is left for the user to decipher)
readLineBS :: HStream a => HandleStream a -> IO (Result a)
readLineBS :: forall a. HStream a => HandleStream a -> IO (Result a)
readLineBS HandleStream a
ref = forall a b.
HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b)
onNonClosedDo HandleStream a
ref forall a b. (a -> b) -> a -> b
$ \ Conn a
conn -> do
   Result a
x <- forall a. HStream a => HandleStream a -> IO (Result a)
bufferReadLine HandleStream a
ref
   forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ())
         (\ StreamHooks a
h -> forall ty. StreamHooks ty -> (ty -> String) -> Result ty -> IO ()
hook_readLine StreamHooks a
h (forall a. BufferOp a -> a -> String
buf_toStr forall a b. (a -> b) -> a -> b
$ forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) Result a
x)
         (forall a. Conn a -> Maybe (StreamHooks a)
connHooks' Conn a
conn)
   forall (m :: * -> *) a. Monad m => a -> m a
return Result a
x

-- The 'Connection' object allows no outward buffering,
-- since in general messages are serialised in their entirety.
writeBlockBS :: HandleStream a -> a -> IO (Result ())
writeBlockBS :: forall a. HandleStream a -> a -> IO (Result ())
writeBlockBS HandleStream a
ref a
b = forall a b.
HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b)
onNonClosedDo HandleStream a
ref forall a b. (a -> b) -> a -> b
$ \ Conn a
conn -> do
  Result ()
x    <- forall a. BufferOp a -> Handle -> a -> IO (Result ())
bufferPutBlock (forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) (forall a. Conn a -> Handle
connHandle Conn a
conn) a
b
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ())
        (\ StreamHooks a
h -> forall ty.
StreamHooks ty -> (ty -> String) -> ty -> Result () -> IO ()
hook_writeBlock StreamHooks a
h (forall a. BufferOp a -> a -> String
buf_toStr forall a b. (a -> b) -> a -> b
$ forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) a
b Result ()
x)
        (forall a. Conn a -> Maybe (StreamHooks a)
connHooks' Conn a
conn)
  forall (m :: * -> *) a. Monad m => a -> m a
return Result ()
x

closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> Bool -> IO ()
closeIt :: forall ty.
HStream ty =>
HandleStream ty -> (ty -> Bool) -> Bool -> IO ()
closeIt HandleStream ty
c ty -> Bool
p Bool
b = do
   forall a. HStream a => HandleStream a -> IO Bool -> IO ()
closeConnection HandleStream ty
c (if Bool
b
                      then forall a. HStream a => HandleStream a -> IO (Result a)
readLineBS HandleStream ty
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Result ty
x -> case Result ty
x of { Right ty
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return (ty -> Bool
p ty
xs); Result ty
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True}
                      else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
   Conn ty
conn <- forall a. MVar a -> IO a
readMVar (forall a. HandleStream a -> MVar (Conn a)
getRef HandleStream ty
c)
   forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ())
         (forall ty. StreamHooks ty -> IO ()
hook_close)
         (forall a. Conn a -> Maybe (StreamHooks a)
connHooks' Conn ty
conn)

closeEOF :: HandleStream ty -> Bool -> IO ()
closeEOF :: forall ty. HandleStream ty -> Bool -> IO ()
closeEOF HandleStream ty
c Bool
flg = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (forall a. HandleStream a -> MVar (Conn a)
getRef HandleStream ty
c) (\ Conn ty
co -> forall (m :: * -> *) a. Monad m => a -> m a
return Conn ty
co{connCloseEOF :: Bool
connCloseEOF=Bool
flg})

bufferGetBlock :: HStream a => HandleStream a -> Int -> IO (Result a)
bufferGetBlock :: forall a. HStream a => HandleStream a -> Int -> IO (Result a)
bufferGetBlock HandleStream a
ref Int
n = forall a b.
HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b)
onNonClosedDo HandleStream a
ref forall a b. (a -> b) -> a -> b
$ \ Conn a
conn -> do
   case forall a. Conn a -> Maybe a
connInput Conn a
conn of
    Just a
c -> do
      let (a
a,a
b) = forall a. BufferOp a -> Int -> a -> (a, a)
buf_splitAt (forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) Int
n a
c
      forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (forall a. HandleStream a -> MVar (Conn a)
getRef HandleStream a
ref) (\ Conn a
co -> forall (m :: * -> *) a. Monad m => a -> m a
return Conn a
co{connInput :: Maybe a
connInput=forall a. a -> Maybe a
Just a
b})
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return a
a)
    Maybe a
_ -> do
      forall a. IO a -> (IOException -> IO a) -> IO a
catchIO (forall a. BufferOp a -> Handle -> Int -> IO a
buf_hGet (forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) (forall a. Conn a -> Handle
connHandle Conn a
conn) Int
n forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
returnforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (m :: * -> *) a. Monad m => a -> m a
return)
              (\ IOException
e ->
                       if IOException -> Bool
isEOFError IOException
e
                        then do
                          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Conn a -> Bool
connCloseEOF Conn a
conn) forall a b. (a -> b) -> a -> b
$ forall a. IO a -> (IOException -> IO a) -> IO a
catchIO (forall bufType. HStream bufType => HandleStream bufType -> IO ()
closeQuick HandleStream a
ref) (\ IOException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
                          forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. BufferOp a -> a
buf_empty (forall a. Conn a -> BufferOp a
connBuffer Conn a
conn)))
                        else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. String -> Result a
failMisc (forall a. Show a => a -> String
show IOException
e)))

bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ())
bufferPutBlock :: forall a. BufferOp a -> Handle -> a -> IO (Result ())
bufferPutBlock BufferOp a
ops Handle
h a
b =
  forall a. IO a -> (IOException -> IO a) -> IO a
catchIO (forall a. BufferOp a -> Handle -> a -> IO ()
buf_hPut BufferOp a
ops Handle
h a
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return ()))
          (\ IOException
e -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. String -> Result a
failMisc (forall a. Show a => a -> String
show IOException
e)))

bufferReadLine :: HStream a => HandleStream a -> IO (Result a)
bufferReadLine :: forall a. HStream a => HandleStream a -> IO (Result a)
bufferReadLine HandleStream a
ref = forall a b.
HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b)
onNonClosedDo HandleStream a
ref forall a b. (a -> b) -> a -> b
$ \ Conn a
conn -> do
  case forall a. Conn a -> Maybe a
connInput Conn a
conn of
   Just a
c -> do
    let (a
a,a
b0)  = forall a. BufferOp a -> (Char -> Bool) -> a -> (a, a)
buf_span (forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) (forall a. Eq a => a -> a -> Bool
/=Char
'\n') a
c
    let (a
newl,a
b1) = forall a. BufferOp a -> Int -> a -> (a, a)
buf_splitAt (forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) Int
1 a
b0
    forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (forall a. HandleStream a -> MVar (Conn a)
getRef HandleStream a
ref) (\ Conn a
co -> forall (m :: * -> *) a. Monad m => a -> m a
return Conn a
co{connInput :: Maybe a
connInput=forall a. a -> Maybe a
Just a
b1})
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. BufferOp a -> a -> a -> a
buf_append (forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) a
a a
newl))
   Maybe a
_ -> forall a. IO a -> (IOException -> IO a) -> IO a
catchIO
              (forall a. BufferOp a -> Handle -> IO a
buf_hGetLine (forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) (forall a. Conn a -> Handle
connHandle Conn a
conn) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. BufferOp a -> a -> a
appendNL (forall a. Conn a -> BufferOp a
connBuffer Conn a
conn))
              (\ IOException
e ->
                 if IOException -> Bool
isEOFError IOException
e
                  then do
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Conn a -> Bool
connCloseEOF Conn a
conn) forall a b. (a -> b) -> a -> b
$ forall a. IO a -> (IOException -> IO a) -> IO a
catchIO (forall bufType. HStream bufType => HandleStream bufType -> IO ()
closeQuick HandleStream a
ref) (\ IOException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
                    forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return   (forall a. BufferOp a -> a
buf_empty (forall a. Conn a -> BufferOp a
connBuffer Conn a
conn)))
                  else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. String -> Result a
failMisc (forall a. Show a => a -> String
show IOException
e)))
 where
   -- yes, this s**ks.. _may_ have to be addressed if perf
   -- suggests worthiness.
  appendNL :: BufferOp a -> a -> a
appendNL BufferOp a
ops a
b = forall a. BufferOp a -> a -> Word8 -> a
buf_snoc BufferOp a
ops a
b Word8
nl

  nl :: Word8
  nl :: Word8
nl = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Enum a => a -> Int
fromEnum Char
'\n')

onNonClosedDo :: HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b)
onNonClosedDo :: forall a b.
HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b)
onNonClosedDo HandleStream a
h Conn a -> IO (Result b)
act = do
  Conn a
x <- forall a. MVar a -> IO a
readMVar (forall a. HandleStream a -> MVar (Conn a)
getRef HandleStream a
h)
  case Conn a
x of
    ConnClosed{} -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ConnError -> Result a
failWith ConnError
ErrorClosed)
    Conn a
_ -> Conn a -> IO (Result b)
act Conn a
x