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
| ShortTerm !Text !Text
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
]
ShortTerm _ pwd -> MacKey $ Text.encodeUtf8 pwd
mac :: Crypto.SHA1
mac = hmac key $ fromChunks [msg]
in MessageIntegrity $ encode mac
where
md5hash :: ByteString -> ByteString
md5hash = Crypto.encode . (Crypto.hash' :: ByteString -> Crypto.MD5)
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]}
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