socket-sctp 0.1.0.0 → 0.2.0.0
raw patch · 10 files changed
+340/−64 lines, 10 filesdep ~socket
Dependency ranges changed: socket
Files
- LICENSE +1/−1
- socket-sctp.cabal +38/−11
- src/System/Socket/Protocol/SCTP.hsc +1/−1
- src/System/Socket/Protocol/SCTP/Internal.hsc +165/−43
- src/System/Socket/Protocol/SCTP/hs_sctp.c +22/−0
- src/System/Socket/Protocol/SCTP/hs_sctp.h +14/−0
- tests/Notifications.hs +44/−0
- tests/SendAll.hsc +45/−0
- tests/SendReceiveMessage.hs +5/−4
- tests/TooSmallBuffer.hs +5/−4
LICENSE view
@@ -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
socket-sctp.cabal view
@@ -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 <shea@shealevy.com>+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
src/System/Socket/Protocol/SCTP.hsc view
@@ -63,7 +63,7 @@ -- > "Hello world!" -- > ( SocketAddressInet Inet.loopback 7777 ) -- > ( 2342 :: PayloadProtocolIdentifier )--- > ( mempty :: MessageFlags )+-- > ( mempty :: SendmsgFlags ) -- > ( 2 :: StreamNumber ) -- > ( 0 :: TimeToLive ) -- > ( 0 :: Context )
src/System/Socket/Protocol/SCTP/Internal.hsc view
@@ -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
+ src/System/Socket/Protocol/SCTP/hs_sctp.c view
@@ -0,0 +1,22 @@+#include <errno.h>+#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;+}
+ src/System/Socket/Protocol/SCTP/hs_sctp.h view
@@ -0,0 +1,14 @@+#include <sys/types.h>+#include <sys/socket.h>+#include <netinet/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 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);
+ tests/Notifications.hs view
@@ -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)
+ tests/SendAll.hsc view
@@ -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
tests/SendReceiveMessage.hs view
@@ -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
tests/TooSmallBuffer.hs view
@@ -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