haskell-tor 0.1.1 → 0.1.2
raw patch · 13 files changed
+657/−53 lines, 13 filesdep ~cryptonitedep ~memory
Dependency ranges changed: cryptonite, memory
Files
- haskell-tor.cabal +13/−8
- src/Data/Hourglass/Now.hs +0/−18
- src/Tor/Circuit.hs +25/−11
- src/Tor/DataFormat/RouterDesc.hs +13/−2
- src/Tor/Link.hs +5/−5
- src/Tor/Options.hs +2/−2
- src/Tor/State/Credentials.hs +15/−5
- src/Tor/State/Routers.hs +2/−2
- test/Test/CipherSuite.hs +76/−0
- test/Test/Handshakes.hs +97/−0
- test/Test/HybridEncrypt.hs +52/−0
- test/Test/Standard.hs +29/−0
- test/Test/TorCell.hs +328/−0
haskell-tor.cabal view
@@ -1,5 +1,5 @@ name: haskell-tor-version: 0.1.1+version: 0.1.2 synopsis: A Haskell Tor Node description: An implementation of the Tor anonymity system in Haskell. The core functionality is exported both as an application@@ -49,10 +49,10 @@ bytestring >= 0.10 && < 0.11, cereal >= 0.4 && < 0.6, containers >= 0.5 && < 0.7,- cryptonite >= 0.6 && < 0.8,+ cryptonite >= 0.6 && < 0.10, fingertree >= 0.1 && < 0.3, hourglass >= 0.2.9 && < 0.4,- memory >= 0.7 && < 0.9,+ memory >= 0.7 && < 0.11, monadLib >= 3.7 && < 3.9, pretty-hex >= 1.0 && < 1.2, pure-zlib >= 0.4 && < 0.5,@@ -67,7 +67,6 @@ Paths_haskell_tor exposed-modules:- Data.Hourglass.Now, Tor, Tor.Circuit, Tor.DataFormat.Consensus,@@ -113,10 +112,10 @@ base >= 4.7 && < 5.0, base64-bytestring >= 1.0 && < 1.2, bytestring >= 0.10 && < 0.11,- cryptonite >= 0.6 && < 0.8,+ cryptonite >= 0.6 && < 0.10, haskell-tor >= 0.1 && < 0.3, hourglass >= 0.2.9 && < 0.4,- memory >= 0.7 && < 0.9,+ memory >= 0.7 && < 0.11, time >= 1.4 && < 1.6, tls >= 1.3.2 && < 1.5, x509 >= 1.6 && < 1.8@@ -137,18 +136,24 @@ hs-source-dirs: test default-language: Haskell2010 other-extensions: CPP, FlexibleInstances, TypeSynonymInstances+ other-modules:+ Test.CipherSuite,+ Test.Handshakes,+ Test.HybridEncrypt,+ Test.Standard,+ Test.TorCell ghc-options: -fno-warn-orphans build-depends: asn1-types >= 0.2 && < 0.4, base >= 4.7 && < 5.0, binary >= 0.7 && < 0.9, bytestring >= 0.10 && < 0.11,- cryptonite >= 0.6 && < 0.8,+ cryptonite >= 0.6 && < 0.10, haskell-tor >= 0.1 && < 0.3, hourglass >= 0.2.9 && < 0.4, HUnit >= 1.2 && < 1.4, QuickCheck >= 2.7 && < 2.9,- memory >= 0.7 && < 0.9,+ memory >= 0.7 && < 0.11, pretty-hex >= 1.0 && < 1.4, test-framework >= 0.8 && < 0.10, test-framework-hunit >= 0.3 && < 0.5,
− src/Data/Hourglass/Now.hs
@@ -1,18 +0,0 @@--- |A helper module, which will likely evenutally be removable.-{-# LANGUAGE RecordWildCards #-}-module Data.Hourglass.Now(getCurrentTime)- where--import Data.Hourglass-import Data.Hourglass.Compat-import qualified Data.Time as T---- |Fetch the current date, and return it as a DateTime.-getCurrentTime :: IO DateTime-getCurrentTime =- do now <- T.getCurrentTime- let dtDate = dateFromTAIEpoch (T.toModifiedJulianDay (T.utctDay now))- dtTime = diffTimeToTimeOfDay (T.utctDayTime now)- return DateTime{..}--
src/Tor/Circuit.hs view
@@ -949,14 +949,14 @@ (g0, Left "Called advance, but I don't support NTor handshakes.") | (nodeid /= routerFingerprint me) || (Just bigB /= routerNTorOnionKey me) = (g0, Left "Called advance, but their fingerprint doesn't match me.")- | Left err <- publicKey keyid =+ | Left err <- toEither (publicKey keyid) = (g0, Left ("Couldn't decode bigX in advance: " ++ err)) | otherwise = (g1, Right (msg,fenc,benc)) where (nodeid, bstr1) = S.splitAt 20 bstr0 (keyid, xpub) = S.splitAt 32 bstr1- Right bigB = publicKey keyid- Right bigX = publicKey xpub+ Right bigB = toEither (publicKey keyid)+ Right bigX = toEither (publicKey xpub) ((bigY, littleY), g1) = withDRG g0 generate25519 secret_input = S.concat [curveExp bigX littleY, curveExp bigX littleB,@@ -977,17 +977,22 @@ completeNTorHandshake :: RouterDesc -> Curve25519Pair -> ByteString -> Either String (CryptoData, CryptoData) completeNTorHandshake router (bigX, littleX) bstr- | Nothing <- routerNTorOnionKey router = Left "Internal error complete/ntor"- | Left err <- publicKey public_pk = Left ("Couldn't decode bigY: "++err)- | Left err <- publicKey server_ntorid = Left ("Couldn't decode bigB: "++err)- | auth /= auth' = Left "Authorization failure"- | otherwise = Right res+ | Nothing <- routerNTorOnionKey router =+ Left "Internal error complete/ntor"+ | Left err <- toEither (publicKey public_pk) =+ Left ("Couldn't decode bigY: "++err)+ | Left err <- toEither (publicKey server_ntorid) =+ Left ("Couldn't decode bigB: "++err)+ | auth /= auth' =+ Left "Authorization failure"+ | otherwise =+ Right res where nodeid = routerFingerprint router (public_pk, auth) = S.splitAt 32 bstr Just server_ntorid = routerNTorOnionKey router- Right bigY = publicKey public_pk- Right bigB = publicKey server_ntorid+ Right bigY = toEither (publicKey public_pk)+ Right bigB = toEither (publicKey server_ntorid) secret_input = S.concat [curveExp bigY littleX, curveExp bigB littleX, nodeid, convert bigB, convert bigX, convert bigY, protoid]@@ -1008,7 +1013,7 @@ generate25519 :: MonadRandom m => m Curve25519Pair generate25519 = do bytes <- getRandomBytes 32- case secretKey (bytes :: ByteString) of+ case toEither (secretKey (bytes :: ByteString)) of Left err -> fail ("Couldn't convert to a secret key: " ++ show err) Right privKey ->@@ -1062,3 +1067,12 @@ modifyMVar_' :: MVar a -> (a -> a) -> IO () modifyMVar_' mv f = modifyMVar_ mv (return . f)++#if MIN_VERSION_cryptonite(0,9,0)+toEither :: CryptoFailable a -> Either String a+toEither (CryptoPassed x) = Right x+toEither (CryptoFailed e) = Left (show e)+#else+toEither :: Either String a -> Either String a+toEither = id+#endif
src/Tor/DataFormat/RouterDesc.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -- |Routines for parsing router descriptions from a directory listing. module Tor.DataFormat.RouterDesc(@@ -7,6 +8,9 @@ where import Control.Applicative+#if MIN_VERSION_cryptonite(0,9,0)+import Crypto.Error+#endif import Crypto.Hash.Easy import qualified Crypto.PubKey.Curve25519 as Curve import Crypto.PubKey.RSA.PKCS15@@ -307,9 +311,16 @@ do _ <- string "ntor-onion-key" _ <- whitespace x <- decodeBase64 =<< manyTill base64Char newline- case Curve.publicKey x of+ case toEither (Curve.publicKey x) of Left err -> fail ("Failure decoding curve25519 public key: " ++ err) Right k -> return r{ routerNTorOnionKey = Just k }+ where+#if MIN_VERSION_cryptonite(0,9,0)+ toEither (CryptoPassed x) = Right x+ toEither (CryptoFailed e) = Left (show e)+#else+ toEither = id+#endif signingKey :: RouterDesc -> Parser RouterDesc signingKey r =
src/Tor/Link.hs view
@@ -35,7 +35,6 @@ import qualified Data.ByteString.Lazy as BSL import Data.ByteString.Char8(pack) import Data.Hourglass-import Data.Hourglass.Now import Data.IORef import Data.Map.Strict(Map) import qualified Data.Map.Strict as Map@@ -49,6 +48,7 @@ import Data.X509.CertificateStore import Network.TLS hiding (Credentials) import qualified Network.TLS as TLS+import System.Hourglass import Tor.DataFormat.RelayCell import Tor.DataFormat.TorAddress import Tor.DataFormat.TorCell@@ -109,7 +109,7 @@ RouterDesc -> IO TorLink initLink ns creds rngMV llog them =- do now <- getCurrentTime+ do now <- dateCurrent let validity = (now, now `timeAdd` mempty{ durationHours = 2 }) (idCert, idKey) <- getSigningKey creds (authPriv, authCert) <- modifyMVar rngMV@@ -246,7 +246,7 @@ idCert' = signedObject (getSigned idCert) -- * Both certificates have validAfter and validUntil dates that -- are not expired.- now <- getCurrentTime+ now <- dateCurrent when (certExpired linkCert' now) $ fail "Link certificate expired." when (certExpired idCert' now) $ fail "Identity certificate expired." -- * The certified key in the Link certificate matches the link key@@ -446,7 +446,7 @@ s -> TorAddress -> IO TorLink acceptLink creds routerDB rngMV llog sock who =- do now <- getCurrentTime+ do now <- dateCurrent let validity = (now, now `timeAdd` mempty{ durationHours = 2 }) (idCert, idKey) <- getSigningKey creds let idCert' = signedObject (getSigned idCert)@@ -473,7 +473,7 @@ sendData tls authcbstr -- "... and a NETINFO cell (4.5) " others <- getAddresses creds- epochsec <- (fromElapsed . timeGetElapsed) <$> getCurrentTime+ epochsec <- fromElapsed <$> timeCurrent sendData tls (putCell (NetInfo epochsec who others)) -- "At this point the initiator may send a NETINFO cell if it does not -- wish to authenticate, or a CERTS cell, an AUTHENTICATE cell, and a
src/Tor/Options.hs view
@@ -12,8 +12,8 @@ where import Data.Hourglass-import Data.Hourglass.Now import Data.Word+import System.Hourglass import Tor.RouterDesc -- |How the node should be set up during initialization. For each of these@@ -132,7 +132,7 @@ -- NOTE: The default value for the logger is (makeLogger putStrLn). makeLogger :: (String -> IO ()) -> String -> IO () makeLogger out msg =- do now <- getCurrentTime+ do now <- dateCurrent out (timePrint timeFormat now ++ msg) where timeFormat = [Format_Text '[', Format_Year4, Format_Text '-', Format_Month2,
src/Tor/State/Credentials.hs view
@@ -1,4 +1,5 @@ -- |Credential management for a Tor node.+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Tor.State.Credentials(@@ -18,6 +19,9 @@ where import Control.Concurrent+#if MIN_VERSION_cryptonite(0,9,0)+import Crypto.Error+#endif import Crypto.Hash import Crypto.Hash.Easy import Crypto.PubKey.Curve25519 as Curve@@ -28,7 +32,6 @@ import Data.ASN1.OID import Data.ByteString(ByteString) import Data.Hourglass-import Data.Hourglass.Now #if MIN_VERSION_base(4,8,0) import Data.List(sortOn) #else@@ -43,6 +46,7 @@ import Data.Word import Data.X509 import Hexdump+import System.Hourglass import Tor.DataFormat.TorAddress import Tor.Options import Tor.RNG@@ -68,7 +72,7 @@ newCredentials :: TorOptions -> IO Credentials newCredentials opts = do g <- drgNew- now <- getCurrentTime+ now <- dateCurrent let s = generateState g opts now creds <- Credentials `fmap` newMVar s logMsg "Credentials created."@@ -100,7 +104,7 @@ getCredentials :: (CredentialState -> a) -> Credentials -> IO a getCredentials getter (Credentials stateMV) = do state <- takeMVar stateMV- now <- getCurrentTime+ now <- dateCurrent let state' = updateKeys state now putMVar stateMV $! state' return (getter state')@@ -125,7 +129,7 @@ (signCert, _) = credIdentity state PubKeyRSA signkey = certPubKey (signedObject (getSigned signCert)) (ntorkey, _) = credOnionNTor state- now <- getCurrentTime+ now <- dateCurrent return (credBaseDesc state) { routerIPv4Address = ip4addr , routerFingerprint = keyHash' sha1 signkey@@ -219,11 +223,17 @@ -- findKey rng = let (bytes, rng') = withRandomBytes rng 32 id- in case secretKey (bytes :: ByteString) of+ in case toEither (secretKey (bytes :: ByteString)) of Left _ -> findKey rng' Right privkey -> (privkey, rng') (privntor, g'') = findKey g' pubntor = toPublic privntor+#if MIN_VERSION_cryptonite(0,9,0)+ toEither (CryptoPassed x) = Right x+ toEither (CryptoFailed e) = Left (show e)+#else+ toEither = id+#endif -- state' = state{ credRNG = g'', credNextSerialNum = serial + 1 , credOnion = (cert, PrivKeyRSA priv)
src/Tor/State/Routers.hs view
@@ -26,7 +26,6 @@ import Data.Serialize.Get import Data.ByteString(ByteString,unpack) import Data.Hourglass-import Data.Hourglass.Now import Data.List #if !MIN_VERSION_base(4,8,0) hiding (find)@@ -35,6 +34,7 @@ import Data.Maybe import Data.Word import MonadLib+import System.Hourglass import Tor.DataFormat.Consensus import Tor.DataFormat.RelayCell import Tor.DataFormat.TorAddress@@ -314,7 +314,7 @@ waitUntil :: DateTime -> IO () waitUntil time =- do now <- getCurrentTime+ do now <- dateCurrent if now > time then return () else do threadDelay 100000 -- (5 * 60 * 1000000) -- 5 minutes
+ test/Test/CipherSuite.hs view
@@ -0,0 +1,76 @@+module Test.CipherSuite(cipherSuiteTests) where++import Data.List+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Test.HUnit(assertEqual)+import Test.Standard+import TLS.CipherSuite++instance Arbitrary CipherSuite where+ arbitrary = elements rfc5246CipherSuites++prop_CipherSerial :: CipherSuite -> Bool+prop_CipherSerial = serialProp (getCipherSuite rfc5246CipherSuites)+ putCipherSuite++-- these were copied and reworked by vim rather than manually copied, like+-- the lists above, and so should be a bit more reliable for cross-checking+-- that I typed things in correctly.+cipherSuiteTests :: Test+cipherSuiteTests =+ testGroup "CipherSuite tests" [+ testProperty "CipherSuite serializes" prop_CipherSerial+ , testGroup "CipherSuite ID checks" [+ checkIdentifier 0x00 0x00 "TLS_NULL_WITH_NULL_NULL"+ , checkIdentifier 0x00 0x01 "TLS_RSA_WITH_NULL_MD5"+ , checkIdentifier 0x00 0x02 "TLS_RSA_WITH_NULL_SHA"+ , checkIdentifier 0x00 0x3B "TLS_RSA_WITH_NULL_SHA256"+ , checkIdentifier 0x00 0x04 "TLS_RSA_WITH_RC4_128_MD5"+ , checkIdentifier 0x00 0x05 "TLS_RSA_WITH_RC4_128_SHA"+ , checkIdentifier 0x00 0x0A "TLS_RSA_WITH_3DES_EDE_CBC_SHA"+ , checkIdentifier 0x00 0x2F "TLS_RSA_WITH_AES_128_CBC_SHA"+ , checkIdentifier 0x00 0x35 "TLS_RSA_WITH_AES_256_CBC_SHA"+ , checkIdentifier 0x00 0x3C "TLS_RSA_WITH_AES_128_CBC_SHA256"+ , checkIdentifier 0x00 0x3D "TLS_RSA_WITH_AES_256_CBC_SHA256"+ , checkIdentifier 0x00 0x0D "TLS_DH_DSS_WITH_3DES_EDE_CBC_SHA"+ , checkIdentifier 0x00 0x10 "TLS_DH_RSA_WITH_3DES_EDE_CBC_SHA"+ , checkIdentifier 0x00 0x13 "TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA"+ , checkIdentifier 0x00 0x16 "TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA"+ , checkIdentifier 0x00 0x30 "TLS_DH_DSS_WITH_AES_128_CBC_SHA"+ , checkIdentifier 0x00 0x31 "TLS_DH_RSA_WITH_AES_128_CBC_SHA"+ , checkIdentifier 0x00 0x32 "TLS_DHE_DSS_WITH_AES_128_CBC_SHA"+ , checkIdentifier 0x00 0x33 "TLS_DHE_RSA_WITH_AES_128_CBC_SHA"+ , checkIdentifier 0x00 0x36 "TLS_DH_DSS_WITH_AES_256_CBC_SHA"+ , checkIdentifier 0x00 0x37 "TLS_DH_RSA_WITH_AES_256_CBC_SHA"+ , checkIdentifier 0x00 0x38 "TLS_DHE_DSS_WITH_AES_256_CBC_SHA"+ , checkIdentifier 0x00 0x39 "TLS_DHE_RSA_WITH_AES_256_CBC_SHA"+ , checkIdentifier 0x00 0x3E "TLS_DH_DSS_WITH_AES_128_CBC_SHA256"+ , checkIdentifier 0x00 0x3F "TLS_DH_RSA_WITH_AES_128_CBC_SHA256"+ , checkIdentifier 0x00 0x40 "TLS_DHE_DSS_WITH_AES_128_CBC_SHA256"+ , checkIdentifier 0x00 0x67 "TLS_DHE_RSA_WITH_AES_128_CBC_SHA256"+ , checkIdentifier 0x00 0x68 "TLS_DH_DSS_WITH_AES_256_CBC_SHA256"+ , checkIdentifier 0x00 0x69 "TLS_DH_RSA_WITH_AES_256_CBC_SHA256"+ , checkIdentifier 0x00 0x6A "TLS_DHE_DSS_WITH_AES_256_CBC_SHA256"+ , checkIdentifier 0x00 0x6B "TLS_DHE_RSA_WITH_AES_256_CBC_SHA256"+ , checkIdentifier 0x00 0x18 "TLS_DH_anon_WITH_RC4_128_MD5"+ , checkIdentifier 0x00 0x1B "TLS_DH_anon_WITH_3DES_EDE_CBC_SHA"+ , checkIdentifier 0x00 0x34 "TLS_DH_anon_WITH_AES_128_CBC_SHA"+ , checkIdentifier 0x00 0x3A "TLS_DH_anon_WITH_AES_256_CBC_SHA"+ , checkIdentifier 0x00 0x6C "TLS_DH_anon_WITH_AES_128_CBC_SHA256"+ , checkIdentifier 0x00 0x6D "TLS_DH_anon_WITH_AES_256_CBC_SHA256"+ ]+ ]+ where+ checkIdentifier a b str =+ let tname = str ++ " has right ident"+ in testCase tname (assertEqual tname str (getId a b))+ --+ getId a b =+ case find (matchId a b) rfc5246CipherSuites of+ Nothing -> "BAD BAD"+ Just x -> cipherName x+ --+ matchId a b CipherSuite{ cipherIdentifier = (m, n) } = (a == m) && (n == b)
+ test/Test/Handshakes.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Test.Handshakes where++import Crypto.Hash+import Crypto.PubKey.Curve25519+import Crypto.PubKey.RSA+import Crypto.PubKey.RSA.Types+import Control.Applicative+import Control.Monad+import Crypto.Random+import Data.ByteArray(convert,eq)+import Data.ByteString(ByteString,pack)+import qualified Data.ByteString as BS+import Data.Word+import Hexdump+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck hiding (generate)+import Test.Standard+import Tor.State.Credentials+import Tor.HybridCrypto+import Tor.Circuit+import Tor.RouterDesc+import Tor.DataFormat.TorCell+import Tor.RNG++import Debug.Trace++data RouterTAP = RouterTAP RouterDesc PrivateKey+ deriving (Show)++instance Arbitrary RouterTAP where+ arbitrary =+ do g <- arbitrary :: Gen TorRNG+ let ((pub, priv), _) = withDRG g (generate (1024 `div` 8) 65537)+ desc = blankRouterDesc{ routerOnionKey = pub }+ return (RouterTAP desc priv)++instance Arbitrary TorRNG where+ arbitrary = drgNewTest `fmap` arbitrary++instance Show TorRNG where+ show _ = "TorRNG"++instance Eq (Context SHA1) where+ a == b = a `eq` b++instance Show (Context SHA1) where+ show x = simpleHex (convert x)++data RouterNTor = RouterNTor RouterDesc SecretKey+ deriving (Show)++instance Arbitrary RouterNTor where+ arbitrary =+ do g0 <- arbitrary :: Gen TorRNG+ let ((pub, priv), g1) = withDRG g0 generate25519+ (fprint, g2) = withRandomBytes g1 20 id+ desc = blankRouterDesc{ routerFingerprint = fprint+ , routerNTorOnionKey = Just pub+ }+ return (RouterNTor desc priv)++tapHandshakeCheck :: Word32 -> RouterTAP -> TorRNG -> Bool+tapHandshakeCheck circId (RouterTAP myRouter priv) g0 =+ let (g1, (privX, cbody)) = startTAPHandshake myRouter g0+ (g2, (dcell, fenc, benc)) = advanceTAPHandshake priv circId cbody g1+ Created circIdD dbody = dcell+ in case completeTAPHandshake privX dbody of+ Left err ->+ False+ Right (fenc', benc') ->+ (circId == circIdD) && (fenc == fenc') && (benc == benc')++ntorHandshakeCheck :: Word32 -> RouterNTor -> TorRNG -> Bool+ntorHandshakeCheck circId (RouterNTor router littleB) g0 =+ case startNTorHandshake router g0 of+ (_, Nothing) ->+ False+ (g1, Just (pair, cbody)) ->+ case advanceNTorHandshake router littleB circId cbody g1 of+ (_, Left err) ->+ False+ (_, Right (Created2 _ dbody, fenc, benc)) ->+ case completeNTorHandshake router pair dbody of+ Left err ->+ False+ Right (fenc', benc') ->+ (fenc == fenc') && (benc == benc')++handshakeTests :: Test+handshakeTests =+ testGroup "Handshakes" [+ testProperty "TAP Handshake" tapHandshakeCheck+ , testProperty "NTor Handshake" ntorHandshakeCheck+ ]
+ test/Test/HybridEncrypt.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-}+module Test.HybridEncrypt(hybridEncryptionTest)+ where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Crypto.PubKey.RSA+import Control.Applicative+import Control.Monad+import Crypto.Random+import Data.ByteString(ByteString,pack)+import qualified Data.ByteString as BS+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Test.Standard+import Tor.State.Credentials+import Tor.HybridCrypto++data InputValues = Input PublicKey PrivateKey ByteString ChaChaDRG++instance Eq InputValues where+ (Input pub priv bstr _) == (Input pub' priv' bstr' _) =+ (pub == pub') && (priv == priv') && (bstr == bstr')++instance Show InputValues where+ show (Input pub priv bstr _) =+ "Input " ++ show pub ++ " " ++ show priv ++ " " ++ show bstr++instance Arbitrary InputValues where+ arbitrary = do g <- arbitraryRNG+ let (pub, priv, g') = generateKeyPair g 1024+ len <- choose (0, 2048)+ msg <- pack <$> replicateM len arbitrary+ return (Input pub priv msg g')++prop_hybridEncWorks :: Bool -> InputValues -> Property+prop_hybridEncWorks force (Input pub priv m g) =+ (not force || (BS.length m > 70)) ==>+ let (m', _) = withDRG g (do em <- hybridEncrypt force pub m+ hybridDecrypt priv em)+ in m == m'++hybridEncryptionTest :: Test+hybridEncryptionTest =+ testGroup "Hybrid encryption tests" [+ testProperty "Hybrid encryption works when forced"+ (prop_hybridEncWorks True)+ , testProperty "Hybrid encryption works in general"+ (prop_hybridEncWorks False)+ ]
+ test/Test/Standard.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}+module Test.Standard where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Monad+import Crypto.Random+import Data.Binary.Get+import Data.Binary.Put+import Data.ByteArray(pack)+import Data.ByteString(ByteString)+import qualified Data.ByteString.Lazy as BS+import Test.QuickCheck++arbitraryRNG :: Gen ChaChaDRG+arbitraryRNG = drgNew++arbitraryBS :: Int -> Gen ByteString+arbitraryBS x = pack <$> replicateM x arbitrary++serialProp :: Eq a => Get a -> (a -> Put) -> a -> Bool+serialProp getter putter x =+ let bstr = runPut (putter x)+ y = runGet getter bstr+ in x == y++instance MonadRandom Gen where+ getRandomBytes x = pack <$> replicateM x arbitrary
+ test/Test/TorCell.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+module Test.TorCell(torCellTests) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Monad+import Crypto.Hash+import Data.ASN1.OID+import Data.Binary.Get+import Data.Binary.Put+import Data.ByteArray(convert)+import Data.ByteString(ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as BSL+import Data.ByteString.Lazy(toStrict,fromStrict)+import Data.Hourglass+import Data.List+import Data.String+import Data.Word+import Data.X509+import Numeric+import Test.QuickCheck+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.Standard+import Tor.DataFormat.RelayCell+import Tor.DataFormat.TorAddress+import Tor.DataFormat.TorCell+import Tor.State.Credentials++instance Arbitrary TorAddress where+ arbitrary = oneof [ Hostname <$> genHostname+ , IP4 <$> genIP4+ , IP6 <$> genIP6+ , return (TransientError "External transient error.")+ , return (NontransientError "External nontransient error.")+ ]++genHostname :: Gen String+genHostname = take 255 <$> + intercalate "." <$>+ (listOf (listOf (elements ['a'..'z'])))++genIP4 :: Gen String+genIP4 = intercalate "." <$>+ (replicateM 4 (show <$> (arbitrary :: Gen Word8)))++genIP6 :: Gen String+genIP6 = do x <- genIP6'+ return ("[" ++ intercalate ":" x ++ "]")+ where+ genIP6' = map showHex' <$> + replicateM 8 (arbitrary :: Gen Word16)++prop_TorAddrSerial :: TorAddress -> Bool+prop_TorAddrSerial = serialProp getTorAddress putTorAddress++data TorAddressBS = TABS ByteString TorAddress+ deriving (Show, Eq)++instance Arbitrary TorAddressBS where+ arbitrary = oneof [ do x <- replicateM 4 arbitrary+ let str = intercalate "." (map show x)+ bstr = BS.pack x+ return (TABS bstr (IP4 str))+ , do x <- replicateM 16 arbitrary+ let bstr = BSL.pack x+ xs = runGet (replicateM 8 getWord16be) bstr+ str = "[" ++ intercalate ":" (map showHex' xs) ++ "]"+ return (TABS (toStrict bstr) (IP6 str))+ ]++prop_TorAddrBSSerial :: TorAddressBS -> Bool+prop_TorAddrBSSerial (TABS bstr x) = bstr == torAddressByteString x++showHex' :: (Show a, Integral a) => a -> String+showHex' x = showHex x ""++instance Arbitrary ExtendSpec where+ arbitrary = oneof [ ExtendIP4 <$> genIP4 <*> arbitrary+ , ExtendIP6 <$> genIP6 <*> arbitrary+ , ExtendDigest <$>+ (BSC.pack <$>+ replicateM 20 (elements "abcdef0123456789"))+ ]++prop_ExtendSpecSerial :: ExtendSpec -> Bool+prop_ExtendSpecSerial = serialProp getExtendSpec putExtendSpec++instance Arbitrary DestroyReason where+ arbitrary = elements [NoReason, TorProtocolViolation, InternalError,+ RequestedDestroy, NodeHibernating, HitResourceLimit,+ ConnectionFailed, ORIdentityIssue, ORConnectionClosed,+ Finished, CircuitConstructionTimeout, CircuitDestroyed,+ NoSuchService]++prop_DestroyReasonSerial1 :: DestroyReason -> Bool+prop_DestroyReasonSerial1 = serialProp getDestroyReason putDestroyReason++prop_DestroyReasonSerial2 :: Word8 -> Bool+prop_DestroyReasonSerial2 x =+ [x] == BSL.unpack (runPut (putDestroyReason+ (runGet getDestroyReason (BSL.pack [x]))))++instance Arbitrary RelayEndReason where+ arbitrary = oneof [ ReasonExitPolicy <$> (IP4 <$> genIP4) <*> arbitrary+ , ReasonExitPolicy <$> (IP6 <$> genIP6) <*> arbitrary+ , elements [ReasonMisc, ReasonResolveFailed,+ ReasonConnectionRefused, ReasonDestroyed, ReasonDone,+ ReasonTimeout, ReasonNoRoute, ReasonHibernating,+ ReasonInternal, ReasonResourceLimit,+ ReasonConnectionReset, ReasonTorProtocol,+ ReasonNotDirectory ]+ ]++prop_RelayEndRsnSerial :: RelayEndReason -> Bool+prop_RelayEndRsnSerial rsn =+ let bstr = runPut (putRelayEndReason rsn)+ len = case rsn of+ ReasonExitPolicy (IP4 _) _ -> 9+ ReasonExitPolicy (IP6 _) _ -> 21+ _ -> 1+ rsn' = runGet (getRelayEndReason len) bstr+ in rsn == rsn'++instance Arbitrary RelayCell where+ arbitrary =+ oneof [ RelayBegin <$> arbitrary <*> legalTorAddress True+ <*> arbitrary <*> arbitrary <*> arbitrary+ <*> arbitrary+ , RelayData <$> arbitrary+ <*> ((BS.pack . take 503) <$> arbitrary)+ , RelayEnd <$> arbitrary <*> arbitrary+ , RelayConnected <$> arbitrary <*> legalTorAddress False+ <*> arbitrary+ , RelaySendMe <$> arbitrary+ , RelayExtend <$> arbitrary <*> genIP4+ <*> arbitrary <*> arbitraryBS 186 <*> arbitraryBS 20+ , RelayExtended <$> arbitrary+ <*> (BS.pack <$> replicateM 148 arbitrary)+ , RelayTruncate <$> arbitrary+ , RelayTruncated <$> arbitrary <*> arbitrary+ , RelayDrop <$> arbitrary+ , RelayResolve <$> arbitrary+ <*> (filter (/= '\0') <$> arbitrary)+ , do strm <- arbitrary+ vals <- listOf $ do x <- legalTorAddress True+ y <- arbitrary+ return (x,y)+ return (RelayResolved strm vals)+ , RelayBeginDir <$> arbitrary+ , RelayExtend2 <$> arbitrary <*> arbitrary <*> arbitrary+ <*> (BS.pack <$> arbitrary)+ , RelayExtended2 <$> arbitrary <*> (BS.pack <$> arbitrary)+ , RelayEstablishIntro <$> arbitrary <*> arbitraryBS 128+ <*> arbitraryBS 20 <*> arbitraryBS 128+ , RelayEstablishRendezvous <$> arbitrary <*> arbitraryBS 20+ , RelayIntroduce1 <$> arbitrary <*> arbitraryBS 20+ <*> (BS.pack <$> arbitrary)+ , RelayIntroduce2 <$> arbitrary <*> (BS.pack <$> arbitrary)+ , RelayRendezvous1 <$> arbitrary <*> arbitraryBS 20+ <*> arbitraryBS 128 <*> arbitraryBS 20+ , RelayRendezvous2 <$> arbitrary <*> arbitraryBS 128+ <*> arbitraryBS 20+ , RelayIntroEstablished <$> arbitrary+ , RelayRendezvousEstablished <$> arbitrary+ , RelayIntroduceAck <$> arbitrary+ ]++legalTorAddress :: Bool -> Gen TorAddress+legalTorAddress allowHostname =+ do x <- arbitrary+ case x of+ Hostname "" -> legalTorAddress allowHostname+ Hostname _ | allowHostname -> return x+ IP4 "0.0.0.0" -> legalTorAddress allowHostname+ IP4 _ -> return x+ IP6 _ -> return x+ _ -> legalTorAddress allowHostname++prop_RelayCellSerial :: RelayCell -> Property+prop_RelayCellSerial x =+ let (_, gutsBS) = runPutM (putRelayCellGuts x)+ bstr = runPut (putRelayCell (BS.replicate 4 0) x)+ (_, y) = runGet getRelayCell bstr+ in (BSL.length gutsBS <= (509 - 11)) ==> (x == y)++prop_RelayCellDigestWorks1 :: RelayCell -> Property+prop_RelayCellDigestWorks1 x =+ let (_, gutsBS) = runPutM (putRelayCellGuts x)+ (bstr, _) = renderRelayCell hashInit x+ (x', _) = runGet (parseRelayCell hashInit) (fromStrict bstr)+ in (BSL.length gutsBS <= (509 - 11)) ==> (x == x')++prop_RelayCellDigestWorks2 :: NonEmptyList RelayCell -> Property+prop_RelayCellDigestWorks2 xs =+ let mxSize = maximum (map putGuts (getNonEmpty xs))+ xs' = runCheck hashInit hashInit (getNonEmpty xs)+ in (mxSize <= (509 - 11)) ==> (getNonEmpty xs == xs')+ where+ putGuts x =+ let (_, gutsBS) = runPutM (putRelayCellGuts x)+ in BSL.length gutsBS+ runCheck _ _ [] = []+ runCheck rstate pstate (f:rest) =+ let (bstr, rstate') = renderRelayCell rstate f+ (f', pstate') = runGet (parseRelayCell pstate) (fromStrict bstr)+ in f' : runCheck rstate' pstate' rest++instance Arbitrary HandshakeType where+ arbitrary = elements [TAP, Reserved, NTor]++prop_HandTypeSerial1 :: HandshakeType -> Bool+prop_HandTypeSerial1 = serialProp getHandshakeType putHandshakeType++prop_HandTypeSerial2 :: Word16 -> Bool+prop_HandTypeSerial2 x =+ let ht = runGet getHandshakeType (runPut (putWord16be x))+ in runPut (putWord16be x) == runPut (putHandshakeType ht)++instance Arbitrary (SignedExact Certificate) where+ arbitrary =+ do certVersion <- arbitrary+ certSerial <- arbitrary+ certIssuerDN <- arbitrary+ certSubjectDN <- arbitrary+ hashAlg <- elements [HashSHA1, HashSHA256, HashSHA384]++ g <- arbitraryRNG+ let (pub, _, _) = generateKeyPair g 1024++ let keyAlg = PubKeyALG_RSA -- FIXME?+ certSignatureAlg = SignatureALG hashAlg keyAlg+ certValidity = (timeFromElapsed (Elapsed (Seconds 257896558)),+ timeFromElapsed (Elapsed (Seconds 2466971758)))+ certPubKey = PubKeyRSA pub+ certExtensions = Extensions Nothing++ let baseCert = Certificate{ .. }+ sigfun = case hashAlg of+ HashSHA1 -> wrapSignatureAlg certSignatureAlg sha1+ HashSHA224 -> wrapSignatureAlg certSignatureAlg sha224+ HashSHA256 -> wrapSignatureAlg certSignatureAlg sha256+ HashSHA384 -> wrapSignatureAlg certSignatureAlg sha384+ HashSHA512 -> wrapSignatureAlg certSignatureAlg sha512+ _ -> error "INTERNAL WEIRDNESS"+ let (signedCert, _) = objectToSignedExact sigfun baseCert+ return signedCert++newtype ReadableStr = ReadableStr { unReadableStr :: String }++instance Show ReadableStr where+ show = show . unReadableStr++instance Arbitrary ReadableStr where+ arbitrary =+ do len <- choose (1, 256)+ str <- replicateM len (elements printableChars)+ return (ReadableStr str)+ where printableChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['_','.',' ']++instance Arbitrary DistinguishedName where+ arbitrary =+ do cn <- unReadableStr <$> arbitrary+ co <- unReadableStr <$> arbitrary+ og <- unReadableStr <$> arbitrary+ ou <- unReadableStr <$> arbitrary+ return (DistinguishedName [+ (getObjectID DnCommonName, fromString cn)+ , (getObjectID DnCountry, fromString co)+ , (getObjectID DnOrganization, fromString og)+ , (getObjectID DnOrganizationUnit, fromString ou)+ ])++wrapSignatureAlg :: SignatureALG ->+ (ByteString -> ByteString) ->+ ByteString ->+ (ByteString, SignatureALG, ())+wrapSignatureAlg name sha bstr =+ let hashed = convert (sha bstr)+ in (hashed, name, ())++sha1 :: ByteString -> ByteString+sha1 = convert . hashWith SHA1++sha224 :: ByteString -> ByteString+sha224 = convert . hashWith SHA224++sha256 :: ByteString -> ByteString+sha256 = convert . hashWith SHA256++sha384 :: ByteString -> ByteString+sha384 = convert . hashWith SHA384++sha512 :: ByteString -> ByteString+sha512 = convert . hashWith SHA512+++instance Arbitrary TorCert where+ arbitrary = oneof [ LinkKeyCert <$> arbitrary+ , RSA1024Identity <$> arbitrary+ , RSA1024Auth <$> arbitrary+ ]++prop_torCertSerial :: TorCert -> Bool+prop_torCertSerial = serialProp getTorCert putTorCert++torCellTests :: Test+torCellTests =+ testGroup "TorCell Serialization" [+ testProperty "TorAddress round-trips" prop_TorAddrSerial+ , testProperty "TorAddress makes sensible ByteStrings" prop_TorAddrBSSerial+ , testProperty "ExtendSpec serializes" prop_ExtendSpecSerial+ , testProperty "DestroyReason serializes (check #1)" prop_DestroyReasonSerial1+ , testProperty "DestroyReason serializes (check #2)" prop_DestroyReasonSerial2+ , testProperty "HandshakeType serializes (check #1)" prop_HandTypeSerial1+ , testProperty "HandshakeType serializes (check #2)" prop_HandTypeSerial2+ , testProperty "RelayEndReason serializes" prop_RelayEndRsnSerial+ , testProperty "RelayCell serializes" prop_RelayCellSerial+ , testProperty "RelayCell serializes w/ digest" prop_RelayCellDigestWorks1+ , testProperty "RelayCell serializes w/ digest" prop_RelayCellDigestWorks2+ , testProperty "Tor certificates serialize" prop_torCertSerial+ ]+