{-
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.
-}

module Main (main) where

import qualified Codec.Archive.Tar as Tar
import qualified Codec.Compression.GZip as GZip
import Control.Concurrent
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Char
import Data.List
import Data.Maybe
import Network.HTTP
import Network.HTTP.Auth
import Network.URI
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.IO.Error
import System.Process

import Package
import Run

-- A random port, that hopefully won't clash with anything else
testPort :: Int
testPort = 8392

main :: IO ()
main = do hSetBuffering stdout LineBuffering
          info "Initialising"
          root <- getCurrentDirectory
          let testDir = "tests/HighLevelTestTemp"
          info "Setting up test directory"
          exists <- doesDirectoryExist testDir
          when exists $ removeDirectoryRecursive testDir
          createDirectory testDir
          (setCurrentDirectory testDir >> doit root)
              `finally` removeDirectoryRecursive (root </> testDir)

doit :: FilePath -> IO ()
doit root
    = do info "initialising hackage database"
         runServerChecked True root ["init"]
         withServerRunning root $ do validate (mkUrl "/")
                                     validate (mkUrl "/accounts.html")
                                     validate (mkUrl "/admin.html")
                                     validate (mkUrl "/upload.html")
                                     runUserTests
                                     runPackageUploadTests
                                     runPackageTests
         withServerRunning root $ runPackageTests
         info "Making database backup"
         runServerChecked False root ["backup", "-o", "hlb.tar"]
         info "Removing old state"
         removeDirectoryRecursive "state"
         info "Checking server doesn't work"
         mec <- runServer True 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"
         runServerChecked False root ["restore", "hlb.tar"]
         info "Making another database backup"
         runServerChecked False root ["backup", "-o", "hlb2.tar"]
         info "Checking databases match"
         db1 <- LBS.readFile "hlb.tar"
         db2 <- LBS.readFile "hlb2.tar"
         unless (db1 == db2) $ die "Databases don't match"
         info "Checking server still works, and data is intact"
         withServerRunning root $ runPackageTests

withServerRunning :: FilePath -> IO () -> IO ()
withServerRunning root f
    = do info "Forking server thread"
         mv <- newEmptyMVar
         bracket (forkIO (do info "Server thread started"
                             void $ runServer True root serverRunningArgs
                          `finally` putMVar mv ()))
                 (\t -> do killThread t
                           takeMVar mv
                           info "Server terminated")
                 (\_ -> do waitForServer
                           info "Server running"
                           f
                           info "Finished with server")

serverRunningArgs :: [String]
serverRunningArgs = ["run", "--disable-caches", "--ip", "127.0.0.1", "--port", show testPort]

runUserTests :: IO ()
runUserTests = do
    do info "Getting user list"
       xs <- getUrlStrings "/users/"
       unless (xs == ["Hackage users","admin"]) $
           die ("Bad user list: " ++ show xs)
    do info "Getting admin user list"
       xs <- getUrlStrings "/users/admins/"
       unless (xs == ["Hackage admins","[","edit","]","admin"]) $
           die ("Bad admin user list: " ++ show xs)
    do info "Creating user"
       postToUrl "/users/" [("username", "testuser"),
                            ("password", "testpass"),
                            ("repeat-password", "testpass")]
    do info "Creating user2"
       postToUrl "/users/" [("username", "testuser2"),
                            ("password", "testpass2"),
                            ("repeat-password", "testpass2")]
    do info "Checking new users are now in user list"
       xs <- getUrlStrings "/users/"
       unless (xs == ["Hackage users","admin","testuser","testuser2"]) $
           die ("Bad user list: " ++ show xs)
    do info "Checking new users are not in admin list"
       xs <- getUrlStrings "/users/admins/"
       unless (xs == ["Hackage admins","[","edit","]","admin"]) $
           die ("Bad admin user list: " ++ show xs)
    do info "Getting password change page for testuser"
       void $ getAuthUrlStrings "testuser" "testpass" "/user/testuser/password"
    do info "Getting password change page for testuser as an admin"
       void $ getAuthUrlStrings "admin" "admin" "/user/testuser/password"
    do info "Getting password change page for testuser as another user"
       checkForbiddenUrl "testuser2" "testpass2" "/user/testuser/password"
    do info "Getting password change page for testuser with bad password"
       checkUnauthedUrl "testuser" "badpass" "/user/testuser/password"
    do info "Getting password change page for testuser with bad username"
       checkUnauthedUrl "baduser" "testpass" "/user/testuser/password"
    do info "Changing password for testuser2"
       void $ postAuthToUrl "testuser2" "testpass2" "/user/testuser2/password"
                  [("password", "newtestpass2"),
                   ("repeat-password", "newtestpass2"),
                   ("_method", "PUT")]
    do info "Checking password has changed"
       void $ getAuthUrlStrings "testuser2" "newtestpass2"
                                "/user/testuser2/password"
       checkUnauthedUrl "testuser2" "testpass2" "/user/testuser2/password"
    do info "Trying to delete testuser2 as testuser2"
       deleteUrlRes ((4, 0, 3) ==) "testuser2" "newtestpass2" "/user/testuser2"
       xs <- getUrlStrings "/users/"
       unless (xs == ["Hackage users","admin","testuser","testuser2"]) $
           die ("Bad user list: " ++ show xs)
    do info "Deleting testuser2 as admin"
       deleteUrlRes ((2, 0, 0) ==) "admin" "admin" "/user/testuser2"
       xs <- getUrlStrings "/users/"
       unless (xs == ["Hackage users","admin","testuser"]) $
           die ("Bad user list: " ++ show xs)
    do info "Getting user info for testuser"
       xs <- getUrlStrings "/user/testuser"
       unless (xs == ["testuser"]) $
           die ("Bad user info: " ++ show xs)

