packages feed

peyotls-codec (empty) → 0.0.0.1

raw patch · 10 files changed

+980/−0 lines, 10 filesdep +asn1-encodingdep +asn1-typesdep +basesetup-changed

Dependencies added: asn1-encoding, asn1-types, base, bytable, bytestring, crypto-pubkey, crypto-pubkey-types, word24, x509, x509-store

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Yoshikuni Jujo+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++  * Redistributions of source code must retain the above copyright notice,+    this list of conditions and the following disclaimer.++  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in the+    documentation and/or other materials provided with the distribution.++  * Neither the name of the Yoshikuni Jujo nor the names of its+    contributors may be used to endorse or promote products derived from+    this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVEN SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,1 @@+import Distribution.Simple; main = defaultMain
+ peyotls-codec.cabal view
@@ -0,0 +1,43 @@+build-type:	Simple+cabal-version:	>= 1.8++name:		peyotls-codec+version:	0.0.0.1+stability:	Experimental+author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp>+maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>+homepage:	https://github.com/YoshikuniJujo/peyotls/wiki++license:	BSD3+license-file:	LICENSE++category:	Network+synopsis:	Codec parts of Pretty Easy YOshikuni-made TLS library+description:++source-repository	head+    type:	git+    location:	git://github.com/YoshikuniJujo/peyotls.git++source-repository	this+    type:	git+    location:	git://github.com/YoshikuniJujo/peyotls.git+    tag:	peyotls-0.1.6.6++library+    hs-source-dirs:	src+    exposed-modules:+            Network.PeyoTLS.Codec, Network.PeyoTLS.Codec.Certificate+            Network.PeyoTLS.CipherSuite+    other-modules:+            Network.PeyoTLS.Codec.ContentTypes,+            Network.PeyoTLS.Codec.Hello, Network.PeyoTLS.Codec.Extension,+            Network.PeyoTLS.Codec.HSAlg+    build-depends:+        base == 4.*, word24 == 1.0.*, bytestring == 0.10.*,+        asn1-encoding == 0.8.*, asn1-types == 0.2.*,+        x509 == 1.4.*, x509-store == 1.4.*,+        crypto-pubkey == 0.2.*, crypto-pubkey-types == 0.4.*,+        bytable == 0.1.*+    ghc-options:	-Wall+    extensions:		PatternGuards, DoAndIfThenElse
+ src/Network/PeyoTLS/CipherSuite.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.PeyoTLS.CipherSuite (+	CipherSuite(..), KeyEx(..), BulkEnc(..)) where++import Control.Arrow (first, (***))+import Data.Word (Word8)+import Data.String (IsString(..))++import qualified Data.ByteString as BS+import qualified Codec.Bytable.BigEndian as B++modNm :: String+modNm = "Network.PeyoTLS.CipherSuite"++data CipherSuite+	= CipherSuite KeyEx BulkEnc+	| EMPTY_RENEGOTIATION_INFO+	| CipherSuiteRaw Word8 Word8+	deriving (Show, Read, Eq)++data KeyEx = RSA | DHE_RSA | ECDHE_RSA | ECDHE_ECDSA | KE_NULL+	deriving (Show, Read, Eq)++data BulkEnc = AES_128_CBC_SHA | AES_128_CBC_SHA256 | BE_NULL+	deriving (Show, Read, Eq)+++instance B.Bytable CipherSuite where+	decode = decodeCs+	encode = encodeCs++decodeCs :: BS.ByteString -> Either String CipherSuite+decodeCs bs = case BS.unpack bs of+	[w1, w2] -> Right $ case (w1, w2) of+		(0x00, 0x00) -> CipherSuite KE_NULL BE_NULL+		(0x00, 0x2f) -> CipherSuite RSA AES_128_CBC_SHA+		(0x00, 0x33) -> CipherSuite DHE_RSA AES_128_CBC_SHA+		(0x00, 0x3c) -> CipherSuite RSA AES_128_CBC_SHA256+		(0x00, 0x67) -> CipherSuite DHE_RSA AES_128_CBC_SHA256+		(0xc0, 0x09) -> CipherSuite ECDHE_ECDSA AES_128_CBC_SHA+		(0xc0, 0x13) -> CipherSuite ECDHE_RSA AES_128_CBC_SHA+		(0xc0, 0x23) -> CipherSuite ECDHE_ECDSA AES_128_CBC_SHA256+		(0xc0, 0x27) -> CipherSuite ECDHE_RSA AES_128_CBC_SHA256+		(0x00, 0xff) -> EMPTY_RENEGOTIATION_INFO+		_ -> CipherSuiteRaw w1 w2+	_ -> Left $ modNm ++ ".decodeCs: not 2 byte"++encodeCs :: CipherSuite -> BS.ByteString+encodeCs (CipherSuite KE_NULL BE_NULL) = "\x00\x00"+encodeCs (CipherSuite RSA AES_128_CBC_SHA) = "\x00\x2f"+encodeCs (CipherSuite DHE_RSA AES_128_CBC_SHA) = "\x00\x33"+encodeCs (CipherSuite RSA AES_128_CBC_SHA256) = "\x00\x3c"+encodeCs (CipherSuite DHE_RSA AES_128_CBC_SHA256) = "\x00\x67"+encodeCs (CipherSuite ECDHE_ECDSA AES_128_CBC_SHA) = "\xc0\x09"+encodeCs (CipherSuite ECDHE_RSA AES_128_CBC_SHA) = "\xc0\x13"+encodeCs (CipherSuite ECDHE_ECDSA AES_128_CBC_SHA256) = "\xc0\x23"+encodeCs (CipherSuite ECDHE_RSA AES_128_CBC_SHA256) = "\xc0\x27"+encodeCs (CipherSuiteRaw w1 w2) = BS.pack [w1, w2]+encodeCs EMPTY_RENEGOTIATION_INFO = "\x00\xff"+encodeCs _ = error $ modNm ++ ".encodeCs: unknown cipher suite"++instance IsString CipherSuite where+	fromString = uncurry CipherSuite . (read *** read) . sep . drop 4+		where+		sep "" = error $ modNm ++ ".separateByWith: parse error"+		sep ('_' : 'W' : 'I' : 'T' : 'H' : '_' : be) = ("", be)+		sep (k : r) = (k :) `first` sep r
+ src/Network/PeyoTLS/Codec.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.PeyoTLS.Codec (+	Handshake(..), HandshakeItem(..),+	ClHello(..), SvHello(..), SssnId(..),+		CipherSuite(..), KeyEx(..), BulkEnc(..),+		CmpMtd(..), Extension(..), isRnInfo, emptyRnInfo,+	SvKeyEx(..), SvKeyExDhe(..), SvKeyExEcdhe(..),+	CertReq(..), certReq, ClCertType(..), SignAlg(..), HashAlg(..),+	SHDone(..), ClKeyEx(..), Epms(..),+	DigitSigned(..), Finished(..),+	CCSpec(..), ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (unless)+import Data.Word (Word8, Word16)+import Data.Word.Word24 (Word24)++import qualified Data.ByteString as BS+import qualified Data.X509 as X509+import qualified Codec.Bytable.BigEndian as B+import qualified Crypto.PubKey.DH as DH+import qualified Crypto.Types.PubKey.ECC as ECC++import Network.PeyoTLS.Codec.Hello (+	ClHello(..), SvHello(..), SssnId(..),+	CipherSuite(..), KeyEx(..), BulkEnc(..),+	CmpMtd(..), HashAlg(..), SignAlg(..),+	Extension(..), isRnInfo, emptyRnInfo )+import Network.PeyoTLS.Codec.Certificate (+	CertReq(..), certReq, ClCertType(..), ClKeyEx(..), DigitSigned(..) )++modNm :: String+modNm = "Network.PeyoTLS.Types"++-- RFC 5246 7.4 Handshake Protocol+--+-- enum {+-- 	hello_request(0), client_hello(1), server_hello(2),+-- 	certificate(11), server_key_exchange(12),+-- 	certificate_request(13), server_hello_done(14),+-- 	certificate_verify(15), client_key_exchange(16),+-- 	finished(20), (255)+-- } HandshakeType;+--+-- struct {+-- 	HandshakeType msg_type;+-- 	uint24 length;+-- 	select (HandshakeType) {+-- 		case hello_request:		HelloRequest;+-- 		case client_hello:		ClientHello;+-- 		case server_hello:		ServerHello;+-- 		case certificate:		Certificate;+-- 		case server_key_exchange:	ServerKeyExchange;+-- 		case certificate_request:	CertificateRequest;+-- 		case server_hello_done:		ServerHelloDone;+-- 		case certificate_verify:	CertificateVerify;+-- 		case client_key_exchange:	ClientKeyExchange;+-- 		case finished:			Finished;+-- 	} body;+-- } Handshake;++data Handshake+	= HCCSpec                     | HHelloReq+	| HClHello ClHello            | HSvHello SvHello+	| HCert X509.CertificateChain | HSvKeyEx BS.ByteString+	| HCertReq CertReq            | HSHDone+	| HCertVer DigitSigned        | HClKeyEx ClKeyEx+	| HFinished BS.ByteString     | HRaw Type BS.ByteString+	deriving Show++instance B.Bytable Handshake where+	decode = B.evalBytableM B.parse; encode = encodeH++instance B.Parsable Handshake where+	parse = (,) <$> B.take 1 <*> B.take 3 >>= \(t, l) -> case t of+		THelloReq -> const HHelloReq <$>+			unless (l == 0) (fail $ modNm ++ ": Handshake.parse")+		TClHello -> HClHello <$> B.take l+		TSvHello -> HSvHello <$> B.take l+		TCert -> HCert <$> B.take l+		TSvKeyEx -> HSvKeyEx <$> B.take l+		TCertReq -> HCertReq <$> B.take l+		TSHDone -> const HSHDone <$>+			unless (l == 0) (fail $ modNm ++ ": Handshake.parse")+		TCertVer -> HCertVer <$> B.take l+		TClKeyEx -> HClKeyEx <$> B.take l+		TFinished -> HFinished <$> B.take l+		_ -> HRaw t <$> B.take l++encodeH :: Handshake -> BS.ByteString+encodeH HHelloReq = encodeH $ HRaw THelloReq ""+encodeH (HClHello ch) = encodeH . HRaw TClHello $ B.encode ch+encodeH (HSvHello sh) = encodeH . HRaw TSvHello $ B.encode sh+encodeH (HCert crts) = encodeH . HRaw TCert $ B.encode crts+encodeH (HSvKeyEx ske) = encodeH $ HRaw TSvKeyEx ske+encodeH (HCertReq cr) = encodeH . HRaw TCertReq $ B.encode cr+encodeH HSHDone = encodeH $ HRaw TSHDone ""+encodeH (HCertVer ds) = encodeH . HRaw TCertVer $ B.encode ds+encodeH (HClKeyEx epms) = encodeH . HRaw TClKeyEx $ B.encode epms+encodeH (HFinished bs) = encodeH $ HRaw TFinished bs+encodeH (HRaw t bs) = B.encode t `BS.append` B.addLen w24 bs+encodeH HCCSpec = B.encode CCSpec++class HandshakeItem hi where+	fromHandshake :: Handshake -> Maybe hi; toHandshake :: hi -> Handshake++instance HandshakeItem Handshake where fromHandshake = Just; toHandshake = id++instance (HandshakeItem l, HandshakeItem r) => HandshakeItem (Either l r) where+	fromHandshake hs = let l = fromHandshake hs; r = fromHandshake hs in+		maybe (Right <$> r) (Just . Left) l+	toHandshake (Left l) = toHandshake l+	toHandshake (Right r) = toHandshake r++data CCSpec = CCSpec | CCSpecRaw Word8 deriving Show++instance HandshakeItem CCSpec where+	fromHandshake HCCSpec = Just CCSpec+	fromHandshake _ = Nothing+	toHandshake CCSpec = HCCSpec+	toHandshake (CCSpecRaw _) = error $ modNm ++ ": CCSpec.toHandshake"++instance B.Bytable CCSpec where+	decode bs = case BS.unpack bs of+		[1] -> Right CCSpec+		[w] -> Right $ CCSpecRaw w+		_ -> Left $ modNm ++ ": CCSpec.decode"+	encode CCSpec = BS.pack [1]+	encode (CCSpecRaw w) = BS.pack [w]++instance HandshakeItem ClHello where+	fromHandshake (HClHello ch) = Just ch+	fromHandshake _ = Nothing+	toHandshake = HClHello++instance HandshakeItem SvHello where+	fromHandshake (HSvHello sh) = Just sh+	fromHandshake _ = Nothing+	toHandshake = HSvHello++instance HandshakeItem X509.CertificateChain where+	fromHandshake (HCert cc) = Just cc+	fromHandshake _ = Nothing+	toHandshake = HCert++data SvKeyEx = SvKeyEx BS.ByteString BS.ByteString HashAlg SignAlg BS.ByteString+	deriving Show++instance HandshakeItem SvKeyEx where+	fromHandshake = undefined+	toHandshake = HSvKeyEx . B.encode++instance B.Bytable SvKeyEx where+	decode = undefined+	encode (SvKeyEx ps pv h s sn) = BS.concat [+		ps, pv, B.encode h, B.encode s, B.addLen w16 sn ]++data SvKeyExDhe = SvKeyExDhe DH.Params DH.PublicNumber HashAlg SignAlg BS.ByteString+	deriving Show++instance HandshakeItem SvKeyExDhe where+	fromHandshake (HSvKeyEx ske) = either (const Nothing) Just $ B.decode ske+	fromHandshake _ = Nothing+	toHandshake = HSvKeyEx . B.encode++instance B.Bytable SvKeyExDhe where+	encode (SvKeyExDhe ps pn h s sn) = BS.concat [+		B.encode ps, B.encode pn, B.encode h, B.encode s, B.addLen w16 sn ]+	decode = B.evalBytableM B.parse++instance B.Parsable SvKeyExDhe where+	parse = SvKeyExDhe <$> B.parse <*> B.parse+		<*> B.parse <*> B.parse <*> (B.take =<< B.take 2)++data SvKeyExEcdhe = SvKeyExEcdhe ECC.Curve ECC.Point HashAlg SignAlg BS.ByteString+	deriving Show++instance HandshakeItem SvKeyExEcdhe where+	fromHandshake (HSvKeyEx ske) = either (const Nothing) Just $ B.decode ske+	fromHandshake _ = Nothing+	toHandshake = HSvKeyEx . B.encode++instance B.Bytable SvKeyExEcdhe where+	encode (SvKeyExEcdhe cv pnt h s sn) = BS.concat [+		B.encode cv, B.encode pnt, B.encode h, B.encode s, B.addLen w16 sn ]+	decode = B.evalBytableM B.parse++instance B.Parsable SvKeyExEcdhe where+	parse = SvKeyExEcdhe <$> B.parse <*> B.parse+		<*> B.parse <*> B.parse <*> (B.take =<< B.take 2)++instance HandshakeItem CertReq where+	fromHandshake (HCertReq cr) = Just cr+	fromHandshake _ = Nothing+	toHandshake = HCertReq++data SHDone = SHDone deriving Show++instance HandshakeItem SHDone where+	fromHandshake HSHDone = Just SHDone+	fromHandshake _ = Nothing+	toHandshake _ = HSHDone++instance HandshakeItem DigitSigned where+	fromHandshake (HCertVer ds) = Just ds+	fromHandshake _ = Nothing+	toHandshake = HCertVer++instance HandshakeItem ClKeyEx where+	fromHandshake (HClKeyEx cke) = Just cke+	fromHandshake _ = Nothing+	toHandshake = HClKeyEx++data Epms = Epms BS.ByteString++instance HandshakeItem Epms where+	fromHandshake (HClKeyEx (ClKeyEx cke)) =+		case B.runBytableM (B.take =<< B.take 2) cke of+			Right (e, "") -> Just $ Epms e+			_ -> Nothing+	fromHandshake _ = Nothing+	toHandshake (Epms epms) = HClKeyEx . ClKeyEx $ B.addLen w16 epms++data Finished = Finished BS.ByteString deriving (Show, Eq)++instance HandshakeItem Finished where+	fromHandshake (HFinished f) = Just $ Finished f+	fromHandshake _ = Nothing+	toHandshake (Finished f) = HFinished f++data Type+	= THelloReq | TClHello | TSvHello  | TCert | TSvKeyEx | TCertReq | TSHDone+	| TCertVer  | TClKeyEx | TFinished | TRaw Word8 deriving Show++instance B.Bytable Type where+	decode bs = case BS.unpack bs of+		[0] -> Right THelloReq+		[1] -> Right TClHello+		[2] -> Right TSvHello+		[11] -> Right TCert+		[12] -> Right TSvKeyEx+		[13] -> Right TCertReq+		[14] -> Right TSHDone+		[15] -> Right TCertVer+		[16] -> Right TClKeyEx+		[20] -> Right TFinished+		[ht] -> Right $ TRaw ht+		_ -> Left $ modNm ++ ": Type.decode"+	encode THelloReq = BS.pack [0]+	encode TClHello = BS.pack [1]+	encode TSvHello = BS.pack [2]+	encode TCert = BS.pack [11]+	encode TSvKeyEx = BS.pack [12]+	encode TCertReq = BS.pack [13]+	encode TSHDone = BS.pack [14]+	encode TCertVer = BS.pack [15]+	encode TClKeyEx = BS.pack [16]+	encode TFinished = BS.pack [20]+	encode (TRaw w) = BS.pack [w]++w16 :: Word16; w16 = undefined+w24 :: Word24; w24 = undefined
+ src/Network/PeyoTLS/Codec/Certificate.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.PeyoTLS.Codec.Certificate (+	CertReq(..), certReq, ClCertType(..), ClKeyEx(..), DigitSigned(..)) where++import Control.Applicative ((<$>), (<*>))+import Data.Word (Word8, Word16)+import Data.Word.Word24 (Word24)++import qualified Data.ByteString as BS+import qualified Data.ASN1.Types as ASN1+import qualified Data.ASN1.Encoding as ASN1+import qualified Data.ASN1.BinaryEncoding as ASN1+import qualified Data.X509 as X509+import qualified Data.X509.CertificateStore as X509+import qualified Codec.Bytable.BigEndian as B++import Network.PeyoTLS.Codec.HSAlg (HashAlg, SignAlg)++modNm :: String+modNm = "Network.PeyoTLS.Codec.Certificate"++instance B.Bytable X509.CertificateChain where+	decode = B.evalBytableM B.parse+	encode = B.addLen w24 . cmap (B.addLen w24)+		. (\(X509.CertificateChainRaw c) -> c) . X509.encodeCertificateChain+		. (\(X509.CertificateChain cs) -> X509.CertificateChain cs)++instance B.Parsable X509.CertificateChain where+	parse = X509.decodeCertificateChain . X509.CertificateChainRaw <$>+			(flip B.list (B.take =<< B.take 3) =<< B.take 3) >>= \ecc ->+		case ecc of+			Right (X509.CertificateChain cs) ->+				return $ X509.CertificateChain cs+			Left (n, em) -> fail $ modNm ++ ": " +++				"X509.CertificateChain.parse" ++ show n ++ " " ++ em++data CertReq = CertReq [ClCertType] [(HashAlg, SignAlg)] [X509.DistinguishedName]+	deriving Show++certReq :: [ClCertType] -> [(HashAlg, SignAlg)] -> X509.CertificateStore -> CertReq+certReq t a = CertReq t a+	. map (X509.certIssuerDN . X509.signedObject . X509.getSigned)+	. X509.listCertificates++instance B.Bytable CertReq where+	encode (CertReq t a n) = BS.concat [+		B.addLen w8 $ cmap B.encode t,+		B.addLen w16 $+			cmap (\(h, s) -> B.encode h `BS.append` B.encode s) a,+		B.addLen w16 . flip cmap n $ B.addLen w16 .+			ASN1.encodeASN1' ASN1.DER . flip ASN1.toASN1 [] ]+	decode = B.evalBytableM $ CertReq+		<$> (flip B.list (B.take 1) =<< B.take 1)+		<*> (flip B.list ((,) <$> B.take 1 <*> B.take 1) =<< B.take 2)+		<*> ((B.take 2 >>=) . flip B.list $+			either (fail . show) (return . fst) . ASN1.fromASN1 =<<+			either (fail . show) return . ASN1.decodeASN1' ASN1.DER =<<+			B.take =<< B.take 2)++data ClCertType = CTRsaSign | CTEcdsaSign | CTRaw Word8 deriving (Show, Eq)++instance B.Bytable ClCertType where+	encode CTRsaSign = "\x01"+	encode CTEcdsaSign = "\x40"+	encode (CTRaw w) = BS.pack [w]+	decode bs = case BS.unpack bs of+		[w] -> Right $ case w of+			1 -> CTRsaSign; 64 -> CTEcdsaSign; _ -> CTRaw w+		_ -> Left $ modNm ++ ": ClCertType.decode"++data ClKeyEx = ClKeyEx BS.ByteString deriving Show+instance B.Bytable ClKeyEx where decode = Right . ClKeyEx; encode (ClKeyEx e) = e++data DigitSigned+	= DigitSigned (HashAlg, SignAlg) BS.ByteString+	| DigitSignedRaw BS.ByteString+	deriving Show++instance B.Bytable DigitSigned where+	decode = B.evalBytableM $ DigitSigned+		<$> ((,) <$> B.take 1 <*> B.take 1) <*> (B.take =<< B.take 2)+	encode (DigitSigned (ha, sa) bs) = BS.concat+		[B.encode ha, B.encode sa, B.addLen w16 bs]+	encode (DigitSignedRaw bs) = bs++cmap :: (a -> BS.ByteString) -> [a] -> BS.ByteString+cmap = (BS.concat .) . map++w8 :: Word8; w8 = undefined+w16 :: Word16; w16 = undefined+w24 :: Word24; w24 = undefined
+ src/Network/PeyoTLS/Codec/ContentTypes.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.PeyoTLS.Codec.ContentTypes (ContType(..), ProtocolVersion) where++import Data.Word++import qualified Data.ByteString as BS+import qualified Codec.Bytable.BigEndian as B++modNm :: String+modNm = "Network.PeyoTLS.Codec.ContentTypes"++-- RFC 5246 6.2.1+--+-- struct {+-- 	uint8 major;+-- 	uint8 minor;+-- } ProtocolVersion;+--+-- enum {+-- 	change_cipher_spec(20), alert(21), handshake(22),+-- 	application_data(23), (255)+-- } ContentType;++data ProtocolVersion = ProtocolVersion Word8 Word8 deriving (Show, Eq)++instance B.Bytable ProtocolVersion where+	encode (ProtocolVersion mj mn) = BS.pack [mj, mn]+	decode mjmn = case BS.unpack mjmn of+		[mj, mn] -> Right $ ProtocolVersion mj mn+		_ -> Left $ modNm ++ ": ProtocolVersion.decode"++data ContType = CTCCSpec | CTAlert | CTHandshake | CTAppData | CTNull | CTRaw Word8+	deriving (Show, Eq)++instance B.Bytable ContType where+	encode CTNull = BS.pack [0]+	encode CTCCSpec = BS.pack [20]+	encode CTAlert = BS.pack [21]+	encode CTHandshake = BS.pack [22]+	encode CTAppData = BS.pack [23]+	encode (CTRaw ct) = BS.pack [ct]+	decode "\0" = Right CTNull+	decode "\20" = Right CTCCSpec+	decode "\21" = Right CTAlert+	decode "\22" = Right CTHandshake+	decode "\23" = Right CTAppData+	decode bs | [ct] <- BS.unpack bs = Right $ CTRaw ct+	decode _ = Left $ modNm ++ ": ContType.decode"
+ src/Network/PeyoTLS/Codec/Extension.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.PeyoTLS.Codec.Extension (+	Extension(..), isRnInfo, emptyRnInfo, SignAlg(..), HashAlg(..) ) where++import Control.Applicative ((<$>), (<*>))+import Data.Bits (shiftL, (.|.))+import Data.Word (Word8, Word16)++import qualified Data.ByteString as BS+import qualified Codec.Bytable.BigEndian as B+import qualified Crypto.Types.PubKey.DH as DH+import qualified Crypto.Types.PubKey.ECC as ECC++import Network.PeyoTLS.Codec.HSAlg(HSAlg, HashAlg(..), SignAlg(..))++modNm :: String+modNm = "Network.PeyoTLS.Codec.Extension"++-- RFC 5246 7.4.1.4. Hello Wxtensions+--+-- struct {+-- 	ExtensionType extension_type;+-- 	opaque extension_data<0..2^16-1>;+-- } Extension;+--+-- enum {+-- 	signature_algorithms(13), (65535)+-- } ExtensionType++data Extension+	= ESName [SName]+	| EECrv [ECC.CurveName]     | EEPFrmt [EPFrmt]+	| ESAlg [HSAlg]       | ESsnTcktTls BS.ByteString+	| ENxPrtNego BS.ByteString  | ERnInfo BS.ByteString+	| ERaw EType BS.ByteString+	deriving (Show, Eq)++instance B.Bytable Extension where+	encode (ESName n) = B.encode . ERaw TSName . B.addLen w16 $ cmap B.encode n+	encode (EECrv c) = B.encode . ERaw TECrv . B.addLen w16 $ cmap B.encode c+	encode (EEPFrmt f) = B.encode . ERaw TEPFrmt . B.addLen w8 $ cmap B.encode f+	encode (ESAlg sa) = B.encode . ERaw TESAlg . B.addLen w16 $ cmap B.encode sa+	encode (ESsnTcktTls t) = B.encode $ ERaw TSsnTcktTls t+	encode (ENxPrtNego n) = B.encode $ ERaw TNxPrtNego n+	encode (ERnInfo i) = B.encode . ERaw TRnInfo $ B.addLen w8 i+	encode (ERaw t e) = B.encode t `BS.append` B.addLen w16 e+	decode = B.evalBytableM B.parse++instance B.Parsable Extension where+	parse = (,) <$> B.take 2 <*> B.take 2 >>= \(t, l) -> case t of+		TSName -> ESName <$> (flip B.list B.parse =<< B.take 2)+		TECrv -> EECrv <$> (flip B.list (B.take 2) =<< B.take 2)+		TEPFrmt -> EEPFrmt <$> (flip B.list (B.take 1) =<< B.take 1)+		TESAlg -> ESAlg <$> (flip B.list (B.take 2) =<< B.take 2)+		TSsnTcktTls -> ESsnTcktTls <$> B.take l+		TNxPrtNego -> ENxPrtNego <$> B.take l+		TRnInfo -> ERnInfo <$> (B.take =<< B.take 1)+		_ -> ERaw t <$> B.take l++cmap :: (a -> BS.ByteString) -> [a] -> BS.ByteString+cmap = (BS.concat .) . map++data EType+	= TSName     | TECrv   | TEPFrmt | TESAlg | TSsnTcktTls+	| TNxPrtNego | TRnInfo | TRaw Word16 deriving (Show, Eq)++instance B.Bytable EType where+	encode TSName = B.encode (0 :: Word16)+	encode TECrv = B.encode (10 :: Word16)+	encode TEPFrmt = B.encode (11 :: Word16)+	encode TESAlg = B.encode (13 :: Word16)+	encode TSsnTcktTls = B.encode (35 :: Word16)+	encode TNxPrtNego = B.encode (13172 :: Word16)+	encode TRnInfo = B.encode (65281 :: Word16)+	encode (TRaw et) = B.encode et+	decode bs = case BS.unpack bs of+		[w1, w2] -> Right $+			case fromIntegral w1 `shiftL` 8 .|. fromIntegral w2 of+				0 -> TSName+				10 -> TECrv+				11 -> TEPFrmt+				13 -> TESAlg+				35 -> TSsnTcktTls+				13172 -> TNxPrtNego+				65281 -> TRnInfo+				et -> TRaw et+		_ -> Left $ modNm ++ ": EType.decode"++data SName = SNHName BS.ByteString | SNRaw NType BS.ByteString deriving (Show, Eq)++instance B.Bytable SName where+	encode (SNHName nm) = B.encode $ SNRaw NTHName nm+	encode (SNRaw nt nm) = B.encode nt `BS.append` B.addLen w16 nm+	decode = B.evalBytableM B.parse++instance B.Parsable SName where+	parse = (\t n -> case t of NTHName -> SNHName n; _ -> SNRaw t n)+		<$> B.take 1 <*> (B.take =<< B.take 2)++data NType = NTHName | NTRaw Word8 deriving (Show, Eq)++instance B.Bytable NType where+	encode NTHName = BS.pack [0]+	encode (NTRaw t) = BS.pack [t]+	decode bs = case BS.unpack bs of+		[t] -> Right $ case t of 0 -> NTHName; _ -> NTRaw t+		_ -> Left $ modNm ++ ": NType.decode"++instance B.Bytable DH.Params where+	encode (DH.Params p g) = BS.concat+		[B.addLen w16 $ B.encode p, B.addLen w16 $ B.encode g]+	decode = B.evalBytableM B.parse++instance B.Parsable DH.Params where+	parse = DH.Params <$> (B.take =<< B.take 2) <*> (B.take =<< B.take 2)++instance B.Bytable DH.PublicNumber where+	encode = B.addLen w16 . B.encode . \(DH.PublicNumber pn) -> pn+	decode = B.evalBytableM B.parse++instance B.Parsable DH.PublicNumber where+	parse = fromInteger <$> (B.take =<< B.take 2)++data ECType = ExpPrm | ExpCh2 | NmdCrv | CRaw Word8 deriving Show++instance B.Bytable ECType where+	encode ExpPrm = BS.pack [1]+	encode ExpCh2 = BS.pack [2]+	encode NmdCrv = BS.pack [3]+	encode (CRaw w) = BS.pack [w]+	decode = B.evalBytableM B.parse++instance B.Parsable ECType where+	parse = (\t -> case t of 1 -> ExpPrm; 2 -> ExpCh2; 3 -> NmdCrv; _ -> CRaw t)+		<$> B.head++instance B.Bytable ECC.CurveName where+	encode ECC.SEC_t163k1 = B.encode (1 :: Word16)+	encode ECC.SEC_t163r1 = B.encode (2 :: Word16)+	encode ECC.SEC_t163r2 = B.encode (3 :: Word16)+	encode ECC.SEC_t193r1 = B.encode (4 :: Word16)+	encode ECC.SEC_t193r2 = B.encode (5 :: Word16)+	encode ECC.SEC_t233k1 = B.encode (6 :: Word16)+	encode ECC.SEC_t233r1 = B.encode (7 :: Word16)+	encode ECC.SEC_t239k1 = B.encode (8 :: Word16)+	encode ECC.SEC_t283k1 = B.encode (9 :: Word16)+	encode ECC.SEC_t283r1 = B.encode (10 :: Word16)+	encode ECC.SEC_t409k1 = B.encode (11 :: Word16)+	encode ECC.SEC_t409r1 = B.encode (12 :: Word16)+	encode ECC.SEC_t571k1 = B.encode (13 :: Word16)+	encode ECC.SEC_t571r1 = B.encode (14 :: Word16)+	encode ECC.SEC_p160k1 = B.encode (15 :: Word16)+	encode ECC.SEC_p160r1 = B.encode (16 :: Word16)+	encode ECC.SEC_p160r2 = B.encode (17 :: Word16)+	encode ECC.SEC_p192k1 = B.encode (18 :: Word16)+	encode ECC.SEC_p192r1 = B.encode (19 :: Word16)+	encode ECC.SEC_p224k1 = B.encode (20 :: Word16)+	encode ECC.SEC_p224r1 = B.encode (21 :: Word16)+	encode ECC.SEC_p256k1 = B.encode (22 :: Word16)+	encode ECC.SEC_p256r1 = B.encode (23 :: Word16)+	encode ECC.SEC_p384r1 = B.encode (24 :: Word16)+	encode ECC.SEC_p521r1 = B.encode (25 :: Word16)+	encode _ = error "Extension.encodeCN: not implemented"+	decode bs = case BS.unpack bs of+		[w1, w2] -> case fromIntegral w1 `shiftL` 8 .|. fromIntegral w2 of+			(1 :: Word16) -> Right ECC.SEC_t163k1+			(2 :: Word16) -> Right ECC.SEC_t163r1+			(3 :: Word16) -> Right ECC.SEC_t163r2+			(4 :: Word16) -> Right ECC.SEC_t193r1+			(5 :: Word16) -> Right ECC.SEC_t193r2+			(6 :: Word16) -> Right ECC.SEC_t233k1+			(7 :: Word16) -> Right ECC.SEC_t233r1+			(8 :: Word16) -> Right ECC.SEC_t239k1+			(9 :: Word16) -> Right ECC.SEC_t283k1+			(10 :: Word16) -> Right ECC.SEC_t283r1+			(11 :: Word16) -> Right ECC.SEC_t409k1+			(12 :: Word16) -> Right ECC.SEC_t409r1+			(13 :: Word16) -> Right ECC.SEC_t571k1+			(14 :: Word16) -> Right ECC.SEC_t571r1+			(15 :: Word16) -> Right ECC.SEC_p160k1+			(16 :: Word16) -> Right ECC.SEC_p160r1+			(17 :: Word16) -> Right ECC.SEC_p160r2+			(18 :: Word16) -> Right ECC.SEC_p192k1+			(19 :: Word16) -> Right ECC.SEC_p192r1+			(20 :: Word16) -> Right ECC.SEC_p224k1+			(21 :: Word16) -> Right ECC.SEC_p224r1+			(22 :: Word16) -> Right ECC.SEC_p256k1+			(23 :: Word16) -> Right ECC.SEC_p256r1+			(24 :: Word16) -> Right ECC.SEC_p384r1+			(25 :: Word16) -> Right ECC.SEC_p521r1+			n -> Left $ modNm ++ ": CurveName.decode: unknown crv: " +++				show n+		_ -> Left $ modNm ++ ": CurveName.decode: bad format"++instance B.Parsable ECC.CurveName where parse = B.take 2++instance B.Bytable ECC.Curve where+	encode c+		| c == ECC.getCurveByName ECC.SEC_p256r1 =+			B.encode NmdCrv `BS.append` B.encode ECC.SEC_p256r1+		| c == ECC.getCurveByName ECC.SEC_p384r1 =+			B.encode NmdCrv `BS.append` B.encode ECC.SEC_p384r1+		| c == ECC.getCurveByName ECC.SEC_p521r1 =+			B.encode NmdCrv `BS.append` B.encode ECC.SEC_p521r1+		| otherwise = error $ modNm ++ ": ECC.Curve.encode: not implemented"+	decode = B.evalBytableM B.parse++instance B.Parsable ECC.Curve where+	parse = (ECC.getCurveByName <$>) $ B.parse >>= \t -> case t of+		NmdCrv -> B.parse+		_ -> error $ modNm ++ ": ECC.Curve.parse: not implemented"++data EPFrmt = EPFUncomp | EPFRaw Word8 deriving (Show, Eq)++instance B.Bytable EPFrmt where+	encode EPFUncomp = BS.pack [0]+	encode (EPFRaw f) = BS.pack [f]+	decode bs = case BS.unpack bs of+		[f] -> Right $ case f of 0 -> EPFUncomp; _ -> EPFRaw f+		_ -> Left $ modNm ++ ": Bytable.decode"++instance B.Bytable ECC.Point where+	encode (ECC.Point x y) = B.addLen w8 $+		4 `BS.cons` pad 32 0 (B.encode x) `BS.append` pad 32 0 (B.encode y)+		where pad n w s = BS.replicate (n - BS.length s) w `BS.append` s+	encode ECC.PointO = error $ modNm ++ ": EC.Point.encode"+	decode = B.evalBytableM B.parse++instance B.Parsable ECC.Point where+	parse = (B.take =<< B.take 1) >>= \bs -> case BS.uncons bs of+		Just (4, xy) -> return $ let (x, y) = BS.splitAt 32 xy in ECC.Point+			(either error id $ B.decode x)+			(either error id $ B.decode y)+		_ -> fail $ modNm ++ ": ECC.Point.parse"++isRnInfo :: Extension -> Bool+isRnInfo (ERnInfo _) = True+isRnInfo _ = False++emptyRnInfo :: Extension+emptyRnInfo = ERnInfo ""++w8 :: Word8; w8 = undefined+w16 :: Word16; w16 = undefined
+ src/Network/PeyoTLS/Codec/HSAlg.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.PeyoTLS.Codec.HSAlg (HSAlg, SignAlg(..), HashAlg(..)) where++import Control.Applicative+import Data.Word (Word8)++import qualified Data.ByteString as BS+import qualified Codec.Bytable.BigEndian as B++modNm :: String+modNm = "Network.PeyoTLS.Codec.HSAlg"++-- RFC 5246 7.4.1.4.1.+--+-- struct {+-- 	HashAlgorithm hash;+-- 	SignatureAlgorithm signature;+-- } SignatureAndHashAlgorithm;++data HSAlg = HSAlg HashAlg SignAlg deriving (Show, Eq)++instance B.Bytable HSAlg where+	encode (HSAlg ha sa) = B.encode ha `BS.append` B.encode sa+	decode hasa = let (ha, sa) = BS.splitAt 1 hasa in+		HSAlg <$> B.decode ha <*> B.decode sa++-- RFC 5246 7.4.1.4.1.+--+-- enum {+-- 	none(0), md5(1), sha1(2), sha224(3), sha256(4), sha384(5),+-- 	sha512(6), (255)+-- } HashAlgorithm;++data HashAlg+	= HNone | Md5 | Sha1 | Sha224 | Sha256 | Sha384 | Sha512+	| HARaw Word8+	deriving (Show, Eq)++instance B.Bytable HashAlg where+	encode HNone  = "\x00"+	encode Md5    = "\x01"+	encode Sha1   = "\x02"+	encode Sha224 = "\x03"+	encode Sha256 = "\x04"+	encode Sha384 = "\x05"+	encode Sha512 = "\x06"+	encode (HARaw w) = BS.pack [w]+	decode bs = case BS.unpack bs of+		[ha] -> Right $ case ha of+			0 -> HNone ; 1 -> Md5+			2 -> Sha1  ; 3 -> Sha224; 4 -> Sha256+			5 -> Sha384; 6 -> Sha512; _ -> HARaw ha+		_ -> Left $ modNm ++ ": HashAlg.decode"+instance B.Parsable HashAlg where parse = B.take 1++-- RFC 5246 7.4.1.4.1.+--+-- enum { anonymous(0), rsa(1), dsa(2), ecdsa(3), (255) }++data SignAlg = SAnon | Rsa | Dsa | Ecdsa | SARaw Word8 deriving (Show, Eq)++instance B.Bytable SignAlg where+	encode SAnon = "\x00"+	encode Rsa = "\x01"+	encode Dsa = "\x02"+	encode Ecdsa = "\x03"+	encode (SARaw w) = BS.pack [w]+	decode bs = case BS.unpack bs of+		[sa] -> Right $ case sa of+			0 -> SAnon+			1 -> Rsa; 2 -> Dsa; 3 -> Ecdsa; _ -> SARaw sa+		_ -> Left $ modNm ++ ": SignAlg.decode"+instance B.Parsable SignAlg where parse = B.take 1
+ src/Network/PeyoTLS/Codec/Hello.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.PeyoTLS.Codec.Hello (+	ClHello(..), SvHello(..), SssnId(..),+		CipherSuite(..), KeyEx(..), BulkEnc(..),+		CmpMtd(..), SignAlg(..), HashAlg(..),+		Extension(..), isRnInfo, emptyRnInfo ) where++import Control.Applicative ((<$>), (<*>))+import Data.Word (Word8, Word16)++import qualified Data.ByteString as BS+import qualified Codec.Bytable.BigEndian as B++import Network.PeyoTLS.Codec.Extension (+	Extension(..), isRnInfo, emptyRnInfo, SignAlg(..), HashAlg(..) )+import Network.PeyoTLS.CipherSuite (CipherSuite(..), KeyEx(..), BulkEnc(..))++modNm :: String+modNm = "Network.PeyoTLS.Codec.Hello"++-- RFC 5246 7.4.1.2. Client Hello+--+-- struct {+-- 	uint32 gmt_unix_time;+-- 	opaque random_bytes[28];+-- } Random+--+-- opaque SessionID<0..32>;+--+-- uint8 CipherSuite[2];+--+-- enum { null(0), (255) } CompressionMethod;+--+-- struct {+-- 	ProtocolVersion client_version;+-- 	Random random;+-- 	SessionID session_id;+-- 	CipherSuite cipher_suites<2..2^16-2>;+-- 	CompressionMethod compression_methods<1..2^8-1>;+-- 	select (extensions_present) {+-- 		case false:	struct {};+-- 		case true:	Extension extensions<0..2^16-1>;+-- 	};+-- } ClientHello;++data ClHello+	= ClHello (Word8, Word8) BS.ByteString SssnId [CipherSuite] [CmpMtd]+		(Maybe [Extension])+	| ClHelloRaw BS.ByteString+	deriving Show++instance B.Bytable ClHello where+	decode = B.evalBytableM $ ClHello+		<$> ((,) <$> B.head <*> B.head)+		<*> B.take 32 <*> (B.take =<< B.take 1)+		<*> (flip B.list (B.take 2) =<< B.take 2)+		<*> (flip B.list (B.take 1) =<< B.take 1)+		<*> do	nl <- B.null+			if nl then return Nothing else Just <$>+				(flip B.list B.parse =<< B.take 2)+	encode (ClHello (vj, vn) r sid css cms mel) = BS.concat [+		B.encode vj, B.encode vn, B.encode r, B.addLen w8 $ B.encode sid,+		B.addLen w16 . BS.concat $ map B.encode css,+		B.addLen w8 . BS.concat $ map B.encode cms,+		maybe "" (B.addLen w16 . BS.concat . map B.encode) mel ]+	encode (ClHelloRaw bs) = bs++-- RFC 5246 7.4.1.3. Server Hello+--+-- struct {+-- 	ProtocolVersion server_version;+-- 	Random random;+-- 	SessionID session_id;+-- 	CipherSuite cipher_suite;+-- 	CompressionMethod compression_method;+-- 	select (extensions_present) {+-- 		case false: struct {};+-- 		case true: Extension extensions<0..2^16-1>;+-- 	};+-- } ServerHello;++data SvHello+	= SvHello (Word8, Word8) BS.ByteString SssnId CipherSuite CmpMtd+		(Maybe [Extension])+	| SvHelloRaw BS.ByteString+	deriving Show++instance B.Bytable SvHello where+	decode = B.evalBytableM $ SvHello+		<$> ((,) <$> B.head <*> B.head)+		<*> B.take 32 <*> (B.take =<< B.take 1) <*> B.take 2 <*> B.take 1+		<*> do	n <- B.null+			if n then return Nothing else Just <$>+				(flip B.list B.parse =<< B.take 2)+	encode (SvHello (vj, vn) r sid cs cm mes) = BS.concat [+		B.encode vj, B.encode vn, B.encode r, B.addLen w8 $ B.encode sid,+		B.encode cs, B.encode cm,+		maybe "" (B.addLen w16 . BS.concat . map B.encode) mes ]+	encode (SvHelloRaw sh) = sh++data SssnId = SssnId BS.ByteString deriving Show++instance B.Bytable SssnId where decode = Right . SssnId; encode (SssnId bs) = bs++data CmpMtd = CmpMtdNull | CmpMtdRaw Word8 deriving (Show, Eq)++instance B.Bytable CmpMtd where+	decode bs = case BS.unpack bs of+		[cm] -> Right $ case cm of 0 -> CmpMtdNull; _ -> CmpMtdRaw cm+		_ -> Left $ modNm ++ ": CmpMtd.decode"+	encode CmpMtdNull = "\0"+	encode (CmpMtdRaw cm) = BS.pack [cm]++w8 :: Word8; w8 = undefined+w16 :: Word16; w16 = undefined