diff --git a/haskell-tor.cabal b/haskell-tor.cabal --- a/haskell-tor.cabal +++ b/haskell-tor.cabal @@ -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, diff --git a/src/Data/Hourglass/Now.hs b/src/Data/Hourglass/Now.hs deleted file mode 100644 --- a/src/Data/Hourglass/Now.hs +++ /dev/null @@ -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{..} - - diff --git a/src/Tor/Circuit.hs b/src/Tor/Circuit.hs --- a/src/Tor/Circuit.hs +++ b/src/Tor/Circuit.hs @@ -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 diff --git a/src/Tor/DataFormat/RouterDesc.hs b/src/Tor/DataFormat/RouterDesc.hs --- a/src/Tor/DataFormat/RouterDesc.hs +++ b/src/Tor/DataFormat/RouterDesc.hs @@ -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 = diff --git a/src/Tor/Link.hs b/src/Tor/Link.hs --- a/src/Tor/Link.hs +++ b/src/Tor/Link.hs @@ -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 diff --git a/src/Tor/Options.hs b/src/Tor/Options.hs --- a/src/Tor/Options.hs +++ b/src/Tor/Options.hs @@ -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, diff --git a/src/Tor/State/Credentials.hs b/src/Tor/State/Credentials.hs --- a/src/Tor/State/Credentials.hs +++ b/src/Tor/State/Credentials.hs @@ -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) diff --git a/src/Tor/State/Routers.hs b/src/Tor/State/Routers.hs --- a/src/Tor/State/Routers.hs +++ b/src/Tor/State/Routers.hs @@ -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 diff --git a/test/Test/CipherSuite.hs b/test/Test/CipherSuite.hs new file mode 100644 --- /dev/null +++ b/test/Test/CipherSuite.hs @@ -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) diff --git a/test/Test/Handshakes.hs b/test/Test/Handshakes.hs new file mode 100644 --- /dev/null +++ b/test/Test/Handshakes.hs @@ -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 + ] diff --git a/test/Test/HybridEncrypt.hs b/test/Test/HybridEncrypt.hs new file mode 100644 --- /dev/null +++ b/test/Test/HybridEncrypt.hs @@ -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) + ] diff --git a/test/Test/Standard.hs b/test/Test/Standard.hs new file mode 100644 --- /dev/null +++ b/test/Test/Standard.hs @@ -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 diff --git a/test/Test/TorCell.hs b/test/Test/TorCell.hs new file mode 100644 --- /dev/null +++ b/test/Test/TorCell.hs @@ -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 + ] +