runPackageUploadTests :: IO ()
runPackageUploadTests = do
    do info "Getting package list"
       xs <- getUrlStrings "/packages/"
       unless (xs == ["Packages by category","Categories:","."]) $
           die ("Bad package list: " ++ show xs)
    do info "Trying to upload testpackage"
       void $ postFileAuthToUrlRes ((4, 0, 3) ==)
                  "testuser" "testpass" "/packages/" "package"
                  (testpackageTarFilename, testpackageTarFileContent)
    do info "Adding testuser to uploaders"
       void $ postAuthToUrl "admin" "admin" "/packages/uploaders/"
                  [("user", "testuser")]
    do info "Uploading testpackage"
       void $ postFileAuthToUrlRes ((2, 0, 0) ==)
                  "testuser" "testpass" "/packages/" "package"
                  (testpackageTarFilename, testpackageTarFileContent)
    where (testpackageTarFilename, testpackageTarFileContent, _, _, _, _)
              = testpackage

runPackageTests :: IO ()
runPackageTests = do
    do info "Getting package list"
       xs <- getUrlStrings "/packages/"
       unless (xs == ["Packages by category",
                      "Categories:","MyCategory","&nbsp;(1).",
                      "MyCategory",
                      "testpackage","library: test package testpackage"]) $
           die ("Bad package list: " ++ show xs)
    do info "Getting package index"
       targz <- getUrl "/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 testpackage info"
       xs <- getUrlStrings "/package/testpackage"
       unless (take 1 xs == ["The testpackage package"]) $
           die ("Bad package info: " ++ show xs)
    do info "Getting testpackage-1.0.0.0 info"
       xs <- getUrlStrings "/package/testpackage-1.0.0.0"
       unless (take 1 xs == ["The testpackage package"]) $
           die ("Bad package info: " ++ show xs)
    do info "Getting testpackage Cabal file"
       cabalFile <- getUrl "/package/testpackage-1.0.0.0/testpackage.cabal"
       unless (cabalFile == testpackageCabalFile) $
           die "Bad Cabal file"
    do info "Getting testpackage tar file"
       tarFile <- getUrl "/package/testpackage/testpackage-1.0.0.0.tar.gz"
       unless (tarFile == testpackageTarFileContent) $
           die "Bad tar file"
    do info "Getting testpackage source"
       hsFile <- getUrl ("/package/testpackage/src"
                     </> testpackageHaskellFilename)
       unless (hsFile == testpackageHaskellFileContent) $
           die "Bad Haskell file"
    do info "Getting testpackage maintainer info"
       xs <- getUrlStrings "/package/testpackage/maintainers/"
       unless (xs == ["Maintainers for", "testpackage",
                      "Maintainers for a package can upload new versions and adjust other attributes in the package database.",
                      "[","edit","]",
                      "testuser"]) $
           die "Bad maintainers list"
    where (_,                             testpackageTarFileContent,
           testpackageCabalIndexFilename, testpackageCabalFile,
           testpackageHaskellFilename,    testpackageHaskellFileContent)
              = testpackage

