module Network.Compat where

import Network.Socket
import Network.BSD (getProtocolNumber)
import System.IO (Handle, IOMode (..))

import qualified Control.Exception as Exception

connectTo :: String             -- Hostname
          -> PortNumber         -- Port Identifier
          -> IO Handle          -- Connected Socket
connectTo :: String -> PortNumber -> IO Handle
connectTo String
host PortNumber
port = do
    ProtocolNumber
proto <- String -> IO ProtocolNumber
getProtocolNumber String
"tcp"
    let hints :: AddrInfo
hints = AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_ADDRCONFIG]
                             , addrProtocol :: ProtocolNumber
addrProtocol = ProtocolNumber
proto
                             , addrSocketType :: SocketType
addrSocketType = SocketType
Stream }
    [AddrInfo]
addrs <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
host) (String -> Maybe String
forall a. a -> Maybe a
Just String
serv)
    String -> [IO Handle] -> IO Handle
forall a. String -> [IO a] -> IO a
firstSuccessful String
"connectTo" ([IO Handle] -> IO Handle) -> [IO Handle] -> IO Handle
forall a b. (a -> b) -> a -> b
$ (AddrInfo -> IO Handle) -> [AddrInfo] -> [IO Handle]
forall a b. (a -> b) -> [a] -> [b]
map AddrInfo -> IO Handle
tryToConnect [AddrInfo]
addrs
  where
  serv :: String
serv = PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port

  tryToConnect :: AddrInfo -> IO Handle
tryToConnect AddrInfo
addr =
    IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Handle) -> IO Handle
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracketOnError
        (Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr))
        Socket -> IO ()
close  -- only done if there's an error
        (\Socket
sock -> do
          Socket -> SockAddr -> IO ()
connect Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
addr)
          Socket -> IOMode -> IO Handle
socketToHandle Socket
sock IOMode
ReadWriteMode
        )

-- Returns the first action from a list which does not throw an exception.
-- If all the actions throw exceptions (and the list of actions is not empty),
-- the last exception is thrown.
-- The operations are run outside of the catchIO cleanup handler because
-- catchIO masks asynchronous exceptions in the cleanup handler.
-- In the case of complete failure, the last exception is actually thrown.
firstSuccessful :: String -> [IO a] -> IO a
firstSuccessful :: String -> [IO a] -> IO a
firstSuccessful String
caller = Maybe IOException -> [IO a] -> IO a
forall b. Maybe IOException -> [IO b] -> IO b
go Maybe IOException
forall a. Maybe a
Nothing
  where
  -- Attempt the next operation, remember exception on failure
  go :: Maybe IOException -> [IO b] -> IO b
go Maybe IOException
_ (IO b
p:[IO b]
ps) =
    do Either IOException b
r <- IO b -> IO (Either IOException b)
forall a. IO a -> IO (Either IOException a)
tryIO IO b
p
       case Either IOException b
r of
         Right b
x -> b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
         Left  IOException
e -> Maybe IOException -> [IO b] -> IO b
go (IOException -> Maybe IOException
forall a. a -> Maybe a
Just IOException
e) [IO b]
ps

  -- All operations failed, throw error if one exists
  go Maybe IOException
Nothing  [] = IOException -> IO b
forall a. IOException -> IO a
ioError (IOException -> IO b) -> IOException -> IO b
forall a b. (a -> b) -> a -> b
$ String -> IOException
userError (String -> IOException) -> String -> IOException
forall a b. (a -> b) -> a -> b
$ String
caller String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": firstSuccessful: empty list"
  go (Just IOException
e) [] = IOException -> IO b
forall e a. Exception e => e -> IO a
Exception.throwIO IOException
e

-- Version of try implemented in terms of the locally defined catchIO
tryIO :: IO a -> IO (Either Exception.IOException a)
tryIO :: IO a -> IO (Either IOException a)
tryIO IO a
m = IO (Either IOException a)
-> (IOException -> IO (Either IOException a))
-> IO (Either IOException a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Exception.catch ((a -> Either IOException a) -> IO a -> IO (Either IOException a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either IOException a
forall a b. b -> Either a b
Right IO a
m) (Either IOException a -> IO (Either IOException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IOException a -> IO (Either IOException a))
-> (IOException -> Either IOException a)
-> IOException
-> IO (Either IOException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> Either IOException a
forall a b. a -> Either a b
Left)