{-# 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 {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 =
     (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
host1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
host2 Bool -> Bool -> Bool
&& Int
port1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
port2

data Conn a 
 = MkConn { Conn a -> Socket
connSock      :: !Socket
          , Conn a -> Handle
connHandle    :: Handle
          , Conn a -> BufferOp a
connBuffer    :: BufferOp a
          , Conn a -> Maybe a
connInput     :: Maybe a
          , Conn a -> EndPoint
connEndPoint  :: EndPoint
          , Conn a -> Maybe (StreamHooks a)
connHooks     :: Maybe (StreamHooks a)
          , Conn a -> Bool
connCloseEOF  :: Bool -- True => close socket upon reaching end-of-stream.
          }
 | ConnClosed
   deriving(Conn a -> Conn a -> Bool
(Conn a -> Conn a -> Bool)
-> (Conn a -> Conn a -> Bool) -> Eq (Conn a)
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' :: Conn a -> Maybe (StreamHooks a)
connHooks' ConnClosed{} = Maybe (StreamHooks a)
forall a. Maybe a
Nothing
connHooks' Conn a
x = Conn a -> Maybe (StreamHooks a)
forall a. Conn a -> Maybe (StreamHooks a)
connHooks Conn a
x

-- all of these are post-op hooks
data StreamHooks ty
 = StreamHooks
     { StreamHooks ty -> (ty -> String) -> Result ty -> IO ()
hook_readLine   :: (ty -> String) -> Result ty -> IO ()
     , StreamHooks ty -> (ty -> String) -> Int -> Result ty -> IO ()
hook_readBlock  :: (ty -> String) -> Int -> Result ty -> IO ()
     , StreamHooks ty -> (ty -> String) -> ty -> Result () -> IO ()
hook_writeBlock :: (ty -> String) -> ty  -> Result () -> IO ()
     , StreamHooks ty -> IO ()
hook_close      :: IO ()
     , 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 :: StreamHooks ty
nullHooks = StreamHooks :: forall ty.
((ty -> String) -> Result ty -> IO ())
-> ((ty -> String) -> Int -> Result ty -> IO ())
-> ((ty -> String) -> ty -> Result () -> IO ())
-> IO ()
-> String
-> StreamHooks ty
StreamHooks 
     { hook_readLine :: (ty -> String) -> Result ty -> IO ()
hook_readLine   = \ ty -> String
_ Result ty
_   -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     , hook_readBlock :: (ty -> String) -> Int -> Result ty -> IO ()
hook_readBlock  = \ ty -> String
_ Int
_ Result ty
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     , hook_writeBlock :: (ty -> String) -> ty -> Result () -> IO ()
hook_writeBlock = \ ty -> String
_ ty
_ Result ()
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     , hook_close :: IO ()
hook_close      = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     , hook_name :: String
hook_name       = String
""
     }

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

getStreamHooks :: HandleStream ty -> IO (Maybe (StreamHooks ty))
getStreamHooks :: HandleStream ty -> IO (Maybe (StreamHooks ty))
getStreamHooks HandleStream ty
h = MVar (Conn ty) -> IO (Conn ty)
forall a. MVar a -> IO a
readMVar (HandleStream ty -> MVar (Conn ty)
forall a. HandleStream a -> MVar (Conn a)
getRef HandleStream ty
h) IO (Conn ty)
-> (Conn ty -> IO (Maybe (StreamHooks ty)))
-> IO (Maybe (StreamHooks ty))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (StreamHooks ty) -> IO (Maybe (StreamHooks ty))
forall (m :: * -> *) a. Monad m => a -> m a
return(Maybe (StreamHooks ty) -> IO (Maybe (StreamHooks ty)))
-> (Conn ty -> Maybe (StreamHooks ty))
-> Conn ty
-> IO (Maybe (StreamHooks ty))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Conn ty -> Maybe (StreamHooks ty)
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       = String -> Int -> IO (HandleStream ByteString)
forall ty. BufferType ty => String -> Int -> IO (HandleStream ty)
openTCPConnection
  openSocketStream :: String -> Int -> Socket -> IO (HandleStream ByteString)
openSocketStream = String -> Int -> Socket -> IO (HandleStream ByteString)
forall ty.
BufferType ty =>
String -> Int -> Socket -> IO (HandleStream ty)
socketConnection
  readBlock :: HandleStream ByteString -> Int -> IO (Result ByteString)
readBlock HandleStream ByteString
c Int
n    = HandleStream ByteString -> Int -> IO (Result ByteString)
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       = HandleStream ByteString -> IO (Result ByteString)
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 = HandleStream ByteString -> ByteString -> IO (Result ())
forall a. HandleStream a -> a -> IO (Result ())
writeBlockBS HandleStream ByteString
c ByteString
str
  close :: HandleStream ByteString -> IO ()
close HandleStream ByteString
c          = HandleStream ByteString -> (ByteString -> Bool) -> Bool -> IO ()
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     = HandleStream ByteString -> (ByteString -> Bool) -> Bool -> IO ()
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   = HandleStream ByteString -> Bool -> IO ()
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 -> String -> Int -> Bool -> IO (HandleStream ByteString)
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 -> String -> Int -> Socket -> Bool -> IO (HandleStream ByteString)
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    = HandleStream ByteString -> Int -> IO (Result ByteString)
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       = HandleStream ByteString -> IO (Result ByteString)
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 = HandleStream ByteString -> ByteString -> IO (Result ())
forall a. HandleStream a -> a -> IO (Result ())
writeBlockBS HandleStream ByteString
c ByteString
str
    close :: HandleStream ByteString -> IO ()
close HandleStream ByteString
c          = HandleStream ByteString -> (ByteString -> Bool) -> Bool -> IO ()
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     = HandleStream ByteString -> (ByteString -> Bool) -> Bool -> IO ()
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   = HandleStream ByteString -> Bool -> IO ()
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)     = HandleStream String -> Int -> IO (Result String)
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)      = HandleStream String -> IO (Result String)
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)    = HandleStream String -> String -> IO (Result ())
forall bufType.
HStream bufType =>
HandleStream bufType -> bufType -> IO (Result ())
Network.TCP.writeBlock HandleStream String
c 
  close :: Connection -> IO ()
close (Connection HandleStream String
c)         = HandleStream String -> IO ()
forall bufType. HStream bufType => HandleStream bufType -> IO ()
Network.TCP.close HandleStream String
c
  closeOnEnd :: Connection -> Bool -> IO ()
closeOnEnd (Connection HandleStream String
c) Bool
f  = HandleStream String -> Bool -> IO ()
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      = String -> Int -> IO (HandleStream String)
forall ty. BufferType ty => String -> Int -> IO (HandleStream ty)
openTCPConnection
    openSocketStream :: String -> Int -> Socket -> IO (HandleStream String)
openSocketStream = String -> Int -> Socket -> IO (HandleStream String)
forall ty.
BufferType ty =>
String -> Int -> Socket -> IO (HandleStream ty)
socketConnection
    readBlock :: HandleStream String -> Int -> IO (Result String)
readBlock HandleStream String
ref Int
n = HandleStream String -> Int -> IO (Result String)
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 = HandleStream String -> IO (Result String)
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 = HandleStream String -> String -> IO (Result ())
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 = HandleStream String -> (String -> Bool) -> Bool -> IO ()
forall ty.
HStream ty =>
HandleStream ty -> (ty -> Bool) -> Bool -> IO ()
closeIt HandleStream String
c String -> Bool
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 = HandleStream String -> (String -> Bool) -> Bool -> IO ()
forall ty.
HStream ty =>
HandleStream ty -> (ty -> Bool) -> Bool -> IO ()
closeIt HandleStream String
c String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bool
False

    closeOnEnd :: HandleStream String -> Bool -> IO ()
closeOnEnd HandleStream String
c Bool
f = HandleStream String -> Bool -> IO ()
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 = String -> Int -> IO (HandleStream String)
forall ty. BufferType ty => String -> Int -> IO (HandleStream ty)
openTCPConnection String
uri Int
port IO (HandleStream String)
-> (HandleStream String -> IO Connection) -> IO Connection
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return(Connection -> IO Connection)
-> (HandleStream String -> Connection)
-> HandleStream String
-> IO Connection
forall 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 :: String -> Int -> IO (HandleStream ty)
openTCPConnection String
uri Int
port = String -> Int -> Bool -> IO (HandleStream ty)
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_ :: 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
_)) | String -> Char
forall a. [a] -> a
last String
rest Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
']'
              -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'v' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'V'
                     then String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"Unsupported post-IPv6 address " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