testpackage :: (FilePath, String, FilePath, String, FilePath, String)
testpackage = mkPackage "testpackage"

getUrl :: String -> IO String
getUrl relPath = getReq (getRequest (mkUrl relPath))

getUrlStrings :: String -> IO [String]
getUrlStrings relPath = do validate url
                           getReqStrings (getRequest url)
    where url = mkUrl relPath

getAuthUrlStrings :: String -> String -> String -> IO [String]
getAuthUrlStrings u p relPath
    = do validate $ mkAuthUrl u p relPath
         withAuth u p (getRequest (mkUrl relPath)) getReqStrings

checkForbiddenUrl :: String -> String -> String -> IO ()
checkForbiddenUrl u p url = withAuth u p (getRequest (mkUrl url)) $
                            checkReqGivesResponse ((4, 0, 3) ==)

checkUnauthedUrl :: String -> String -> String -> IO ()
checkUnauthedUrl u p url = withAuth u p (getRequest (mkUrl url)) $
                           checkReqGivesResponse ((4, 0, 1) ==)

deleteUrlRes :: ((Int, Int, Int) -> Bool) -> String -> String -> String
             -> IO ()
deleteUrlRes wantedCode u p url = case parseURI (mkUrl url) of
                                  Nothing -> die "Bad URL"
                                  Just uri ->
                                      withAuth u p (mkRequest DELETE uri) $
                                      checkReqGivesResponse wantedCode

withAuth :: String -> String -> Request_String -> (Request_String -> IO a)
         -> IO a
withAuth u p req f = do
    res <- simpleHTTP req
    case res of
        Left e ->
            die ("Request failed: " ++ show e)
        Right rsp
         | rspCode rsp == (4, 0, 1) ->
            do let uri = rqURI req
                   hdrs = retrieveHeaders HdrWWWAuthenticate rsp
                   challenges = catMaybes $ map (headerToChallenge uri) hdrs
               auth <- case challenges of
                       [] -> die "No challenges"
                       c : _ ->
                           case c of
                           ChalBasic r ->
                               return $ AuthBasic {
                                            auSite = uri,
                                            auRealm = r,
                                            auUsername = u,
                                            auPassword = p
                                        }
                           ChalDigest r d n o _stale a q ->
                               return $ AuthDigest {
                                            auRealm = r,
                                            auUsername = u,
                                            auPassword = p,
                                            auDomain = d,
                                            auNonce = n,
                                            auOpaque = o,
                                            auAlgorithm = a,
                                            auQop = q
                                        }
               let req' = insertHeader HdrAuthorization
                                       (withAuthority auth req)
                                       req
               f req'
         | otherwise ->
            badResponse rsp

