BuildClient.hs

{-# LANGUAGE PatternGuards #-}
module Main (main) where

import Network.HTTP hiding (password)
import Network.Browser
import Network.URI (URI(..), parseRelativeReference, relativeTo)

import Distribution.Client
import Distribution.Client.Cron (cron, rethrowSignalsAsExceptions,
                                 Signal(..), ReceivedSignal(..))

import Distribution.Package
import Distribution.Text
import Distribution.Verbosity
import Distribution.Simple.Utils hiding (intercalate)
import Distribution.Version (Version(..))

import Data.List
import Data.Maybe
import Data.IORef
import Data.Time
import Control.Exception
import Control.Monad
import Control.Monad.Trans
import qualified Data.ByteString.Lazy as BS
import qualified Data.Set as S

import qualified Codec.Compression.GZip  as GZip
import qualified Codec.Archive.Tar       as Tar

import System.Environment
import System.Exit
import System.FilePath
import System.Directory
import System.Console.GetOpt
import System.Process
import System.IO
import System.IO.Error

import Paths_hackage_server (version)


import Data.Aeson (eitherDecode)

data Mode = Help [String]
          | Init URI [URI]
          | Stats
          | Build [PackageId]

data BuildOpts = BuildOpts {
                     bo_verbosity  :: Verbosity,
                     bo_runTime    :: Maybe NominalDiffTime,
                     bo_stateDir   :: FilePath,
                     bo_continuous :: Maybe Int,
                     bo_keepGoing  :: Bool,
                     bo_dryRun     :: Bool,
                     bo_prune      :: Bool
                 }

data BuildConfig = BuildConfig {
                       bc_srcURI   :: URI,
                       bc_auxURIs  :: [URI],
                       bc_username :: String,
                       bc_password :: String
                   }

srcName :: URI -> String
srcName uri = fromMaybe (show uri) (uriHostName uri)

installDirectory :: BuildOpts -> FilePath
installDirectory bo = bo_stateDir bo </> "tmp-install"

resultsDirectory :: BuildOpts -> FilePath
resultsDirectory bo = bo_stateDir bo </> "results"

main :: IO ()
main = topHandler $ do
    rethrowSignalsAsExceptions [SIGABRT, SIGINT, SIGQUIT, SIGTERM]
    hSetBuffering stdout LineBuffering
    args <- getArgs
    (mode, opts) <- validateOpts args

    case mode of
        Help strs ->
            do let usageHeader = intercalate "\n" [
                       "Usage: hackage-build init URL [auxiliary URLs] [options]",
                       "       hackage-build build [packages] [options]",
                       "       hackage-build stats",
                       "Options:"]
               mapM_ putStrLn $ strs
               putStrLn $ usageInfo usageHeader buildFlagDescrs
               unless (null strs) exitFailure
        Init uri auxUris -> initialise opts uri auxUris
        Stats ->
            do stateDir <- canonicalizePath $ bo_stateDir opts
               let opts' = opts {
                               bo_stateDir = stateDir
                           }
               stats opts'
        Build pkgs ->
            do stateDir <- canonicalizePath $ bo_stateDir opts
               let opts' = opts {
                               bo_stateDir = stateDir
                           }
               case bo_continuous opts' of
                 Nothing ->
                   buildOnce opts' pkgs
                 Just interval -> do
                   cron (bo_verbosity opts')
                        interval
                        (const (buildOnce opts' pkgs))
                        ()


---------------------------------
-- Initialisation & config file
--

initialise :: BuildOpts -> URI -> [URI] -> IO ()
initialise opts uri auxUris
    = do putStrLn "Enter hackage username"
         username <- getLine
         putStrLn "Enter hackage password"
         password <- getLine
         let config = BuildConfig {
                        bc_srcURI   = uri,
                        bc_auxURIs  = auxUris,
                        bc_username = username,
                        bc_password = password
                      }
         createDirectoryIfMissing False $ bo_stateDir opts
         createDirectoryIfMissing False $ resultsDirectory opts
         writeConfig opts config
         writeCabalConfig opts config

writeConfig :: BuildOpts -> BuildConfig -> IO ()
writeConfig opts BuildConfig {
                   bc_srcURI   = uri,
                   bc_auxURIs  = auxUris,
                   bc_username = username,
                   bc_password = password
                 } =
    -- [Note: Show/Read URI]
    -- Ideally we'd just be showing a BuildConfig, but URI doesn't
    -- have Show/Read, so that doesn't work. So instead, we write
    -- out a tuple containing the uri as a string, and parse it
    -- each time we read it.
    let confStr = show (show uri, map show auxUris, username, password) in
    writeFile (configFile opts) confStr

readConfig :: BuildOpts -> IO BuildConfig
readConfig opts = do
    xs <- readFile $ configFile opts
    case reads xs of
      [((uriStr, auxUriStrs, username, password), _)] ->
         case mapM validateHackageURI (uriStr : auxUriStrs) of
         -- Shouldn't happen: We check that this
         -- returns Right when we create the
         -- config file. See [Note: Show/Read URI].
           Left theError -> die theError
           Right (uri : auxUris) ->
               return $ BuildConfig {
                            bc_srcURI   = uri,
                            bc_auxURIs  = auxUris,
                            bc_username = username,
                            bc_password = password
                        }
           Right _ -> error "The impossible happened"
      _ ->
         die "Can't parse config file (maybe re-run \"hackage-build init\")"

configFile :: BuildOpts -> FilePath
configFile opts = bo_stateDir opts </> "hackage-build-config"

writeCabalConfig :: BuildOpts -> BuildConfig -> IO ()
writeCabalConfig opts config = do
    let tarballsDir  = bo_stateDir opts </> "cached-tarballs"
    writeFile (bo_stateDir opts </> "cabal-config") . unlines $
        [ "remote-repo: " ++ srcName uri ++ ":" ++ show uri
        | uri <- bc_srcURI config : bc_auxURIs config ]
     ++ [ "remote-repo-cache: " ++ tarballsDir ]
    createDirectoryIfMissing False tarballsDir


----------------------
-- Displaying status
--

data StatResult = AllVersionsBuiltOk
                | AllVersionsAttempted
                | NoneBuilt
                | SomeBuiltOk
                | SomeFailed
    deriving Eq

stats :: BuildOpts -> IO ()
stats opts = do
    config <- readConfig opts
    let verbosity = bo_verbosity opts

    notice verbosity "Initialising"

    (didFail, _, _)  <- mkPackageFailed opts

    pkgIdsHaveDocs <- getDocumentationStats verbosity config didFail
    infoStats verbosity (Just statsFile) pkgIdsHaveDocs
  where
    statsFile = bo_stateDir opts </> "stats"

infoStats :: Verbosity -> Maybe FilePath -> [DocInfo] -> IO ()
infoStats verbosity mDetailedStats pkgIdsHaveDocs = do
    nfo $ "There are "
       ++ show (length byPackage)
       ++ " packages with a total of "
       ++ show (length pkgIdsHaveDocs)
       ++ " package versions"
    nfo $ "So far we have built or attempted to built "
       ++ show (length (filter ((/= DocsNotBuilt) . docInfoHasDocs) pkgIdsHaveDocs))
       ++ " packages; only "
       ++ show (length (filter ((== DocsNotBuilt) . docInfoHasDocs) pkgIdsHaveDocs))
       ++ " left!"

    nfo "Considering the most recent version only:"
    nfo . printTable . indent $ [
        [show (length mostRecentBuilt)   , "built succesfully"]
      , [show (length mostRecentFailed)  , "failed to build"]
      , [show (length mostRecentNotBuilt), "not yet built"]
      ]

    nfo "Considering all versions:"
    nfo . printTable . indent $ [
        [count AllVersionsBuiltOk,   "all versions built successfully"]
      , [count AllVersionsAttempted, "attempted to build all versions, but some failed"]
      , [count SomeBuiltOk,          "not all versions built yet, but those that did were ok"]
      , [count SomeFailed,           "not all versions built yet, and some failures"]
      , [count NoneBuilt,            "no versions built yet"]
      ]

    case mDetailedStats of
      Nothing        -> return ()
      Just statsFile -> do
        writeFile statsFile $ printTable (["Package", "Version", "Has docs?"] : formattedStats)
        notice verbosity $ "Detailed statistics written to " ++ statsFile
  where
    -- | We avoid 'info' here because it re-wraps the text
    nfo :: String -> IO ()
    nfo str = when (verbosity >= verbose) $ putStrLn str

    byPackage :: [[DocInfo]]
    byPackage = map (sortBy (flip (comparing docInfoPackageVersion)))
              $ groupBy (equating  docInfoPackageName)
              $ sortBy  (comparing docInfoPackageName) pkgIdsHaveDocs

    mostRecentBuilt, mostRecentFailed, mostRecentNotBuilt :: [[DocInfo]]
    mostRecentBuilt    = filter ((== HasDocs)      . docInfoHasDocs . head) byPackage
    mostRecentFailed   = filter ((== DocsFailed)   . docInfoHasDocs . head) byPackage
    mostRecentNotBuilt = filter ((== DocsNotBuilt) . docInfoHasDocs . head) byPackage

    categorise :: [DocInfo] -> StatResult
    categorise ps
      | all (== HasDocs)      hd = AllVersionsBuiltOk
      | all (/= DocsNotBuilt) hd = AllVersionsAttempted
      | all (== DocsNotBuilt) hd = NoneBuilt
      | all (/= DocsFailed)   hd = SomeBuiltOk
      | otherwise                = SomeFailed
      where
        hd = map docInfoHasDocs ps

    categorised :: [StatResult]
    categorised = map categorise byPackage

    count :: StatResult -> String
    count c = show (length (filter (c ==) categorised))

    formatPkg :: [DocInfo] -> [[String]]
    formatPkg = map $ \docInfo -> [
                          display (docInfoPackageName docInfo)
                        , display (docInfoPackageVersion docInfo)
                        , show (docInfoHasDocs docInfo)
                        ]

    formattedStats :: [[String]]
    formattedStats = concatMap formatPkg byPackage

    indent :: [[String]] -> [[String]]
    indent = map ("  " :)

-- | Formats a 2D table so that everything is nicely aligned
--
-- NOTE: Expects the same number of columns in every row!
printTable :: [[String]] -> String
printTable xss = intercalate "\n"
               . map (intercalate " ")
               . map padCols
               $ xss
  where
    colWidths :: [[Int]]
    colWidths = map (map length) $ xss

    maxColWidths :: [Int]
    maxColWidths = foldr1 (\xs ys -> map (uncurry max) (zip xs ys)) colWidths

    padCols :: [String] -> [String]
    padCols cols = map (uncurry padTo) (zip maxColWidths cols)

    padTo :: Int -> String -> String
    padTo len str = str ++ replicate (len - length str) ' '

data HasDocs = HasDocs | DocsNotBuilt | DocsFailed
  deriving (Eq, Show)

data DocInfo = DocInfo {
    docInfoPackage     :: PackageIdentifier
  , docInfoHasDocs     :: HasDocs
  , docInfoIsCandidate :: Bool
  }

docInfoPackageName :: DocInfo -> PackageName
docInfoPackageName = pkgName . docInfoPackage

docInfoPackageVersion :: DocInfo -> Version
docInfoPackageVersion = pkgVersion . docInfoPackage

docInfoBaseURI :: BuildConfig -> DocInfo -> URI
docInfoBaseURI config docInfo =
  if not (docInfoIsCandidate docInfo)
    then bc_srcURI config <//> "package" </> display (docInfoPackage docInfo)
    else bc_srcURI config <//> "package" </> display (docInfoPackage docInfo) </> "candidate"

docInfoDocsURI :: BuildConfig -> DocInfo -> URI
docInfoDocsURI config docInfo = docInfoBaseURI config docInfo <//> "docs"

docInfoTarGzURI :: BuildConfig -> DocInfo -> URI
docInfoTarGzURI config docInfo = docInfoBaseURI config docInfo <//> display (docInfoPackage docInfo) <.> "tar.gz"

docInfoReports :: BuildConfig -> DocInfo -> URI
docInfoReports config docInfo = docInfoBaseURI config docInfo <//> "reports/"

getDocumentationStats :: Verbosity 
                      -> BuildConfig
                      -> (PackageId -> IO Bool)
                      -> IO [DocInfo]
getDocumentationStats verbosity config didFail = do
    notice verbosity "Downloading documentation index"
    httpSession verbosity "hackage-build" version $ do
      mPackages   <- liftM eitherDecode `liftM` requestGET' packagesUri
      mCandidates <- liftM eitherDecode `liftM` requestGET' candidatesUri

      case (mPackages, mCandidates) of
        -- Download failure
        (Nothing, _) -> fail $ "Could not download " ++ show packagesUri
        (_, Nothing) -> fail $ "Could not download " ++ show candidatesUri
        -- Decoding failure
        (Just (Left e), _) -> fail $ "Could not decode " ++ show packagesUri   ++ ": " ++ e
        (_, Just (Left e)) -> fail $ "Could not decode " ++ show candidatesUri ++ ": " ++ e
        -- Success
        (Just (Right packages), Just (Right candidates)) -> do
          packages'   <- liftIO $ mapM checkFailed packages
          candidates' <- liftIO $ mapM checkFailed candidates
          return $ map (setIsCandidate False) packages'
                ++ map (setIsCandidate True)  candidates'
  where
    packagesUri   = bc_srcURI config <//> "packages" </> "docs.json"
    candidatesUri = bc_srcURI config <//> "packages" </> "candidates" </> "docs.json"

    checkFailed :: (String, Bool) -> IO (PackageIdentifier, HasDocs)
    checkFailed (pkgId, docsBuilt) = do
      let pkgId' = fromJust (simpleParse pkgId)
      if docsBuilt
        then return (pkgId', HasDocs)
        else do failed <- didFail pkgId'
                if failed then return (pkgId', DocsFailed)
                          else return (pkgId', DocsNotBuilt)

    setIsCandidate :: Bool -> (PackageIdentifier, HasDocs) -> DocInfo
    setIsCandidate isCandidate (pId, hasDocs) = DocInfo {
        docInfoPackage     = pId
      , docInfoHasDocs     = hasDocs
      , docInfoIsCandidate = isCandidate
      }


----------------------
-- Building packages
--

buildOnce :: BuildOpts -> [PackageId] -> IO ()
buildOnce opts pkgs = keepGoing $ do
    config <- readConfig opts

    notice verbosity "Initialising"
    (has_failed, mark_as_failed, persist_failed) <- mkPackageFailed opts

    flip finally persist_failed $ do
        updatePackageIndex
        pkgIdsHaveDocs <- getDocumentationStats verbosity config has_failed
        infoStats verbosity Nothing pkgIdsHaveDocs

        -- First build all of the latest versions of each package
        -- Then go back and build all the older versions
        -- NOTE: assumes all these lists are non-empty
        let latestFirst :: [[DocInfo]] -> [DocInfo]
            latestFirst ids = map head ids ++ concatMap tail ids

        -- Find those files *not* marked as having documentation in our cache
        let toBuild :: [DocInfo]
            toBuild = filter shouldBuild
                    . latestFirst
                    . map (sortBy (flip (comparing docInfoPackageVersion)))
                    . groupBy (equating  docInfoPackageName)
                    . sortBy  (comparing docInfoPackageName)
                    $ pkgIdsHaveDocs

        notice verbosity $ show (length toBuild) ++ " package(s) to build"

        -- Try to build each of them, uploading the documentation and
        -- build reports along the way. We mark each package as having
        -- documentation in the cache even if the build fails because
        -- we don't want to keep continually trying to build a failing
        -- package!
        startTime <- getCurrentTime

        let go :: [DocInfo] -> IO ()
            go [] = return ()
            go (docInfo : toBuild') = do
              (mTgz, mRpt, logfile) <- buildPackage verbosity opts config docInfo
              case mTgz of
                Nothing -> mark_as_failed (docInfoPackage docInfo)
                Just _  -> return ()
              case mRpt of
                Just _  | bo_dryRun opts -> return ()
                Just report -> uploadResults verbosity config docInfo
                                              mTgz report logfile
                _           -> return ()

              -- We don't check the runtime until we've actually tried
              -- to build a doc, so as to ensure we make progress.
              outOfTime <- case bo_runTime opts of
                  Nothing -> return False
                  Just d  -> do
                    currentTime <- getCurrentTime
                    return $ (currentTime `diffUTCTime` startTime) > d

              if outOfTime then return ()
                           else go toBuild'

        go toBuild
  where
    shouldBuild :: DocInfo -> Bool
    shouldBuild docInfo =
        case docInfoHasDocs docInfo of
          DocsNotBuilt -> null pkgs || any (isSelectedPackage pkgid) pkgs
          _            -> False
      where
        pkgid = docInfoPackage docInfo

    -- do versionless matching if no version was given
    isSelectedPackage pkgid pkgid'@(PackageIdentifier _ (Version [] _)) =
        packageName pkgid == packageName pkgid'
    isSelectedPackage pkgid pkgid' =
        pkgid == pkgid'

    keepGoing :: IO () -> IO ()
    keepGoing act
      | bo_keepGoing opts = Control.Exception.catch act showExceptionAsWarning
      | otherwise         = act

    showExceptionAsWarning :: SomeException -> IO ()
    showExceptionAsWarning e
      -- except for signals telling us to really stop
      | Just (ReceivedSignal {}) <- fromException e
      = throwIO e

      | Just UserInterrupt <- fromException e
      = throwIO e

      | otherwise
      = do warn verbosity (show e)
           notice verbosity "Abandoning this build attempt."

    verbosity = bo_verbosity opts

    updatePackageIndex = do
      update_ec <- cabal opts "update" [] Nothing
      unless (update_ec == ExitSuccess) $
          die "Could not 'cabal update' from specified server"


-- Builds a little memoised function that can tell us whether a
-- particular package failed to build its documentation
mkPackageFailed :: BuildOpts
                -> IO (PackageId -> IO Bool, PackageId -> IO (), IO ())
mkPackageFailed opts = do
    init_failed <- readFailedCache (bo_stateDir opts)
    cache_var   <- newIORef init_failed

    let mark_as_failed pkg_id = atomicModifyIORef cache_var $ \already_failed ->
                                  (S.insert pkg_id already_failed, ())
        has_failed     pkg_id = liftM (pkg_id `S.member`) $ readIORef cache_var
        persist               = readIORef cache_var >>= writeFailedCache (bo_stateDir opts)

    return (has_failed, mark_as_failed, persist)
  where
    readFailedCache :: FilePath -> IO (S.Set PackageId)
    readFailedCache cache_dir = do
        pkgstrs <- handleDoesNotExist (return []) $ liftM lines $ readFile (cache_dir </> "failed")
        case validatePackageIds pkgstrs of
            Left theError -> die theError
            Right pkgs -> return (S.fromList pkgs)

    writeFailedCache :: FilePath -> S.Set PackageId -> IO ()
    writeFailedCache cache_dir pkgs =
      writeFile (cache_dir </> "failed") $ unlines $ map display $ S.toList pkgs


-- | Build documentation and return @(Just tgz)@ for the built tgz file
-- on success, or @Nothing@ otherwise.
buildPackage :: Verbosity -> BuildOpts -> BuildConfig
             -> DocInfo
             -> IO (Maybe FilePath, Maybe FilePath, FilePath)
buildPackage verbosity opts config docInfo = do
    let pkgid = docInfoPackage docInfo
    notice verbosity ("Building " ++ display pkgid)
    handleDoesNotExist (return ()) $
        removeDirectoryRecursive $ installDirectory opts
    createDirectory $ installDirectory opts

    -- Create the local package db
    let packageDb = installDirectory opts </> "packages.db"
    -- TODO: use Distribution.Simple.Program.HcPkg
    ph <- runProcess "ghc-pkg"
                     ["init", packageDb]
                     Nothing Nothing Nothing Nothing Nothing
    init_ec <- waitForProcess ph
    unless (init_ec == ExitSuccess) $
        die $ "Could not initialise the package db " ++ packageDb

    -- The documentation is installed within the stateDir because we
    -- set a prefix while installing
    let doc_root     = installDirectory opts </> "haddocks"
        doc_dir_tmpl = doc_root </> "$pkgid-docs"
        doc_dir_pkg  = doc_root </> display pkgid ++ "-docs"
--        doc_dir_html = doc_dir </> "html"
--        deps_doc_dir = doc_dir </> "deps"
--        temp_doc_dir = doc_dir </> display (docInfoPackage docInfo) ++ "-docs"
        pkg_url      = "/package" </> "$pkg-$version"
        pkg_flags    =
            ["--enable-documentation",
             "--htmldir=" ++ doc_dir_tmpl,
             -- We only care about docs, so we want to build as
             -- quickly as possible, and hence turn
             -- optimisation off. Also explicitly pass -O0 as a
             -- GHC option, in case it overrides a .cabal
             -- setting or anything
             "--disable-optimization", "--ghc-option", "-O0",
             "--disable-library-for-ghci",
             -- We don't want packages installed in the user
             -- package.conf to affect things. In particular,
             -- we don't want doc building to fail because
             -- "packages are likely to be broken by the reinstalls"
             "--package-db=clear", "--package-db=global",
             "--package-db=" ++ packageDb,
             -- We know where this documentation will
             -- eventually be hosted, bake that in.
             -- The wiki claims we shouldn't include the
             -- version in the hyperlinks so we don't have
             -- to rehaddock some package when the dependent
             -- packages get updated. However, this is NOT
             -- what the Hackage v1 did, so ignore that:
             "--haddock-html-location=" ++ pkg_url </> "docs",
             -- Link "Contents" to the package page:
             "--haddock-contents-location=" ++ pkg_url,
             -- Link to colourised source code:
             "--haddock-hyperlink-source",
             "--prefix=" ++ installDirectory opts,
             "--build-summary=" ++ installDirectory opts </> "reports" </> "$pkgid.report",
             -- We want both html documentation and hoogle database generated
             "--haddock-html",
             "--haddock-hoogle",
             -- For candidates we need to use the full URL, because
             -- otherwise cabal-install will not find the package.
             -- For regular packages however we need to use just the
             -- package name, otherwise cabal-install will not
             -- generate a report
             if docInfoIsCandidate docInfo
               then show (docInfoTarGzURI config docInfo)
               else display pkgid
             ]

    -- The installDirectory is purely temporary, while the resultsDirectory is
    -- more persistent. We will grab various outputs from the tmp dir and stash
    -- them for safe keeping (for later upload or manual inspection) in the
    -- results dir.
    let resultDir         = resultsDirectory opts
        resultLogFile     = resultDir </> display pkgid <.> "log"
        resultReportFile  = resultDir </> display pkgid <.> "report"
        resultDocsTarball = resultDir </> (display pkgid ++ "-docs") <.> "tar.gz"

    buildLogHnd <- openFile resultLogFile WriteMode

    -- We ignore the result of calling @cabal install@ because
    -- @cabal install@ succeeds even if the documentation fails to build.
    void $ cabal opts "install" pkg_flags (Just buildLogHnd)

    -- Grab the report for the package we want. Stash it for safe keeping.
    report <- handleDoesNotExist (return Nothing) $ do
                renameFile (installDirectory opts </> "reports"
                                </> display pkgid <.> "report")
                           resultReportFile
                return (Just resultReportFile)

    docs_generated <- fmap and $ sequence [
        doesDirectoryExist doc_dir_pkg,
        doesFileExist (doc_dir_pkg </> "doc-index.html"),
        doesFileExist (doc_dir_pkg </> display (docInfoPackageName docInfo) <.> "haddock")]
    docs <- if docs_generated
              then do
                when (bo_prune opts) (pruneHaddockFiles doc_dir_pkg)
                BS.writeFile resultDocsTarball =<< tarGzDirectory doc_dir_pkg
                return (Just resultDocsTarball)
              else return Nothing

    notice verbosity $ unlines
      [ "Build results for " ++ display pkgid ++ ":"
      , fromMaybe "no report" report
      , fromMaybe "no docs" docs
      , resultLogFile
      ]

    return (docs, report, resultLogFile)


cabal :: BuildOpts -> String -> [String] -> Maybe Handle -> IO ExitCode
cabal opts cmd args moutput = do
    let verbosity = bo_verbosity opts
        cabalConfigFile = bo_stateDir opts </> "cabal-config"
        verbosityArgs = if verbosity == silent
                        then ["-v0"]
                        else []
        all_args = ("--config-file=" ++ cabalConfigFile)
                 : cmd
                 : verbosityArgs
                ++ args
    info verbosity $ unwords ("cabal":all_args)
    ph <- runProcess "cabal" all_args Nothing
                     Nothing Nothing moutput moutput
    waitForProcess ph

pruneHaddockFiles :: FilePath -> IO ()
pruneHaddockFiles dir = do
    -- Hackage doesn't support the haddock frames view, so remove it
    -- both visually (no frames link) and save space too.
    files <- getDirectoryContents dir
    sequence_
      [ removeFile (dir </> file)
      | file <- files
      , unwantedFile file ]
    hackJsUtils
  where
    unwantedFile file
      | "frames.html" == file             = True 
      | "mini_" `isPrefixOf` file         = True
        -- The .haddock file is haddock-version specific
        -- so it is not useful to make available for download
      | ".haddock" <- takeExtension file  = True
      | otherwise                         = False

    -- The "Frames" link is added by the JS, just comment it out.
    hackJsUtils = do
      content <- readFile (dir </> "haddock-util.js")
      _ <- evaluate (length content)
      writeFile (dir </> "haddock-util.js") (munge content)
      where
        munge = unlines
              . map removeAddMenuItem
              . lines
        removeAddMenuItem l | (sp, l') <- span (==' ') l
                            , "addMenuItem" `isPrefixOf` l'
                            = sp ++ "//" ++ l'
        removeAddMenuItem l = l


tarGzDirectory :: FilePath -> IO BS.ByteString
tarGzDirectory dir = do
    res <- liftM (GZip.compress . Tar.write) $
               Tar.pack containing_dir [nested_dir]
    -- This seq is extremely important! Tar.pack is lazy, scanning
    -- directories as entries are demanded.
    -- This interacts very badly with the renameDirectory stuff with
    -- which tarGzDirectory gets wrapped.
    BS.length res `seq` return res
  where (containing_dir, nested_dir) = splitFileName dir

uploadResults :: Verbosity -> BuildConfig -> DocInfo
              -> Maybe FilePath -> FilePath -> FilePath -> IO ()
uploadResults verbosity config docInfo
              mdocsTarballFile buildReportFile buildLogFile =
    httpSession verbosity "hackage-build" version $ do
      -- Make sure we authenticate to Hackage
      setAuthorityGen (provideAuthInfo (bc_srcURI config)
                                       (Just (bc_username config, bc_password config)))
      case mdocsTarballFile of
        Nothing              -> return ()
        Just docsTarballFile ->
          putDocsTarball config docInfo docsTarballFile

      buildId <- postBuildReport config docInfo buildReportFile
      putBuildLog buildId buildLogFile

putDocsTarball :: BuildConfig -> DocInfo -> FilePath -> HttpSession ()
putDocsTarball config docInfo docsTarballFile =
    requestPUTFile (docInfoDocsURI config docInfo)
      "application/x-tar" (Just "gzip") docsTarballFile

type BuildReportId = URI

postBuildReport :: BuildConfig -> DocInfo -> FilePath -> HttpSession BuildReportId
postBuildReport config docInfo reportFile = do
    let uri = docInfoReports config docInfo
    body <- liftIO $ BS.readFile reportFile
    setAllowRedirects False
    (_, response) <- request Request {
      rqURI     = uri,
      rqMethod  = POST,
      rqHeaders = [Header HdrContentType   ("text/plain"),
                   Header HdrContentLength (show (BS.length body)),
                   Header HdrAccept        ("text/plain")],
      rqBody    = body
    }
    case rspCode response of
      --TODO: fix server to not do give 303, 201 is more appropriate
      (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location
                                       return $ relativeTo rel uri
                                  | Header HdrLocation location <- rspHeaders response ]
                -> return buildId
      _         -> do checkStatus uri response
                      fail "Unexpected response from server."

putBuildLog :: BuildReportId -> FilePath -> HttpSession ()
putBuildLog reportId buildLogFile = do
    body <- liftIO $ BS.readFile buildLogFile
    let uri = reportId <//> "log"
    setAllowRedirects False
    (_, response) <- request Request {
        rqURI     = uri,
        rqMethod  = PUT,
        rqHeaders = [Header HdrContentType   ("text/plain"),
                     Header HdrContentLength (show (BS.length body)),
                     Header HdrAccept        ("text/plain")],
        rqBody    = body
      }
    case rspCode response of
      --TODO: fix server to not to give 303, 201 is more appropriate
      (3,0,3)   -> return ()
      _         -> checkStatus uri response


-------------------------
-- Command line handling
-------------------------

data BuildFlags = BuildFlags {
    flagCacheDir   :: Maybe FilePath,
    flagVerbosity  :: Verbosity,
    flagRunTime    :: Maybe NominalDiffTime,
    flagHelp       :: Bool,
    flagForce      :: Bool,
    flagContinuous :: Bool,
    flagKeepGoing  :: Bool,
    flagDryRun     :: Bool,
    flagInterval   :: Maybe String,
    flagPrune      :: Bool
}

emptyBuildFlags :: BuildFlags
emptyBuildFlags = BuildFlags {
    flagCacheDir   = Nothing
  , flagVerbosity  = normal
  , flagRunTime    = Nothing
  , flagHelp       = False
  , flagForce      = False
  , flagContinuous = False
  , flagKeepGoing  = False
  , flagDryRun     = False
  , flagInterval   = Nothing
  , flagPrune      = False
  }

buildFlagDescrs :: [OptDescr (BuildFlags -> BuildFlags)]
buildFlagDescrs =
  [ Option ['h'] ["help"]
      (NoArg (\opts -> opts { flagHelp = True }))
      "Show this help text"

  , Option ['s'] []
      (NoArg (\opts -> opts { flagVerbosity = silent }))
      "Silent mode"

  , Option ['v'] []
      (NoArg (\opts -> opts { flagVerbosity = moreVerbose (flagVerbosity opts) }))
      "Verbose mode (can be listed multiple times e.g. -vv)"

  , Option [] ["run-time"]
      (ReqArg (\mins opts -> case reads mins of
                             [(mins', "")] -> opts { flagRunTime = Just (fromInteger mins' * 60) }
                             _ -> error "Can't parse minutes") "MINS")
      "Limit the running time of the build client"

  , Option [] ["cache-dir"]
      (ReqArg (\dir opts -> opts { flagCacheDir = Just dir }) "DIR")
      "Where to put files during building"

  , Option [] ["continuous"]
      (NoArg (\opts -> opts { flagContinuous = True }))
      "Build continuously rather than just once"

  , Option [] ["keep-going"]
      (NoArg (\opts -> opts { flagKeepGoing = True }))
      "Keep going after errors"

  , Option [] ["dry-run"]
      (NoArg (\opts -> opts { flagDryRun = True }))
      "Don't record results or upload"

  , Option [] ["interval"]
      (ReqArg (\int opts -> opts { flagInterval = Just int }) "MIN")
      "Set the building interval in minutes (default 30)"

  , Option [] ["prune-haddock-files"]
      (NoArg (\opts -> opts { flagPrune = True }))
      "Remove unnecessary haddock files (frames, .haddock file)"
  ]

validateOpts :: [String] -> IO (Mode, BuildOpts)
validateOpts args = do
    let (flags0, args', errs) = getOpt Permute buildFlagDescrs args
        flags = accum flags0 emptyBuildFlags

        stateDir = fromMaybe "build-cache" (flagCacheDir flags)

        opts = BuildOpts {
                   bo_verbosity  = flagVerbosity flags,
                   bo_runTime    = flagRunTime flags,
                   bo_stateDir   = stateDir,
                   bo_continuous = case (flagContinuous flags, flagInterval flags) of
                                     (True, Just i)  -> Just (read i)
                                     (True, Nothing) -> Just 30 -- default interval
                                     (False, _)      -> Nothing,
                   bo_keepGoing  = flagKeepGoing flags,
                   bo_dryRun     = flagDryRun flags,
                   bo_prune      = flagPrune flags
               }

        mode = case args' of
               _ | flagHelp flags -> Help []
                 | not (null errs) -> Help errs
               "init" : uriStr : auxUriStrs ->
                   -- We don't actually want the URI at this point
                   -- (see [Note: Show/Read URI])
                   case mapM validateHackageURI (uriStr : auxUriStrs) of
                     Left  theError      -> Help [theError]
                     Right (uri:auxUris) -> Init uri auxUris
                     Right _             -> error "impossible"
               ["stats"] ->
                   Stats
               "stats" : _ ->
                   Help ["stats takes no arguments"]
               "build" : pkgstrs ->
                   case validatePackageIds pkgstrs of
                   Left  theError -> Help [theError]
                   Right pkgs     -> Build pkgs
               cmd : _ -> Help ["Unrecognised command: " ++ show cmd]
               [] -> Help []

    -- Ensure we store the absolute state_dir, because we might
    -- change the CWD later and we don't want the stateDir to be
    -- invalidated by such a change
    --
    -- We have to ensure the directory exists before we do
    -- canonicalizePath, or otherwise we get an exception if it
    -- does not yet exist

    return (mode, opts)

  where

    accum flags = foldr (flip (.)) id flags

{------------------------------------------------------------------------------
  Auxiliary
------------------------------------------------------------------------------}

handleDoesNotExist :: IO a -> IO a -> IO a
handleDoesNotExist handler act
    = handleJust (\e -> if isDoesNotExistError e then Just () else Nothing)
                 (\() -> handler)
                 act