Additional small changes to support better distribution and wider lib…

…rary support. This commit makes sure that all the test files get appropriately picked up when packaged with cabal sdist. In addition, it modifies the Travis build to try to make sure that we don't keep having this problem. Finally, at a user's request, we loosen some of the requirements, and allow newer versions of cryptonite and memory. The former requires some CPP ugliness, which we will need to deprecate sometime in the future. (This is a squashed merge of the "bug" branch.)
GaloisInc · Nov 29, 2015 · 756fb3b · 756fb3b
1 parent 8aea2aa
commit 756fb3b
Show file tree

Hide file tree

Showing 9 changed files with 76 additions and 54 deletions.
diff --git a/.travis.yml b/.travis.yml
@@ -53,6 +53,6 @@ script:
 # If there are no other `.tar.gz` files in `dist`, this can be even simpler:
 # `cabal install --force-reinstalls dist/*-*.tar.gz`
  - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
-   (cd dist && cabal install --force-reinstalls $NETWORK -f$HANS --constraint="tls $HANS" "$SRC_TGZ")
+   (cd dist && cabal install --force-reinstalls $NETWORK -f$HANS --constraint="tls $HANS" "$SRC_TGZ" --enable-tests )
 
 
diff --git 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 @@ library
                       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 @@ library
                       Paths_haskell_tor
 
   exposed-modules:
-                      Data.Hourglass.Now,
                       Tor,
                       Tor.Circuit,
                       Tor.DataFormat.Consensus,
@@ -113,10 +112,10 @@ executable haskell-tor
                       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 @@ test-suite test-tor
   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
diff --git a/src/Tor/Circuit.hs b/src/Tor/Circuit.hs
@@ -949,14 +949,14 @@ advanceNTorHandshake me littleB circId bstr0 g0
       (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 @@ advanceNTorHandshake me littleB circId bstr0 g0
 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 @@ type Curve25519Pair = (Curve.PublicKey, Curve.SecretKey)
 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' mv f = modifyMVar mv (return . f)
 
 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
@@ -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 @@ module Tor.DataFormat.RouterDesc(
  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 @@ ntorOnionKey r =
   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
@@ -35,7 +35,6 @@ import qualified Data.ByteString as BS
 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 hiding (HashSHA1, HashSHA256)
 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 @@ initLink :: HasBackend s =>
             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 @@ getRespInitialMsgs tls (CertificateChain tlsCerts) =
          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 @@ acceptLink :: HasBackend s =>
               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 @@ acceptLink creds routerDB rngMV llog sock who =
     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
@@ -12,8 +12,8 @@ module Tor.Options(
  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 @@ defaultTorExitOptions  = TorExitOptions {
 -- 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
@@ -1,4 +1,5 @@
 -- |Credential management for a Tor node.
+{-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 module Tor.State.Credentials(
@@ -18,6 +19,9 @@ module Tor.State.Credentials(
  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 Crypto.Random
 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.String
 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 @@ newtype Credentials = Credentials (MVar CredentialState)
 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 @@ getTLSKey = getCredentials credTLS
 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 @@ getRouterDesc (Credentials stateMV) =
            (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 @@ maybeRegenOnion force now state | force || (now > expiration) = (state', True)
   --
   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
@@ -26,7 +26,6 @@ import Data.Bits
 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 qualified Data.Map.Strict as Map
 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 @@ computeNextTime consensus g = (timeAdd lowest diffAmt, g')
 
 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