uri
                     else String -> String
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 <- IO [AddrInfo] -> IO [AddrInfo]
forall a. IO a -> IO a
withSocketsDo (IO [AddrInfo] -> IO [AddrInfo]) -> IO [AddrInfo] -> IO [AddrInfo]
forall a b. (a -> b) -> a -> b
$ Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just (AddrInfo -> Maybe AddrInfo) -> AddrInfo -> Maybe AddrInfo
forall a b. (a -> b) -> a -> b
$ AddrInfo
defaultHints { addrFamily :: Family
addrFamily = Family
AF_UNSPEC, addrSocketType :: SocketType
addrSocketType = SocketType
Stream }) (String -> Maybe String
forall a. a -> Maybe a
Just String
fixedUri) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> (Int -> String) -> Int -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Maybe String) -> Int -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int
port)

    let
      connectAddrInfo :: AddrInfo -> IO (HandleStream ty)
connectAddrInfo AddrInfo
a = IO Socket
-> (Socket -> IO ())
-> (Socket -> IO (HandleStream ty))
-> IO (HandleStream ty)
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)
            String -> Int -> Socket -> Bool -> IO (HandleStream ty)
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 [] = Maybe (HandleStream ty) -> IO (Maybe (HandleStream ty))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (HandleStream ty)
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  IO (HandleStream ty) -> IO (Either IOException (HandleStream ty))
forall e a. Exception e => IO a -> IO (Either e a)
try (AddrInfo -> IO (HandleStream ty)
forall ty. BufferType ty => AddrInfo -> IO (HandleStream ty)
connectAddrInfo AddrInfo
h) IO (Either IOException (HandleStream ty))
-> (Either IOException (HandleStream ty)
    -> IO (Maybe (HandleStream ty)))
