diff --git a/radius.cabal b/radius.cabal --- a/radius.cabal +++ b/radius.cabal @@ -1,5 +1,5 @@ name: radius -version: 0.6.1.0 +version: 0.7.1.0 synopsis: Remote Authentication Dial In User Service (RADIUS) description: This module provides types and on the wire de/coding of RADIUS packets as per RFC2865 homepage: https://gitlab.com/codemonkeylabs/RADIUS @@ -24,6 +24,7 @@ , cryptonite , iproute , memory + , lens default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Network/RADIUS/Encoding.hs b/src/Network/RADIUS/Encoding.hs --- a/src/Network/RADIUS/Encoding.hs +++ b/src/Network/RADIUS/Encoding.hs @@ -16,7 +16,7 @@ module Network.RADIUS.Encoding where import Control.Monad (when) -import Data.Binary (Binary(..), encode) +import Data.Binary (Binary(..), decode, encode) import Data.Binary.Put (Put, putLazyByteString, putWord8, putWord16be, putWord32be, runPut) import Data.Binary.Get (Get, getLazyByteString, @@ -46,17 +46,17 @@ authenticatorLength = 16 instance Binary Packet where - put Packet{ getHeader = Header{..} , .. } = do - let iD = fromIntegral $ getPacketId - authLen = B.length getPacketAuthenticator - attributes = encodeAttributes getPacketAttributes + put Packet{ _getHeader = Header{..} , .. } = do + let iD = fromIntegral $ _getPacketId + authLen = B.length _getPacketAuthenticator + attributes = encodeAttributes _getPacketAttributes attrsLen = fromIntegral $ B.length $ attributes when (authLen /= authenticatorLength) $ error $ "RADIUS.Encoding: Invalid Authenticator length " ++ show authLen - put getPacketType + put _getPacketType putWord8 iD putWord16be $ attrsLen + radiusHeaderSize - putLazyByteString getPacketAuthenticator + putLazyByteString _getPacketAuthenticator putLazyByteString attributes get = do header <- decodeHeader @@ -69,18 +69,18 @@ iD <- getWord8 packetLength <- getWord16be authenticator <- getLazyByteString authenticatorLength - return Header { getPacketType = packetType, - getPacketId = iD, - getPacketLength = packetLength, - getPacketAuthenticator = authenticator } + return Header { _getPacketType = packetType, + _getPacketId = iD, + _getPacketLength = packetLength, + _getPacketAuthenticator = authenticator } -- | Given an already decoded header, this function can be used to decode the complete packet -- from the available data decodePacket :: Header -> Get Packet decodePacket header@Header{..} = do attributes <- decodeAttributes [] - return Packet { getHeader = header, - getPacketAttributes = attributes } + return Packet { _getHeader = header, + _getPacketAttributes = attributes } sign :: ByteString -> ByteString -> ByteString sign packet secret = @@ -188,6 +188,7 @@ put (PasswordRetryAttribute value) = putAttribute 75 value put (PromptAttribute value) = putAttribute 76 value put (AcctInterimIntervalAttribute value) = putAttribute 85 value + put (DNSServerIPv6AddressAttribute value) = putAttribute 169 value put (UnknownAttribute attributeType value) = putAttribute attributeType value put (FramedIPv6Prefix prefixLength prefix) = putAttributeM 97 $ do putWord8 0 -- reserved @@ -198,7 +199,7 @@ putWord8 prefixLength putLazyByteString $ encode prefix put (VendorSpecificAttribute vendorId str) = putAttributeM 26 $ do - when (not $ B.null str) $ error $ "Empty String not allowed in Vendor-Specific Attribute " + when (B.null str) $ error "Empty String not allowed in Vendor-Specific Attribute " putWord32be vendorId putLazyByteString str put (CHAPPassword identity str) = putAttributeM 3 $ do @@ -299,13 +300,15 @@ getAttribute 75 = getAttributeValue >>= return . PasswordRetryAttribute getAttribute 76 = getAttributeValue >>= return . PromptAttribute getAttribute 85 = getAttributeValue >>= return . AcctInterimIntervalAttribute +getAttribute 169 = getAttributeValue >>= return . DNSServerIPv6AddressAttribute getAttribute 97 = do attrLen <- getWord8 _reserved <- getWord8 prefixLength <- getWord8 - when (attrLen /= 20) $ error $ "Unsupported RADIUS Framed IPv6 Prefix attribute length " - ++ show attrLen - prefix <- get + when (attrLen < 4 || attrLen > 20) $ + error $ show attrLen ++ " is an invalid RADIUS Framed IPv6 Prefix attribute length" + let available = fromIntegral $ attrLen - 4 + prefix <- getFromBytes available 20 return $ FramedIPv6Prefix prefixLength prefix getAttribute 26 = do attrLen <- getWord8 @@ -320,15 +323,24 @@ return $ CHAPPassword identity attrData getAttribute 123 = do attrLen <- getWord8 - when (attrLen /= 20) $ error $ "Unsupported RADIUS Delegated IPv6 Prefix attribute length " - ++ show attrLen + when (attrLen < 4 || attrLen > 20) $ + error $ show attrLen ++ + " is an invalid RADIUS Delegated IPv6 Prefix attribute length" _reserved <- getWord8 prefixLength <- getWord8 - prefix <- get + let available = fromIntegral $ attrLen - 4 + prefix <- getFromBytes available 20 return $ DelegatedIPv6Prefix prefixLength prefix getAttribute n = getAttributeStr >>= return . UnknownAttribute n -- | For internal use. +getFromBytes :: Binary a => Int64 -> Int64 -> Get a +getFromBytes len size = do + let padBytes = size - len + pad = B.replicate padBytes '\0' + str <- getLazyByteString len + return . decode $ B.append str pad + getAttributeStr :: Get ByteString getAttributeStr = getWord8 >>= getLazyByteString . fromIntegral . (subtract 2) -- minus type + len diff --git a/src/Network/RADIUS/Microsoft.hs b/src/Network/RADIUS/Microsoft.hs --- a/src/Network/RADIUS/Microsoft.hs +++ b/src/Network/RADIUS/Microsoft.hs @@ -15,7 +15,9 @@ module Network.RADIUS.Microsoft (encodeMPPESendKeyAttribute, encodeMPPERecvKeyAttribute, encodeMPPEEncryptionPolicyAttribute, - encodeMPPEEncryptionTypesAttribute) where + encodeMPPEEncryptionTypesAttribute, + encodePrimaryDNSServer, + encodeSecondaryDNSServer) where import Prelude hiding (zipWith) import Crypto.Hash.Algorithms (MD5) @@ -25,7 +27,9 @@ import Data.ByteArray (convert) import Data.ByteString (ByteString, pack, zipWith) import Data.ByteString.Internal (w2c) +import Data.IP (IPv4) import Data.Word (Word8, Word16, Word32) +import Network.RADIUS.Encoding (putAttribute) import Network.RADIUS.Types import qualified Data.ByteString.Lazy.Char8 as LB @@ -100,3 +104,15 @@ putWord8 8 -- for MS-MPPE-Encryption-Types. putWord8 6 -- fixed length putWord32be types + +-- | Encode MS-DNS-Primary-DNA-Server as per [RFC2548] +encodePrimaryDNSServer :: IPv4 + -> PacketAttribute +encodePrimaryDNSServer = + vendorSpecificAttribute . runPut . putAttribute 28 + +-- | Encode MS-DNS-Secondary-DNA-Server as per [RFC2548] +encodeSecondaryDNSServer :: IPv4 + -> PacketAttribute +encodeSecondaryDNSServer = + vendorSpecificAttribute . runPut . putAttribute 29 diff --git a/src/Network/RADIUS/Types.hs b/src/Network/RADIUS/Types.hs --- a/src/Network/RADIUS/Types.hs +++ b/src/Network/RADIUS/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} {-| Module : Network.RADIUS.Types Description : Provides types and definitions for RADIUS as per RFC 2865 @@ -21,15 +22,16 @@ import Data.Data (Data) import Data.Word (Word8, Word16, Word32, Word64) import Data.IP (IPv4, IPv6) +import Control.Lens.TH (makePrisms, makeLenses) -data Header = Header { getPacketType :: PacketType, - getPacketId :: Word8, - getPacketLength :: Word16, - getPacketAuthenticator :: ByteString } +data Header = Header { _getPacketType :: PacketType, + _getPacketId :: Word8, + _getPacketLength :: Word16, + _getPacketAuthenticator :: ByteString } deriving (Show, Eq) -data Packet = Packet { getHeader :: Header, - getPacketAttributes :: [PacketAttribute] } +data Packet = Packet { _getHeader :: Header, + _getPacketAttributes :: [PacketAttribute] } deriving (Show, Eq) data PacketType = AccessRequest @@ -146,6 +148,7 @@ | AcctTerminateCauseAttribute { getAcctTerminateCauseAttribute :: TerminateCause } | AcctMultiSessionIdAttribute { getAcctMultiSessionIdAttribute :: ByteString } | AcctLinkCountAttribute { getAcctLinkCountAttribute :: Word32 } + | DNSServerIPv6AddressAttribute { getDNSServerIPv6AddressAttribute :: IPv6 } | UnknownAttribute { getUnknownType :: Word8, getUnknownAttribute :: ByteString } deriving (Show, Eq, Data) @@ -484,3 +487,20 @@ fromEnum UseZoneFilterInclusivelyARAPAccess = 2 fromEnum UseZoneFilterExclusivelyARAPAccess = 4 fromEnum (UnknownARAPZoneAccess x) = x + +makeLenses ''Header +makeLenses ''Packet +makePrisms ''PacketType +makePrisms ''PacketAttribute +makePrisms ''StatusType +makePrisms ''Authentic +makePrisms ''TerminateCause +makePrisms ''ServiceType +makePrisms ''FramedProtocol +makePrisms ''FramedRouting +makePrisms ''FramedCompression +makePrisms ''LoginService +makePrisms ''TerminationAction +makePrisms ''NASPortType +makePrisms ''ARAPZoneAccess +