{-# LANGUAGE CPP, RecordWildCards, GADTs #-}
module Main (main) where
-- stdlib
import Control.Exception
import Control.Monad
import Data.Maybe (fromJust)
import Data.Time
import Network.URI (URI, parseURI)
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck hiding (label)
import System.IO.Temp (withSystemTempDirectory)
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Data.ByteString.Lazy.Char8 as BS
-- Cabal
#if MIN_VERSION_Cabal(2,0,0)
import Distribution.Package (mkPackageName)
#else
import Distribution.Package (PackageName(PackageName))
#endif
-- hackage-security
import Hackage.Security.Client
import Hackage.Security.Client.Repository
import Hackage.Security.JSON (DeserializationError(..))
import Hackage.Security.Util.Checked
import Hackage.Security.Util.Path
import Hackage.Security.Util.Some
import Hackage.Security.Util.Pretty
import qualified Hackage.Security.Client.Repository.Remote as Remote
import qualified Hackage.Security.Client.Repository.Cache as Cache
-- TestSuite
import TestSuite.HttpMem
import TestSuite.InMemCache
import TestSuite.InMemRepo
import TestSuite.InMemRepository
import TestSuite.PrivateKeys
import TestSuite.Util.StrictMVar
import TestSuite.JSON as JSON
{-------------------------------------------------------------------------------
TestSuite driver
-------------------------------------------------------------------------------}
main :: IO ()
main = defaultMain tests
tests :: TestTree
tests = testGroup "hackage-security" [
testGroup "InMem" [
testCase "testInMemInitialHasForUpdates" testInMemInitialHasUpdates
, testCase "testInMemNoUpdates" testInMemNoUpdates
, testCase "testInMemUpdatesAfterCron" testInMemUpdatesAfterCron
, testCase "testInMemKeyRollover" testInMemKeyRollover
, testCase "testInMemOutdatedTimestamp" testInMemOutdatedTimestamp
, testCase "testInMemIndex" testInMemIndex
]
, testGroup "HttpMem" [
testCase "testHttpMemInitialHasForUpdates" testHttpMemInitialHasUpdates
, testCase "testHttpMemNoUpdates" testHttpMemNoUpdates
, testCase "testHttpMemUpdatesAfterCron" testHttpMemUpdatesAfterCron
, testCase "testHttpMemKeyRollover" testHttpMemKeyRollover
, testCase "testHttpMemOutdatedTimestamp" testHttpMemOutdatedTimestamp
, testCase "testHttpMemIndex" testHttpMemIndex
]
, testGroup "Canonical JSON" [
testProperty "prop_roundtrip_canonical" JSON.prop_roundtrip_canonical
, testProperty "prop_roundtrip_pretty" JSON.prop_roundtrip_pretty
, testProperty "prop_canonical_pretty" JSON.prop_canonical_pretty
, testProperty "prop_aeson_canonical" JSON.prop_aeson_canonical
]
]
{-------------------------------------------------------------------------------
In-memory tests
These tests test the core TUF infrastructure, but any specific Repository
implementation; instead, they use one specifically designed for testing
(almost a Repository mock-up).
-------------------------------------------------------------------------------}
-- | Initial check for updates: empty cache
testInMemInitialHasUpdates :: Assertion
testInMemInitialHasUpdates = inMemTest $ \_inMemRepo logMsgs repo -> do
withAssertLog "A" logMsgs [] $
assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry
-- | Check that if we run updates again, with no changes on the server,
-- we get NoUpdates
testInMemNoUpdates :: Assertion
testInMemNoUpdates = inMemTest $ \_inMemRepo logMsgs repo -> do
withAssertLog "A" logMsgs [] $ do
assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry
withAssertLog "B" logMsgs [] $ do
assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry
-- | Test that we have updates reported after the timestamp is resigned
testInMemUpdatesAfterCron :: Assertion
testInMemUpdatesAfterCron = inMemTest $ \inMemRepo logMsgs repo -> do
withAssertLog "A" logMsgs [] $ do
assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry
withAssertLog "B" logMsgs [] $ do
assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry
inMemRepoCron inMemRepo =<< getCurrentTime
withAssertLog "C" logMsgs [] $ do
assertEqual "C.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry
withAssertLog "D" logMsgs [] $ do
assertEqual "D.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry
-- | Test what happens when the timestamp/snapshot keys rollover
testInMemKeyRollover :: Assertion
testInMemKeyRollover = inMemTest $ \inMemRepo logMsgs repo -> do
withAssertLog "A" logMsgs [] $ do
assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry
withAssertLog "B" logMsgs [] $ do
assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry
inMemRepoKeyRollover inMemRepo =<< getCurrentTime
let msgs = [verificationError $ unknownKeyError timestampPath]
withAssertLog "C" logMsgs msgs $ do
assertEqual "C.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry
withAssertLog "D" logMsgs [] $ do
assertEqual "D.1" NoUpdates =<< checkForUpdates repo =<< checkExpiry
-- | Test what happens when server has an outdated timestamp
-- (after a successful initial update)
testInMemOutdatedTimestamp :: Assertion
testInMemOutdatedTimestamp = inMemTest $ \_inMemRepo logMsgs repo -> do
withAssertLog "A" logMsgs [] $ do
assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry
withAssertLog "B" logMsgs [] $ do
assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry
now <- getCurrentTime
let (FileExpires fourDaysLater) = expiresInDays now 4
let msgs = replicate 5 (inHistory (Right (expired timestampPath)))
catchVerificationLoop msgs $ do
withAssertLog "C" logMsgs [] $ do
assertEqual "C.1" HasUpdates =<< checkForUpdates repo fourDaysLater
testInMemIndex :: Assertion
testInMemIndex = inMemTest $ \inMemRepo _logMsgs repo ->
testRepoIndex inMemRepo repo
{-------------------------------------------------------------------------------
Same tests, but going through the "real" Remote repository and Cache, though
still using an in-memory repository (with a HttpLib bridge)
These are almost hte same as the in-memory tests, but the log messages we
expect are slightly different because the Remote repository indicates what
is is downloading, and why.
-------------------------------------------------------------------------------}
-- | Initial check for updates: empty cache
testHttpMemInitialHasUpdates :: Assertion
testHttpMemInitialHasUpdates = httpMemTest $ \_inMemRepo logMsgs repo -> do
withAssertLog "A" logMsgs msgsInitialUpdate $
assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry
-- | Check that if we run updates again, with no changes on the server,
-- we get NoUpdates
testHttpMemNoUpdates :: Assertion
testHttpMemNoUpdates = httpMemTest $ \_inMemRepo logMsgs repo -> do
withAssertLog "A" logMsgs msgsInitialUpdate $ do
assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry
withAssertLog "B" logMsgs msgsNoUpdates $ do
assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry
-- | Test that we have updates reported after the timestamp is resigned
testHttpMemUpdatesAfterCron :: Assertion
testHttpMemUpdatesAfterCron = httpMemTest $ \inMemRepo logMsgs repo -> do
withAssertLog "A" logMsgs msgsInitialUpdate $ do
assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry
withAssertLog "B" logMsgs msgsNoUpdates $ do
assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry
inMemRepoCron inMemRepo =<< getCurrentTime
withAssertLog "C" logMsgs msgsResigned $ do
assertEqual "C.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry
withAssertLog "D" logMsgs msgsNoUpdates $ do
assertEqual "D.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry
-- | Test what happens when the timestamp/snapshot keys rollover
testHttpMemKeyRollover :: Assertion
testHttpMemKeyRollover = httpMemTest $ \inMemRepo logMsgs repo -> do
withAssertLog "A" logMsgs msgsInitialUpdate $ do
assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry
withAssertLog "B" logMsgs msgsNoUpdates $ do
assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry
inMemRepoKeyRollover inMemRepo =<< getCurrentTime
withAssertLog "C" logMsgs msgsKeyRollover $ do
assertEqual "C.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry
withAssertLog "D" logMsgs msgsNoUpdates $ do
assertEqual "D.1" NoUpdates =<< checkForUpdates repo =<< checkExpiry
-- | Test what happens when server has an outdated timestamp
-- (after a successful initial update)
testHttpMemOutdatedTimestamp :: Assertion
testHttpMemOutdatedTimestamp = httpMemTest $ \_inMemRepo logMsgs repo -> do
withAssertLog "A" logMsgs msgsInitialUpdate $ do
assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry
withAssertLog "B" logMsgs msgsNoUpdates $ do
assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry
now <- getCurrentTime
let (FileExpires fourDaysLater) = expiresInDays now 4
let msgs = replicate 5 (inHistory (Right (expired timestampPath)))
catchVerificationLoop msgs $ do
withAssertLog "C" logMsgs [] $ do
assertEqual "C.1" HasUpdates =<< checkForUpdates repo fourDaysLater
testHttpMemIndex :: Assertion
testHttpMemIndex = httpMemTest $ \inMemRepo _logMsgs repo ->
testRepoIndex inMemRepo repo
{-------------------------------------------------------------------------------
Identical tests between the two variants
-------------------------------------------------------------------------------}
testRepoIndex :: (Throws SomeRemoteError, Throws VerificationError)
=> InMemRepo -> Repository down -> IO ()
testRepoIndex inMemRepo repo = do
assertEqual "A" HasUpdates =<< checkForUpdates repo =<< checkExpiry
dir1 <- getDirectory repo
directoryFirst dir1 @?= DirectoryEntry 0
directoryNext dir1 @?= DirectoryEntry 0
length (directoryEntries dir1) @?= 0
now <- getCurrentTime
inMemRepoSetIndex inMemRepo now testEntries1
assertEqual "B" HasUpdates =<< checkForUpdates repo =<< checkExpiry
dir2 <- getDirectory repo
directoryFirst dir2 @?= DirectoryEntry 0
directoryNext dir2 @?= DirectoryEntry 2
length (directoryEntries dir2) @?= 1
directoryLookup dir2 testEntryIndexFile @?= Just (DirectoryEntry 0)
withIndex repo $ \IndexCallbacks{..} -> do
(sentry, next) <- indexLookupEntry (DirectoryEntry 0)
next @?= Nothing
case sentry of Some entry -> checkIndexEntry entry
where
checkIndexEntry :: IndexEntry dec -> Assertion
checkIndexEntry entry = do
toUnrootedFilePath (unrootPath (indexEntryPath entry))
@?= "foo/preferred-versions"
indexEntryContent entry @?= testEntrycontent
case indexEntryPathParsed entry of
Just (IndexPkgPrefs pkgname) -> do
pkgname @?= mkPackageName "foo"
case indexEntryContentParsed entry of
Right () -> return ()
_ -> fail "unexpected index entry content"
_ -> fail "unexpected index path"
#if MIN_VERSION_tar(0,6,0)
testEntries1 :: [Tar.GenEntry Tar.TarPath linkTarget]
#else
testEntries1 :: [Tar.Entry]
#endif
testEntries1 = either (const []) (pure . (`Tar.fileEntry` testEntrycontent))
(Tar.toTarPath False "foo/preferred-versions")
testEntrycontent = BS.pack "foo >= 1"
testEntryIndexFile = IndexPkgPrefs (mkPackageName "foo")
{-------------------------------------------------------------------------------
Log messages we expect when using the Remote repository
-------------------------------------------------------------------------------}
-- | The log messages we expect on the initial check for updates
msgsInitialUpdate :: [LogMessage -> Bool]
msgsInitialUpdate = [
selectedMirror inMemURI
, downloading isTimestamp
, downloading isSnapshot
, downloading isMirrors
, noLocalCopy
, downloading isIndex
, lockingWait
, lockingWaitDone
, lockingRelease
]
-- | Log messages when we do a check for updates and there are no changes
msgsNoUpdates :: [LogMessage -> Bool]
msgsNoUpdates = [
selectedMirror inMemURI
, downloading isTimestamp
, lockingWait
, lockingWaitDone
, lockingRelease
]
-- | Log messages we expect when the timestamp and snapshot have been resigned
msgsResigned :: [LogMessage -> Bool]
msgsResigned = [
selectedMirror inMemURI
, downloading isTimestamp
, downloading isSnapshot
, lockingWait
, lockingWaitDone
, lockingRelease
]
-- | Log messages we expect when the timestamp key has been rolled over
msgsKeyRollover :: [LogMessage -> Bool]
msgsKeyRollover = [
selectedMirror inMemURI
, downloading isTimestamp
, verificationError $ unknownKeyError timestampPath
, downloading isRoot
, lockingWait
, lockingWaitDone
, lockingRelease
, downloading isTimestamp
, downloading isSnapshot
-- Since we delete the timestamp and snapshot on a root info change,
-- we will then conclude that we need to update the mirrors and the index.
, downloading isMirrors
, updating isIndex
, lockingWait
, lockingWaitDone
, lockingRelease
]
{-------------------------------------------------------------------------------
Classifying log messages
-------------------------------------------------------------------------------}
downloading :: (forall fs typ. RemoteFile fs typ -> Bool) -> LogMessage -> Bool
downloading isFile (LogDownloading file) = isFile file
downloading _ _ = False
noLocalCopy :: LogMessage -> Bool
noLocalCopy (LogCannotUpdate (RemoteIndex _ _) UpdateImpossibleNoLocalCopy) = True
noLocalCopy _ = False
selectedMirror :: URI -> LogMessage -> Bool
selectedMirror mirror (LogSelectedMirror mirror') = mirror' == show mirror
selectedMirror _ _ = False
updating :: (forall fs typ. RemoteFile fs typ -> Bool) -> LogMessage -> Bool
updating isFile (LogUpdating file) = isFile file
updating _ _ = False
lockingWait, lockingWaitDone, lockingRelease :: LogMessage -> Bool
lockingWait (LogLockWait _) = True
lockingWait _ = False
lockingWaitDone (LogLockWaitDone _) = True
lockingWaitDone _ = False
lockingRelease (LogUnlock _) = True
lockingRelease _ = False
expired :: TargetPath -> VerificationError -> Bool
expired f (VerificationErrorExpired f') = f == f'
expired _ _ = False
unknownKeyError :: TargetPath -> VerificationError -> Bool
unknownKeyError f (VerificationErrorDeserialization f' (DeserializationErrorUnknownKey _keyId)) =
f == f'
unknownKeyError _ _ = False
verificationError :: (VerificationError -> Bool) -> LogMessage -> Bool
verificationError isErr (LogVerificationError err) = isErr err
verificationError _ _ = False
inHistory :: Either RootUpdated (VerificationError -> Bool) -> HistoryMsg -> Bool
inHistory (Right isErr) (Right err) = isErr err
inHistory (Left _) (Left _) = True
inHistory _ _ = False
type HistoryMsg = Either RootUpdated VerificationError
catchVerificationLoop :: ([HistoryMsg -> Bool]) -> Assertion -> Assertion
catchVerificationLoop history = handleJust isLoop handler
where
isLoop :: VerificationError -> Maybe VerificationHistory
isLoop (VerificationErrorLoop history') = Just history'
isLoop _ = Nothing
handler :: VerificationHistory -> Assertion
handler history' =
unless (length history == length history' && and (zipWith ($) history history')) $
assertFailure $ "Unexpected verification history:"
++ unlines (map pretty' history')
pretty' :: HistoryMsg -> String
pretty' (Left RootUpdated) = "root updated"
pretty' (Right err) = pretty err
{-------------------------------------------------------------------------------
Classifying files
-------------------------------------------------------------------------------}
isRoot :: RemoteFile fs typ -> Bool
isRoot (RemoteRoot _) = True
isRoot _ = False
isIndex :: RemoteFile fs typ -> Bool
isIndex (RemoteIndex _ _) = True
isIndex _ = False
isMirrors :: RemoteFile fs typ -> Bool
isMirrors (RemoteMirrors _) = True
isMirrors _ = False
isSnapshot :: RemoteFile fs typ -> Bool
isSnapshot (RemoteSnapshot _) = True
isSnapshot _ = False
isTimestamp :: RemoteFile fs typ -> Bool
isTimestamp RemoteTimestamp = True
isTimestamp _ = False
timestampPath :: TargetPath
timestampPath = TargetPathRepo $ repoLayoutTimestamp hackageRepoLayout
{-------------------------------------------------------------------------------
Auxiliary
-------------------------------------------------------------------------------}
-- | Check the contents of the log
assertLog :: String -> [LogMessage -> Bool] -> [LogMessage] -> Assertion
assertLog label expected actual = go expected actual
where
go :: [LogMessage -> Bool] -> [LogMessage] -> Assertion
go [] [] = return ()
go [] as = unexpected as
go (_:_) [] = assertFailure $ label ++ ": expected log message"
go (e:es) (a:as) = if e a then go es as else unexpected [a]
unexpected :: [LogMessage] -> Assertion
unexpected msgs = assertFailure $ label ++ ": "
++ "unexpected log messages:\n"
++ unlines (map pretty msgs)
++ "\nfull set of log messages was:\n"
++ unlines (map pretty actual)
-- | Run the actions and check its log messages
withAssertLog :: String
-> MVar [LogMessage]
-> [LogMessage -> Bool]
-> Assertion -> Assertion
withAssertLog label mv expected action = do
oldMsgs <- modifyMVar mv $ \old -> return ([], old)
action
newMsgs <- modifyMVar mv $ \new -> return (oldMsgs, new)
assertLog label expected newMsgs
-- | Unit test using the in-memory repository/cache
inMemTest :: ( ( Throws SomeRemoteError
, Throws VerificationError
) => InMemRepo -> MVar [LogMessage] -> Repository InMemFile -> Assertion
)
-> Assertion
inMemTest test = uncheckClientErrors $ do
now <- getCurrentTime
keys <- createPrivateKeys
let root = initRoot now layout keys
withSystemTempDirectory "hackage-security-test" $ \tempDir' -> do
tempDir <- makeAbsolute $ fromFilePath tempDir'
inMemRepo <- newInMemRepo layout root now keys
inMemCache <- newInMemCache tempDir layout
logMsgs <- newMVar []
let logger msg = modifyMVar_ logMsgs $ \msgs -> return $ msgs ++ [msg]
repository <- newInMemRepository layout hackageIndexLayout inMemRepo inMemCache logger
bootstrap repository (map someKeyId (privateRoot keys)) (KeyThreshold 2)
test inMemRepo logMsgs repository
where
layout :: RepoLayout
layout = hackageRepoLayout
-- | Unit test using the Remote repository but with the in-mem repo
httpMemTest :: ( ( Throws SomeRemoteError
, Throws VerificationError
) => InMemRepo -> MVar [LogMessage] -> Repository Remote.RemoteTemp -> Assertion
)
-> Assertion
httpMemTest test = uncheckClientErrors $ do
now <- getCurrentTime
keys <- createPrivateKeys
let root = initRoot now layout keys
withSystemTempDirectory "hackage-security-test" $ \tempDir' -> do
tempDir <- makeAbsolute $ fromFilePath tempDir'
inMemRepo <- newInMemRepo layout root now keys
logMsgs <- newMVar []
let logger msg = modifyMVar_ logMsgs $ \msgs -> return $ msgs ++ [msg]
httpLib = httpMem inMemRepo
cache = Cache.Cache {
cacheRoot = tempDir </> fragment "cache"
, cacheLayout = cabalCacheLayout
}
Remote.withRepository httpLib
[inMemURI]
Remote.defaultRepoOpts
cache
hackageRepoLayout
hackageIndexLayout
logger
$ \repository -> do
withAssertLog "bootstrap" logMsgs bootstrapMsgs $
bootstrap repository (map someKeyId (privateRoot keys)) (KeyThreshold 2)
test inMemRepo logMsgs repository
where
bootstrapMsgs :: [LogMessage -> Bool]
bootstrapMsgs = [ selectedMirror inMemURI
, downloading isRoot
, lockingWait
, lockingWaitDone
, lockingRelease
]
layout :: RepoLayout
layout = hackageRepoLayout
-- | Base URI for the in-memory repository
--
-- This could really be anything at all
inMemURI :: URI
inMemURI = fromJust (parseURI "inmem://")
-- | Return @Just@ the current time
checkExpiry :: IO (Maybe UTCTime)
checkExpiry = Just `fmap` getCurrentTime
#if !MIN_VERSION_Cabal(2,0,0)
-- | Emulate Cabal2's @mkPackageName@ constructor-function
mkPackageName :: String -> PackageName
mkPackageName = PackageName
#endif