-> IO (Maybe (HandleStream ty))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IOException -> IO (Maybe (HandleStream ty)))
-> (HandleStream ty -> IO (Maybe (HandleStream ty)))
-> Either IOException (HandleStream ty)
-> IO (Maybe (HandleStream ty))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IOException -> IO (Maybe (HandleStream ty))
next (Maybe (HandleStream ty) -> IO (Maybe (HandleStream ty))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (HandleStream ty) -> IO (Maybe (HandleStream ty)))
-> (HandleStream ty -> Maybe (HandleStream ty))
-> HandleStream ty
-> IO (Maybe (HandleStream ty))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandleStream ty -> Maybe (HandleStream ty)
forall a. a -> Maybe a
Just)

    case [AddrInfo]
addrinfos of
        [] -> String -> IO (HandleStream ty)
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] -> AddrInfo -> IO (HandleStream ty)
forall ty. BufferType ty => AddrInfo -> IO (HandleStream ty)
connectAddrInfo AddrInfo
ai IO (HandleStream ty)
-> (IOException -> IO (HandleStream ty)) -> IO (HandleStream ty)
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (\IOException
e -> String -> IO (HandleStream ty)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (HandleStream ty)) -> String -> IO (HandleStream ty)
forall a b. (a -> b) -> a -> b
$
                  String
