123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166 |
- -- {-# LANGUAGE OverloadedStrings #-}
- -- {-# LANGUAGE ExistentialQuantification #-}
- -- {-# LANGUAGE ForeignFunctionInterface #-}
- -- {-# LANGUAGE InterruptibleFFI #-}
- -- {-# LANGUAGE EmptyDataDecls #-}
- module System.IO.Uniform.Network (
- SocketIO,
- BoundedPort,
- connectTo,
- connectToHost,
- bindPort,
- accept,
- closePort,
- getPeer
- ) where
- import System.IO.Uniform
- import System.IO.Uniform.External
- import Foreign
- import Foreign.C.Types
- import Foreign.C.String
- import Foreign.C.Error
- import qualified Data.IP as IP
- --import Data.ByteString (ByteString)
- import qualified Data.ByteString as BS
- --import qualified Data.ByteString.Lazy as LBS
- --import qualified Data.ByteString.Builder as BSBuild
- import qualified Data.List as L
- import Control.Exception
- import Control.Applicative ((<$>))
- --import Data.Monoid (mappend)
- import qualified Network.Socket as Soc
- import System.IO.Error
- --import Control.Concurrent.MVar
- --import Data.Default.Class
- import System.Posix.Types (Fd(..))
- -- | UniformIO IP connections.
- instance UniformIO SocketIO where
- uRead s n = do
- allocaArray n (
- \b -> do
- count <- c_recv (sock s) b (fromIntegral n)
- if count < 0
- then throwErrno "could not read"
- else BS.packCStringLen (b, fromIntegral count)
- )
- uPut s t = do
- BS.useAsCStringLen t (
- \(str, n) -> do
- count <- c_send (sock s) str $ fromIntegral n
- if count < 0
- then throwErrno "could not write"
- else return ()
- )
- uClose s = do
- f <- Fd <$> c_prepareToClose (sock s)
- closeFd f
- startTls st s = withCString (tlsCertificateChainFile st) (
- \cert -> withCString (tlsPrivateKeyFile st) (
- \key -> withCString (tlsDHParametersFile st) (
- \para -> do
- r <- c_startSockTls (sock s) cert key para
- if r == nullPtr
- then throwErrno "could not start TLS"
- else return . TlsIO $ r
- )
- )
- )
- isSecure _ = False
- -- | connectToHost hostName port
- --
- -- Connects to the given host and port.
- connectToHost :: String -> Int -> IO SocketIO
- connectToHost host port = do
- ip <- getAddr
- connectTo ip port
- where
- getAddr :: IO IP.IP
- getAddr = do
- add <- Soc.getAddrInfo Nothing (Just host) Nothing
- case add of
- [] -> throwIO $ mkIOError doesNotExistErrorType "host not found" Nothing Nothing
- (a:_) -> case Soc.addrAddress a of
- Soc.SockAddrInet _ a' -> return . IP.IPv4 . IP.fromHostAddress $ a'
- Soc.SockAddrInet6 _ _ a' _ -> return . IP.IPv6 . IP.fromHostAddress6 $ a'
- _ -> throwIO $ mkIOError doesNotExistErrorType "host not found" Nothing Nothing
- -- | ConnecctTo ipAddress port
- --
- -- Connects to the given port of the host at the given IP address.
- connectTo :: IP.IP -> Int -> IO SocketIO
- connectTo host port = do
- r <- case host of
- IP.IPv4 host' -> fmap SocketIO $ c_connect4 (fromIntegral . IP.toHostAddress $ host') (fromIntegral port)
- IP.IPv6 host' -> fmap SocketIO $ withArray (ipToArray host') (
- \add -> c_connect6 add (fromIntegral port)
- )
- if sock r == nullPtr
- then throwErrno "could not connect to host"
- else return r
- where
- ipToArray :: IP.IPv6 -> [CUChar]
- ipToArray ip = let
- (w0, w1, w2, w3) = IP.toHostAddress6 ip
- in L.concat [wtoc w0, wtoc w1, wtoc w2, wtoc w3]
- wtoc :: Word32 -> [CUChar]
- wtoc w = let
- c0 = fromIntegral $ mod w 256
- w1 = div w 256
- c1 = fromIntegral $ mod w1 256
- w2 = div w1 256
- c2 = fromIntegral $ mod w2 256
- c3 = fromIntegral $ div w2 256
- in [c3, c2, c1, c0]
-
- -- | bindPort port
- -- Binds to the given IP port, becoming ready to accept connections on it.
- -- Binding to port numbers under 1024 will fail unless performed by the superuser,
- -- once bounded, a process can reduce its privileges and still accept clients on that port.
- bindPort :: Int -> IO BoundedPort
- bindPort port = do
- r <- fmap BoundedPort $ c_getPort $ fromIntegral port
- if lis r == nullPtr
- then throwErrno "could not bind to port"
- else return r
-
- -- | accept port
- --
- -- Accept clients on a port previously bound with bindPort.
- accept :: BoundedPort -> IO SocketIO
- accept port = do
- r <- fmap SocketIO $ c_accept (lis port)
- if sock r == nullPtr
- then throwErrno "could not accept connection"
- else return r
- -- | Gets the address of the peer socket of a internet connection.
- getPeer :: SocketIO -> IO (IP.IP, Int)
- getPeer s = allocaArray 16 (
- \p6 -> alloca (
- \p4 -> alloca (
- \iptype -> do
- p <- c_getPeer (sock s) p4 p6 iptype
- if p == -1
- then throwErrno "could not get peer address"
- else do
- iptp <- peek iptype
- if iptp == 1
- then do --IPv6
- add <- peekArray 16 p6
- return (IP.IPv6 . IP.toIPv6b $ map fromIntegral add, fromIntegral p)
- else do --IPv4
- add <- peek p4
- return (IP.IPv4 . IP.fromHostAddress . fromIntegral $ add, fromIntegral p)
- )
- )
- )
|