-- This is a simple HTML screen-scraping function. It skips down to
-- a div with class "content", and then returns the list of strings
-- that are in the following HTML.
getReqStrings :: Request_String -> IO [String]
getReqStrings req
    = do body <- getReq req
         let xs0 = lines body
             contentStart = ("<div id=\"content\"" `isSuffixOf`)
             xs1 = dropWhile (not . contentStart) xs0
             trim = dropWhile isSpace . reverse
                  . dropWhile isSpace . reverse
             tidy = filter (not . null) . map trim
         case getStrings 1 $ unlines xs1 of
             Nothing -> die ("Bad HTML?\n\n" ++ body)
             Just strings -> return $ tidy strings
    where isAngleBracket '<' = True
          isAngleBracket '>' = True
          isAngleBracket _   = False
          getStrings :: Integer -> String -> Maybe [String]
          getStrings 0 xs = case break isAngleBracket xs of
                            (_,    '>' : _)   -> Nothing
                            (pref, '<' : xs') -> fmap (pref :)
                                               $ getStrings 1 xs'
                            _                 -> Just [xs]
          getStrings n xs = case break isAngleBracket xs of
                            (_, '>' : xs') -> getStrings (n - 1) xs'
                            (_, '<' : xs') -> getStrings (n + 1) xs'
                            _              -> Nothing

getReq :: Request_String -> IO String
getReq req
    = do res <- simpleHTTP req
         case res of
             Left e ->
                 die ("Request failed: " ++ show e)
             Right rsp
              | rspCode rsp == (2, 0, 0) ->
                 return $ rspBody rsp
              | otherwise ->
                 badResponse rsp

mkPostReq :: String -> [(String, String)] -> Request_String
mkPostReq url vals = setRequestBody (postRequest (mkUrl url))
                                    ("application/x-www-form-urlencoded",
                                     urlEncodeVars vals)

postToUrl :: String -> [(String, String)] -> IO ()
postToUrl url vals = checkReqGivesResponse ((3, 0, 3) ==) $ mkPostReq url vals

postAuthToUrl :: String -> String -> String -> [(String, String)] -> IO ()
postAuthToUrl u p url vals
    = withAuth u p (mkPostReq url vals) (checkReqGivesResponse goodCode)
    where goodCode (3, 0, 3) = True
          goodCode (2, 0, 0) = True
          goodCode _         = False

postFileAuthToUrlRes :: ((Int, Int, Int) -> Bool)
                     -> String -> String -> String -> String
                     -> (FilePath, String)
                     -> IO ()
postFileAuthToUrlRes wantedCode u p url field file
    = postFileAuthToReqRes wantedCode u p (postRequest (mkUrl url)) field file

postFileAuthToReqRes :: ((Int, Int, Int) -> Bool)
                     -> String -> String -> Request_String -> String
                     -> (FilePath, String)
                     -> IO ()
postFileAuthToReqRes wantedCode u p req field (filename, fileContents)
    = let boundary = "--BOUNDARY"
          req' = setRequestBody req
                                ("multipart/form-data; boundary=" ++ boundary,
                                 body)
          unlines' = concat . map (++ "\r\n")
          body = unlines' ["--" ++ boundary,
                           "Content-Disposition: form-data; name=" ++ show field ++ "; filename=" ++ show filename,
                           "Content-Type: application/gzip",
                           -- Base64 encoding avoids any possibility of
                           -- the boundary clashing with the file data
                           "Content-Transfer-Encoding: base64",
                           "",
                           BS.unpack $ Base64.encode $ BS.pack fileContents,
                           "--" ++ boundary ++ "--",
                           ""]

      in withAuth u p req' (checkReqGivesResponse wantedCode)

checkReqGivesResponse :: ((Int, Int, Int) -> Bool) -> Request_String -> IO ()
checkReqGivesResponse wantedCode req
    = do res <- simpleHTTP req
         case res of
             Left e ->
                 die ("Request failed: " ++ show e)
             Right rsp
              | wantedCode (rspCode rsp) ->
                 return ()
              | otherwise ->
                 badResponse rsp

mkUrl :: String -> String
mkUrl relPath = "http://127.0.0.1:" ++ show testPort ++ relPath

mkAuthUrl :: String -> String -> String -> String
mkAuthUrl u p relPath = "http://" ++ u ++ ":" ++ p ++ "@127.0.0.1:" ++ show testPort ++ relPath

badResponse :: Response String -> IO a
badResponse rsp = die ("Bad response code: " ++ show (rspCode rsp) ++ "\n\n"
                    ++ show rsp ++ "\n\n"
                    ++ rspBody rsp)

-- validate is in the wdg-html-validator package on Debian
validate :: String -> IO ()
validate url = do putStrLn ("HTML validating " ++ show url)
                  ec <- rawSystem "/usr/bin/validate" ["--warn", url]
                  unless (ec == ExitSuccess) $
                      die "Validate failed"

waitForServer :: IO ()
waitForServer = f 10
    where f :: Int -> IO ()
          f n = do info "Making a request to see if server is up"
                   res <- tryIOError $ simpleHTTP (getRequest (mkUrl "/"))
                   case res of
                       Right (Right rsp)
                        | rspCode rsp == (2, 0, 0) ->
                           info "Server is up"
                       _ ->
                           do when (n == 0) $ die "Server didn't come up"
                              info "Server not up yet; will try again shortly"
                              info ("(result was " ++ show res ++ ")")
                              threadDelay 100000
                              f (n - 1)

runServerChecked :: Bool -> FilePath -> [String] -> IO ()
runServerChecked withStatic root args
    = do mec <- runServer withStatic root args
         case mec of
             Just ExitSuccess -> return ()
             _ -> die "Bad exit code from server"

runServer :: Bool -> FilePath -> [String] -> IO (Maybe ExitCode)
runServer withStatic root args = run server args'
    where server = root </> "dist/build/hackage-server/hackage-server"
          args' = if withStatic
                  then ("--static-dir=" ++ root </> "static/") : args
                  else                                           args

info :: String -> IO ()
info str = putStrLn ("= " ++ str)

die :: String -> IO a
die err = do hPutStrLn stderr err
             exitFailure