"openTCPConnection: failed to connect to "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ SockAddr -> String
forall a. Show a => a -> String
show (AddrInfo -> SockAddr
addrAddress AddrInfo
ai) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
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 = String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"openTCPConnection: failed to connect; tried addresses: "
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ [SockAddr] -> String
forall a. Show a => a -> String
show ((AddrInfo -> SockAddr) -> [AddrInfo] -> [SockAddr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AddrInfo -> SockAddr
addrAddress [AddrInfo]
ais)
          in [AddrInfo] -> IO (Maybe (HandleStream ty))
forall ty.
BufferType ty =>
[AddrInfo] -> IO (Maybe (HandleStream ty))
tryAddrInfos [AddrInfo]
ais IO (Maybe (HandleStream ty))
-> (Maybe (HandleStream ty) -> IO (HandleStream ty))
-> IO (HandleStream ty)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (HandleStream ty)
-> (HandleStream ty -> IO (HandleStream ty))
-> Maybe (HandleStream ty)
-> IO (HandleStream ty)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO (HandleStream ty)
forall a. IO a
err HandleStream ty -> IO (HandleStream ty)
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 :: String -> Int -> Socket -> IO (HandleStream ty)
socketConnection String
hst Int
port Socket
sock = String -> Int -> Socket -> Bool -> IO (HandleStream ty)
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_ :: 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 -> (ty -> Maybe ty) -> IO ty -> IO (Maybe ty)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ty -> Maybe ty
forall a. a -> Maybe a
Just (IO ty -> IO (Maybe ty)) -> IO ty -> IO (Maybe ty)
forall a b. (a -> b) -> a -> b
$ BufferOp ty -> Handle -> IO ty
forall a. BufferOp a -> Handle -> IO a
buf_hGetContents BufferOp ty
forall bufType. BufferType bufType => BufferOp bufType
bufferOps Handle
h; Bool
_ -> Maybe ty -> IO (Maybe ty)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ty
forall a. Maybe a
Nothing }
    let conn :: Conn ty
conn = MkConn :: forall a.
Socket
-> Handle
-> BufferOp a
-> Maybe a
-> EndPoint
-> Maybe (StreamHooks a)
-> Bool
-> Conn a
MkConn 
         { connSock :: Socket
connSock     = Socket
sock
         , connHandle :: Handle
connHandle   = Handle
h
         , connBuffer :: BufferOp ty
connBuffer   = BufferOp ty
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    = Maybe (StreamHooks ty)
forall a. Maybe a
Nothing
         , connCloseEOF :: Bool
connCloseEOF = Bool
False
         }
    MVar (Conn ty)
v <- Conn ty -> IO (MVar (Conn ty))
forall a. a -> IO (MVar a)
newMVar Conn ty
conn
    HandleStream ty -> IO (HandleStream ty)
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar (Conn ty) -> HandleStream ty
forall a. MVar (Conn a) -> HandleStream a
HandleStream MVar (Conn ty)
v)

closeConnection :: HStream a => HandleStream a -> IO Bool -> IO ()
closeConnection :: 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 <- MVar (Conn a) -> IO (Conn a)
forall a. MVar a -> IO a
readMVar (HandleStream a -> MVar (Conn a)
forall a. HandleStream a -> MVar (Conn a)
getRef HandleStream a
ref)
  Conn a -> IO ()
