module Data.Radius.Implements (
signPacket, signedPacket,
AuthenticatorError (..),
checkSignedRequest, checkSignedResponse,
) where
import Control.Monad (unless)
import Data.Monoid ((<>))
import Data.Word (Word16)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Serialize.Put (Put, runPut)
import qualified Data.ByteArray as BA
import Crypto.Hash (Digest, hash, MD5)
import Crypto.MAC.HMAC (HMAC, hmac, hmacGetDigest)
import Data.Radius.Packet (Code (..), Header (..), Packet (..))
import Data.Radius.Scalar (AtString (..), Bin128, mayBin128, fromBin128, bin128Zero)
import Data.Radius.Attribute
(Number (MessageAuthenticator), messageAuthenticator,
NumberAbstract (Standard), Attribute' (Attribute'), TypedNumberSets, )
import Data.Radius.StreamGet (Attributes)
import qualified Data.Radius.StreamGet as Get
import qualified Data.Radius.StreamPut as Put
hmacMD5 :: ByteString -> ByteString -> Bin128
hmacMD5 rsk bs =
maybe (error "hmacMD5: BUG? Invalid result length") id
. mayBin128 . BA.convert $ hmacGetDigest (hmac rsk bs :: HMAC MD5)
md5 :: ByteString -> Bin128
md5 bs = maybe (error "md5: BUG? Invalid result length") id
. mayBin128 $ BA.convert (hash bs :: Digest MD5)
signPacket :: (a -> ByteString -> Put)
-> ByteString
-> Bin128
-> (Word16 -> Bin128 -> Header)
-> (Bin128 -> [Attribute' a])
-> (Word16, Bin128, Bin128)
signPacket va rsk auth mkH mkA = (len, msgAuth, respAuth)
where
asMsgAuth0 = mkA bin128Zero
pput = runPut . Put.upacket va
len = fromIntegral . BS.length . pput
$ Packet { header = mkH 0 auth, attributes = asMsgAuth0 }
msgAuth = hmacMD5 rsk . pput
$ Packet { header = mkH len auth, attributes = asMsgAuth0 }
respAuth = md5 $ (pput $ Packet { header = mkH len auth, attributes = mkA msgAuth }) <> rsk
signedPacket :: (a -> ByteString -> Put)
-> ByteString
-> Bin128
-> (Word16 -> Bin128 -> Header)
-> (Bin128 -> [Attribute' a])
-> Packet [Attribute' a]
signedPacket va rsk auth mkH mkA = case code $ mkH len auth of
AccessAccept -> response
AccessReject -> response
AccessChallenge -> response
AccessRequest -> other
Other _ -> other
where
(len, msgAuth, respAuth) = signPacket va rsk auth mkH mkA
response = Packet { header = mkH len respAuth, attributes = mkA msgAuth }
other = Packet { header = mkH len auth , attributes = mkA msgAuth }
data AuthenticatorError v
= NoMessageAuthenticator (Attributes v)
| BadMessageAuthenticator
| MoreThanOneMessageAuthenticator
| BadAuthenticator
| AttributesDecodeError String
| NotRequestPacket Code
| NotResponsePacket Code
instance Show (AuthenticatorError v) where
show = d where
d (NoMessageAuthenticator _) = "no messageAuthenticator found"
d BadMessageAuthenticator = "bad messageAuthenticator"
d MoreThanOneMessageAuthenticator = "more than one messageAuthenticator found"
d BadAuthenticator = "bad radius packet authenticator"
d (AttributesDecodeError s) = "fail to decode attributes: " ++ s
d (NotRequestPacket c) = "not request packet: code: " ++ show c
d (NotResponsePacket c) = "not response packet: code: " ++ show c
checkSignedRequest :: (TypedNumberSets a, Ord a)
=> (a -> ByteString -> Put)
-> ByteString
-> Packet [Attribute' a]
-> Either (AuthenticatorError a) (Attributes a)
checkSignedRequest va rsk upkt = case code $ header upkt of
c@AccessAccept -> notRequestCode c
c@AccessReject -> notRequestCode c
c@AccessChallenge -> notRequestCode c
AccessRequest -> check
Other _ -> check
where
notRequestCode = Left . NotRequestPacket
check = checkMA calcMsgAuth $ attrs
attrs = attributes upkt
calcMsgAuth = hmacMD5 rsk . runPut . Put.upacket va
$ upkt { attributes = replace0MA attrs }
checkSignedResponse :: (TypedNumberSets a, Ord a)
=> (a -> ByteString -> Put)
-> ByteString
-> Bin128
-> Packet [Attribute' a]
-> Either (AuthenticatorError a) (Attributes a)
checkSignedResponse va rsk reqAuth upkt = case code $ header upkt of
AccessAccept -> check
AccessReject -> check
AccessChallenge -> check
c@AccessRequest -> notResponseCode c
c@(Other _) -> notResponseCode c
where
notResponseCode = Left . NotResponsePacket
check = do
unless (authenticator (header upkt) == calcRespAuth) $ Left BadAuthenticator
checkMA calcMsgAuth attrs
attrs = attributes upkt
calcRespAuth = md5
$ (runPut . Put.upacket va $ upkt { header = (header upkt) { authenticator = reqAuth } }) <> rsk
calcMsgAuth = hmacMD5 rsk . runPut . Put.upacket va
$ upkt { header = (header upkt) { authenticator = reqAuth }
, attributes = replace0MA attrs }
checkMA :: (TypedNumberSets a, Ord a)
=> Bin128 -> [Attribute' a] -> Either (AuthenticatorError a) (Attributes a)
checkMA calcMsgAuth attrs = do
ta <- either (Left . AttributesDecodeError) return . Get.extractAttributes $ mapM Get.tellT attrs
case Get.takeTyped ta messageAuthenticator of
[] -> Left $ NoMessageAuthenticator ta
[AtString bs] -> do
unless (bs == fromBin128 calcMsgAuth) $ Left BadMessageAuthenticator
return ta
_:_:_ -> Left MoreThanOneMessageAuthenticator
replace0MA :: [Attribute' a] -> [Attribute' a]
replace0MA = rec' where
rec' [] =
[]
rec' (Attribute' n@(Standard MessageAuthenticator) _ : xs) =
Attribute' n (fromBin128 bin128Zero) : rec' xs
rec' (x : xs) =
x : rec' xs