2012-05-14 05:39:20 +00:00
|
|
|
-- |
|
|
|
|
-- Module : Network.TLS.Extension
|
|
|
|
-- License : BSD-style
|
|
|
|
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
|
|
|
|
-- Stability : experimental
|
|
|
|
-- Portability : unknown
|
|
|
|
--
|
|
|
|
-- basic extensions are defined in RFC 6066
|
|
|
|
--
|
|
|
|
module Network.TLS.Extension
|
|
|
|
( Extension(..)
|
|
|
|
, supportedExtensions
|
|
|
|
-- all extensions ID supported
|
2012-10-17 06:30:07 +00:00
|
|
|
, extensionID_ServerName
|
2012-10-17 06:30:41 +00:00
|
|
|
, extensionID_MaxFragmentLength
|
2012-05-14 05:39:20 +00:00
|
|
|
, extensionID_SecureRenegotiation
|
|
|
|
, extensionID_NextProtocolNegotiation
|
|
|
|
-- all implemented extensions
|
2012-10-20 07:59:39 +00:00
|
|
|
, ServerNameType(..)
|
2012-10-17 06:30:26 +00:00
|
|
|
, ServerName(..)
|
2012-10-17 06:30:41 +00:00
|
|
|
, MaxFragmentLength(..)
|
|
|
|
, MaxFragmentEnum(..)
|
2012-05-14 05:39:20 +00:00
|
|
|
, SecureRenegotiation(..)
|
|
|
|
, NextProtocolNegotiation(..)
|
|
|
|
) where
|
|
|
|
|
|
|
|
import Control.Applicative ((<$>))
|
|
|
|
import Control.Monad
|
|
|
|
|
|
|
|
import Data.Word
|
|
|
|
import Data.Maybe (fromMaybe)
|
|
|
|
import Data.ByteString (ByteString)
|
|
|
|
import qualified Data.ByteString as B
|
2012-10-20 07:59:39 +00:00
|
|
|
import qualified Data.ByteString.Char8 as BC
|
2012-05-14 05:39:20 +00:00
|
|
|
|
2012-08-27 07:13:23 +00:00
|
|
|
import Network.TLS.Struct (ExtensionID)
|
2012-05-14 05:39:20 +00:00
|
|
|
import Network.TLS.Wire
|
2012-10-20 07:59:39 +00:00
|
|
|
import Network.BSD (HostName)
|
2012-05-14 05:39:20 +00:00
|
|
|
|
2012-10-17 06:30:41 +00:00
|
|
|
extensionID_ServerName, extensionID_MaxFragmentLength
|
|
|
|
, extensionID_SecureRenegotiation
|
|
|
|
, extensionID_NextProtocolNegotiation :: ExtensionID
|
2012-10-17 06:30:07 +00:00
|
|
|
extensionID_ServerName = 0x0
|
2012-10-17 06:30:41 +00:00
|
|
|
extensionID_MaxFragmentLength = 0x1
|
2012-10-17 06:30:07 +00:00
|
|
|
extensionID_SecureRenegotiation = 0xff01
|
2012-05-14 05:39:20 +00:00
|
|
|
extensionID_NextProtocolNegotiation = 0x3374
|
|
|
|
|
|
|
|
-- | all supported extensions by the implementation
|
|
|
|
supportedExtensions :: [ExtensionID]
|
2012-10-17 06:30:07 +00:00
|
|
|
supportedExtensions = [ extensionID_ServerName
|
2012-10-17 06:30:41 +00:00
|
|
|
, extensionID_MaxFragmentLength
|
2012-10-17 06:30:07 +00:00
|
|
|
, extensionID_SecureRenegotiation
|
2012-05-14 05:39:20 +00:00
|
|
|
, extensionID_NextProtocolNegotiation
|
|
|
|
]
|
|
|
|
|
|
|
|
-- | Extension class to transform bytes to and from a high level Extension type.
|
|
|
|
class Extension a where
|
2012-08-27 13:18:04 +00:00
|
|
|
extensionID :: a -> ExtensionID
|
2012-05-14 05:39:20 +00:00
|
|
|
extensionDecode :: Bool -> ByteString -> Maybe a
|
|
|
|
extensionEncode :: a -> ByteString
|
|
|
|
|
2012-10-17 06:28:35 +00:00
|
|
|
-- | Server Name extension including the name type and the associated name.
|
2012-08-27 14:11:29 +00:00
|
|
|
-- the associated name decoding is dependant of its name type.
|
|
|
|
-- name type = 0 : hostname
|
2012-10-20 07:59:39 +00:00
|
|
|
data ServerName = ServerName [ServerNameType]
|
2012-08-27 14:11:29 +00:00
|
|
|
deriving (Show,Eq)
|
|
|
|
|
2012-10-20 07:59:39 +00:00
|
|
|
data ServerNameType = ServerNameHostName HostName
|
|
|
|
| ServerNameOther (Word8, ByteString)
|
|
|
|
deriving (Show,Eq)
|
|
|
|
|
2012-08-27 14:11:29 +00:00
|
|
|
instance Extension ServerName where
|
2012-10-17 06:30:07 +00:00
|
|
|
extensionID _ = extensionID_ServerName
|
2013-01-27 16:08:39 +00:00
|
|
|
extensionEncode (ServerName l) = runPut $ putOpaque16 (runPut $ mapM_ encodeNameType l)
|
2012-10-20 07:59:39 +00:00
|
|
|
where encodeNameType (ServerNameHostName hn) = putWord8 0 >> putOpaque16 (BC.pack hn) -- FIXME: should be puny code conversion
|
2013-01-27 16:08:39 +00:00
|
|
|
encodeNameType (ServerNameOther (nt,opaque)) = putWord8 nt >> putBytes opaque
|
|
|
|
extensionDecode _ = runGetMaybe (getWord16 >>= \len -> getList (fromIntegral len) getServerName >>= return . ServerName)
|
2012-08-27 14:11:29 +00:00
|
|
|
where getServerName = do
|
|
|
|
ty <- getWord8
|
|
|
|
sname <- getOpaque16
|
2012-10-20 07:59:39 +00:00
|
|
|
return (1+2+B.length sname, case ty of
|
|
|
|
0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion
|
|
|
|
_ -> ServerNameOther (ty, sname))
|
2012-08-27 14:11:29 +00:00
|
|
|
|
2012-10-17 06:30:41 +00:00
|
|
|
-- | Max fragment extension with length from 512 bytes to 4096 bytes
|
2012-10-20 07:57:28 +00:00
|
|
|
data MaxFragmentLength = MaxFragmentLength MaxFragmentEnum
|
2012-10-17 06:30:41 +00:00
|
|
|
deriving (Show,Eq)
|
|
|
|
data MaxFragmentEnum = MaxFragment512 | MaxFragment1024 | MaxFragment2048 | MaxFragment4096
|
|
|
|
deriving (Show,Eq)
|
|
|
|
|
|
|
|
instance Extension MaxFragmentLength where
|
|
|
|
extensionID _ = extensionID_MaxFragmentLength
|
2012-10-20 07:58:36 +00:00
|
|
|
extensionEncode (MaxFragmentLength e) = B.singleton $ marshallSize e
|
2012-10-17 06:30:41 +00:00
|
|
|
where marshallSize MaxFragment512 = 1
|
|
|
|
marshallSize MaxFragment1024 = 2
|
|
|
|
marshallSize MaxFragment2048 = 3
|
|
|
|
marshallSize MaxFragment4096 = 4
|
2012-10-20 07:58:14 +00:00
|
|
|
extensionDecode _ = runGetMaybe (MaxFragmentLength . unmarshallSize <$> getWord8)
|
2012-10-17 06:30:41 +00:00
|
|
|
where unmarshallSize 1 = MaxFragment512
|
|
|
|
unmarshallSize 2 = MaxFragment1024
|
|
|
|
unmarshallSize 3 = MaxFragment2048
|
|
|
|
unmarshallSize 4 = MaxFragment4096
|
2012-10-20 07:57:53 +00:00
|
|
|
unmarshallSize n = error ("unknown max fragment size " ++ show n)
|
2012-10-17 06:30:41 +00:00
|
|
|
|
2012-08-27 14:11:17 +00:00
|
|
|
-- | Secure Renegotiation
|
2012-05-14 05:39:20 +00:00
|
|
|
data SecureRenegotiation = SecureRenegotiation ByteString (Maybe ByteString)
|
|
|
|
deriving (Show,Eq)
|
|
|
|
|
|
|
|
instance Extension SecureRenegotiation where
|
|
|
|
extensionID _ = extensionID_SecureRenegotiation
|
|
|
|
extensionEncode (SecureRenegotiation cvd svd) =
|
|
|
|
runPut $ putOpaque8 (cvd `B.append` fromMaybe B.empty svd)
|
|
|
|
extensionDecode isServerHello = runGetMaybe getSecureReneg
|
|
|
|
where getSecureReneg = do
|
|
|
|
opaque <- getOpaque8
|
|
|
|
if isServerHello
|
|
|
|
then let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque
|
|
|
|
in return $ SecureRenegotiation cvd (Just svd)
|
|
|
|
else return $ SecureRenegotiation opaque Nothing
|
|
|
|
|
2012-08-27 14:11:17 +00:00
|
|
|
-- | Next Protocol Negotiation
|
2012-05-14 05:39:20 +00:00
|
|
|
data NextProtocolNegotiation = NextProtocolNegotiation [ByteString]
|
|
|
|
deriving (Show,Eq)
|
|
|
|
|
|
|
|
instance Extension NextProtocolNegotiation where
|
|
|
|
extensionID _ = extensionID_NextProtocolNegotiation
|
|
|
|
extensionEncode (NextProtocolNegotiation bytes) =
|
|
|
|
runPut $ mapM_ putOpaque8 bytes
|
|
|
|
extensionDecode _ = runGetMaybe (NextProtocolNegotiation <$> getNPN)
|
|
|
|
where getNPN = do
|
|
|
|
avail <- remaining
|
|
|
|
case avail of
|
|
|
|
0 -> return []
|
|
|
|
_ -> do liftM2 (:) getOpaque8 getNPN
|