forall a. Conn a -> IO ()
closeConn Conn a
c IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (\IOException
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
  MVar (Conn a) -> (Conn a -> IO (Conn a)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (HandleStream a -> MVar (Conn a)
forall a. HandleStream a -> MVar (Conn a)
getRef HandleStream a
ref) (\ Conn a
_ -> Conn a -> IO (Conn a)
forall (m :: * -> *) a. Monad m => a -> m a
return Conn a
forall a. Conn a
ConnClosed)
 where
   -- Be kind to peer & close gracefully.
  closeConn :: Conn a -> IO ()
closeConn Conn a
ConnClosed = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  closeConn Conn a
conn = do
    let sk :: Socket
sk = Conn a -> Socket
forall a. Conn a -> Socket
connSock Conn a
conn
    Handle -> IO ()
hFlush (Conn a -> Handle
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 (Conn a -> Handle
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 () -> IO ()
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 = HandleStream String -> EndPoint -> IO Bool
forall ty. HandleStream ty -> EndPoint -> IO Bool
isTCPConnectedTo HandleStream String
conn EndPoint
endPoint

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

readBlockBS :: HStream a => HandleStream a -> Int -> IO (Result a)
readBlockBS :: HandleStream a -> Int -> IO (Result a)
readBlockBS HandleStream a
ref Int
n = HandleStream a -> (Conn a -> IO (Result a)) -> IO (Result a)
forall a b.
HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b)
onNonClosedDo HandleStream a
ref ((Conn a -> IO (Result a)) -> IO (Result a))
-> (Conn a -> IO (Result a)) -> IO (Result a)
forall a b. (a -> b) -> a -> b
$ \ Conn a
conn -> do
   Result a
x <- HandleStream a -> Int -> IO (Result a)
forall a. HStream a => HandleStream a -> Int -> IO (Result a)
bufferGetBlock HandleStream a
ref Int
n
   IO () -> (StreamHooks a -> IO ()) -> Maybe (StreamHooks a) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
         (\ StreamHooks a
h -> StreamHooks a -> (a -> String) -> Int -> Result a -> IO ()
forall ty.
StreamHooks ty -> (ty -> String) -> Int -> Result ty -> IO ()
hook_readBlock StreamHooks a
h (BufferOp a -> a -> String
forall a. BufferOp a -> a -> String
buf_toStr (BufferOp a -> a -> String) -> BufferOp a -> a -> String
forall a b. (a -> b) -> a -> b
$ Conn a -> BufferOp a
forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) Int
n Result a
x)
         (Conn a -> Maybe (StreamHooks a)
forall a. Conn a -> Maybe (StreamHooks a)
connHooks' Conn a
conn)
   Result a -> IO (Result a)
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 :: HandleStream a -> IO (Result a)
readLineBS HandleStream a
ref = HandleStream a -> (Conn a -> IO (Result a)) -> IO (Result a)
forall a b.
HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b)
onNonClosedDo HandleStream a
ref ((Conn a -> IO (Result a)) -> IO (Result a))
-> (Conn a -> IO (Result a)) -> IO (Result a)
forall a b. (a -> b) -> a -> b
$ \ Conn a
conn -> do
   Result a
x <- HandleStream a -> IO (Result a)
forall a. HStream a => HandleStream a -> IO (Result a)
bufferReadLine HandleStream a
ref
   IO () -> (StreamHooks a -> IO ()) -> Maybe (StreamHooks a) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
         (\ StreamHooks a
h -> StreamHooks a -> (a -> String) -> Result a -> IO ()
forall ty. StreamHooks ty -> (ty -> String) -> Result ty -> IO ()
hook_readLine StreamHooks a
h (BufferOp a -> a -> String
forall a. BufferOp a -> a -> String
buf_toStr (BufferOp a -> a -> String) -> BufferOp a -> a -> String
forall a b. (a -> b) -> a -> b
$ Conn a -> BufferOp a
forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) Result a
x)
         (Conn a -> Maybe (StreamHooks a)
forall a. Conn a -> Maybe (StreamHooks a)
connHooks' Conn a
conn)
   Result a -> IO (Result a)
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 :: HandleStream a -> a -> IO (Result ())
writeBlockBS HandleStream a
ref a
b = HandleStream a -> (Conn a -> IO (Result ())) -> IO (Result ())
forall a b.
HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b)
onNonClosedDo HandleStream a
ref ((Conn a -> IO (Result ())) -> IO (Result ()))
-> (Conn a -> IO (Result ())) -> IO (Result ())
forall a b. (a -> b) -> a -> b
$ \ Conn a
conn -> do
  Result ()
x    <- BufferOp a -> Handle -> a -> IO (Result ())
forall a. BufferOp a -> Handle -> a -> IO (Result ())
bufferPutBlock (Conn a -> BufferOp a
forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) (Conn a -> Handle
forall a. Conn a -> Handle
connHandle Conn a
conn) a
b
  IO () -> (StreamHooks a -> IO ()) -> Maybe (StreamHooks a) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        (\ StreamHooks a
h -> StreamHooks a -> (a -> String) -> a -> Result () -> IO ()
forall ty.
StreamHooks ty -> (ty -> String) -> ty -> Result () -> IO ()
hook_writeBlock StreamHooks a
h (BufferOp a -> a -> String
forall a. BufferOp a -> a -> String
buf_toStr (BufferOp a -> a -> String) -> BufferOp a -> a -> String
forall a b. (a -> b) -> a -> b
$ Conn a -> BufferOp a
forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) a
b Result ()
x)
        (Conn a -> Maybe (StreamHooks a)
forall a. Conn a -> Maybe (StreamHooks a)
connHooks' Conn a
conn)
  Result () -> IO (Result ())
forall (m :: * -> *) a. Monad m => a -> m a
return Result ()
x

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

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

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

bufferReadLine :: HStream a => HandleStream a -> IO (Result a)
bufferReadLine :: HandleStream a -> IO (Result a)
bufferReadLine HandleStream a
ref = HandleStream a -> (Conn a -> IO (Result a)) -> IO (Result a)
forall a b.
HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b)
onNonClosedDo HandleStream a
ref ((Conn a -> IO (Result a)) -> IO (Result a))
-> (Conn a -> IO (Result a)) -> IO (Result a)
forall a b. (a -> b) -> a -> b
$ \ Conn a
conn -> do
  case Conn a -> Maybe a
