hackage-server-0.5.0: tests/HighLevelTest.hs
{-
This is a very high-level test of the hackage server. It forks a fresh server
instance, and then uses HTTP to run various requests on that server.
System requirements:
1. Port `testPort` (currently 8392) must be available on localhost
2. You must allow for outgoing HTTP traffic, as we POST to html5.validator.nu
for HTML validation.
-}
module Main (main) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Compression.GZip as GZip
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.List (isInfixOf)
import Data.String ()
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import Package
import Util
import HttpUtils ( isOk
, isNoContent
, isForbidden
, Authorization(..)
)
import HackageClientUtils
main :: IO ()
main = do hSetBuffering stdout LineBuffering
info "Initialising"
root <- getCurrentDirectory
info "Setting up test directory"
exists <- doesDirectoryExist (testDir root)
when exists $ removeDirectoryRecursive (testDir root)
createDirectory (testDir root)
(setCurrentDirectory (testDir root) >> doit root)
`finally` removeDirectoryRecursive (testDir root)
testName :: FilePath
testName = "HighLevelTestTemp"
testDir :: FilePath -> FilePath
testDir root = root </> "tests" </> testName
doit :: FilePath -> IO ()
doit root
= do info "initialising hackage database"
runServerChecked root ["init"]
withServerRunning root $ do void $ validate NoAuth "/"
void $ validate NoAuth "/accounts"
void $ validate (Auth "admin" "admin") "/admin"
void $ validate NoAuth "/upload"
runUserTests
runPackageUploadTests
runPackageTests
withServerRunning root $ runPackageTests
info "Making database backup"
tarGz1 <- createBackup testName root "1"
info "Removing old state"
removeDirectoryRecursive "state"
info "Checking server doesn't work"
mec <- runServer root serverRunningArgs
case mec of
Just (ExitFailure 1) -> return ()
Just (ExitFailure _) -> die "Server failed with wrong exit code"
Just ExitSuccess -> die "Server worked unexpectedly"
Nothing -> die "Got a signal?"
info $ "Restoring database from " ++ tarGz1
runServerChecked root ["restore", tarGz1]
info "Making another database backup"
tarGz2 <- createBackup testName root "2"
info "Checking databases match"
db1 <- LBS.readFile tarGz1
db2 <- LBS.readFile tarGz2
unless (db1 == db2) $ die "Databases don't match"
info "Checking server still works, and data is intact"
withServerRunning root $ runPackageTests
runUserTests :: IO ()
runUserTests = do
do info "Getting user list"
xs <- fmap (map userName) getUsers
unless (xs == ["admin"]) $
die ("Bad user list: " ++ show xs)
do info "Getting admin user list"
xs <- getAdmins
unless (map userName (groupMembers xs) == ["admin"]) $
die ("Bad admin user list: " ++ show xs)
do -- For this test we just create the users directly using the admin
-- interface, there's a separate test that tests the self-signup.
createUserDirect (Auth "admin" "admin") "HackageTestUser1" "testpass1"
createUserDirect (Auth "admin" "admin") "HackageTestUser2" "testpass2"
do info "Checking new users are now in user list"
xs <- fmap (map userName) getUsers
unless (xs == ["admin","HackageTestUser1","HackageTestUser2"]) $
die ("Bad user list: " ++ show xs)
do info "Checking new users are not in admin list"
xs <- getAdmins
unless (map userName (groupMembers xs) == ["admin"]) $
die ("Bad admin user list: " ++ show xs)
do info "Getting password change page for HackageTestUser1"
void $ validate (Auth "HackageTestUser1" "testpass1") "/user/HackageTestUser1/password"
do info "Getting password change page for HackageTestUser1 as an admin"
void $ validate (Auth "admin" "admin") "/user/HackageTestUser1/password"
do info "Getting password change page for HackageTestUser1 as another user"
checkIsForbidden (Auth "HackageTestUser2" "testpass2") "/user/HackageTestUser1/password"
do info "Getting password change page for HackageTestUser1 with bad password"
checkIsUnauthorized (Auth "HackageTestUser1" "badpass") "/user/HackageTestUser1/password"
do info "Getting password change page for HackageTestUser1 with bad username"
checkIsUnauthorized (Auth "baduser" "testpass1") "/user/HackageTestUser1/password"
do info "Changing password for HackageTestUser2"
post (Auth "HackageTestUser2" "testpass2") "/user/HackageTestUser2/password" [
("password", "newtestpass2")
, ("repeat-password", "newtestpass2")
, ("_method", "PUT")
]
do info "Checking password has changed"
void $ validate (Auth "HackageTestUser2" "newtestpass2") "/user/HackageTestUser2/password"
checkIsUnauthorized (Auth "HackageTestUser2" "testpass2") "/user/HackageTestUser2/password"
do info "Trying to delete HackageTestUser2 as HackageTestUser2"
delete isForbidden (Auth "HackageTestUser2" "newtestpass2") "/user/HackageTestUser2"
xs <- fmap (map userName) getUsers
unless (xs == ["admin","HackageTestUser1","HackageTestUser2"]) $
die ("Bad user list: " ++ show xs)
do info "Deleting HackageTestUser2 as admin"
delete isNoContent (Auth "admin" "admin") "/user/HackageTestUser2"
xs <- fmap (map userName) getUsers
unless (xs == ["admin","HackageTestUser1"]) $
die ("Bad user list: " ++ show xs)
do info "Getting user info for HackageTestUser1"
xs <- validate NoAuth "/user/HackageTestUser1"
--TODO: set the user's real name, and then look for that here
unless ("HackageTestUser1" `isInfixOf` xs) $
die ("Bad user info: " ++ show xs)
runPackageUploadTests :: IO ()
runPackageUploadTests = do
do info "Getting package list"
xs <- map packageName `liftM` getPackages
unless (xs == []) $
die ("Bad package list: " ++ show xs)
do info "Trying to upload testpackage"
postFile isForbidden
(Auth "HackageTestUser1" "testpass1")
"/packages/" "package"
(testpackageTarFilename, testpackageTarFileContent)
do info "Adding HackageTestUser1 to uploaders"
post (Auth "admin" "admin") "/packages/uploaders/" [
("user", "HackageTestUser1")
]
do info "Uploading testpackage"
postFile isOk
(Auth "HackageTestUser1" "testpass1")
"/packages/" "package"
(testpackageTarFilename, testpackageTarFileContent)
where
(testpackageTarFilename, testpackageTarFileContent, _, _, _, _) =
testpackage
runPackageTests :: IO ()
runPackageTests = do
do info "Getting package list"
xs <- map packageName `liftM` getPackages
unless (xs == ["testpackage"]) $
die ("Bad package list: " ++ show xs)
do info "Getting package index"
targz <- getUrl NoAuth "/packages/index.tar.gz"
let tar = GZip.decompress $ LBS.pack targz
entries = Tar.foldEntries (:) [] (error . show) $ Tar.read tar
entryFilenames = map Tar.entryPath entries
entryContents = map Tar.entryContent entries
unless (entryFilenames == [testpackageCabalIndexFilename]) $
die ("Bad index filenames: " ++ show entryFilenames)
case entryContents of
[Tar.NormalFile bs _]
| LBS.unpack bs == testpackageCabalFile ->
return ()
_ ->
die "Bad index contents"
do info "Getting package index with etag"
validateETagHandling "/packages/index.tar.gz"
do info "Getting testpackage info"
xs <- validate NoAuth "/package/testpackage"
unless ("The testpackage package" `isInfixOf` xs) $
die ("Bad package info: " ++ show xs)
do info "Getting testpackage-1.0.0.0 info"
xs <- validate NoAuth "/package/testpackage-1.0.0.0"
unless ("The testpackage package" `isInfixOf` xs) $
die ("Bad package info: " ++ show xs)
do info "Getting testpackage Cabal file"
cabalFile <- getUrl NoAuth "/package/testpackage-1.0.0.0/testpackage.cabal"
unless (cabalFile == testpackageCabalFile) $
die "Bad Cabal file"
do info "Getting testpackage tar file"
tarFile <- getUrl NoAuth "/package/testpackage/testpackage-1.0.0.0.tar.gz"
unless (tarFile == testpackageTarFileContent) $
die "Bad tar file"
do info "Getting testpackage source"
hsFile <- getUrl NoAuth ("/package/testpackage/src" </> testpackageHaskellFilename)
unless (hsFile == testpackageHaskellFileContent) $
die "Bad Haskell file"
do info "Getting testpackage source with etag"
validateETagHandling ("/package/testpackage/src" </> testpackageHaskellFilename)
do info "Getting testpackage maintainer info"
xs <- getGroup "/package/testpackage/maintainers/.json"
unless (map userName (groupMembers xs) == ["HackageTestUser1"]) $
die "Bad maintainers list"
where
(_, testpackageTarFileContent,
testpackageCabalIndexFilename, testpackageCabalFile,
testpackageHaskellFilename, testpackageHaskellFileContent)
= testpackage
testpackage :: (FilePath, String, FilePath, String, FilePath, String)
testpackage = mkPackage "testpackage"