diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2012 Philipp Balzarek + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/source/Network/Endian.hs b/source/Network/Endian.hs new file mode 100644 --- /dev/null +++ b/source/Network/Endian.hs @@ -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 diff --git a/source/Network/Stun.hs b/source/Network/Stun.hs new file mode 100644 --- /dev/null +++ b/source/Network/Stun.hs @@ -0,0 +1,158 @@ +-- | Session Traversal Utilities for NAT (STUN) +-- +-- +-- +-- 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) diff --git a/source/Network/Stun/Base.hs b/source/Network/Stun/Base.hs new file mode 100644 --- /dev/null +++ b/source/Network/Stun/Base.hs @@ -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]] diff --git a/source/Network/Stun/Credentials.hs b/source/Network/Stun/Credentials.hs new file mode 100644 --- /dev/null +++ b/source/Network/Stun/Credentials.hs @@ -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 diff --git a/source/Network/Stun/Error.hs b/source/Network/Stun/Error.hs new file mode 100644 --- /dev/null +++ b/source/Network/Stun/Error.hs @@ -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." + } diff --git a/source/Network/Stun/Internal.hs b/source/Network/Stun/Internal.hs new file mode 100644 --- /dev/null +++ b/source/Network/Stun/Internal.hs @@ -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 diff --git a/source/Network/Stun/MappedAddress.hs b/source/Network/Stun/MappedAddress.hs new file mode 100644 --- /dev/null +++ b/source/Network/Stun/MappedAddress.hs @@ -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" diff --git a/source/Tests.hs b/source/Tests.hs new file mode 100644 --- /dev/null +++ b/source/Tests.hs @@ -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 + ] diff --git a/stunclient.cabal b/stunclient.cabal new file mode 100644 --- /dev/null +++ b/stunclient.cabal @@ -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