stunclient (empty) → 0.1.0.0
raw patch · 11 files changed
+847/−0 lines, 11 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, cereal, crypto-api, cryptohash, cryptohash-cryptoapi, digest, network, random, stringprep, test-framework, test-framework-quickcheck2, text, transformers, unbounded-delays
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- source/Network/Endian.hs +26/−0
- source/Network/Stun.hs +158/−0
- source/Network/Stun/Base.hs +192/−0
- source/Network/Stun/Credentials.hs +101/−0
- source/Network/Stun/Error.hs +75/−0
- source/Network/Stun/Internal.hs +13/−0
- source/Network/Stun/MappedAddress.hs +97/−0
- source/Tests.hs +105/−0
- stunclient.cabal +58/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2012 Philipp Balzarek <p.balzarek@googlemail.com>++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ source/Network/Endian.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}++module Network.Endian where++import Data.Word+++-- from network/HsNet.h+#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS)+# define WITH_WINSOCK 1+#endif++#if !defined(CALLCONV)+# if defined(WITH_WINSOCK)+# define CALLCONV stdcall+# else+# define CALLCONV ccall+# endif+#endif++-- from network/Socket.hs+foreign import CALLCONV unsafe "ntohs" ntohs :: Word16 -> Word16+foreign import CALLCONV unsafe "htons" htons :: Word16 -> Word16+foreign import CALLCONV unsafe "ntohl" ntohl :: Word32 -> Word32+foreign import CALLCONV unsafe "htonl" htonl :: Word32 -> Word32
+ source/Network/Stun.hs view
@@ -0,0 +1,158 @@+-- | Session Traversal Utilities for NAT (STUN)+--+-- <http://tools.ietf.org/html/rfc5389>+--+-- For a simple way to find the mapped address see 'findMappedAddress'+module Network.Stun+ ( -- * Requests+ bindRequest+ , stunRequest+ , stunRequest'+ -- * Messages+ , Message(..)+ , MessageClass(..)+ , TransactionID(..)+ -- * Attributes+ , Attribute(..)+ , findAttribute+ , IsAttribute(..)+ -- * Mapped Address+ , findMappedAddress+ , MappedAddress+ , XorMappedAddress+ , fromXorMappedAddress+ , xorMappedAddress+ -- * Credentials+ , Username(..)+ , Credentials(..)+ , withMessageIntegrity+ , checkMessageIntegrity+ -- * Errors+ , StunError(..)+ , ErrorAttribute(..)+ , errTryAlternate+ , errBadRequest+ , errUnauthorized+ , errUnknownAttribute+ , errStaleNonce+ , errServerError+ ) where++import Control.Applicative+import Control.Concurrent.Timeout+import Control.Monad.IO.Class+import Control.Monad.Trans.Error+import Data.Serialize+import qualified Network.BSD as Net+import qualified Network.Socket as S+import qualified Network.Socket.ByteString as SocketBS+import Network.Stun.Base+import Network.Stun.Credentials+import Network.Stun.Error+import Network.Stun.MappedAddress+import System.Random++-- | Generate a new bind request+bindRequest :: IO Message+bindRequest = do+ tid <- TID <$> randomIO <*> randomIO <*> randomIO+ return $ Message { messageMethod = 1+ , messageClass = Request+ , transactionID = tid+ , messageAttributes = []+ , fingerprint = True+ }++data StunError = TimeOut+ | ProtocolError -- !BS.ByteString+ | ErrorMsg !Message+ | WrongMessageType !Message+ deriving (Show, Eq)+instance Error StunError++-- | Send a STUN request to the server denoted by address and wait for an+-- answer. The request will be sucessively sent once for each element of+-- timeOuts until an answer is received or all requests time out.+stunRequest+ :: S.SockAddr -- ^ Address of the stun server+ -> Net.PortNumber -- ^ local port to use+ -> [Integer] -- ^ time outs in µs (10^-6 seconds), will default to+ -- [0.5s, 1s, 2s] if empty. 0 means wait indefinitly.+ -> Message -- ^ Request to send+ -> IO (Either StunError Message)+stunRequest host localPort timeOuts msg = runErrorT $ do+ (r, s) <- ErrorT $ stunRequest' host localPort timeOuts msg+ liftIO $ S.close s+ return r+++-- | Same as 'stunRequest' but returns the used socket+stunRequest'+ :: S.SockAddr -- ^ Address of the stun server+ -> Net.PortNumber -- ^ local port to use+ -> [Integer] -- ^ time outs in µs (10^-6 seconds), will default to+ -- [0.5s, 1s, 2s] if empty. 0 means wait indefinitly.+ -> Message -- ^ Request to send+ -> IO (Either StunError (Message, S.Socket))+stunRequest' host' _localPort timeOuts msg = runErrorT $ do+ let host = setHostPort host'+ s <- liftIO $ case host of+ S.SockAddrInet _hostPort _ha -> do+ s <- S.socket S.AF_INET S.Datagram S.defaultProtocol+ return s+ S.SockAddrInet6 _hostPort _fi _ha _sid -> do+ s <- S.socket S.AF_INET6 S.Datagram S.defaultProtocol+ S.setSocketOption s S.IPv6Only 1+ return s+ _ -> error $ "stunRequest': SockAddrUnix not implemented"+ liftIO $ S.connect s host+ let go [] = liftIO (S.close s) >> throwError TimeOut+ go (to:tos) = do+ _ <- liftIO $ SocketBS.sendTo s (encode msg) host+ r <- liftIO . timeout to $ SocketBS.recvFrom s 1024+ case r of+ Nothing -> go tos+ Just (answer, _) -> return answer+ answer <- go $ if null timeOuts then [500000, 1000000, 2000000] else timeOuts+ case decode answer of+ Left _ -> throwError $ ProtocolError -- answer+ Right msg' -> do+ case messageClass msg' of+ Failure -> throwError $ ErrorMsg msg'+ Success -> return (msg', s)+ _ -> throwError $ WrongMessageType msg'+ where+ setHostPort (S.SockAddrInet pn ha) = S.SockAddrInet+ (if pn == 0 then 3478 else pn) ha+ setHostPort (S.SockAddrInet6 pn fl ha si) = S.SockAddrInet6+ (if pn == 0 then 3478 else pn)+ fl ha si+ setHostPort s = s++-- | Get the mapped address by sending a bind request to /host/, using+-- /localport/ . The request will be retransmitted for each entry of /timeOuts/.+-- If the list of time outs is empty, a default of 500ms, 1s and 2s is used+-- returns the reflexive and the local address+findMappedAddress :: S.SockAddr -- ^ STUN server address+ -> Net.PortNumber -- ^ local port to use (or 0 for a random+ -- port)+ -> [Integer] -- ^ timeOuts in µs (10^-6 seconds)+ -> IO (Either StunError (S.SockAddr, S.SockAddr))+findMappedAddress host localPort timeOuts = runErrorT $ do+ br <- liftIO $ bindRequest+ (msg, s) <- ErrorT $ stunRequest' host localPort timeOuts br+ xma <- case findAttribute $ messageAttributes msg of+ Right [xma] -> return . Just+ $! fromXorMappedAddress (transactionID msg) xma+ Right [] -> return Nothing+ _ -> throwError $ ProtocolError+ ma <- case findAttribute $ messageAttributes msg of+ Right [ma] -> return . Just $! unMA ma+ Right [] -> return Nothing+ _ -> throwError $ ProtocolError+ m <- case (xma <|> ma) of+ Just m' -> return m'+ Nothing -> throwError $ ProtocolError -- no mapped Address+ local <- liftIO $ S.getSocketName s+ liftIO $ S.sClose s+ return $ (m, local)
+ source/Network/Stun/Base.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE RecordWildCards #-}+module Network.Stun.Base where++import Control.Monad+import Data.Bits+import qualified Data.ByteString as BS+import Data.Digest.CRC32+import Data.Serialize+import Data.Word++type Method = Word16++data MessageClass = Request+ | Success+ | Failure+ | Indication+ deriving (Show, Eq)++data Attribute = Attribute { attributeType :: {-# UNPACK #-} !Word16+ , attributeValue :: BS.ByteString+ } deriving (Show, Eq)+++data TransactionID = TID {-# UNPACK #-} !Word32+ {-# UNPACK #-} !Word32+ {-# UNPACK #-} !Word32+ deriving (Show, Read, Eq)++data Message = Message { messageMethod :: !Method+ , messageClass :: !MessageClass+ , transactionID :: !TransactionID+ , messageAttributes :: [Attribute]+ , fingerprint :: !Bool+ } deriving (Eq, Show)++-- | "magic cookie" constant+cookie :: Word32+cookie = 0x2112A442++data AttributeError = AttributeWrongType | AttributeDecodeError+ deriving (Show, Eq)++class Serialize a => IsAttribute a where+ attributeTypeValue :: a -> Word16+ toAttribute :: a -> Attribute+ toAttribute x = Attribute { attributeType = attributeTypeValue x+ , attributeValue = encode x+ }+ fromAttribute :: Attribute -> Either AttributeError a+ fromAttribute (Attribute tp vl) = x+ where x = if tp == attributeTypeValue ((\(Right r) -> r) x) then+ case decode vl of+ Left _ -> Left AttributeDecodeError+ Right r -> Right r+ else Left AttributeWrongType++findAttribute :: IsAttribute a => [Attribute] -> Either AttributeError [a]+findAttribute [] = Right []+findAttribute (x:xs) = case fromAttribute x of+ Right r -> (r :) `fmap` findAttribute xs+ Left AttributeWrongType -> findAttribute xs+ Left AttributeDecodeError -> Left AttributeDecodeError+++putAttribute :: Attribute -> PutM ()+putAttribute Attribute{..} = do+ putWord16be attributeType+ putWord16be (fromIntegral $ BS.length attributeValue)+ putByteString attributeValue+ -- padding:+ replicateM_ (negate (BS.length attributeValue) `mod` 4) $ putWord8 0+ return ()++getAttribute :: Get Attribute+getAttribute = do+ attributeType <- getWord16be+ leng <- getWord16be+ attributeValue <- getBytes (fromIntegral leng)+ -- consume padding:+ _ <- replicateM (negate (fromIntegral leng) `mod` 4) $ getWord8+ return Attribute{..}++instance Serialize Attribute where+ put = putAttribute+ get = getAttribute++encodeMessageType :: Method -> MessageClass -> Word16+encodeMessageType method messageClass =+ (method .&. 0xf) -- least 4 bits remain the same+ .|. (c0 `shiftL` 4) -- bit 5 is class low bit+ .|. ((method .&. 0x70) `shiftL` 1) -- next 3 bits are offset by 1+ .|. (c1 `shiftL` 8) -- bit 9 is class high bit+ .|. ((method .&. 0xf80) `shiftL` 2) -- highest 5 bits are offset by 2+ -- most significant 2 bits remain 0+ where+ (c1, c0) = case messageClass of+ Request -> (0,0) :: (Word16, Word16)+ Success -> (1,0)+ Failure -> (1,1)+ Indication -> (0,1)++decodeMessageType :: Word16 -> (Method, MessageClass)+decodeMessageType word = (method, mClass)+ where+ mClass = case (c1, c0) of+ (False, False) -> Request+ (True , False) -> Success+ (True , True ) -> Failure+ (False, True ) -> Indication+ c0 = testBit word 4+ c1 = testBit word 8+ method =+ (word .&. 0xf) -- least 4 bits remain the same+ .|. ((word .&. 0xe0) `shiftR` 1) -- next 3 bits are offset by 1+ .|. ((word .&. 0x3e00) `shiftR` 2) -- highest 5 bits are offset by 2+++fingerprintXorConstant :: Word32+fingerprintXorConstant = 0x5354554e++fingerprintAttribute :: Word32 -> Attribute+fingerprintAttribute crc = Attribute { attributeType = 0x8028+ , attributeValue = encode $ crc `xor` fingerprintXorConstant+ }++putPlainMessage :: Int -> Message -> PutM ()+putPlainMessage plusSize Message{..} = do+ putWord16be (encodeMessageType messageMethod messageClass)+ let messageBody = runPut . void $ mapM put messageAttributes+ let messageLength = (fromIntegral $ BS.length messageBody + plusSize)+ putWord16be messageLength+ putWord32be cookie+ let (TID tid1 tid2 tid3) = transactionID+ putWord32be tid1+ putWord32be tid2+ putWord32be tid3+ putByteString messageBody++putMessage :: Message -> PutM ()+putMessage m | fingerprint m = do+ -- The rfc demands that we crc32 the message until the beginning of the+ -- fingerprint attribute, but with the message length already set to the+ -- length of the entire message (including fingerprint), so we pass the+ -- length of the fingerprint attribute (8 byte) to be added to the length+ let msg = runPut $ putPlainMessage 8 m+ putByteString msg+ put . fingerprintAttribute . crc32 $ msg+ -- No fingerprint demanded+ | otherwise = putPlainMessage 0 m++getMessage :: Get Message+getMessage = do+ (mlen, msg) <- lookAhead $ do+ tp <- getWord16be+ guard $ 0xc000 .&. tp == 0 -- highest 2 bits are always 0+ let (messageMethod, messageClass) = decodeMessageType tp+ messageLength <- fromIntegral `fmap` getWord16be+ guard $ messageLength `mod` 4 == 0+ guard . (== cookie) =<< getWord32be -- "Magic cookie"+ transactionID <- liftM3 TID getWord32be getWord32be getWord32be+ messageAttributes <- isolate messageLength getMessageAttributes+ let fingerprint = False+ return (messageLength, Message{..})+ case reverse . messageAttributes $ msg of -- Fingerprint has to be the last+ -- attribute+ (Attribute 0x8028 fp :_) -> do+ start <- getBytes ( 20 -- header length+ + mlen -- plus message length+ - 8 -- but only up to the beginning of+ -- fingerprint+ )+ let crc = fingerprintXorConstant `xor` crc32 start+ label "fingeprint does not match" $ guard (encode crc == fp)+ return msg{ fingerprint = True+ , messageAttributes = init . messageAttributes $ msg+ }+ _ -> return msg+ where+ getMessageAttributes = isEmpty >>= \e -> if e then return [] else go+ go = do+ attr <- getAttribute+ empty <- isEmpty+ rest <- if empty then return [] else go+ return $ attr:rest++instance Serialize Message where+ put = putMessage+ get = getMessage++-- Helper for debugging bit-twiddling+showBits :: Bits a => a -> [Char]+showBits a = reverse [if testBit a i then '1' else '0' | i <- [0.. bitSize a - 1]]
+ source/Network/Stun/Credentials.hs view
@@ -0,0 +1,101 @@+module Network.Stun.Credentials+ ( Credentials(..)+ , Username(..)+ , MessageIntegrity(..)+ , withMessageIntegrity+ , checkMessageIntegrity+ ) where++import Control.Monad+import Crypto.HMAC+import qualified Crypto.Hash.CryptoAPI as Crypto+import qualified Crypto.Classes as Crypto+import Data.ByteString (ByteString)+import Data.ByteString.Lazy (fromChunks)+import Data.Serialize+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text++import Network.Stun.Base++data Username = Username {unUsername :: !Text}++instance Serialize Username where+ put = putByteString . Text.encodeUtf8 . unUsername+ get = (Username . Text.decodeUtf8) `liftM` ensure 0++instance IsAttribute Username where+ attributeTypeValue _ = 0x0006++data Credentials = LongTerm !Text !Text !Text -- ^ username realm password+ | ShortTerm !Text !Text -- ^ username password++cUsername :: Credentials -> Text+cUsername (LongTerm uname _ _) = uname+cUsername (ShortTerm uname _) = uname++data MessageIntegrity = MessageIntegrity { miHmac :: !ByteString}+ deriving (Show, Eq)++instance Serialize MessageIntegrity where+ put = putByteString . miHmac+ get = MessageIntegrity `fmap` ensure 20++instance IsAttribute MessageIntegrity where+ attributeTypeValue _ = 0x0008++mkMessageIntegrity :: Credentials -> Message -> MessageIntegrity+mkMessageIntegrity cred m = let+ msg = runPut $ putPlainMessage 24 m+ key = case cred of+ LongTerm uname realm pwd -> MacKey . md5hash+ . Text.encodeUtf8+ . Text.intercalate (Text.singleton ':') $+ [ uname+ , realm+ , pwd -- TODO: SaslPrep+ ]+ ShortTerm _ pwd -> MacKey $ Text.encodeUtf8 pwd --TODO: SaslPrep+ mac :: Crypto.SHA1+ mac = hmac key $ fromChunks [msg]+ in MessageIntegrity $ encode mac+ where+ md5hash :: ByteString -> ByteString+ md5hash = Crypto.encode . (Crypto.hash' :: ByteString -> Crypto.MD5)++-- | Generate a MESSAGE-INTEGRITY attribute and append it to the message+-- attribute list+withMessageIntegrity :: Credentials -> Message -> Message+withMessageIntegrity cred msg = msg{messageAttributes =+ messageAttributes msg ++ [uname, integrity]+ }+ where+ uname = toAttribute $ Username (cUsername cred)+ integrity = toAttribute $+ mkMessageIntegrity cred msg{messageAttributes =+ messageAttributes msg ++ [uname]}+++-- | Checks the credentials of a message+--+-- * returns Nothing when the credentials don't match+--+-- * returns Just (False, oldmsg) when no MESSAGE-INTEGRITY attribute is present+--+-- where oldmsg is the unchanged message passed to the function+--+-- * returns Just (True, prunedmsg) when the attribute is present and matches+--+-- where prunedmsg is the message with all fields after MESSAGE-INTEGRITY removed+checkMessageIntegrity :: Credentials -> Message -> Maybe (Bool, Message)+checkMessageIntegrity cred msg = let+ (attrs, rest) = break ((==)(attributeTypeValue (undefined :: MessageIntegrity))+ . attributeType ) $ messageAttributes msg+ in case rest of+ [] -> Just (False, msg)+ (inte: _) -> if fromAttribute inte+ == Right (mkMessageIntegrity cred+ msg{messageAttributes = attrs})+ then Just (True, msg {messageAttributes = attrs})+ else Nothing
+ source/Network/Stun/Error.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Stun.Error where++import Control.Applicative+import Control.Monad+import Data.Bits+import Data.Serialize+import Data.Text (Text)+import qualified Data.Text.Encoding as Text+import Network.Stun.Base++data ErrorAttribute = ErrorAttribute { code :: {-# UNPACK #-}!Int+ -- ^ Code has to be between+ -- 300 and 699 inclusive+ , reason :: !Text -- ^ At most 128 unicode+ -- characters+ } deriving (Show, Eq)++instance IsAttribute ErrorAttribute where+ attributeTypeValue _ = 0x0009++putErrorAttribute :: ErrorAttribute -> PutM ()+putErrorAttribute ErrorAttribute{..} = do+ putWord16be 0+ putWord8 (fromIntegral $ code `div` 100)+ putWord8 (fromIntegral $ code `mod` 100)+ putByteString $ Text.encodeUtf8 reason++getErrorAttribute :: Get ErrorAttribute+getErrorAttribute = do+ skip 2+ hundreds <- (fromIntegral . (0x7 .&.)) <$> getWord8 -- mask out highest 5+ -- bits+ guard (hundreds >= 3 && hundreds <= 6 )+ rest <- fromIntegral <$> getWord8+ guard $ rest <= 99+ let code = 100 * hundreds + rest+ reason <- Text.decodeUtf8 <$> ensure 0+ return ErrorAttribute{..}++instance Serialize ErrorAttribute where+ put = putErrorAttribute+ get = getErrorAttribute++errTryAlternate :: ErrorAttribute+errTryAlternate = ErrorAttribute { code = 300+ , reason = "Try Alternate: The client should contact an alternate server for this request."+ }++errBadRequest :: ErrorAttribute+errBadRequest = ErrorAttribute { code = 400+ , reason = "Bad Request: The request was malformed."++ }++errUnauthorized :: ErrorAttribute+errUnauthorized = ErrorAttribute { code = 401+ , reason = "Unauthorized: The request did not contain the correct credentials to proceed."+ }++errUnknownAttribute :: ErrorAttribute+errUnknownAttribute = ErrorAttribute {code = 420+ , reason = "Unknown Attribute: The server received a STUN packet containing a comprehension-required attribute that it did not understand."+ }++errStaleNonce :: ErrorAttribute+errStaleNonce = ErrorAttribute {code = 438+ , reason = "Stale Nonce: The NONCE used by the client was no longer valid."+ }++errServerError :: ErrorAttribute+errServerError = ErrorAttribute { code = 500+ , reason = "Server Error: The server has suffered a temporary error."+ }
+ source/Network/Stun/Internal.hs view
@@ -0,0 +1,13 @@+-- | This module exports /everything/ from this package (except some functions+-- defined in Network.Stun) to avoid the need for copy/paste.+module Network.Stun.Internal+ ( module Network.Stun.Base+ , module Network.Stun.Credentials+ , module Network.Stun.Error+ , module Network.Stun.MappedAddress+ ) where++import Network.Stun.Base+import Network.Stun.Credentials+import Network.Stun.Error+import Network.Stun.MappedAddress
+ source/Network/Stun/MappedAddress.hs view
@@ -0,0 +1,97 @@+module Network.Stun.MappedAddress where++import Control.Applicative ((<$>))+import Control.Monad+import Data.Bits+import Data.Serialize+import Data.Word+import Network.Endian+import Network.Socket+import Network.Stun.Base++xmaAttributeType :: Word16+xmaAttributeType = 0x0020++maAttributeType :: Word16+maAttributeType = 0x0001++newtype MappedAddress = MA{unMA :: SockAddr }+ deriving (Eq, Show)++instance Serialize MappedAddress where+ put = putAddress . unMA+ get = MA `liftM` getAddress++instance IsAttribute MappedAddress where+ attributeTypeValue _ = 0x0001+++newtype XorMappedAddress = XMA{unXMA :: SockAddr }+ deriving (Eq, Show)++instance Serialize XorMappedAddress where+ put = putAddress . unXMA+ get = XMA `liftM` getAddress++instance IsAttribute XorMappedAddress where+ attributeTypeValue _ = 0x0020+++-- most significant 16 bits of the magic cookie+halfCookie :: Word16+halfCookie = fromIntegral $ cookie `shiftR` 16++putAddress :: SockAddr -> PutM ()+putAddress (SockAddrInet port address) = do+ putWord8 0+ putWord8 1+ putWord16be $ fromIntegral port+ putWord32host address -- address already is BE+putAddress (SockAddrInet6 port _ (addr1, addr2, addr3, addr4) _ ) = do+ putWord8 0+ putWord8 2+ putWord16be $ fromIntegral port+ putWord32be addr1+ putWord32be addr2+ putWord32be addr3+ putWord32be addr4+putAddress _ = error "putAddress: Address type not implemented"++getAddress :: Get SockAddr+getAddress = do+ guard . (== 0) =<< getWord8+ family <- getWord8+ port <- fromIntegral <$> getWord16be+ case family of+ 1 -> do+ address <- getWord32host+ return $ SockAddrInet port address+ 2 -> do+ addr1 <- getWord32be+ addr2 <- getWord32be+ addr3 <- getWord32be+ addr4 <- getWord32be+ return $ (SockAddrInet6 port 0 (addr1, addr2, addr3, addr4)) 0+ _ -> mzero++fromXorMappedAddress :: TransactionID -> XorMappedAddress -> SockAddr+fromXorMappedAddress tid (XMA addr) = xorAddress tid addr++xorMappedAddress :: TransactionID -> SockAddr -> XorMappedAddress+xorMappedAddress tid addr = XMA $ xorAddress tid addr++xorAddress :: TransactionID -> SockAddr -> SockAddr+xorAddress _ (SockAddrInet port address) =+ SockAddrInet (fromIntegral (halfCookie `xor` (fromIntegral port)))+ (htonl cookie `xor` address)+xorAddress (TID tid1 tid2 tid3)+ (SockAddrInet6 port fi (addr1, addr2, addr3, addr4) sid) =+ SockAddrInet6 (fromIntegral (halfCookie `xor` (fromIntegral port)))+ fi+ ( cookie `xor` addr1+ , tid1 `xor` addr2+ , tid2 `xor` addr3+ , tid3 `xor` addr4+ )+ sid+xorAddress _ _ = error "xorAddress does not work on SockAddrUnix"
+ source/Tests.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RecordWildCards #-}+module Main where++import Control.Applicative+import Control.Monad+import qualified Data.ByteString as BS+import Data.Serialize+import qualified Data.Text as Text+import Data.Word+import Network.Socket+import qualified Network.Stun.Base as Stun+import qualified Network.Stun.Error as Stun+import qualified Network.Stun.MappedAddress as Stun+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck++instance Arbitrary Stun.MessageClass where+ arbitrary = elements [ Stun.Request+ , Stun.Success+ , Stun.Failure+ , Stun.Indication]++++checkEncDec method messageClass = let method' = method `mod` (2^12) in+ (method', messageClass) ==+ (Stun.decodeMessageType $ Stun.encodeMessageType method' messageClass)++checkDecEnc word = let word' = word `mod` (2^14) in+ word' == (uncurry Stun.encodeMessageType $ Stun.decodeMessageType word')+++test1 = testProperty "checkEncDec" checkEncDec+test2 = testProperty "checkDecEnc" checkDecEnc++instance Arbitrary Stun.Message where+ arbitrary = do+ messageMethod <- (`mod` (2^12)) `liftM` arbitrary+ messageClass <- arbitrary+ transactionID <- liftM3 Stun.TID arbitrary arbitrary arbitrary+ messageAttributes <- arbitrary+ fingerprint <- arbitrary+ return Stun.Message{..}+++checkSerializer x = decode (encode x) == Right x++test3 = testProperty "checkSerializer/Message"+ (checkSerializer :: Stun.Message -> Bool)++instance Arbitrary Stun.Attribute where+ arbitrary = liftM2 Stun.Attribute arbitrary (BS.pack `liftM` arbitrary)++test4 = testProperty "checkSerializer/Attribute"+ (checkSerializer :: Stun.Attribute -> Bool)+++instance Arbitrary SockAddr where+ arbitrary = do+ fam <- (`mod` 2) <$> (arbitrary :: Gen Int)+ port <- fromIntegral <$> (arbitrary :: Gen Word16)+ case fam of+ 1 -> SockAddrInet port <$> arbitrary+ 0 -> do+ addr <- (,,,) <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ return $ SockAddrInet6 port 0 addr 0 -- Flow and scopeID aren't+ -- encoded+++instance Arbitrary Stun.MappedAddress where+ arbitrary = Stun.MA <$> arbitrary+++instance Arbitrary Stun.TransactionID where+ arbitrary = Stun.TID <$> arbitrary <*> arbitrary <*> arbitrary++test5 = testProperty "checkSerializer/Address"+ (checkSerializer :: Stun.MappedAddress -> Bool)++xorAddressInvolution tid addr = Stun.xorAddress tid (Stun.xorAddress tid addr)+ == addr+test6 = testProperty "xorAddressInvolution" xorAddressInvolution++instance Arbitrary Stun.ErrorAttribute where+ arbitrary = do+ code <- choose (300,699)+ textLength <- choose (0,128)+ reason <- Text.pack <$> replicateM textLength arbitrary+ return Stun.ErrorAttribute{..}+test7 = testProperty "checkSerializer/Error"+ (checkSerializer :: Stun.ErrorAttribute -> Bool)++main = defaultMain[ test1+ , test2+ , test3+ , test4+ , test5+ , test6+ , test7+ ]
+ stunclient.cabal view
@@ -0,0 +1,58 @@+name: stunclient+version: 0.1.0.0+synopsis: RFC 5389: Session Traversal Utilities for NAT (STUN) client+description: RFC 5389: Session Traversal Utilities for NAT (STUN) client+license: MIT+license-file: LICENSE+author: Philipp Balzarek+maintainer: p.balzarek@googlemail.com+copyright: Philipp Balzarek+category: Network+build-type: Simple+cabal-version: >=1.8+bug-reports: https://github.com/Philonous/hs-stun/issues++library+ exposed-modules: Network.Stun+ , Network.Stun.Internal+ other-modules: Network.Stun.Base+ , Network.Stun.Error+ , Network.Stun.MappedAddress+ , Network.Stun.Credentials+ , Network.Endian+ hs-source-dirs: source+ build-depends: base >= 4.5 && < 5+ , network >= 2.4+ , transformers >= 0.3+ , cereal >= 0.3+ , bytestring >= 0.10+ , text >= 0.11+ , stringprep >= 0.1+ , random >= 1.0+ , digest >= 0.0+ , unbounded-delays >= 0.1+ , cryptohash-cryptoapi >= 0.1+ , cryptohash >= 0.9+ , crypto-api >= 0.12+ ghc-options: -Wall++test-suite test-serialize+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ hs-source-dirs: source+ build-depends: base >= 4.5+ , network >= 2.4+ , transformers >= 0.3+ , cereal >= 0.3+ , bytestring >= 0.10+ , text >= 0.11+ , random >= 1.0+ , digest >= 0.0+ , unbounded-delays >= 0.1+ , QuickCheck >= 2.6+ , test-framework >= 0.8+ , test-framework-quickcheck2 >= 0.3++Source-Repository head+ Type: git+ Location: git://github.com/Philonous/hs-stun.git