forall a. Conn a -> Maybe a
connInput Conn a
conn of
   Just a
c -> do
    let (a
a,a
b0)  = BufferOp a -> (Char -> Bool) -> a -> (a, a)
forall a. BufferOp a -> (Char -> Bool) -> a -> (a, a)
buf_span (Conn a -> BufferOp a
forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n') a
c
    let (a
newl,a
b1) = BufferOp a -> Int -> a -> (a, a)
forall a. BufferOp a -> Int -> a -> (a, a)
buf_splitAt (Conn a -> BufferOp a
forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) Int
1 a
b0
    MVar (Conn a) -> (Conn a -> IO (Conn a)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (HandleStream a -> MVar (Conn a)
forall a. HandleStream a -> MVar (Conn a)
getRef HandleStream a
ref) (\ Conn a
co -> Conn a -> IO (Conn a)
forall (m :: * -> *) a. Monad m => a -> m a
return Conn a
co{connInput :: Maybe a
connInput=a -> Maybe a
forall a. a -> Maybe a
Just a
b1})
    Result a -> IO (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return (BufferOp a -> a -> a -> a
forall a. BufferOp a -> a -> a -> a
buf_append (Conn a -> BufferOp a
forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) a
a a
newl))
   Maybe a
_ -> IO (Result a) -> (IOException -> IO (Result a)) -> IO (Result a)
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO
              (BufferOp a -> Handle -> IO a
forall a. BufferOp a -> Handle -> IO a
buf_hGetLine (Conn a -> BufferOp a
forall a. Conn a -> BufferOp a
connBuffer Conn a
conn) (Conn a -> Handle
forall a. Conn a -> Handle
connHandle Conn a
conn) IO a -> (a -> IO (Result a)) -> IO (Result a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 
                    Result a -> IO (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> IO (Result a))
-> (a -> Result a) -> a -> IO (Result a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Result a) -> (a -> a) -> a -> Result a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BufferOp a -> a -> a
forall a. BufferOp a -> a -> a
appendNL (Conn a -> BufferOp a
forall a. Conn a -> BufferOp a
connBuffer Conn a
conn))
              (\ IOException
e ->
                 if IOException -> Bool
isEOFError IOException
e
                  then do
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Conn a -> Bool
forall a. Conn a -> Bool
connCloseEOF Conn a
conn) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO (HandleStream a -> IO ()
forall bufType. HStream bufType => HandleStream bufType -> IO ()
closeQuick HandleStream a
ref) (\ IOException
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                    Result a -> IO (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return   (BufferOp a -> a
forall a. BufferOp a -> a
buf_empty (Conn a -> BufferOp a
forall a. Conn a -> BufferOp a
connBuffer Conn a
conn)))
                  else Result a -> IO (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Result a
forall a. String -> Result a
failMisc (IOException -> String
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 = BufferOp a -> a -> Word8 -> a
forall a. BufferOp a -> a -> Word8 -> a
buf_snoc BufferOp a
ops a
b Word8
nl
  
  nl :: Word8
  nl :: Word8
nl = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'\n')

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