diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015 Lars Petersen +Copyright (c) 2015 Lars Petersen, 2016 Shea Levy Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/socket-sctp.cabal b/socket-sctp.cabal --- a/socket-sctp.cabal +++ b/socket-sctp.cabal @@ -1,24 +1,26 @@ name: socket-sctp -version: 0.1.0.0 +version: 0.2.0.0 synopsis: STCP socket extensions library. description: This is a binding to the types and operations of `libsctp`. - It's intended to be used in conjunction with the `socket` - library. + This library is intended to used in conjunction with the `socket` + library it depends on. license: MIT license-file: LICENSE -author: Lars Petersen -maintainer: info@lars-petersen.net +author: Lars Petersen, Shea Levy +maintainer: shea@shealevy.com category: System, Socket, Network build-type: Simple cabal-version: >=1.10 -homepage: https://github.com/lpeterse/haskell-socket-sctp -bug-reports: https://github.com/lpeterse/haskell-socket-sctp/issues -tested-with: GHC==7.10.1, GHC==7.8.3 +homepage: https://github.com/shlevy/haskell-socket-sctp +bug-reports: https://github.com/shlevy/haskell-socket-sctp/issues +tested-with: GHC==7.10.1, GHC==7.8.3, GHC==8.0.1 extra-source-files: README.md CHANGELOG.md CONTRIBUTORS.txt + src/System/Socket/Protocol/SCTP/hs_sctp.c + src/System/Socket/Protocol/SCTP/hs_sctp.h library ghc-options: -Wall @@ -26,15 +28,19 @@ other-modules: System.Socket.Protocol.SCTP.Internal build-depends: base >= 4.7 && < 5 , bytestring < 0.11 - , socket >= 0.5.1.0 && < 0.6.0.0 + , socket >= 0.7.0.0 && < 0.8 hs-source-dirs: src + include-dirs: src/System/Socket/Protocol/SCTP + c-sources: src/System/Socket/Protocol/SCTP/hs_sctp.c + install-includes: src/System/Socket/Protocol/SCTP/hs_sctp.h build-tools: hsc2hs default-language: Haskell2010 - extra-libraries: sctp + if !os(freebsd) + extra-libraries: sctp source-repository head type: git - location: git://github.com/lpeterse/haskell-socket-sctp.git + location: git://github.com/shlevy/haskell-socket-sctp.git test-suite SendReceiveMessage hs-source-dirs: tests @@ -49,6 +55,27 @@ test-suite TooSmallBuffer hs-source-dirs: tests main-is: TooSmallBuffer.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , bytestring < 0.11 + , socket + , socket-sctp + +test-suite SendAll + hs-source-dirs: tests + main-is: SendAll.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-tools: hsc2hs + build-depends: base >= 4.7 && < 5 + , bytestring < 0.11 + , socket + , socket-sctp + +test-suite Notifications + hs-source-dirs: tests + main-is: Notifications.hs type: exitcode-stdio-1.0 default-language: Haskell2010 build-depends: base >= 4.7 && < 5 diff --git a/src/System/Socket/Protocol/SCTP.hsc b/src/System/Socket/Protocol/SCTP.hsc --- a/src/System/Socket/Protocol/SCTP.hsc +++ b/src/System/Socket/Protocol/SCTP.hsc @@ -63,7 +63,7 @@ -- > "Hello world!" -- > ( SocketAddressInet Inet.loopback 7777 ) -- > ( 2342 :: PayloadProtocolIdentifier ) --- > ( mempty :: MessageFlags ) +-- > ( mempty :: SendmsgFlags ) -- > ( 2 :: StreamNumber ) -- > ( 0 :: TimeToLive ) -- > ( 0 :: Context ) diff --git a/src/System/Socket/Protocol/SCTP/Internal.hsc b/src/System/Socket/Protocol/SCTP/Internal.hsc --- a/src/System/Socket/Protocol/SCTP/Internal.hsc +++ b/src/System/Socket/Protocol/SCTP/Internal.hsc @@ -1,4 +1,5 @@ -{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, FlexibleContexts #-} +#include "netinet/sctp.h" module System.Socket.Protocol.SCTP.Internal ( SCTP -- * Operations @@ -16,6 +17,12 @@ , TransportSequenceNumber (..) , CumulativeTransportSequenceNumber (..) , AssociationIdentifier (..) + -- * SendmsgFlags + , SendmsgFlags (..) +#ifdef SCTP_SENDALL + , sendall +#endif + , unorderedSendmsg -- * SendReceiveInfoFlags , SendReceiveInfoFlags (..) -- ** unordered @@ -31,6 +38,14 @@ , InitMessage (..) -- ** Events , Events (..) + -- * Notifications + , msgNotification + , Notification (..) + , AssocId + , unsafeParseNotification + -- ** SCTP_ASSOC_CHANGE + , AssocChange (..) + , AcState(..) ) where import Control.Applicative @@ -39,6 +54,8 @@ import Data.Bits import Data.Monoid import Data.Word +import Data.Int +import Data.Ix import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS @@ -46,18 +63,27 @@ import Foreign.Ptr import Foreign.Marshal import Foreign.C.Types +import Foreign.C.String import System.Posix.Types ( Fd(..) ) import System.Socket import System.Socket.Unsafe -import System.Socket.Protocol +import System.Socket.Type.SequentialPacket +import System.Socket.Type.Stream -#include "netinet/sctp.h" +#if __GLASGOW_HASKELL__ < 800 #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#endif data SCTP +-- | Class containing all protocol types that can be used with SCTP. +class SCTPType t where + +instance SCTPType SequentialPacket +instance SCTPType Stream + data SendReceiveInfo = SendReceiveInfo { sinfoStreamNumber :: StreamNumber @@ -84,6 +110,14 @@ = SendReceiveInfoFlags Word16 deriving (Eq, Ord, Show, Num, Storable, Bits) +newtype SendmsgFlags + = SendmsgFlags Word32 + deriving (Eq, Ord, Show, Num, Storable, Bits) + +instance Monoid SendmsgFlags where + mempty = SendmsgFlags 0 + mappend = (.|.) + newtype PayloadProtocolIdentifier = PayloadProtocolIdentifier Word32 deriving (Eq, Ord, Show, Num, Storable) @@ -123,6 +157,14 @@ shutdown :: SendReceiveInfoFlags shutdown = SendReceiveInfoFlags (#const SCTP_EOF) +#ifdef SCTP_SENDALL +sendall :: SendmsgFlags +sendall = SendmsgFlags (#const SCTP_SENDALL) +#endif + +unorderedSendmsg :: SendmsgFlags +unorderedSendmsg = SendmsgFlags (#const SCTP_UNORDERED) + instance Storable SendReceiveInfo where sizeOf _ = (#size struct sctp_sndrcvinfo) alignment _ = (#alignment struct sctp_sndrcvinfo) @@ -154,16 +196,16 @@ -- | Receive a message on a SCTP socket. -- --- - Everything that applies to `System.Socket.recv` is also true for this operation. +-- - Everything that applies to `System.Socket.receive` is also true for this operation. -- - The fields of the `SendReceiveInfo` structure are only filled if `dataIOEvent` -- has been enabled trough the `Events` socket option. -- - If the supplied buffer size is not sufficient, several consecutive reads are -- necessary to receive the complete message. The `msgEndOfRecord` flag is set -- when the message has been read completely. -receiveMessage :: Family f => Socket f SequentialPacket SCTP - -> Int -- ^ buffer size in bytes - -> MessageFlags - -> IO (BS.ByteString, SocketAddress f, SendReceiveInfo, MessageFlags) +receiveMessage :: (Family f, Storable (SocketAddress f), SCTPType t) => Socket f t SCTP + -> Int -- ^ buffer size in bytes + -> MessageFlags + -> IO (BS.ByteString, SocketAddress f, SendReceiveInfo, MessageFlags) receiveMessage sock bufSize flags = do alloca $ \addrPtr-> do alloca $ \addrSizePtr-> do @@ -192,34 +234,39 @@ -- -- - Everything that applies to `System.Socket.send` is also true for this operation. -- - Sending a message is atomic unless the `ExplicitEndOfRecord` option has been enabled (not yet supported), -sendMessage :: Family f => Socket f SequentialPacket SCTP - -> BS.ByteString - -> SocketAddress f - -> PayloadProtocolIdentifier -- ^ a user value not interpreted by SCTP - -> MessageFlags - -> StreamNumber - -> TimeToLive - -> Context - -> IO Int +sendMessage :: (Storable (SocketAddress f)) => Socket f t SCTP + -> BS.ByteString + -> Maybe (SocketAddress f) + -> PayloadProtocolIdentifier -- ^ a user value not interpreted by SCTP + -> SendmsgFlags + -> StreamNumber + -> TimeToLive + -> Context + -> IO Int sendMessage sock msg addr ppid flags sn ttl context = do - alloca $ \addrPtr-> do - BS.unsafeUseAsCStringLen msg $ \(msgPtr,msgSize)-> do - poke addrPtr addr - i <- tryWaitRetryLoop - sock - unsafeSocketWaitWrite - $ \fd-> c_sctp_sendmsg - fd - msgPtr - (fromIntegral msgSize) - addrPtr - (fromIntegral $ sizeOf addr) - ppid - flags - sn - ttl - context - return (fromIntegral i) + BS.unsafeUseAsCStringLen msg $ \(msgPtr,msgSize)-> do + let finish addrPtr sz = do + i <- tryWaitRetryLoop + sock + unsafeSocketWaitWrite + $ \fd-> c_sctp_sendmsg + fd + msgPtr + (fromIntegral msgSize) + addrPtr + sz + ppid + flags + sn + ttl + context + return (fromIntegral i) + case addr of + Just addr' -> do + alloca $ \addrPtr-> do + poke addrPtr addr' + finish addrPtr (fromIntegral $ sizeOf addr') + Nothing -> finish nullPtr 0 {-- NOT YET SUPPORTED :-( @@ -272,11 +319,10 @@ poke ((#ptr struct sctp_initmsg, sinit_max_attempts) ptr) (maxAttempts a) poke ((#ptr struct sctp_initmsg, sinit_max_init_timeo) ptr) (maxInitTimeout a) -instance GetSocketOption InitMessage where +instance SocketOption InitMessage where getSocketOption sock = unsafeGetSocketOption sock (#const IPPROTO_SCTP) (#const SCTP_INITMSG) -instance SetSocketOption InitMessage where setSocketOption sock value = unsafeSetSocketOption sock (#const IPPROTO_SCTP) (#const SCTP_INITMSG) value @@ -336,14 +382,90 @@ f True = 1 f False = 0 -instance GetSocketOption Events where +instance SocketOption Events where getSocketOption sock = unsafeGetSocketOption sock (#const IPPROTO_SCTP) (#const SCTP_EVENTS) -instance SetSocketOption Events where setSocketOption sock value = unsafeSetSocketOption sock (#const IPPROTO_SCTP) (#const SCTP_EVENTS) value +-------------------------------------- +-- Notifications +-------------------------------------- + +msgNotification :: MessageFlags +msgNotification = MessageFlags (#const MSG_NOTIFICATION) + +data Notification = AssocChangeNotification !AssocChange + | UnsupportedNotification !BS.ByteString deriving (Show) + {- Other notifications we may want to support in the future + | PaddrChangeNotification !PaddrChange + | RemoteErrorNotification !RemoteError + | SendFailedNotification !SendFailed + | ShutdownEventNotification !ShutdownEvent + | AdaptationEventNotification !AdaptationEvent + | PdapiEventNotification !PdapiEvent + | AuthkeyEventNotification !AuthEvent + | SenderDryEventNotification !SenderDryEvent + | SendFailedEventNotification !SendFailedEvent + -} + +data AssocChange + = AssocChange + { acState :: !AcState + -- Error codes don't seem to be standardized... + --, acError :: !ErrorCode + , acError :: !Word16 + , acOutboundStreams :: !Word16 + , acInboundStreams :: !Word16 + , acAssocId :: !AssocId + , acInfo :: !BS.ByteString + } deriving (Show) + +newtype AssocId = + AssocId #{type sctp_assoc_t} deriving (Bounded, Enum, Eq, Integral, Num, Ord, Read, Real, Show, Ix, Storable, Bits) + +data AcState = COMM_UP + | COMM_LOST + | RESTART + | SHUTDOWN_COMP + | CANT_STR_ASSOC + | UNKNOWN_AC_STATE deriving (Show) + +-- | Parse an SCTP notification. +-- +-- This assumes that the buffer contains a complete notification (i.e. +-- MSG_EOR was set on the last chunk it contains), and is thus unsafe. +-- Unfortunately, because of the possibility of partial notifications +-- from a too-small buffer for recvmsg, this must be exposed to users. +unsafeParseNotification :: BS.ByteString -> IO Notification +unsafeParseNotification bs = + BS.unsafeUseAsCStringLen bs $ \(ptr, sz) -> do + ty <- #{peek union sctp_notification, sn_header.sn_type} ptr :: IO Word16 + case ty of + #{const SCTP_ASSOC_CHANGE} -> AssocChangeNotification <$> unsafeParseAssocChange (ptr, sz) + _ -> return $ UnsupportedNotification bs + +unsafeParseAssocChange :: CStringLen -> IO AssocChange +unsafeParseAssocChange (ptr, sz) = do + st <- parseState <$> #{peek struct sctp_assoc_change, sac_state} ptr + err <- #{peek struct sctp_assoc_change, sac_error} ptr + outb <- #{peek struct sctp_assoc_change, sac_outbound_streams} ptr + inb <- #{peek struct sctp_assoc_change, sac_inbound_streams} ptr + aid <- AssocId <$> #{peek struct sctp_assoc_change, sac_assoc_id} ptr + info <- BS.packCStringLen (#{ptr struct sctp_assoc_change, sac_info} ptr, infoSize) + return $ AssocChange st err outb inb aid info + where + parseState :: Word16 -> AcState + parseState #{const SCTP_COMM_UP} = COMM_UP + parseState #{const SCTP_COMM_LOST} = COMM_LOST + parseState #{const SCTP_RESTART} = RESTART + parseState #{const SCTP_SHUTDOWN_COMP} = SHUTDOWN_COMP + parseState #{const SCTP_CANT_STR_ASSOC} = CANT_STR_ASSOC + parseState _ = UNKNOWN_AC_STATE + + infoSize = sz - #{offset struct sctp_assoc_change, sac_info} + ------------------------------------------------------------------------ -- FFI ------------------------------------------------------------------------ @@ -351,8 +473,8 @@ foreign import ccall unsafe "memset" c_memset :: Ptr a -> CInt -> CSize -> IO () -foreign import ccall unsafe "sctp_recvmsg" - c_sctp_recvmsg :: Fd -> Ptr a -> CSize -> Ptr b -> Ptr CInt -> Ptr SendReceiveInfo -> Ptr MessageFlags -> IO CInt +foreign import ccall unsafe "hs_sctp_recvmsg" + c_sctp_recvmsg :: Fd -> Ptr a -> CSize -> Ptr b -> Ptr CInt -> Ptr SendReceiveInfo -> Ptr MessageFlags -> Ptr CInt -> IO CInt -foreign import ccall unsafe "sctp_sendmsg" - c_sctp_sendmsg :: Fd -> Ptr a -> CSize -> Ptr b -> CInt -> PayloadProtocolIdentifier -> MessageFlags -> StreamNumber -> TimeToLive -> Context -> IO CInt +foreign import ccall unsafe "hs_sctp_sendmsg" + c_sctp_sendmsg :: Fd -> Ptr a -> CSize -> Ptr b -> CInt -> PayloadProtocolIdentifier -> SendmsgFlags -> StreamNumber -> TimeToLive -> Context -> Ptr CInt -> IO CInt diff --git a/src/System/Socket/Protocol/SCTP/hs_sctp.c b/src/System/Socket/Protocol/SCTP/hs_sctp.c new file mode 100644 --- /dev/null +++ b/src/System/Socket/Protocol/SCTP/hs_sctp.c @@ -0,0 +1,22 @@ +#include +#include "hs_sctp.h" + +int hs_sctp_sendmsg(int sd, const void * msg, size_t len, + struct sockaddr *to, socklen_t tolen, + uint32_t ppid, uint32_t flags, + uint16_t stream_no, uint32_t timetolive, + uint32_t context, int *err) { + int i = sctp_sendmsg(sd, msg, len, to, tolen, ppid, flags, + stream_no, timetolive, context); + *err = errno; + return i; +} + +int hs_sctp_recvmsg(int sd, void * msg, size_t len, + struct sockaddr * from, socklen_t * fromlen, + struct sctp_sndrcvinfo * sinfo, int * msg_flags, + int *err) { + int i = sctp_recvmsg(sd, msg, len, from, fromlen, sinfo, msg_flags); + *err = errno; + return i; +} diff --git a/src/System/Socket/Protocol/SCTP/hs_sctp.h b/src/System/Socket/Protocol/SCTP/hs_sctp.h new file mode 100644 --- /dev/null +++ b/src/System/Socket/Protocol/SCTP/hs_sctp.h @@ -0,0 +1,14 @@ +#include +#include +#include + +int hs_sctp_sendmsg(int sd, const void * msg, size_t len, + struct sockaddr *to, socklen_t tolen, + uint32_t ppid, uint32_t flags, + uint16_t stream_no, uint32_t timetolive, + uint32_t context, int *err); + +int hs_sctp_recvmsg(int sd, void * msg, size_t len, + struct sockaddr * from, socklen_t * fromlen, + struct sctp_sndrcvinfo * sinfo, int * msg_flags, + int *err); diff --git a/tests/Notifications.hs b/tests/Notifications.hs new file mode 100644 --- /dev/null +++ b/tests/Notifications.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.Monoid +import Control.Monad +import Control.Exception +import Control.Concurrent +import Data.Bits + +import System.Socket +import System.Socket.Type.SequentialPacket +import System.Socket.Family.Inet as Inet +import System.Socket.Protocol.SCTP as SCTP + +main :: IO () +main = do + server <- socket `onException` p 0 :: IO (Socket Inet SequentialPacket SCTP) + client <- socket `onException` p 1 :: IO (Socket Inet SequentialPacket SCTP) + bind server addr `onException` p 3 + listen server 5 `onException` p 4 + + setSocketOption + server + (mempty { associationEvent = True }) `onException` p 5 + connect client addr `onException` p 6 + + (msg, adr, sinfo, flags) <- SCTP.receiveMessage server 4096 mempty + `onException` p 7 + + when (flags .&. msgEndOfRecord == mempty) (e 8) + when (flags .&. msgNotification == mempty) (e 9) + notification <- unsafeParseNotification msg + case notification of + AssocChangeNotification (AssocChange { acState = COMM_UP }) -> return () + _ -> e 10 + +addr :: SocketAddress Inet +addr = SocketAddressInet Inet.inetLoopback 7777 + +p :: Int -> IO () +p i = print i + +e :: Int -> IO () +e i = error (show i) diff --git a/tests/SendAll.hsc b/tests/SendAll.hsc new file mode 100644 --- /dev/null +++ b/tests/SendAll.hsc @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} +#include "netinet/sctp.h" +#ifdef SCTP_SENDALL +module Main where + +import System.Socket +import System.Socket.Type.SequentialPacket +import System.Socket.Protocol.SCTP as SCTP +import System.Socket.Family.Inet as Inet +import Control.Monad + +main :: IO () +main = do + server <- socket :: IO (Socket Inet SequentialPacket SCTP) + client1 <- socket :: IO (Socket Inet SequentialPacket SCTP) + client2 <- socket :: IO (Socket Inet SequentialPacket SCTP) + bind server addr + listen server 5 + connect client1 addr + connect client2 addr + SCTP.sendMessage + server + "hallo" + Nothing + 0 + sendall + 0 + 3 + 0 + (msg1, _, _, _) <- SCTP.receiveMessage client1 4096 mempty + when (msg1 /= "hallo") (error "0") + (msg2, _, _, _) <- SCTP.receiveMessage client2 4096 mempty + when (msg2 /= "hallo") (error "1") + +addr :: SocketAddress Inet +addr = SocketAddressInet Inet.inetLoopback 7777 + +#else + +module Main where + +main :: IO () +main = return () + +#endif diff --git a/tests/SendReceiveMessage.hs b/tests/SendReceiveMessage.hs --- a/tests/SendReceiveMessage.hs +++ b/tests/SendReceiveMessage.hs @@ -7,6 +7,7 @@ import Control.Concurrent import System.Socket +import System.Socket.Type.SequentialPacket import System.Socket.Family.Inet as Inet import System.Socket.Protocol.SCTP as SCTP @@ -23,9 +24,9 @@ SCTP.sendMessage client "hallo" - addr + (Just addr) ( 2342 :: PayloadProtocolIdentifier ) - ( mempty :: MessageFlags ) + ( mempty :: SendmsgFlags ) ( 2 :: StreamNumber ) ( 3 :: TimeToLive ) ( 4 :: Context ) `onException` p 7 @@ -37,8 +38,8 @@ when (msg /= "hallo") (e 11) when (flags /= msgEndOfRecord) (e 12) -addr :: SocketAddressInet -addr = SocketAddressInet Inet.loopback 7777 +addr :: SocketAddress Inet +addr = SocketAddressInet Inet.inetLoopback 7777 p :: Int -> IO () p i = print i diff --git a/tests/TooSmallBuffer.hs b/tests/TooSmallBuffer.hs --- a/tests/TooSmallBuffer.hs +++ b/tests/TooSmallBuffer.hs @@ -7,6 +7,7 @@ import Control.Concurrent import System.Socket +import System.Socket.Type.SequentialPacket import System.Socket.Family.Inet as Inet import System.Socket.Protocol.SCTP as SCTP @@ -23,9 +24,9 @@ SCTP.sendMessage client "hallowelt" - addr + (Just addr) ( 2342 :: PayloadProtocolIdentifier ) - ( mempty :: MessageFlags ) + ( mempty :: SendmsgFlags ) ( 2 :: StreamNumber ) ( 3 :: TimeToLive ) ( 4 :: Context ) `onException` p 7 @@ -44,8 +45,8 @@ when (msg' /= "welt") (e 16) when (flags' /= msgEndOfRecord) (e 17) -addr :: SocketAddressInet -addr = SocketAddressInet Inet.loopback 7777 +addr :: SocketAddress Inet +addr = SocketAddressInet Inet.inetLoopback 7777 p :: Int -> IO () p i = print i