packages feed

hackage-server (empty) → 0.4

raw patch · 139 files changed

+25844/−0 lines, 139 filesdep +Cabaldep +HStringTemplatedep +HTTPsetup-changedbinary-added

Dependencies added: Cabal, HStringTemplate, HTTP, acid-state, aeson, array, async, attoparsec, base, base16-bytestring, base64-bytestring, binary, blaze-builder, bytestring, cereal, containers, crypto-api, csv, deepseq, directory, filepath, happstack-server, hscolour, hslogger, lifted-base, mime-mail, mtl, network, old-locale, parsec, pretty, process, pureMD5, random, rss, safecopy, snowball, split, stm, tar, text, time, tokenize, transformers, unix, unordered-containers, vector, xhtml, zlib

Files

+ BuildClient.hs view
@@ -0,0 +1,774 @@+{-# LANGUAGE PatternGuards #-}+module Main (main) where++import Network.Browser+import Network.URI (URI(..), URIAuth(..))++import Distribution.Client+import Distribution.Client.Cron (cron, rethrowSignalsAsExceptions, Signal(..))++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 Data.Aeson (eitherDecode)++data Mode = Help [String]+          | Init String+          | Stats+          | Build [PackageId]++data BuildOpts = BuildOpts {+                     bo_verbosity  :: Verbosity,+                     bo_runTime    :: Maybe NominalDiffTime,+                     bo_stateDir   :: FilePath,+                     bo_continuous :: Maybe Int,+                     bo_keepGoing  :: Bool+                 }++data BuildConfig = BuildConfig {+                       bc_srcURI   :: URI,+                       bc_username :: String,+                       bc_password :: String+                   }++srcName :: BuildConfig -> String+srcName config = fromMaybe (show (bc_srcURI config))+                           (uriHostName (bc_srcURI config))++installDirectory :: BuildOpts -> FilePath+installDirectory bo = bo_stateDir bo </> "inst"++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 [options]",+                       "       hackage-build build [packages] [options]",+                       "       hackage-build stats",+                       "Options:"]+               mapM_ putStrLn $ strs+               putStrLn $ usageInfo usageHeader buildFlagDescrs+               unless (null strs) exitFailure+        Init uri -> initialise opts uri+        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))+                        ()++initialise :: BuildOpts -> String -> IO ()+initialise opts uriStr+    = do putStrLn "Enter hackage username"+         username <- getLine+         putStrLn "Enter hackage password"+         password <- getLine+         createDirectoryIfMissing False $ bo_stateDir opts+         -- [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.+         writeFile (configFile opts) (show (uriStr, username, password))++readConfig :: BuildOpts -> IO BuildConfig+readConfig opts = do xs <- readFile $ configFile opts+                     case reads xs of+                         [((uriStr, username, password), "")] ->+                             case validateHackageURI uriStr 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 ->+                                 return $ BuildConfig {+                                              bc_srcURI   = uri,+                                              bc_username = username,+                                              bc_password = password+                                          }+                         _ ->+                             die "Can't parse config file"++configFile :: BuildOpts -> FilePath+configFile opts = bo_stateDir opts </> "hd-config"++data StatResult = AllVersionsBuiltOk+                | AllVersionsAttempted+                | NoneBuilt+                | SomeBuiltOk+                | SomeFailed+    deriving Eq++stats :: BuildOpts -> IO ()+stats opts = do+    config <- readConfig opts+    let verbosity = bo_verbosity opts+        cacheDir = bo_stateDir opts </> cacheDirName+        cacheDirName | URI { uriAuthority = Just auth } <- bc_srcURI config+                     = makeValid (uriRegName auth ++ uriPort auth)+                     | otherwise+                     = error $ "unexpected URI " ++ show (bc_srcURI config)++    notice verbosity "Initialising"++    createDirectoryIfMissing False cacheDir+    (didFail, _, _)  <- mkPackageFailed opts++    httpSession verbosity $ do+      liftIO $ notice verbosity "Getting index"+      infoStats verbosity (Just statsFile) =<< getDocumentationStats config didFail+  where+    statsFile = bo_stateDir opts </> "stats"++infoStats :: MonadIO m => Verbosity -> Maybe FilePath -> [DocInfo] -> m ()+infoStats verbosity mDetailedStats pkgIdsHaveDocs = liftIO $ 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"++getDocumentationStats :: BuildConfig+                      -> (PackageId -> IO Bool)+                      -> HttpSession [DocInfo]+getDocumentationStats config didFail = 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+      }++buildOnce :: BuildOpts -> [PackageId] -> IO ()+buildOnce opts pkgs = keepGoing $ do+    config <- readConfig opts+    let cacheDir = bo_stateDir opts </> cacheDirName+        cacheDirName | URI { uriAuthority = Just auth } <- bc_srcURI config+                     = makeValid (uriRegName auth ++ uriPort auth)+                     | otherwise+                     = error $ "unexpected URI " ++ show (bc_srcURI config)++    notice verbosity "Initialising"+    (has_failed, mark_as_failed, persist_failed) <- mkPackageFailed opts++    createDirectoryIfMissing False cacheDir++    configFileExists <- doesFileExist (bo_stateDir opts </> "cabal-config")+    unless configFileExists $ prepareBuildPackages opts config++    flip finally persist_failed $ do+        pkgIdsHaveDocs <- httpSession verbosity $+          getDocumentationStats 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++        liftIO $ 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 <- liftIO $ getCurrentTime++        let go :: [DocInfo] -> IO ()+            go [] = return ()+            go (docInfo : toBuild') = do+              mTgz <- buildPackage verbosity opts config docInfo+              case mTgz of+                Nothing ->+                  liftIO $ mark_as_failed (docInfoPackage docInfo)+                Just docs_tgz -> httpSession verbosity $ do+                  -- Make sure we authenticate to Hackage+                  setAuthorityGen $ provideAuthInfo (bc_srcURI config)+                                  $ Just (bc_username config, bc_password config)+                  requestPUT (docInfoDocsURI config docInfo) "application/x-tar" (Just "gzip") docs_tgz++              -- 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  -> liftIO $ 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 -> docInfoPackage docInfo `elem` pkgs || null pkgs+      _            -> docInfoPackage docInfo `elem` pkgs++    keepGoing :: IO () -> IO ()+    keepGoing act+      | bo_keepGoing opts = catch act showExceptionAsWarning+      | otherwise         = act++    showExceptionAsWarning :: SomeException -> IO ()+    showExceptionAsWarning e = do+      warn verbosity (show e)+      notice verbosity "Abandoning this build attempt."++    verbosity = bo_verbosity opts++-- 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++prepareBuildPackages :: BuildOpts -> BuildConfig -> IO ()+prepareBuildPackages opts config+ = withCurrentDirectory (bo_stateDir opts) $ do+    writeFile "cabal-config" $ unlines [+        "remote-repo: " ++ srcName config ++ ":" ++ show (bc_srcURI config <//> "packages" </> "archive"),+        "remote-repo-cache: " ++ installDirectory opts </> "packages",+        "logs-dir: " ++ installDirectory opts </> "logs",+        "library-for-ghci: False",+        "package-db: " ++ installDirectory opts </> "local.conf.d",+        "documentation: True",+        "remote-build-reporting: detailed",+        -- TODO: These are currently only used for the "upload" commands+        --       only, not "report"+        "username: " ++ bc_username config,+        "password: " ++ bc_password config+      ]++-- | Build documentation and return @(Just tgz)@ for the built tgz file+-- on success, or @Nothing@ otherwise.+buildPackage :: MonadIO m+             => Verbosity -> BuildOpts -> BuildConfig+             -> DocInfo+             -> m (Maybe BS.ByteString)+buildPackage verbosity opts config docInfo = do+    liftIO $ do notice verbosity ("Building " ++ display (docInfoPackage docInfo))+                handleDoesNotExist (return ()) $+                    removeDirectoryRecursive $ installDirectory opts+                createDirectory $ installDirectory opts++                -- Create cache for the empty configuration directory+                let packageConf = installDirectory opts </> "local.conf.d"+                local_conf_d_exists <- doesDirectoryExist packageConf+                unless local_conf_d_exists $ do+                    createDirectory packageConf+                    ph <- runProcess "ghc-pkg"+                                     ["recache",+                                      "--package-conf=" ++ packageConf]+                                     Nothing Nothing Nothing Nothing Nothing+                    -- TODO: Why do we ignore the exit code here?+                    _ <- waitForProcess ph+                    return ()++                -- We don't really want to be running "cabal update"+                -- every time, but the index file and package cache+                -- end up in the same place, so when re remove the+                -- latter we also remove the former+                update_ec <- cabal opts "update" []+                unless (update_ec == ExitSuccess) $+                    die "Could not 'cabal update' from specified server"++    -- The documentation is installed within the stateDir because we+    -- set a prefix while installing+    let doc_root = installDirectory opts </> "share" </> "doc"+        doc_dir      = doc_root </> display (docInfoPackage docInfo)+        doc_dir_html = doc_dir </> "html"+        temp_doc_dir = doc_root </> display (docInfoPackage docInfo) </> display (docInfoPackage docInfo) ++ "-docs"+        pkg_url      = "/package" </> "$pkg-$version"++    liftIO $ withCurrentDirectory (installDirectory opts) $ do+        -- We CANNOT build from an unpacked directory, because Cabal+        -- only generates build reports if you are building from a+        -- tarball that was verifiably downloaded from the server++        -- We ignore the result of calling @cabal install@ because+        -- @cabal install@ succeeds even if the documentation fails to build.+        void $ cabal opts "install"+                     ["--enable-documentation",+                      -- 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",+                      -- 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"+                      "--ghc-pkg-option", "--no-user-package-conf",+                      -- 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",+                      -- Give the user a choice between themes:+                      "--haddock-option=--built-in-themes",+                      -- Link "Contents" to the package page:+                      "--haddock-contents-location=" ++ pkg_url,+                      -- Link to colourised source code:+                      "--haddock-hyperlink-source",+                      -- The docdir can differ between Cabal versions+                      "--docdir=" ++ doc_dir,+                      "--prefix=" ++ installDirectory opts,+                      -- 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 (docInfoPackage docInfo)+                      ]++        -- Remove reports for dependencies (so that we only submit the report+        -- for the package we are currently building)+        dotCabal <- getAppUserDataDirectory "cabal"+        let reportsDir = dotCabal </> "reports" </> srcName config+        handleDoesNotExist (return ()) $ withRecursiveContents_ reportsDir $ \path ->+           unless ((display (docInfoPackage docInfo) ++ ".log") `isSuffixOf` path) $+             removeFile path++        -- Submit a report even if installation/tests failed: all+        -- interesting data points!+        report_ec <- cabal opts "report"+                           ["--username", bc_username config,+                            "--password", bc_password config]++        -- Delete reports after submission because we don't want to+        -- submit them *again* in the future+        when (report_ec == ExitSuccess) $ do+            -- This seems like a bit of a mess: some data goes into the+            -- user directory:+            handleDoesNotExist (return ()) $ removeDirectoryRecursive reportsDir++            -- Other data goes into a local file storing build reports:+            let simple_report_log = installDirectory opts </> "packages" </> srcName config </> "build-reports.log"+            handleDoesNotExist (return ()) $ removeFile simple_report_log++        docs_generated <- liftM2 (&&) (doesDirectoryExist doc_dir_html)+                                      (doesFileExist (doc_dir_html </> "doc-index.html"))+        if docs_generated+            then do+                notice verbosity $ "Docs generated for " ++ display (docInfoPackage docInfo)+                liftM Just $+                    -- We need the files in the documentation .tar.gz+                    -- to have paths like foo-x.y.z-docs/index.html+                    -- Unfortunately, on disk they have paths like+                    -- foo-x.y.z/html/index.html. This hack resolves+                    -- the problem:+                    bracket_ (renameDirectory doc_dir_html temp_doc_dir)+                             (renameDirectory temp_doc_dir doc_dir_html)+                             (tarGzDirectory temp_doc_dir)+            else do+              notice verbosity $ "Docs for " ++ display (docInfoPackage docInfo) ++ " failed to build"+              return Nothing++cabal :: BuildOpts -> String -> [String] -> IO ExitCode+cabal opts cmd args = do+    cwd' <- getCurrentDirectory+    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+    notice verbosity $ "In " ++ cwd' ++ ":\n" ++ unwords ("cabal":all_args)+    ph <- runProcess "cabal" all_args (Just cwd')+                     Nothing Nothing Nothing Nothing+    waitForProcess ph++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++withCurrentDirectory :: FilePath -> IO a -> IO a+withCurrentDirectory cwd1 act+    = bracket (do cwd2 <- getCurrentDirectory+                  setCurrentDirectory cwd1+                  return cwd2)+              setCurrentDirectory+              (const act)+++-------------------------+-- Command line handling+-------------------------++data BuildFlags = BuildFlags {+    flagCacheDir   :: Maybe FilePath,+    flagVerbosity  :: Verbosity,+    flagRunTime    :: Maybe NominalDiffTime,+    flagHelp       :: Bool,+    flagForce      :: Bool,+    flagContinuous :: Bool,+    flagKeepGoing  :: Bool,+    flagInterval   :: Maybe String+}++emptyBuildFlags :: BuildFlags+emptyBuildFlags = BuildFlags {+    flagCacheDir   = Nothing+  , flagVerbosity  = normal+  , flagRunTime    = Nothing+  , flagHelp       = False+  , flagForce      = False+  , flagContinuous = False+  , flagKeepGoing  = False+  , flagInterval   = Nothing+  }++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 [] ["interval"]+      (ReqArg (\int opts -> opts { flagInterval = Just int }) "MIN")+      "Set the building interval in minutes (default 30)"+  ]++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+               }++        mode = case args' of+               _ | flagHelp flags -> Help []+                 | not (null errs) -> Help errs+               ["init", uri] ->+                   -- We don't actually want the URI at this point+                   -- (see [Note: Show/Read URI])+                   case validateHackageURI uri of+                   Left  theError -> Help [theError]+                   Right _        -> Init uri+               "init" : _ ->+                   Help ["init takes a single argument (repo URL)"]+               ["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++withRecursiveContents :: FilePath -> (FilePath -> IO a) -> IO [a]+withRecursiveContents topdir act = do+  names <- getDirectoryContents topdir+  let properNames = filter (`notElem` [".", ".."]) names+  ass <- forM properNames $ \name -> do+    let path = topdir </> name+    isDirectory <- doesDirectoryExist path+    if isDirectory+      then withRecursiveContents path act+      else return `liftM` act path+  return (concat ass)++withRecursiveContents_ :: FilePath -> (FilePath -> IO ()) -> IO ()+withRecursiveContents_ fp = void . withRecursiveContents fp
+ Data/IntTrie.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}++module Data.IntTrie (++  IntTrie(..),+  construct,++  lookup,+  TrieLookup(..),++#ifdef TESTS+  tests,+  prop,+#endif++ ) where++import Prelude hiding (lookup)++import Data.Typeable (Typeable)++import qualified Data.Array.Unboxed as A+import Data.Array.IArray  ((!))+import qualified Data.Bits as Bits+import Data.Word (Word32)++import Data.List hiding (lookup)+import Data.Function (on)+import Data.SafeCopy (base, deriveSafeCopy)++import Distribution.Server.Framework.Instances()+import Distribution.Server.Framework.MemSize++-- | A compact mapping from sequences of small ints to small ints.+--+newtype IntTrie k v = IntTrie (A.UArray Word32 Word32)+    deriving (Show, Typeable)++-- Version 0 used 16-bit integers and is no longer supported+-- (To upgrade, DELETE /server-status/tarindices to wipe the tar indices state)+$(deriveSafeCopy 1 'base ''IntTrie)++instance MemSize (IntTrie k v) where+    memSize (IntTrie o) = memSizeUArray 4 o++-- Compact, read-only implementation of a trie. It's intended for use with file+-- paths, but we do that via string ids.++#ifdef TESTS+-- Example mapping:+--+example0 :: [(FilePath, Int)]+example0 =+  [("foo-1.0/foo-1.0.cabal", 512)   -- tar block 1+  ,("foo-1.0/LICENSE",       2048)  -- tar block 4+  ,("foo-1.0/Data/Foo.hs",   4096)] -- tar block 8++-- After converting path components to integers this becomes:+--+example1 :: Paths Word32 Word32+example1 =+  [([1,2],   512)+  ,([1,3],   2048)+  ,([1,4,5], 4096)]++-- As a trie this looks like:++--  [ (1, *) ]+--        |+--        [ (2, 512), (3, 1024), (4, *) ]+--                                   |+--                                   [ (5, 4096) ]++-- We use an intermediate trie representation++example2 :: Trie Word32 Word32+example2 = Trie [ Node 1 t1 ]+  where+    t1   = Trie [ Leaf 2 512, Leaf 3 2048, Node 4 t2 ]+    t2   = Trie [ Leaf 5 4096 ]+++example2' :: Trie Word32 Word32+example2' = Trie [ Node 0 t1 ]+  where+    t1   = Trie [ Node 3 t2 ]+    t2   = Trie [ Node 1 t3, Node 2 t4 ]+    t3   = Trie [ Leaf 4 10608 ]+    t4   = Trie [ Leaf 4 10612 ]+{-+0: [1,N0,3]++  3: [1,N3,6]++   6: [2,N1,N2,11,12]++     11: [1,4,10608]+     14: [1,4,10612]+-}++example2'' :: Trie Word32 Word32+example2'' = Trie [ Node 1 t1, Node 2 t2 ]+  where+    t1   = Trie [ Leaf 4 10608 ]+    t2   = Trie [ Leaf 4 10612 ]++example2''' :: Trie Word32 Word32+example2''' = Trie [ Node 0 t3 ]+  where+    t3  = Trie [ Node 4 t8, Node 6 t11 ]+    t8  = Trie [ Node 1 t14 ]+    t11 = Trie [ Leaf 5 10605 ]+    t14 = Trie [ Node 2 t19, Node 3 t22 ]+    t19 = Trie [ Leaf 7 10608 ]+    t22 = Trie [ Leaf 7 10612 ]+{-+ 0: [1,N0,3]+ 3: [2,N4,N6,8,11]+ 8: [1,N1,11]+11: [1,5,10605]+14: [2,N2,N3,16,19]+19: [1,7,10608]+22: [1,7,10612]+-}++-- We convert from the 'Paths' to the 'Trie' using 'mkTrie':+--+test1 = example2 == mkTrie example1+#endif++-- Each node has a size and a sequence of keys followed by an equal length+-- sequnce of corresponding entries. Since we're going to flatten this into+-- a single array then we will need to replace the trie structure with pointers+-- represented as array offsets.++-- Each node is a pair of arrays, one of keys and one of Either value pointer.+-- We need to distinguish values from internal pointers. We use a tag bit:+--+tagLeaf, tagNode, untag :: Word32 -> Word32+tagLeaf = id+tagNode = flip Bits.setBit   31+untag   = flip Bits.clearBit 31++-- So the overall array form of the above trie is:+--+-- offset:   0   1    2    3   4  5  6    7    8     9     10  11  12+-- array:  [ 1 | N1 | 3 ][ 3 | 2, 3, N4 | 512, 2048, 10 ][ 1 | 5 | 4096 ]+--                     \__/                           \___/++#ifdef TESTS+example3 :: [Word32]+example3 =+ [1, tagNode 1,+     3,+  3, tagLeaf 2, tagLeaf 3, tagNode 4,+     512,       2048,      10,+  1, tagLeaf 5,+     4096+ ]++-- We get the array form by using flattenTrie:++test2 = example3 == flattenTrie example2++example4 :: IntTrie Int Int+example4 = IntTrie (mkArray example3)++test3 = case lookup example4 [1] of+          Just (Completions [2,3,4]) -> True+          _                          -> False++test1, test2, test3, tests :: Bool+tests = test1 && test2 && test3+#endif++-------------------------------------+-- Toplevel trie array construction+--++-- So constructing the 'IntTrie' as a whole is just a matter of stringing+-- together all the bits++-- | Build an 'IntTrie' from a bunch of (key, value) pairs, where the keys+-- are sequences.+--+construct :: (Ord k, Enum k, Enum v) => [([k], v)] -> IntTrie k v+construct = IntTrie . mkArray . flattenTrie . mkTrie++mkArray :: [Word32] -> A.UArray Word32 Word32+mkArray xs = A.listArray (0, fromIntegral (length xs) - 1) xs+++---------------------------------+-- Looking up in the trie array+--++data TrieLookup k v = Entry !v | Completions [k] deriving Show++lookup :: (Enum k, Enum v) => IntTrie k v -> [k] -> Maybe (TrieLookup k v)+lookup (IntTrie arr) = fmap convertLookup . go 0 . convertKey+  where+    go :: Word32 -> [Word32] -> Maybe (TrieLookup Word32 Word32)+    go nodeOff []     = Just (completions nodeOff)+    go nodeOff (k:ks) = case search nodeOff (tagLeaf k) of+      Just entryOff+        | null ks   -> Just (entry entryOff)+        | otherwise -> Nothing+      Nothing     -> case search nodeOff (tagNode k) of+        Nothing       -> Nothing+        Just entryOff -> go (arr ! entryOff) ks++    entry       entryOff = Entry (arr ! entryOff)+    completions nodeOff  = Completions [ untag (arr ! keyOff)+                                       | keyOff <- [keysStart..keysEnd] ]+      where+        nodeSize  = arr ! nodeOff+        keysStart = nodeOff + 1+        keysEnd   = nodeOff + nodeSize++    search :: Word32 -> Word32 -> Maybe Word32+    search nodeOff key = fmap (+nodeSize) (bsearch keysStart keysEnd key)+      where+        nodeSize  = arr ! nodeOff+        keysStart = nodeOff + 1+        keysEnd   = nodeOff + nodeSize++    bsearch :: Word32 -> Word32 -> Word32 -> Maybe Word32+    bsearch a b key+      | a > b     = Nothing+      | otherwise = case compare key (arr ! mid) of+          LT -> bsearch a (mid-1) key+          EQ -> Just mid+          GT -> bsearch (mid+1) b key+      where mid = (a + b) `div` 2+++convertKey :: Enum k => [k] -> [Word32]+convertKey = map (fromIntegral . fromEnum)++convertLookup :: (Enum k, Enum v) => TrieLookup Word32 Word32+                                  -> TrieLookup k v+convertLookup (Entry v)        = Entry       (word16ToEnum v)+convertLookup (Completions ks) = Completions (map word16ToEnum ks)++word16ToEnum :: Enum n => Word32 -> n+word16ToEnum = toEnum . fromIntegral+++-------------------------+-- Intermediate Trie type+--++-- The trie node functor+data TrieNodeF k v x = Leaf k v | Node k x deriving (Eq, Show)++instance Functor (TrieNodeF k v) where+  fmap _ (Leaf k v) = Leaf k v+  fmap f (Node k x) = Node k (f x)++-- The trie functor+type    TrieF k v x = [TrieNodeF k v x]++-- Trie is the fixpoint of the 'TrieF' functor+newtype Trie  k v   = Trie (TrieF k v (Trie k v)) deriving (Eq, Show)+++unfoldTrieNode :: (s -> TrieNodeF k v [s]) -> s -> TrieNodeF k v (Trie k v)+unfoldTrieNode f = fmap (unfoldTrie f) . f++unfoldTrie :: (s -> TrieNodeF k v [s]) -> [s] -> Trie k v+unfoldTrie f = Trie . map (unfoldTrieNode f)++{-+trieSize :: Trie k v -> Int+trieSize (Trie ts) = 1 + sum (map trieNodeSize ts)++trieNodeSize :: TrieNodeF k v (Trie k v) -> Int+trieNodeSize (Leaf _ _) = 2+trieNodeSize (Node _ t) = 2 + trieSize t+-}++---------------------------------+-- Building and flattening Tries+--++-- A list of non-empty key-lists paired+type Paths  k v = [([k], v)]+++mkTrie :: Ord k => Paths k v -> Trie k v+mkTrie = unfoldTrie (fmap split) . split+       . sortBy (compare `on` fst)+  where+    split :: Eq k => Paths k v -> TrieF k v (Paths k v)+    split = map mkGroup . groupBy ((==) `on` (head . fst))+      where+        mkGroup = \ksvs@((k0:_,v0):_) ->+          case [ (ks, v) | (_:ks, v) <- ksvs, not (null ks) ] of+            []    -> Leaf k0 v0+            ksvs' -> Node k0 ksvs'++type Offset = Int++-- This is a breadth-first traversal. We keep a list of the tries that we are+-- to write out next. Each of these have an offset allocated to them at the+-- time we put them into the list. We keep a running offset so we know where+-- to allocate next.+--+flattenTrie :: (Enum k, Enum v) => Trie k v -> [Word32]+flattenTrie trie = go [trie] (size trie)+  where+    size (Trie tns) = 1 + 2 * length tns++    go :: (Enum k, Enum v) => [Trie k v] -> Offset -> [Word32]+    go []                  _      = []+    go (Trie tnodes:tries) offset = flat ++ go (tries++tries') offset'+      where+        count = length tnodes+        flat  = fromIntegral count : keys ++ values+        (keys, values) = unzip (sortBy (compare `on` fst) keysValues)+        (keysValues, tries', offset') = doNodes offset [] [] tnodes++    doNodes off kvs ts' []       = (kvs, reverse ts', off)+    doNodes off kvs ts' (tn:tns) = case tn of+      Leaf k v -> doNodes off            (leafKV k v  :kvs)    ts'  tns+      Node k t -> doNodes (off + size t) (nodeKV k off:kvs) (t:ts') tns++    leafKV k v = (tagLeaf (enum2Word32 k), enum2Word32 v)+    nodeKV k o = (tagNode (enum2Word32 k), int2Word32  o)++int2Word32 :: Int -> Word32+int2Word32 = fromIntegral++enum2Word32 :: Enum n => n -> Word32+enum2Word32 = int2Word32 . fromEnum+++-------------------------+-- Correctness property+--++#ifdef TESTS++prop :: (Show from, Show to, Enum from, Enum to, Ord from, Eq to) => Paths from to -> Bool+prop paths =+  flip all paths $ \(key, value) ->+    case lookup trie key of+      Just (Entry value') | value' == value -> True+      Just (Entry value') -> error $ "IntTrie: " ++ show (key, value, value')+      Nothing             -> error $ "IntTrie: didn't find " ++ show key+      Just (Completions xs) -> error $ "IntTrie: " ++ show xs++  where+    trie = construct paths++--TODO: missing data abstraction property++#endif
+ Data/StringTable.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}++module Data.StringTable (++    StringTable,+    lookup,+    index,+    construct,++    prop,++ ) where++import Prelude hiding (lookup)+import qualified Data.List as List+import qualified Data.Array.Unboxed as A+import Data.Array.Unboxed ((!))+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Typeable (Typeable)+import qualified Data.ByteString.Char8 as BS+import Data.Word (Word32)++import Distribution.Server.Framework.Instances()+import Distribution.Server.Framework.MemSize++-- | An effecient mapping from strings to a dense set of integers.+--+data StringTable id+         = StringTable+               !BS.ByteString          -- all the strings concatenated+               !(A.UArray Int Word32)  -- offset table+  deriving (Show, Typeable)++$(deriveSafeCopy 0 'base ''StringTable)++instance MemSize (StringTable id) where+    memSize (StringTable s o) = 3 + memSize s + memSizeUArray 4 o++-- | Look up a string in the token table. If the string is present, return+-- its corresponding index.+--+lookup :: Enum id => StringTable id -> String -> Maybe id+lookup (StringTable bs tbl) str = binarySearch 0 (topBound-1) (BS.pack str)+  where+    (0, topBound) = A.bounds tbl++    binarySearch a b key+      | a > b     = Nothing+      | otherwise = case compare key (index' bs tbl mid) of+          LT -> binarySearch a (mid-1) key+          EQ -> Just (toEnum mid)+          GT -> binarySearch (mid+1) b key+      where mid = (a + b) `div` 2++index' :: BS.ByteString -> A.UArray Int Word32 -> Int -> BS.ByteString+index' bs tbl i = BS.take len . BS.drop start $ bs+  where+    start, end, len :: Int+    start = fromIntegral (tbl ! i)+    end   = fromIntegral (tbl ! (i+1))+    len   = end - start+++-- | Given the index of a string in the table, return the string.+--+index :: Enum id => StringTable id -> id -> String+index (StringTable bs tbl) = BS.unpack . index' bs tbl . fromEnum+++-- | Given a list of strings, construct a 'StringTable' mapping those strings+-- to a dense set of integers.+--+construct :: Enum id => [String] -> StringTable id+construct strs = StringTable bs tbl+  where+    bs      = BS.pack (concat strs')+    tbl     = A.array (0, length strs') (zip [0..] offsets)+    offsets = scanl (\off str -> off + fromIntegral (length str)) 0 strs'+    strs'   = map head . List.group . List.sort $ strs+++enumStrings :: Enum id => StringTable id -> [String]+enumStrings (StringTable bs tbl) = map (BS.unpack . index' bs tbl) [0..h-1]+  where (0,h) = A.bounds tbl+++enumIds :: Enum id => StringTable id -> [id]+enumIds (StringTable _ tbl) = map toEnum [0..h-1]+  where (0,h) = A.bounds tbl++prop :: [String] -> Bool+prop strs =+     all lookupIndex (enumStrings tbl)+  && all indexLookup (enumIds tbl)++  where+    tbl :: StringTable Int+    tbl = construct strs++    lookupIndex str = index tbl ident == str+      where Just ident = lookup tbl str++    indexLookup ident = lookup tbl str == Just ident+      where str       = index tbl ident
+ Data/TarIndex.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, TemplateHaskell #-}++module Data.TarIndex (++    TarIndex,+    TarIndexEntry(..),+    TarEntryOffset,++    lookup,+    construct,++#ifdef TESTS+    prop_lookup, prop,+#endif+  ) where++import Data.SafeCopy (base, deriveSafeCopy)+import Data.Typeable (Typeable)++import qualified Data.StringTable as StringTable+import Data.StringTable (StringTable)+import qualified Data.IntTrie as IntTrie++import Data.IntTrie (IntTrie)+import qualified System.FilePath as FilePath+import Prelude hiding (lookup)+#ifdef TESTS+import qualified Prelude+#endif++import Distribution.Server.Framework.MemSize+++-- | An index of the entries in a tar file. This lets us look up a filename+-- within the tar file and find out where in the tar file (ie the file offset)+-- that entry occurs.+--+data TarIndex = TarIndex++  -- As an example of how the mapping works, consider these example files:+  --   "foo/bar.hs" at offset 0+  --   "foo/baz.hs" at offset 1024+  --+  -- We split the paths into components and enumerate them.+  --   { "foo" -> TokenId 0, "bar.hs" -> TokenId 1,  "baz.hs" -> TokenId 2 }+  --+  -- We convert paths into sequences of 'TokenId's, i.e.+  --   "foo/bar.hs" becomes [PathComponentId 0, PathComponentId 1]+  --   "foo/baz.hs" becomes [PathComponentId 0, PathComponentId 2]+  --+  -- We use a trie mapping sequences of 'PathComponentId's to the entry offset:+  --  { [PathComponentId 0, PathComponentId 1] -> offset 0+  --  , [PathComponentId 0, PathComponentId 2] -> offset 1024 }++  -- | The mapping of filepath components as strings to ids.+  !(StringTable PathComponentId)++  -- Mapping of sequences of filepath component ids to tar entry offsets.+  !(IntTrie PathComponentId TarEntryOffset)+  deriving (Show, Typeable)+++data TarIndexEntry = TarFileEntry !TarEntryOffset+                   | TarDir [FilePath]+  deriving (Show, Typeable)+++newtype PathComponentId = PathComponentId Int+  deriving (Eq, Ord, Enum, Show, Typeable)++type TarEntryOffset = Int++$(deriveSafeCopy 0 'base ''TarIndex)+$(deriveSafeCopy 0 'base ''PathComponentId)+$(deriveSafeCopy 0 'base ''TarIndexEntry)++instance MemSize TarIndex where+    memSize (TarIndex a b) = memSize2 a b+++-- | Look up a given filepath in the index. It may return a 'TarFileEntry'+-- containing the offset and length of the file within the tar file, or if+-- the filepath identifies a directory then it returns a 'TarDir' containing+-- the list of files within that directory.+--+lookup :: TarIndex -> FilePath -> Maybe TarIndexEntry+lookup (TarIndex pathTable pathTrie) path =+    case toComponentIds pathTable path of+      Nothing    -> Nothing+      Just fpath -> fmap (mkIndexEntry fpath) (IntTrie.lookup pathTrie fpath)+  where+    mkIndexEntry _ (IntTrie.Entry offset)        = TarFileEntry offset+    mkIndexEntry _ (IntTrie.Completions entries) =+      TarDir [ fromComponentIds pathTable [entry]+             | entry <- entries ]++-- | Construct a 'TarIndex' from a list of filepaths and their corresponding+--+construct :: [(FilePath, TarEntryOffset)] -> TarIndex+construct pathsOffsets = TarIndex pathTable pathTrie+  where+    pathComponents = concatMap (FilePath.splitDirectories . fst) pathsOffsets+    pathTable = StringTable.construct pathComponents+    pathTrie  = IntTrie.construct+                  [ (cids, offset)+                  | (path, offset) <- pathsOffsets+                  , let Just cids = toComponentIds pathTable path ]++toComponentIds :: StringTable PathComponentId -> FilePath -> Maybe [PathComponentId]+toComponentIds table = lookupComponents [] . FilePath.splitDirectories+  where+    lookupComponents cs' []     = Just (reverse cs')+    lookupComponents cs' (c:cs) = case StringTable.lookup table c of+      Nothing  -> Nothing+      Just cid -> lookupComponents (cid:cs') cs++fromComponentIds :: StringTable PathComponentId -> [PathComponentId] -> FilePath+fromComponentIds table = FilePath.joinPath . map (StringTable.index table)++#ifdef TESTS++-- properties of a finite mapping...++prop_lookup :: [(FilePath, TarEntryOffset)] -> FilePath -> Bool+prop_lookup xs x =+  case (lookup (construct xs) x, Prelude.lookup x xs) of+    (Nothing,                    Nothing)      -> True+    (Just (TarFileEntry offset), Just offset') -> offset == offset'+    _                                          -> False++prop :: [(FilePath, TarEntryOffset)] -> Bool+prop paths+  | not $ StringTable.prop pathbits = error "TarIndex: bad string table"+  | not $ IntTrie.prop intpaths     = error "TarIndex: bad int trie"+  | not $ prop'                     = error "TarIndex: bad prop"+  | otherwise                       = True++  where+    index@(TarIndex pathTable _) = construct paths++    pathbits = concatMap (FilePath.splitDirectories . fst) paths+    intpaths = [ (cids, offset)+               | (path, offset) <- paths+               , let Just cids = toComponentIds pathTable path ]+    prop' = flip all paths $ \(file, offset) ->+      case lookup index file of+        Just (TarFileEntry offset') -> offset' == offset+        _                           -> False+++example0 :: [(FilePath, Int)]+example0 =+  [("foo-1.0/foo-1.0.cabal", 512)   -- tar block 1+  ,("foo-1.0/LICENSE",       2048)  -- tar block 4+  ,("foo-1.0/Data/Foo.hs",   4096)] -- tar block 8++#endif
+ Distribution/Client.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE PatternGuards #-}+module Distribution.Client+  ( -- * Command line handling+    validateHackageURI+  , validatePackageIds+    -- * Fetching info from source and destination servers+  , PkgIndexInfo(..)+  , downloadIndex+  , readNewIndex+    -- * HTTP utilities+  , HttpSession+  , uriHostName+  , httpSession+  , requestGET'+  , requestPUT+  , (<//>)+  , provideAuthInfo+    -- * TODO: Exported although they appear unusued+  , extractURICredentials+  , removeURICredentials+  , getETag+  , downloadFile'+  , requestGET+  , requestPUTFile+  , requestPOST+  ) where++import Network.HTTP+import Network.Browser+import Network.URI (URI(..), URIAuth(..), parseURI)++import Distribution.Client.UploadLog as UploadLog (read, Entry(..))+import Distribution.Server.Users.Types (UserId(..), UserName(UserName))+import Distribution.Server.Util.Index as PackageIndex (read)+import Distribution.Server.Util.Merge+import Distribution.Server.Util.Parse (unpackUTF8)+import Distribution.Package+import Distribution.Verbosity+import Distribution.Simple.Utils+import Distribution.Text++import Data.List+import Data.Maybe+import Control.Applicative+import Control.Exception+import Data.Time+import Data.Time.Clock.POSIX+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy          as BS+import qualified Distribution.Server.Util.GZip as GZip+import qualified Codec.Archive.Tar             as Tar+import qualified Codec.Archive.Tar.Entry       as Tar++import Control.Monad.Trans+import System.IO+import System.IO.Error+import System.FilePath+import System.Directory+import qualified System.FilePath.Posix as Posix++import Paths_hackage_server (version)++-------------------------+-- Command line handling+-------------------------++validateHackageURI :: String -> Either String URI+validateHackageURI str = case parseURI str of+  Nothing                          -> Left ("invalid URL " ++ str)+  Just uri+    | uriScheme uri /= "http:"     -> Left ("only http URLs are supported " ++ str)+    | isNothing (uriAuthority uri) -> Left ("server name required in URL " ++ str)+    | otherwise                    -> Right uri++validatePackageIds :: [String] -> Either String [PackageId]+validatePackageIds pkgstrs =+    case theErrors of+      theError : _ ->+          Left $ "'" ++ theError ++ "' is not a valid package name or id"+      _ -> Right pkgs+  where+    pkgstrs'  = [ (pkgstr, simpleParse pkgstr) | pkgstr <- pkgstrs ]+    pkgs      = [ pkgid  | (_, Just pkgid)   <- pkgstrs' ]+    theErrors = [ pkgstr | (pkgstr, Nothing) <- pkgstrs' ]++----------------------------------------------------+-- Fetching info from source and destination servers+----------------------------------------------------++data PkgIndexInfo = PkgIndexInfo+                       PackageId+                       (Maybe UTCTime)  -- Upload time+                       (Maybe UserName) -- Name of uploader+                       (Maybe UserId)   -- Id of uploader+  deriving Show++downloadIndex :: URI -> FilePath -> HttpSession [PkgIndexInfo]+downloadIndex uri | isOldHackageURI uri = downloadOldIndex uri+                  | otherwise           = downloadNewIndex uri+  where++isOldHackageURI :: URI -> Bool+isOldHackageURI uri+  | Just auth <- uriAuthority uri = uriRegName auth == "hackage.haskell.org"+  | otherwise                     = False+++downloadOldIndex :: URI -> FilePath -> HttpSession [PkgIndexInfo]+downloadOldIndex uri cacheDir = do++    downloadFile indexURI indexFile+    downloadFile logURI logFile++    liftIO $ do++      pkgids <- withFile indexFile ReadMode $ \hnd -> do+        content <- BS.hGetContents hnd+        case PackageIndex.read (\pkgid _ -> pkgid) (GZip.decompressNamed indexFile content) of+          Right pkgs     -> return pkgs+          Left  theError ->+              die $ "Error parsing index at " ++ show uri ++ ": " ++ theError++      theLog <- withFile logFile ReadMode $ \hnd -> do+        content <- hGetContents hnd+        case UploadLog.read content of+          Right theLog   -> return theLog+          Left  theError ->+              die $ "Error parsing log at " ++ show uri ++ ": " ++ theError++      return (mergeLogInfo pkgids theLog)++  where+    indexURI  = uri <//> "packages" </> "archive" </> "00-index.tar.gz"+    indexFile = cacheDir </> "00-index.tar.gz"++    logURI    = uri <//> "packages" </> "archive" </> "log"+    logFile   = cacheDir </> "log"++    mergeLogInfo pkgids theLog =+        catMaybes+      . map selectDetails+      $ mergeBy (\pkgid entry -> compare pkgid (entryPkgId entry))+                (sort pkgids)+                ( map (maximumBy (comparing entryTime))+                . groupBy (equating  entryPkgId)+                . sortBy  (comparing entryPkgId)+                $ theLog )++    selectDetails (OnlyInRight _)     = Nothing+    selectDetails (OnlyInLeft  pkgid) =+      Just $ PkgIndexInfo pkgid Nothing Nothing Nothing+    selectDetails (InBoth pkgid (UploadLog.Entry time uname _)) =+      Just $ PkgIndexInfo pkgid (Just time) (Just uname) Nothing++    entryPkgId (Entry _ _ pkgid) = pkgid+    entryTime  (Entry time _ _)  = time+++downloadNewIndex :: URI -> FilePath -> HttpSession [PkgIndexInfo]+downloadNewIndex uri cacheDir = do+    downloadFile indexURI indexFile+    readNewIndex cacheDir++  where+    indexURI  = uri <//> "packages/00-index.tar.gz"+    indexFile = cacheDir </> "00-index.tar.gz"++readNewIndex :: FilePath -> HttpSession [PkgIndexInfo]+readNewIndex cacheDir = do+    liftIO $ withFile indexFile ReadMode $ \hnd -> do+      content <- BS.hGetContents hnd+      case PackageIndex.read selectDetails (GZip.decompressNamed indexFile content) of+        Left theError ->+            error ("Error parsing index at " ++ show indexFile ++ ": "+                ++ theError)+        Right pkgs -> return pkgs++  where+    indexFile = cacheDir </> "00-index.tar.gz"++    selectDetails :: PackageId -> Tar.Entry -> PkgIndexInfo+    selectDetails pkgid entry =+        PkgIndexInfo+          pkgid+          (Just time)+          (if null username then Nothing else Just (UserName username))+          (if userid == 0   then Nothing else Just (UserId userid))+      where+        time     = epochTimeToUTC (Tar.entryTime entry)+        username = Tar.ownerName (Tar.entryOwnership entry)+        userid   = Tar.ownerId   (Tar.entryOwnership entry)++        epochTimeToUTC :: Tar.EpochTime -> UTCTime+        epochTimeToUTC = posixSecondsToUTCTime . realToFrac+++-------------------------+-- HTTP utilities+-------------------------++infixr 5 <//>++(<//>) :: URI -> FilePath -> URI+uri <//> path = uri { uriPath = Posix.addTrailingPathSeparator (uriPath uri)+                                Posix.</> path }+++extractURICredentials :: URI -> Maybe (String, String)+extractURICredentials uri+  | Just authority <- uriAuthority uri+  , (username, ':':passwd0) <- break (==':') (uriUserInfo authority)+  , let passwd = takeWhile (/='@') passwd0+  , not (null username)+  , not (null passwd)+  = Just (username, passwd)+extractURICredentials _ = Nothing++removeURICredentials :: URI -> URI+removeURICredentials uri = uri { uriAuthority = fmap (\auth -> auth { uriUserInfo = "" }) (uriAuthority uri) }++provideAuthInfo :: URI -> Maybe (String, String) -> URI -> String -> IO (Maybe (String, String))+provideAuthInfo for_uri credentials = \uri _realm -> do+    if uriHostName uri == uriHostName for_uri then return credentials+                                              else return Nothing++uriHostName :: URI -> Maybe String+uriHostName = fmap uriRegName . uriAuthority+++type HttpSession a = BrowserAction (HandleStream ByteString) a++httpSession :: Verbosity -> HttpSession a -> IO a+httpSession verbosity action =+    browse $ do+      setUserAgent ("hackage-mirror/" ++ display version)+      setErrHandler die+      setOutHandler (debug verbosity)+      setAllowBasicAuth True+      setCheckForProxy True+      action++downloadFile :: URI -> FilePath -> HttpSession ()+downloadFile uri file = do+  out $ "downloading " ++ show uri ++ " to " ++ file+  let etagFile = file <.> "etag"+  metag <- liftIO $ catchJustDoesNotExistError+                        (Just <$> readFile etagFile)+                        (\_ -> return Nothing)+  case metag of+    Just etag -> do+      let headers = [mkHeader HdrIfNoneMatch (quote etag)]+      (_, rsp) <- request (Request uri GET headers BS.empty)+      case rspCode rsp of+        (3,0,4) -> out $ file ++ " unchanged with ETag " ++ etag+        (2,0,0) -> liftIO $ writeDowloadedFileAndEtag rsp+        _       -> err (showFailure uri rsp)++    Nothing -> do+      (_, rsp) <- request (Request uri GET [] BS.empty)+      case rspCode rsp of+        (2,0,0) -> liftIO $ writeDowloadedFileAndEtag rsp+        _       -> err (showFailure uri rsp)++  where+    writeDowloadedFileAndEtag rsp = do+      BS.writeFile file (rspBody rsp)+      setETag file (unquote <$> findHeader HdrETag rsp)++getETag :: FilePath -> IO (Maybe String)+getETag file =+    catchJustDoesNotExistError+      (Just <$> readFile (file </> ".etag"))+      (\_ -> return Nothing)++setETag :: FilePath -> Maybe String -> IO ()+setETag file Nothing     = catchJustDoesNotExistError+                             (removeFile (file <.> "etag"))+                             (\_ -> return ())+setETag file (Just etag) = writeFile  (file <.> "etag") etag++catchJustDoesNotExistError :: IO a -> (IOError -> IO a) -> IO a+catchJustDoesNotExistError =+  catchJust (\e -> if isDoesNotExistError e then Just e else Nothing)++quote :: String -> String+quote   s = '"' : s ++ ['"']++unquote :: String -> String+unquote ('"':s) = go s+  where+    go []       = []+    go ('"':[]) = []+    go (c:cs)   = c : go cs+unquote     s   = s++-- AAARG! total lack of exception handling in HTTP monad!+downloadFile' :: URI -> FilePath -> HttpSession Bool+downloadFile' uri file = do+  out $ "downloading " ++ show uri ++ " to " ++ file+  mcontent <- requestGET' uri+  case mcontent of+    Nothing      -> do out $ "404 " ++ show uri+                       return False++    Just content -> do liftIO $ BS.writeFile file content+                       return True++requestGET :: URI -> HttpSession ByteString+requestGET uri = do+    (_, rsp) <- request (Request uri GET headers BS.empty)+    checkStatus uri rsp+    return (rspBody rsp)+  where+    headers = []++-- Really annoying!+requestGET' :: URI -> HttpSession (Maybe ByteString)+requestGET' uri = do+    (_, rsp) <- request (Request uri GET headers BS.empty)+    case rspCode rsp of+      (4,0,4) -> return Nothing+      _       -> do checkStatus uri rsp+                    return (Just (rspBody rsp))+  where+    headers = []+++requestPUTFile :: URI -> String -> Maybe String -> FilePath -> HttpSession ()+requestPUTFile uri mime_type mEncoding file = do+    content <- liftIO $ BS.readFile file+    requestPUT uri mime_type mEncoding content++requestPOST, requestPUT :: URI -> String -> Maybe String -> ByteString -> HttpSession ()+requestPOST = requestPOSTPUT POST+requestPUT = requestPOSTPUT PUT++requestPOSTPUT :: RequestMethod -> URI -> String -> Maybe String -> ByteString -> HttpSession ()+requestPOSTPUT meth uri mimetype mEncoding body = do+    (_, rsp) <- request (Request uri meth headers body)+    checkStatus uri rsp+  where+    headers = [ Header HdrContentLength (show (BS.length body))+              , Header HdrContentType mimetype ]+              ++ case mEncoding of+                Nothing       -> []+                Just encoding -> [ Header HdrContentEncoding encoding ]+++checkStatus :: URI -> Response ByteString -> HttpSession ()+checkStatus uri rsp = case rspCode rsp of+  -- 200 OK+  (2,0,0) -> return ()+  -- 204 No Content+  (2,0,4) -> return ()+  -- 400 Bad Request+  (4,0,0) -> liftIO (warn normal (showFailure uri rsp)) >> return ()+  -- Other+  _code   -> err (showFailure uri rsp)++showFailure :: URI -> Response ByteString -> String+showFailure uri rsp =+    show (rspCode rsp) ++ " " ++ rspReason rsp ++ show uri+ ++ case lookupHeader HdrContentType (rspHeaders rsp) of+      Just mimetype | "text/plain" `isPrefixOf` mimetype+                   -> '\n' : (unpackUTF8 . rspBody $ rsp)+      _            -> ""
+ Distribution/Server.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}+module Distribution.Server (+    -- * Server control+    Server(..),+    ServerEnv(..),+    initialise,+    run,+    shutdown,+    checkpoint,++    -- * Server configuration+    ListenOn(..),+    ServerConfig(..),+    defaultServerConfig,+    hasSavedState,++    -- * Server state+    serverState,+    initState,++    -- * Temporary server while loading data+    setUpTemp,+    tearDownTemp+ ) where++import Distribution.Server.Framework+import qualified Distribution.Server.Framework.BackupRestore as Import+import qualified Distribution.Server.Framework.BlobStorage as BlobStorage+import qualified Distribution.Server.Framework.Auth as Auth+import Distribution.Server.Framework.Templating (TemplatesMode(NormalMode))+import Distribution.Server.Framework.AuthTypes (PasswdPlain(..))++import Distribution.Server.Framework.Feature as Feature+import qualified Distribution.Server.Features as Features+import Distribution.Server.Features.Users++import qualified Distribution.Server.Users.Types as Users+import qualified Distribution.Server.Users.Users as Users+import qualified Distribution.Server.Users.Group as Group++import Distribution.Text+import Distribution.Verbosity as Verbosity++import System.Directory (createDirectoryIfMissing, doesDirectoryExist)+import Control.Concurrent+import Network.URI (URI(..), URIAuth(URIAuth), nullURI)+import Network.BSD (getHostName)+import Data.List (foldl', nubBy)+import Data.Int  (Int64)+import Control.Arrow (second)+import Data.Function (on)+import qualified System.Log.Logger as HsLogger+import Control.Exception.Lifted as Lifted++import Paths_hackage_server (getDataDir)+++data ListenOn = ListenOn {+  loPortNum :: Int,+  loIP :: String+} deriving (Show)++data ServerConfig = ServerConfig {+  confVerbosity :: Verbosity,+  confHostUri   :: URI,+  confListenOn  :: ListenOn,+  confStateDir  :: FilePath,+  confStaticDir :: FilePath,+  confTmpDir    :: FilePath,+  confCacheDelay:: Int+} deriving (Show)++confDbStateDir, confBlobStoreDir,+  confStaticFilesDir, confTemplatesDir :: ServerConfig -> FilePath+confDbStateDir   config = confStateDir config </> "db"+confBlobStoreDir config = confStateDir config </> "blobs"+confStaticFilesDir config = confStaticDir config </> "static"+confTemplatesDir   config = confStaticDir config </> "templates"++defaultServerConfig :: IO ServerConfig+defaultServerConfig = do+  hostName <- getHostName+  dataDir  <- getDataDir+  let portnum = 8080 :: Int+  return ServerConfig {+    confVerbosity = Verbosity.normal,+    confHostUri   = nullURI {+                      uriScheme    = "http:",+                      uriAuthority = Just (URIAuth "" hostName (':' : show portnum))+                    },+    confListenOn  = ListenOn {+                        loPortNum = 8080,+                        loIP = "0.0.0.0"+                    },+    confStateDir  = "state",+    confStaticDir = dataDir,+    confTmpDir    = "state" </> "tmp",+    confCacheDelay= 0+  }++data Server = Server {+  serverFeatures    :: [HackageFeature],+  serverUserFeature :: UserFeature,+  serverListenOn    :: ListenOn,+  serverEnv         :: ServerEnv+}++-- | If we made a server instance from this 'ServerConfig', would we find some+-- existing saved state or would it be a totally clean instance with no+-- existing state.+--+hasSavedState :: ServerConfig -> IO Bool+hasSavedState = doesDirectoryExist . confDbStateDir++-- | Make a server instance from the server configuration.+--+-- This does not yet run the server (see 'run') but it does setup the server+-- state system, making it possible to import data, and initializes the+-- features.+--+-- Note: the server instance must eventually be 'shutdown' or you'll end up+-- with stale lock files.+--+initialise :: ServerConfig -> IO Server+initialise config@(ServerConfig verbosity hostURI listenOn+                                    stateDir _ tmpDir+                                    cacheDelay) = do+    createDirectoryIfMissing False stateDir+    let blobStoreDir  = confBlobStoreDir   config+        staticDir     = confStaticFilesDir config+        templatesDir  = confTemplatesDir   config++    store   <- BlobStorage.open blobStoreDir++    let env = ServerEnv {+            serverStaticDir     = staticDir,+            serverTemplatesDir  = templatesDir,+            serverTemplatesMode = NormalMode,+            serverStateDir      = stateDir,+            serverBlobStore     = store,+            serverTmpDir        = tmpDir,+            serverCacheDelay    = cacheDelay * 1000000, --microseconds+            serverBaseURI       = hostURI,+            serverVerbosity     = verbosity+         }+    -- do feature initialization+    (features, userFeature) <- Features.initHackageFeatures env++    return Server {+        serverFeatures    = features,+        serverUserFeature = userFeature,+        serverListenOn    = listenOn,+        serverEnv         = env+    }++-- | Actually run the server, i.e. start accepting client http connections.+--+run :: Server -> IO ()+run server = do+    -- We already check this in Main, so we expect this check to always+    -- succeed, but just in case...+    let staticDir = serverStaticDir (serverEnv server)+    exists <- doesDirectoryExist staticDir+    when (not exists) $ fail $ "The static files directory " ++ staticDir ++ " does not exist."++    runServer listenOn $ do++      handlePutPostQuotas++      setLogging++      fakeBrowserHttpMethods (impl server)++  where+    listenOn = serverListenOn server++    -- HS6 - Quotas should be configurable as well. Also there are places in+    -- the code that want to work with the request body directly but maybe+    -- fail if the request body has already been consumed. The body will only+    -- be consumed if it is a POST/PUT request *and* the content-type is+    -- multipart/form-data. If this does happen, you should get a clear error+    -- message saying what happened.+    handlePutPostQuotas = decodeBody bodyPolicy+      where+        tmpdir = serverTmpDir (serverEnv server)+        quota  = 50 * (1024 ^ (2:: Int64))+                -- setting quota at 50mb, though perhaps should be configurable?+        bodyPolicy = defaultBodyPolicy tmpdir quota quota quota++    setLogging =+        liftIO $ HsLogger.updateGlobalLogger+                   "Happstack.Server"+                   (adjustLogLevel (serverVerbosity (serverEnv server)))+      where+        adjustLogLevel v+          | v == Verbosity.normal    = HsLogger.setLevel HsLogger.WARNING+          | v == Verbosity.verbose   = HsLogger.setLevel HsLogger.INFO+          | v == Verbosity.deafening = HsLogger.setLevel HsLogger.DEBUG+          | otherwise                = id++    -- This is a cunning hack to solve the problem that current web browsers+    -- (non-HTML5 forms) do not support PUT, DELETE, etc, they only support GET+    -- and POST. We don't want to compromise the design of the whole server+    -- just because of browsers not supporting HTTP properly, so we allow+    -- browsers to PUT/DELETE etc by POSTing with a query or body paramater of+    -- _method=PUT/DELETE.+    fakeBrowserHttpMethods part =+      msum [ do method POST+                methodOverrideHack part++             -- or just do things the normal way+           , part+           ]+++-- | Perform a clean shutdown of the server.+--+shutdown :: Server -> IO ()+shutdown server =+  Features.shutdownAllFeatures (serverFeatures server)++--TODO: stop accepting incomming connections,+-- wait for connections to be processed.++-- | Write out a checkpoint of the server state. This makes recovery quicker+-- because fewer logged transactions have to be replayed.+--+checkpoint :: Server -> IO ()+checkpoint server =+  Features.checkpointAllFeatures (serverFeatures server)++-- | Return /one/ abstract state component per feature+serverState :: Server -> [(String, AbstractStateComponent)]+serverState server = [ (featureName feature, mconcat (featureState feature))+                     | feature <- serverFeatures server+                     ]++-- An alternative to an import: starts the server off to a sane initial state.+-- To accomplish this, we import a 'null' tarball, finalizing immediately after initializing import+initState ::  Server -> (String, String) -> IO ()+initState server (admin, pass) = do+    let store = serverBlobStore (serverEnv server)+    void . Import.importBlank store $ map (second abstractStateRestore) (serverState server)+    -- create default admin user+    let UserFeature{updateAddUser, adminGroup} = serverUserFeature server+    muid <- case simpleParse admin of+        Just uname -> do+            let userAuth = Auth.newPasswdHash Auth.hackageRealm uname (PasswdPlain pass)+            updateAddUser uname (Users.UserAuth userAuth)+        Nothing -> fail "Couldn't parse admin name (should be alphanumeric)"+    case muid of+        Right uid -> Group.addUserList adminGroup uid+        Left Users.ErrUserNameClash -> fail $ "Inconceivable!! failed to create admin user"++-- The top-level server part.+-- It collects resources from Distribution.Server.Features, collects+-- them into a path hierarchy, and serves them.+impl :: Server -> ServerPart Response+impl server = logExceptions $+    runServerPartE $+      handleErrorResponse (serveErrorResponse errHandlers Nothing) $+        renderServerTree [] serverTree+          `mplus`+        fallbackNotFound+  where+    serverTree :: ServerTree (DynamicPath -> ServerPartE Response)+    serverTree =+        fmap (serveResource errHandlers)+      -- ServerTree Resource+      . foldl' (\acc res -> addServerNode (resourceLocation res) res acc) serverTreeEmpty+      -- [Resource]+      $ concatMap Feature.featureResources (serverFeatures server)++    errHandlers = nubBy ((==) `on` fst)+                . reverse+                . (("txt", textErrorPage):)+                . concatMap Feature.featureErrHandlers+                $ serverFeatures server++    -- This basic one be overridden in another feature but means even in a+    -- minimal server we can provide content-negoticated text/plain errors+    textErrorPage :: ErrorResponse -> ServerPartE Response+    textErrorPage = return . toResponse++    fallbackNotFound =+      errNotFound "Page not found"+        [MText "Sorry, it's just not here."]+++    logExceptions :: ServerPart Response -> ServerPart Response+    logExceptions act = Lifted.catch act $ \e -> do+                          liftIO . lognotice verbosity $ "WARNING: Received exception: " ++ show e+                          Lifted.throwIO (e :: SomeException)++    verbosity = serverVerbosity (serverEnv server)++data TempServer = TempServer ThreadId++setUpTemp :: ServerConfig -> Int -> IO TempServer+setUpTemp sconf secs = do+    tid <- forkIO $ do+        -- wait a certain amount of time before setting it up, because sometimes+        -- happstack-state is very fast, and switching the servers has a time+        -- cost to it+        threadDelay $ secs*1000000+        -- could likewise specify a mirror to redirect to for tarballs, and 503 for everything else+        runServer listenOn $ (resp 503 $ setHeader "Content-Type" "text/html" $ toResponse html503)+    return (TempServer tid)+  where listenOn = confListenOn sconf++runServer :: (ToMessage a) => ListenOn -> ServerPartT IO a -> IO ()+runServer listenOn f+    = do socket <- bindIPv4 (loIP listenOn) (loPortNum listenOn)+         simpleHTTPWithSocket socket nullConf f++-- | Static 503 page, based on Happstack's 404 page.+html503 :: String+html503 =+    "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">" +++    "<html><head><title>503 Service Unavailable</title></head><body><h1>" +++    "503 Service Unavailable</h1><p>The server is undergoing maintenance" +++    "<br>It'll be back soon</p></body></html>"++tearDownTemp :: TempServer -> IO ()+tearDownTemp (TempServer tid) = do+    killThread tid+    -- give the server enough time to release the bind+    threadDelay $ 1000000+
+ Distribution/Server/Features.hs view
@@ -0,0 +1,258 @@+-- | This module ties together all the hackage features that we will use.+--+-- To add a feature:+--+-- * Import its initialization function+-- * Call its initialization function with all of its required arguments+-- * Add it to the allFeatures list+--+{-# LANGUAGE CPP #-}+module Distribution.Server.Features where++import Distribution.Server.Framework.Feature+import Distribution.Server.Framework.ServerEnv (ServerEnv(..))+import Distribution.Server.Framework.Logging++import Distribution.Server.Features.StaticFiles (initStaticFilesFeature)+import Distribution.Server.Features.Users    (initUserFeature, UserFeature)+import Distribution.Server.Features.Core     (initCoreFeature, coreResource, queryGetPackageIndex)+import Distribution.Server.Features.Upload   (initUploadFeature)+import Distribution.Server.Features.Mirror   (initMirrorFeature)++#ifndef MINIMAL+import Distribution.Server.Features.TarIndexCache       (initTarIndexCacheFeature)+import Distribution.Server.Features.Html                (initHtmlFeature)+import Distribution.Server.Features.PackageCandidates   (initPackageCandidatesFeature, candidatesCoreResource, queryGetCandidateIndex)+import Distribution.Server.Features.RecentPackages      (initRecentPackagesFeature)+import Distribution.Server.Features.Distro              (initDistroFeature)+import Distribution.Server.Features.PackageContents     (initPackageContentsFeature)+import Distribution.Server.Features.Documentation       (initDocumentationFeature)+import Distribution.Server.Features.BuildReports        (initBuildReportsFeature)+import Distribution.Server.Features.LegacyRedirects     (legacyRedirectsFeature)+import Distribution.Server.Features.PreferredVersions   (initVersionsFeature)+-- [reverse index disabled] import Distribution.Server.Features.ReverseDependencies (initReverseFeature)+import Distribution.Server.Features.DownloadCount       (initDownloadFeature)+import Distribution.Server.Features.Tags                (initTagsFeature)+import Distribution.Server.Features.Search              (initSearchFeature)+import Distribution.Server.Features.PackageList         (initListFeature)+import Distribution.Server.Features.HaskellPlatform     (initPlatformFeature)+import Distribution.Server.Features.UserDetails         (initUserDetailsFeature)+import Distribution.Server.Features.UserSignup          (initUserSignupFeature)+import Distribution.Server.Features.LegacyPasswds       (initLegacyPasswdsFeature)+import Distribution.Server.Features.EditCabalFiles      (initEditCabalFilesFeature)+#endif+import Distribution.Server.Features.ServerIntrospect (serverIntrospectFeature)++#ifdef DEBUG+import Distribution.Server.Features.Crash+#endif++import Control.Applicative ((<$>))+import Distribution.Server.Packages.PackageIndex (allPackages)+import Distribution.Package (packageId)++-- TODO:+-- * PackageServe: serving from tarballs (most of the work is setting it up on import)+-- * Snippet: code samples, pastebin for 'getting started' code+-- * LibraryRank: http://hackage.haskell.org/trac/hackage/ticket/183+-- * HaskellPlatform: mark off packages in the haskell platform.+-- * Anonymous build reports should work, as well as candidate build reports+-- * alter Users to be more in line with the current way registering is handled,+--     with email addresses available to maintainers, etc.+-- * UserNotify: email users and let them email each other+-- * Backup: would need a [HackageFeature] to backup, though a HackageFeature itself.+--     best approach is probably to write backup tarball to disk and transfer+--     it away through non-HTTP means (somewhat more secure)++initHackageFeatures :: ServerEnv -> IO ([HackageFeature], UserFeature)+initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do++    loginfo verbosity "Initialising features"++    -- Arguments denote feature dependencies.+    -- What follows is a topological sort along those lines+    staticFilesFeature <- initStaticFilesFeature env++    usersFeature    <- initUserFeature env++    coreFeature     <- initCoreFeature env+                         usersFeature++    mirrorFeature   <- initMirrorFeature env+                         coreFeature+                         usersFeature++    uploadFeature   <- initUploadFeature env+                         coreFeature+                         usersFeature++#ifndef MINIMAL+    tarIndexCacheFeature <- initTarIndexCacheFeature env usersFeature++    packageContentsFeature <- initPackageContentsFeature env+                                coreFeature+                                tarIndexCacheFeature++    packagesFeature <- initRecentPackagesFeature env+                         usersFeature+                         coreFeature+                         packageContentsFeature++    userDetailsFeature <- initUserDetailsFeature env+                            usersFeature+                            coreFeature++    userSignupFeature <- initUserSignupFeature env+                           usersFeature+                           userDetailsFeature++    legacyPasswdsFeature <- initLegacyPasswdsFeature env+                              usersFeature++    distroFeature   <- initDistroFeature env+                         usersFeature+                         coreFeature++    candidatesFeature <- initPackageCandidatesFeature env+                           usersFeature+                           coreFeature+                           uploadFeature+                           tarIndexCacheFeature++    reportsCoreFeature <- initBuildReportsFeature "reports-core" env+                         usersFeature+                         uploadFeature+                         (coreResource coreFeature)++    reportsCandidatesFeature <- initBuildReportsFeature "reports-candidates" env+                         usersFeature+                         uploadFeature+                         (candidatesCoreResource candidatesFeature)++    documentationCoreFeature <- initDocumentationFeature "documentation-core" env+                         (coreResource coreFeature)+                         (map packageId . allPackages <$> queryGetPackageIndex coreFeature)+                         uploadFeature+                         tarIndexCacheFeature++    documentationCandidatesFeature <- initDocumentationFeature "documentation-candidates" env+                         (candidatesCoreResource candidatesFeature)+                         (map packageId . allPackages <$> queryGetCandidateIndex candidatesFeature)+                         uploadFeature+                         tarIndexCacheFeature++    downloadFeature <- initDownloadFeature env+                         coreFeature+                         usersFeature++    tagsFeature     <- initTagsFeature env+                         coreFeature+                         uploadFeature++    versionsFeature <- initVersionsFeature env+                         coreFeature+                         uploadFeature+                         tagsFeature++    {- [reverse index disabled]+    reverseFeature  <- initReverseFeature env+                         coreFeature+                         versionsFeature+                         -}++    searchFeature   <- initSearchFeature env+                         coreFeature++    listFeature     <- initListFeature env+                         coreFeature+                         -- [reverse index disabled] reverseFeature+                         downloadFeature+                         tagsFeature+                         versionsFeature++    platformFeature <- initPlatformFeature env++    htmlFeature     <- initHtmlFeature env+                         usersFeature+                         coreFeature+                         packagesFeature+                         uploadFeature+                         candidatesFeature+                         versionsFeature+                         -- [reverse index disabled] reverseFeature+                         tagsFeature+                         downloadFeature+                         listFeature+                         searchFeature+                         mirrorFeature+                         distroFeature+                         documentationCoreFeature+                         documentationCandidatesFeature+                         userDetailsFeature++    editCabalFeature <- initEditCabalFilesFeature env+                          usersFeature+                          coreFeature+                          uploadFeature+#endif++    -- The order of initialization above should be the same as+    -- the order of this list.+    let allFeatures :: [HackageFeature]+        allFeatures =+         [ getFeatureInterface usersFeature+         , getFeatureInterface coreFeature+         , getFeatureInterface mirrorFeature+         , getFeatureInterface uploadFeature+#ifndef MINIMAL+         , getFeatureInterface tarIndexCacheFeature+         , getFeatureInterface packageContentsFeature+         , getFeatureInterface packagesFeature+         , getFeatureInterface userDetailsFeature+         , getFeatureInterface userSignupFeature+         , getFeatureInterface legacyPasswdsFeature+         , getFeatureInterface distroFeature+         , getFeatureInterface candidatesFeature+         , getFeatureInterface reportsCoreFeature+         , getFeatureInterface reportsCandidatesFeature+         , getFeatureInterface documentationCoreFeature+         , getFeatureInterface documentationCandidatesFeature+         , getFeatureInterface downloadFeature+         , getFeatureInterface tagsFeature+         , getFeatureInterface versionsFeature+         -- [reverse index disabled] , getFeatureInterface reverseFeature+         , getFeatureInterface searchFeature+         , getFeatureInterface listFeature+         , getFeatureInterface platformFeature+         , getFeatureInterface htmlFeature+         , legacyRedirectsFeature uploadFeature+         , editCabalFeature+#endif+         , staticFilesFeature+         , serverIntrospectFeature allFeatures+#ifdef DEBUG+         , serverCrashFeature+#endif+         ]++    -- Run all post init hooks, now that everyone's gotten a chance to register+    -- for them. This solution is iffy for initial feature hooks that rely on+    -- other features It also happens even in the backup/restore modes.+    loginfo verbosity "Running feature post-init hooks"+    mapM_ featurePostInit allFeatures+    loginfo verbosity "Initialising features done"++    return (allFeatures, usersFeature)++featureCheckpoint :: HackageFeature -> IO ()+featureCheckpoint = mapM_ abstractStateCheckpoint . featureState++checkpointAllFeatures :: [HackageFeature] -> IO ()+checkpointAllFeatures = mapM_ featureCheckpoint++featureShutdown :: HackageFeature -> IO ()+featureShutdown = mapM_ abstractStateClose . featureState++shutdownAllFeatures :: [HackageFeature] -> IO ()+shutdownAllFeatures   = mapM_ featureShutdown . reverse+
+ Distribution/Server/Features/BuildReports.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-}+module Distribution.Server.Features.BuildReports (+    ReportsFeature(..),+    ReportsResource(..),+    initBuildReportsFeature+  ) where++import Distribution.Server.Framework hiding (BuildLog)++import Distribution.Server.Features.Users+import Distribution.Server.Features.Upload+import Distribution.Server.Features.Core++import Distribution.Server.Features.BuildReports.Backup+import Distribution.Server.Features.BuildReports.State+import qualified Distribution.Server.Features.BuildReports.BuildReport as BuildReport+import Distribution.Server.Features.BuildReports.BuildReport (BuildReport(..))+import Distribution.Server.Features.BuildReports.BuildReports (BuildReports, BuildReportId(..), BuildLog(..))+import qualified Distribution.Server.Framework.ResponseContentTypes as Resource++import qualified Distribution.Server.Framework.BlobStorage as BlobStorage++import Distribution.Text+import Distribution.Package++import Data.ByteString.Lazy.Char8 (unpack) -- Build reports are ASCII+++-- TODO:+-- 1. Put the HTML view for this module in the HTML feature; get rid of the text view+-- 2. Decide build report upload policy (anonymous and authenticated)+data ReportsFeature = ReportsFeature {+    reportsFeatureInterface :: HackageFeature,+    reportsResource :: ReportsResource+}++instance IsHackageFeature ReportsFeature where+    getFeatureInterface = reportsFeatureInterface+++data ReportsResource = ReportsResource {+    reportsList :: Resource,+    reportsPage :: Resource,+    reportsLog  :: Resource,+    reportsListUri :: String -> PackageId -> String,+    reportsPageUri :: String -> PackageId -> BuildReportId -> String,+    reportsLogUri  :: PackageId -> BuildReportId -> String+}+++initBuildReportsFeature :: String+                        -> ServerEnv+                        -> UserFeature -> UploadFeature+                        -> CoreResource+                        -> IO ReportsFeature+initBuildReportsFeature name env@ServerEnv{serverStateDir} user upload core = do+    reportsState <- reportsStateComponent name serverStateDir+    return $ buildReportsFeature name env user upload core reportsState++reportsStateComponent :: String -> FilePath -> IO (StateComponent AcidState BuildReports)+reportsStateComponent name stateDir = do+  st  <- openLocalStateFrom (stateDir </> "db" </> name) initialBuildReports+  return StateComponent {+      stateDesc    = "Build reports"+    , stateHandle  = st+    , getState     = query st GetBuildReports+    , putState     = update st . ReplaceBuildReports+    , backupState  = dumpBackup+    , restoreState = restoreBackup+    , resetState   = reportsStateComponent name+    }++buildReportsFeature :: String+                    -> ServerEnv+                    -> UserFeature+                    -> UploadFeature+                    -> CoreResource+                    -> StateComponent AcidState BuildReports+                    -> ReportsFeature+buildReportsFeature name+                    ServerEnv{serverBlobStore = store}+                    UserFeature{..} UploadFeature{trusteesGroup}+                    CoreResource{ packageInPath+                                , guardValidPackageId+                                , corePackagePage+                                }+                    reportsState+  = ReportsFeature{..}+  where+    reportsFeatureInterface = (emptyHackageFeature name) {+        featureDesc = "Build reports and build logs"+      , featureResources =+          map ($ reportsResource) [+              reportsList+            , reportsPage+            , reportsLog+            ]+      , featureState = [abstractAcidStateComponent reportsState]+      }++    reportsResource = ReportsResource+          { reportsList = (extendResourcePath "/reports/.:format" corePackagePage) {+                resourceDesc = [ (GET, "List available build reports")+                               , (POST, "Upload a new build report")+                               ]+              , resourceGet  = [ ("txt", textPackageReports) ]+              , resourcePost = [ ("",    submitBuildReport) ]+              }+          , reportsPage = (extendResourcePath "/reports/:id.:format" corePackagePage) {+                resourceDesc   = [ (GET, "Get a specific build report")+                                 , (DELETE, "Delete a specific build report")+                                 ]+              , resourceGet    = [ ("txt", textPackageReport) ]+              , resourceDelete = [ ("",    deleteBuildReport) ]+              }+          , reportsLog  = (extendResourcePath "/reports/:id/log" corePackagePage) {+                resourceDesc   = [ (GET, "Get the build log associated with a build report")+                                 , (DELETE, "Delete a build log")+                                 , (PUT, "Upload a build log for a build report")+                                 ]+              , resourceGet    = [ ("txt", serveBuildLog) ]+              , resourceDelete = [ ("",    deleteBuildLog )]+              , resourcePut    = [ ("",    putBuildLog) ]+              }+          , reportsListUri = \format pkgid -> renderResource (reportsList reportsResource) [display pkgid, format]+          , reportsPageUri = \format pkgid repid -> renderResource (reportsPage reportsResource) [display pkgid, display repid, format]+          , reportsLogUri  = \pkgid repid -> renderResource (reportsLog reportsResource) [display pkgid, display repid]+          }++    textPackageReports dpath = do+      pkgid <- packageInPath dpath+      guardValidPackageId pkgid+      reportList <- queryState reportsState $ LookupPackageReports pkgid+      return . toResponse $ show reportList++    textPackageReport dpath = do+      pkgid <- packageInPath dpath+      guardValidPackageId pkgid+      (reportId, report, mlog) <- packageReport dpath pkgid+      return . toResponse $ unlines [ "Report #" ++ display reportId, show report+                                    , maybe "No build log" (const "Build log exists") mlog]++    -- result: not-found error or text file+    serveBuildLog :: DynamicPath -> ServerPartE Response+    serveBuildLog dpath = do+      pkgid <- packageInPath dpath+      guardValidPackageId pkgid+      (repid, _, mlog) <- packageReport dpath pkgid+      case mlog of+        Nothing -> errNotFound "Log not found" [MText $ "Build log for report " ++ display repid ++ " not found"]+        Just (BuildLog blobId) -> do+            file <- liftIO $ BlobStorage.fetch store blobId+            return . toResponse $ Resource.BuildLog file++    -- result: auth error, not-found error, parse error, or redirect+    submitBuildReport :: DynamicPath -> ServerPartE Response+    submitBuildReport dpath = do+      pkgid <- packageInPath dpath+      guardValidPackageId pkgid+      guardAuthorised_ [AnyKnownUser] -- allow any logged-in user+      reportbody <- expectTextPlain+      case BuildReport.parse $ unpack reportbody of+          Left err -> errBadRequest "Error submitting report" [MText err]+          Right report -> do+              reportId <- updateState reportsState $ AddReport pkgid (report, Nothing)+              -- redirect to new reports page+              seeOther (reportsPageUri reportsResource "" pkgid reportId) $ toResponse ()++    {-+      Example using curl:++        curl -u admin:admin \+             -X POST \+             -H "Content-Type: text/plain" \+             --data-binary @reports/nats-0.1 \+             http://localhost:8080/package/nats-0.1/reports/+    -}++    -- result: auth error, not-found error or redirect+    deleteBuildReport :: DynamicPath -> ServerPartE Response+    deleteBuildReport dpath = do+      pkgid <- packageInPath dpath+      guardValidPackageId pkgid+      reportId <- reportIdInPath dpath+      guardAuthorised_ [InGroup trusteesGroup]+      success <- updateState reportsState $ DeleteReport pkgid reportId+      if success+          then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse ()+          else errNotFound "Build report not found" [MText $ "Build report #" ++ display reportId ++ " not found"]++    -- result: auth error, not-found error, or redirect+    putBuildLog :: DynamicPath -> ServerPartE Response+    putBuildLog dpath = do+      pkgid <- packageInPath dpath+      guardValidPackageId pkgid+      reportId <- reportIdInPath dpath+      -- logged in users+      guardAuthorised_ [AnyKnownUser]+      blogbody <- expectTextPlain+      buildLog <- liftIO $ BlobStorage.add store blogbody+      void $ updateState reportsState $ SetBuildLog pkgid reportId (Just $ BuildLog buildLog)+      -- go to report page (linking the log)+      seeOther (reportsPageUri reportsResource "" pkgid reportId) $ toResponse ()++    {-+      Example using curl: (TODO: why is this PUT, while logs are POST?)++        curl -u admin:admin \+             -X PUT \+             -H "Content-Type: text/plain" \+             --data-binary @logs/nats-0.1 \+             http://localhost:8080/package/nats-0.1/reports/1/log+    -}++    -- result: auth error, not-found error or redirect+    deleteBuildLog :: DynamicPath -> ServerPartE Response+    deleteBuildLog dpath = do+      pkgid <- packageInPath dpath+      guardValidPackageId pkgid+      reportId <- reportIdInPath dpath+      guardAuthorised_ [InGroup trusteesGroup]+      void $ updateState reportsState $ SetBuildLog pkgid reportId Nothing+      -- go to report page (which should no longer link the log)+      seeOther (reportsPageUri reportsResource "" pkgid reportId) $ toResponse ()++    ---------------------------------------------------------------------------++    reportIdInPath :: MonadPlus m => DynamicPath -> m BuildReportId+    reportIdInPath dpath = maybe mzero return (simpleParse =<< lookup "id" dpath)++    packageReport :: DynamicPath -> PackageId -> ServerPartE (BuildReportId, BuildReport, Maybe BuildLog)+    packageReport dpath pkgid = do+      reportId <- reportIdInPath dpath+      mreport  <- queryState reportsState $ LookupReport pkgid reportId+      case mreport of+        Nothing -> errNotFound "Report not found" [MText "Build report does not exist"]+        Just (report, mlog) -> return (reportId, report, mlog)+
+ Distribution/Server/Features/BuildReports/Backup.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE PatternGuards #-}+module Distribution.Server.Features.BuildReports.Backup (+    dumpBackup,+    restoreBackup,+    buildReportsToExport,+    packageReportsToExport+  ) where++import Distribution.Server.Features.BuildReports.BuildReport (BuildReport)+import qualified Distribution.Server.Features.BuildReports.BuildReport as Report+import Distribution.Server.Features.BuildReports.BuildReports (BuildReports(..), PkgBuildReports(..), BuildReportId(..), BuildLog(..))+import qualified Distribution.Server.Features.BuildReports.BuildReports as Reports++import qualified Distribution.Server.Framework.BlobStorage as BlobStorage+import Distribution.Server.Framework.BackupDump+import Distribution.Server.Framework.BackupRestore+import Distribution.Server.Util.Parse (unpackUTF8, packUTF8)++import Distribution.Package+import Distribution.Text (display, simpleParse)+import Distribution.Version++import Control.Monad (foldM)+import Data.Map (Map)+import qualified Data.Map as Map+import System.FilePath (splitExtension)+import Data.ByteString.Lazy (ByteString)++dumpBackup  :: BuildReports -> [BackupEntry]+dumpBackup = buildReportsToExport++restoreBackup :: RestoreBackup BuildReports+restoreBackup = updateReports Reports.emptyReports Map.empty++-- when logs are encountered before their corresponding build reports+type PartialLogs = Map (PackageId, BuildReportId) BuildLog++updateReports :: BuildReports -> PartialLogs -> RestoreBackup BuildReports+updateReports buildReports partialLogs = RestoreBackup {+    restoreEntry = \entry -> do+      case entry of+        BackupByteString ["package", pkgStr, reportItem] bs+          | Just pkgId <- simpleParse pkgStr+          , (num, ".txt") <- splitExtension reportItem ->+              do checkPackageVersion pkgStr pkgId+                 (buildReports', partialLogs') <- importReport pkgId num bs buildReports partialLogs+                 return (updateReports buildReports' partialLogs')+        BackupBlob ["package", pkgStr, reportItem] blobId+          | Just pkgId <- simpleParse pkgStr+          , (num, ".log") <- splitExtension reportItem ->+              do checkPackageVersion pkgStr pkgId+                 (buildReports', partialLogs') <- importLog pkgId num blobId buildReports partialLogs+                 return (updateReports buildReports' partialLogs')+        _ ->+          return (updateReports buildReports partialLogs)+  , restoreFinalize =+      foldM insertLog buildReports (Map.toList partialLogs)+  }++insertLog :: BuildReports -> ((PackageId, BuildReportId), BuildLog) -> Restore BuildReports+insertLog buildReps ((pkgId, reportId), buildLog) =+  case Reports.setBuildLog pkgId reportId (Just buildLog) buildReps of+    Just buildReps' -> return buildReps'+    Nothing -> fail $ "Build log #" ++ display reportId ++ " exists for " ++ display pkgId ++ " but report itself does not"++checkPackageVersion :: String -> PackageIdentifier -> Restore ()+checkPackageVersion pkgStr pkgId =+  case packageVersion pkgId of+    Version [] [] -> fail $ "Build report package id " ++ show pkgStr ++ " must specify a version"+    _             -> return ()++importReport :: PackageId -> String -> ByteString -> BuildReports -> PartialLogs -> Restore (BuildReports, PartialLogs)+importReport pkgId repIdStr contents buildReps partialLogs = do+  reportId <- parseText "report id" repIdStr+  report   <- Report.parse (unpackUTF8 contents)+  let (mlog, partialLogs') = Map.updateLookupWithKey (\_ _ -> Nothing) (pkgId, reportId) partialLogs+      buildReps' = Reports.unsafeSetReport pkgId reportId (report, mlog) buildReps --doesn't check for duplicates+  return (buildReps', partialLogs')++importLog :: PackageId -> String -> BlobStorage.BlobId -> BuildReports -> PartialLogs -> Restore (BuildReports, PartialLogs)+importLog pkgId repIdStr blobId buildReps logs = do+  reportId <- parseText "report id" repIdStr+  let buildLog = BuildLog blobId+  case Reports.setBuildLog pkgId reportId (Just buildLog) buildReps of+    Nothing -> return (buildReps, Map.insert (pkgId, reportId) buildLog logs)+    Just buildReps' -> return (buildReps', logs)++------------------------------------------------------------------------------+buildReportsToExport :: BuildReports -> [BackupEntry]+buildReportsToExport buildReports = concatMap (uncurry packageReportsToExport) (Map.toList $ Reports.reportsIndex buildReports)++packageReportsToExport :: PackageId -> PkgBuildReports -> [BackupEntry]+packageReportsToExport pkgId pkgReports = concatMap (uncurry $ reportToExport prefix) (Map.toList $ Reports.reports pkgReports)+    where prefix = ["package", display pkgId]++reportToExport :: [FilePath] -> BuildReportId -> (BuildReport, Maybe BuildLog) -> [BackupEntry]+reportToExport prefix reportId (report, mlog) = BackupByteString (getPath ".txt") (packUTF8 $ Report.show report) :+    case mlog of Nothing -> []; Just (BuildLog blobId) -> [blobToBackup (getPath ".log") blobId]+  where+    getPath ext = prefix ++ [display reportId ++ ext]+
+ Distribution/Server/Features/BuildReports/BuildReport.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Reporting+-- Copyright   :  (c) David Waern 2008+-- License     :  BSD-like+--+-- Maintainer  :  david.waern@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Anonymous build report data structure, printing and parsing+--+-----------------------------------------------------------------------------+module Distribution.Server.Features.BuildReports.BuildReport (+    BuildReport(..),+    InstallOutcome(..),+    Outcome(..),++    -- * parsing and pretty printing+    read,+    parse,+    parseList,+    show,+    showList,+  ) where++import Distribution.Package+         ( PackageIdentifier )+import Distribution.PackageDescription+         ( FlagName(..), FlagAssignment )+--import Distribution.Version+--         ( Version )+import Distribution.System+         ( OS, Arch )+import Distribution.Compiler+         ( CompilerId )+import qualified Distribution.Text as Text+         ( Text(disp, parse) )+import Distribution.ParseUtils+         ( FieldDescr(..), ParseResult(..), Field(..)+         , simpleField, listField, readFields+         , syntaxError, locatedErrorMsg, showFields )+import Distribution.Simple.Utils+         ( comparing )+import Distribution.Server.Util.Merge+import Distribution.Server.Framework.Instances ()+import Distribution.Server.Framework.MemSize++import qualified Distribution.Compat.ReadP as Parse+         ( ReadP, pfail, munch1, skipSpaces )+import qualified Text.PrettyPrint.HughesPJ as Disp+         ( Doc, char, text )+import Text.PrettyPrint.HughesPJ+         ( (<+>), (<>) )++import Data.List+         ( unfoldr, sortBy )+import Data.Char as Char+         ( isAlpha, isAlphaNum )+import Data.Typeable+         ( Typeable )++import Prelude hiding (show, read)++data BuildReport+   = BuildReport {+    -- | The package this build report is about+    package         :: PackageIdentifier,++    -- | The OS and Arch the package was built on+    os              :: OS,+    arch            :: Arch,++    -- | The Haskell compiler (and hopefully version) used+    compiler        :: CompilerId,++    -- | The uploading client, ie cabal-install-x.y.z+    client          :: PackageIdentifier,++    -- | Which configurations flags we used+    flagAssignment  :: FlagAssignment,++    -- | Which dependent packages we were using exactly+    dependencies    :: [PackageIdentifier],++    -- | Did installing work ok?+    installOutcome  :: InstallOutcome,++    --   Which version of the Cabal library was used to compile the Setup.hs+--    cabalVersion    :: Version,++    --   Which build tools we were using (with versions)+--    tools      :: [PackageIdentifier],++    -- | Configure outcome, did configure work ok?+    docsOutcome     :: Outcome,++    -- | Configure outcome, did configure work ok?+    testsOutcome    :: Outcome+  }+  deriving (Eq, Typeable, Show)++data InstallOutcome+   = DependencyFailed PackageIdentifier+   | DownloadFailed+   | UnpackFailed+   | SetupFailed+   | ConfigureFailed+   | BuildFailed+   | InstallFailed+   | InstallOk+   deriving (Eq, Show)++data Outcome = NotTried | Failed | Ok deriving (Eq, Show)++-- ------------------------------------------------------------+-- * External format+-- ------------------------------------------------------------++initialBuildReport :: BuildReport+initialBuildReport = BuildReport {+    package         = requiredField "package",+    os              = requiredField "os",+    arch            = requiredField "arch",+    compiler        = requiredField "compiler",+    client          = requiredField "client",+    flagAssignment  = [],+    dependencies    = [],+    installOutcome  = requiredField "install-outcome",+--    cabalVersion  = Nothing,+--    tools         = [],+    docsOutcome     = NotTried,+    testsOutcome    = NotTried+  }+  where+    requiredField fname = error ("required field: " ++ fname)++-- -----------------------------------------------------------------------------+-- Parsing++read :: String -> BuildReport+read s = case parse s of+  Left  err -> error $ "error parsing build report: " ++ err+  Right rpt -> rpt++parse :: Monad m => String -> m BuildReport+parse s = case parseFields s of+  ParseFailed perror -> fail msg where (_, msg) = locatedErrorMsg perror+  ParseOk   _ report -> return report++--FIXME: this does not allow for optional or repeated fields+parseFields :: String -> ParseResult BuildReport+parseFields input = do+  fields <- mapM extractField =<< readFields input+  let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name)+                       sortedFieldDescrs+                       (sortBy (comparing (\(_,name,_) -> name)) fields)+  checkMerged initialBuildReport merged++  where+    extractField :: Field -> ParseResult (Int, String, String)+    extractField (F line name value)  = return (line, name, value)+    extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza"+    extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza"++    checkMerged report [] = return report+    checkMerged report (merged:remaining) = case merged of+      InBoth fieldDescr (line, _name, value) -> do+        report' <- fieldSet fieldDescr line value report+        checkMerged report' remaining+      OnlyInRight (line, name, _) ->+        syntaxError line ("Unrecognized field " ++ name)+      OnlyInLeft  fieldDescr ->+        fail ("Missing field " ++ fieldName fieldDescr)++parseList :: String -> [BuildReport]+parseList str =+  [ report | Right report <- map parse (split str) ]++  where+    split :: String -> [String]+    split = filter (not . null) . unfoldr chunk . lines+    chunk [] = Nothing+    chunk ls = case break null ls of+                 (r, rs) -> Just (unlines r, dropWhile null rs)++-- -----------------------------------------------------------------------------+-- Pretty-printing++show :: BuildReport -> String+show = showFields fieldDescrs++-- -----------------------------------------------------------------------------+-- Description of the fields, for parsing/printing++fieldDescrs :: [FieldDescr BuildReport]+fieldDescrs =+ [ simpleField "package"         Text.disp      Text.parse+                                 package        (\v r -> r { package = v })+ , simpleField "os"              Text.disp      Text.parse+                                 os             (\v r -> r { os = v })+ , simpleField "arch"            Text.disp      Text.parse+                                 arch           (\v r -> r { arch = v })+ , simpleField "compiler"        Text.disp      Text.parse+                                 compiler       (\v r -> r { compiler = v })+ , simpleField "client"          Text.disp      Text.parse+                                 client         (\v r -> r { client = v })+ , listField   "flags"           dispFlag       parseFlag+                                 flagAssignment (\v r -> r { flagAssignment = v })+ , listField   "dependencies"    Text.disp      Text.parse+                                 dependencies   (\v r -> r { dependencies = v })+ , simpleField "install-outcome" Text.disp      Text.parse+                                 installOutcome (\v r -> r { installOutcome = v })+ , simpleField "docs-outcome"    Text.disp      Text.parse+                                 docsOutcome    (\v r -> r { docsOutcome = v })+ , simpleField "tests-outcome"   Text.disp      Text.parse+                                 testsOutcome   (\v r -> r { testsOutcome = v })+ ]++sortedFieldDescrs :: [FieldDescr BuildReport]+sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs++dispFlag :: (FlagName, Bool) -> Disp.Doc+dispFlag (FlagName name, True)  =                  Disp.text name+dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name++parseFlag :: Parse.ReadP r (FlagName, Bool)+parseFlag = do+  name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')+  case name of+    ('-':flag) -> return (FlagName flag, False)+    flag       -> return (FlagName flag, True)++instance Text.Text InstallOutcome where+  disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid+  disp DownloadFailed  = Disp.text "DownloadFailed"+  disp UnpackFailed    = Disp.text "UnpackFailed"+  disp SetupFailed     = Disp.text "SetupFailed"+  disp ConfigureFailed = Disp.text "ConfigureFailed"+  disp BuildFailed     = Disp.text "BuildFailed"+  disp InstallFailed   = Disp.text "InstallFailed"+  disp InstallOk       = Disp.text "InstallOk"++  parse = do+    name <- Parse.munch1 Char.isAlphaNum+    case name of+      "DependencyFailed" -> do Parse.skipSpaces+                               pkgid <- Text.parse+                               return (DependencyFailed pkgid)+      "DownloadFailed"   -> return DownloadFailed+      "UnpackFailed"     -> return UnpackFailed+      "SetupFailed"      -> return SetupFailed+      "ConfigureFailed"  -> return ConfigureFailed+      "BuildFailed"      -> return BuildFailed+      "InstallFailed"    -> return InstallFailed+      "InstallOk"        -> return InstallOk+      _                  -> Parse.pfail++instance Text.Text Outcome where+  disp NotTried = Disp.text "NotTried"+  disp Failed   = Disp.text "Failed"+  disp Ok       = Disp.text "Ok"+  parse = do+    name <- Parse.munch1 Char.isAlpha+    case name of+      "NotTried" -> return NotTried+      "Failed"   -> return Failed+      "Ok"       -> return Ok+      _          -> Parse.pfail++instance MemSize BuildReport where+    memSize (BuildReport a b c d e f g h i j) = memSize10 a b c d e f g h i j++instance MemSize InstallOutcome where+    memSize (DependencyFailed a) = memSize1 a+    memSize _                    = memSize0++instance MemSize Outcome where+    memSize _ = memSize0
+ Distribution/Server/Features/BuildReports/BuildReports.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Distribution.Server.Features.BuildReports.BuildReports (+    BuildReport(..),+    BuildReports(..),+    BuildReportId(..),+    PkgBuildReports(..),+    BuildLog(..),+    emptyReports,+    emptyPkgReports,+    addReport,+    deleteReport,+    setBuildLog,+    lookupReport,+    lookupPackageReports,+    unsafeSetReport+  ) where++import qualified Distribution.Server.Framework.BlobStorage as BlobStorage+import qualified Distribution.Server.Features.BuildReports.BuildReport as BuildReport+import Distribution.Server.Features.BuildReports.BuildReport (BuildReport)++import Distribution.Package (PackageId)+import Distribution.Text (Text(..))++import Distribution.Server.Framework.MemSize++import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Serialize as Serialize+import Data.Serialize (Serialize)+import Data.Typeable (Typeable)+import Control.Applicative ((<$>))++import qualified Distribution.Server.Util.Parse as Parse+import qualified Text.PrettyPrint          as Disp++import qualified Data.ByteString.Char8 as BS.Char8 -- Build reports are ASCII++newtype BuildReportId = BuildReportId Int+  deriving (Eq, Ord, Serialize, Typeable, Show, MemSize)++incrementReportId :: BuildReportId -> BuildReportId+incrementReportId (BuildReportId n) = BuildReportId (n+1)++instance Text BuildReportId where+  disp (BuildReportId n) = Disp.int n+  parse = BuildReportId <$> Parse.int++newtype BuildLog = BuildLog BlobStorage.BlobId+  deriving (Eq, Serialize, Typeable, Show, MemSize)++data PkgBuildReports = PkgBuildReports {+    -- for each report, other useful information: Maybe UserId, UTCTime+    -- perhaps deserving its own data structure (SubmittedReport?)+    -- When a report was submitted is very useful information.+    -- also, use IntMap instead of Map BuildReportId?+    reports      :: !(Map BuildReportId (BuildReport, Maybe BuildLog)),+    -- one more than the maximum report id used+    nextReportId :: !BuildReportId+} deriving (Eq, Typeable, Show)++data BuildReports = BuildReports {+    reportsIndex :: !(Map.Map PackageId PkgBuildReports)+} deriving (Eq, Typeable, Show)++emptyPkgReports :: PkgBuildReports+emptyPkgReports = PkgBuildReports {+    reports = Map.empty,+    nextReportId = BuildReportId 1+}++emptyReports :: BuildReports+emptyReports = BuildReports {+    reportsIndex = Map.empty+}++lookupReport :: PackageId -> BuildReportId -> BuildReports -> Maybe (BuildReport, Maybe BuildLog)+lookupReport pkgid reportId buildReports = Map.lookup reportId . reports =<< Map.lookup pkgid (reportsIndex buildReports)++lookupPackageReports :: PackageId -> BuildReports -> [(BuildReportId, (BuildReport, Maybe BuildLog))]+lookupPackageReports pkgid buildReports = case Map.lookup pkgid (reportsIndex buildReports) of+    Nothing -> []+    Just rs -> Map.toList (reports rs)++-------------------------+-- PackageIds should /not/ have empty Versions. Caller should ensure this.+addReport :: PackageId -> (BuildReport, Maybe BuildLog) -> BuildReports -> (BuildReports, BuildReportId)+addReport pkgid report buildReports =+    let pkgReports  = Map.findWithDefault emptyPkgReports pkgid (reportsIndex buildReports)+        reportId    = nextReportId pkgReports+        pkgReports' = PkgBuildReports { reports = Map.insert reportId report (reports pkgReports)+                                      , nextReportId = incrementReportId reportId }+    in (buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) }, reportId)++unsafeSetReport :: PackageId -> BuildReportId -> (BuildReport, Maybe BuildLog) -> BuildReports -> BuildReports+unsafeSetReport pkgid reportId report buildReports =+    let pkgReports  = Map.findWithDefault emptyPkgReports pkgid (reportsIndex buildReports)+        pkgReports' = PkgBuildReports { reports = Map.insert reportId report (reports pkgReports)+                                      , nextReportId = max (incrementReportId reportId) (nextReportId pkgReports) }+    in buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) }++deleteReport :: PackageId -> BuildReportId -> BuildReports -> Maybe BuildReports+deleteReport pkgid reportId buildReports = case Map.lookup pkgid (reportsIndex buildReports) of+    Nothing -> Nothing+    Just pkgReports -> case Map.lookup reportId (reports pkgReports) of+        Nothing -> Nothing+        Just {} -> let pkgReports' = pkgReports { reports = Map.delete reportId (reports pkgReports) }+                   in Just $ buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) }++setBuildLog :: PackageId -> BuildReportId -> Maybe BuildLog -> BuildReports -> Maybe BuildReports+setBuildLog pkgid reportId buildLog buildReports = case Map.lookup pkgid (reportsIndex buildReports) of+    Nothing -> Nothing+    Just pkgReports -> case Map.lookup reportId (reports pkgReports) of+        Nothing -> Nothing+        Just (rlog, _) -> let pkgReports' = pkgReports { reports = Map.insert reportId (rlog, buildLog) (reports pkgReports) }+                         in Just $ buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) }++-------------------+-- Serialize instances+--++instance Serialize BuildReport where+  put = Serialize.put . BS.Char8.pack . BuildReport.show+  get = (BuildReport.read . BS.Char8.unpack) `fmap` Serialize.get++instance Serialize BuildReports where+  put (BuildReports index) = Serialize.put index+  get = do+    rs <- Serialize.get+    return BuildReports {+      reportsIndex = rs+    }++-- note: if the set of report ids is [1, 2, 3], then nextReportId = 4+-- after calling deleteReport for 3, the set is [1, 2] and nextReportId is still 4.+-- however, upon importing, nextReportId will = 3, one more than the maximum present+-- this is also a problem in ReportsBackup.hs. but it's not a major issue I think.+instance Serialize PkgBuildReports where+    put (PkgBuildReports listing _) = Serialize.put listing+    get = do+        listing <- Serialize.get+        return PkgBuildReports {+            reports = listing,+            nextReportId = if Map.null listing+                              then BuildReportId 1+                              else incrementReportId (fst $ Map.findMax listing)+        }+++instance MemSize BuildReports where+    memSize (BuildReports a) = memSize1 a++instance MemSize PkgBuildReports where+    memSize (PkgBuildReports a b) = memSize2 a b
+ Distribution/Server/Features/BuildReports/State.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell,+             FlexibleInstances, FlexibleContexts, MultiParamTypeClasses,+             TypeOperators, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Distribution.Server.Features.BuildReports.State where++import Distribution.Server.Features.BuildReports.BuildReports (BuildReportId, BuildLog, BuildReport, BuildReports, PkgBuildReports)+import qualified Distribution.Server.Features.BuildReports.BuildReports as BuildReports++import Distribution.Package++import qualified Data.Serialize as Serialize+import Control.Monad.Reader+import qualified Control.Monad.State as State+import Data.Acid     (Query, Update, makeAcidic)+import Data.SafeCopy (SafeCopy(..), contain)++-- BuildReportId+instance SafeCopy BuildReportId where+    putCopy = contain . Serialize.put+    getCopy = contain Serialize.get++-- BuildLog+instance SafeCopy BuildLog where+    putCopy = contain . Serialize.put+    getCopy = contain Serialize.get++-- BuildReport+instance SafeCopy BuildReport where+    putCopy = contain . Serialize.put+    getCopy = contain Serialize.get++-- PkgBuildReports+instance SafeCopy PkgBuildReports where+    putCopy = contain . Serialize.put+    getCopy = contain Serialize.get++-- BuildReports+instance SafeCopy BuildReports where+  putCopy = contain . Serialize.put+  getCopy = contain Serialize.get++initialBuildReports :: BuildReports+initialBuildReports = BuildReports.emptyReports++-- and defined methods+addReport :: PackageId -> (BuildReport, Maybe BuildLog) -> Update BuildReports BuildReportId+addReport pkgid report = do+    buildReports <- State.get+    let (reports, reportId) = BuildReports.addReport pkgid report buildReports+    State.put reports+    return reportId++setBuildLog :: PackageId -> BuildReportId -> Maybe BuildLog -> Update BuildReports Bool+setBuildLog pkgid reportId buildLog = do+    buildReports <- State.get+    case BuildReports.setBuildLog pkgid reportId buildLog buildReports of+        Nothing -> return False+        Just reports -> State.put reports >> return True++deleteReport :: PackageId -> BuildReportId -> Update BuildReports Bool --Maybe BuildReports+deleteReport pkgid reportId = do+    buildReports <- State.get+    case BuildReports.deleteReport pkgid reportId buildReports of+        Nothing -> return False+        Just reports -> State.put reports >> return True++lookupReport :: PackageId -> BuildReportId -> Query BuildReports (Maybe (BuildReport, Maybe BuildLog))+lookupReport pkgid reportId = asks (BuildReports.lookupReport pkgid reportId)++lookupPackageReports :: PackageId -> Query BuildReports [(BuildReportId, (BuildReport, Maybe BuildLog))]+lookupPackageReports pkgid = asks (BuildReports.lookupPackageReports pkgid)++getBuildReports :: Query BuildReports BuildReports+getBuildReports = ask++replaceBuildReports :: BuildReports -> Update BuildReports ()+replaceBuildReports = State.put++makeAcidic ''BuildReports ['addReport+                          ,'setBuildLog+                          ,'deleteReport+                          ,'lookupReport+                          ,'lookupPackageReports+                          ,'getBuildReports+                          ,'replaceBuildReports+                          ]+
+ Distribution/Server/Features/Core.hs view
@@ -0,0 +1,421 @@+{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, DoRec #-}+module Distribution.Server.Features.Core (+    CoreFeature(..),+    CoreResource(..),+    initCoreFeature,++    -- * Change events+    PackageChange(..),+    isPackageChangeAny,+    isPackageAdd,+    isPackageDelete,+    isPackageIndexChange,++    -- * Misc other utils+    packageExists,+    packageIdExists,+  ) where++import Distribution.Server.Framework++import Distribution.Server.Features.Core.State+import Distribution.Server.Features.Core.Backup++import Distribution.Server.Features.Users++import Distribution.Server.Packages.Types+import Distribution.Server.Users.Types (UserId)+import qualified Distribution.Server.Packages.Index as Packages.Index+import qualified Codec.Compression.GZip as GZip+import qualified Distribution.Server.Framework.ResponseContentTypes as Resource+import qualified Distribution.Server.Packages.PackageIndex as PackageIndex+import Distribution.Server.Packages.PackageIndex (PackageIndex)+import qualified Distribution.Server.Framework.BlobStorage as BlobStorage++import Data.Time.Clock (UTCTime)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.ByteString.Lazy (ByteString)++import Distribution.Text (display)+import Distribution.Package+import Distribution.Version (Version(..))+++data CoreFeature = CoreFeature {+    coreFeatureInterface :: HackageFeature,++    coreResource     :: CoreResource,++    -- queries+    queryGetPackageIndex :: MonadIO m => m (PackageIndex PkgInfo),++    -- update transactions+    updateAddPackage         :: MonadIO m => PackageId ->+                                CabalFileText -> UploadInfo ->+                                Maybe PkgTarball -> m Bool,+    updateDeletePackage      :: MonadIO m => PackageId -> m Bool,+    updateAddPackageRevision :: MonadIO m => PackageId ->+                                CabalFileText -> UploadInfo -> m (),+    updateAddPackageTarball  :: MonadIO m => PackageId ->+                                PkgTarball -> UploadInfo -> m Bool,+    updateSetPackageUploader :: MonadIO m => PackageId -> UserId -> m Bool,+    updateSetPackageUploadTime :: MonadIO m => PackageId -> UTCTime -> m Bool,++    -- | Set an entry in the 00-index.tar file.+    -- The 00-index.tar file contains all the package entries, but it is an+    -- extensible format and we can add more stuff. E.g. version preferences+    -- or crypto signatures.+    updateArchiveIndexEntry  :: MonadIO m => String -> (ByteString, UTCTime) -> m (),++    -- | Notification of package or index changes+    packageChangeHook :: Hook PackageChange (),++    -- | Notification of downloads+    packageDownloadHook :: Hook PackageId ()+}++instance IsHackageFeature CoreFeature where+    getFeatureInterface = coreFeatureInterface++-- | This is designed so that you can pattern match on just the kinds of+-- events you are interested in.+data PackageChange = PackageChangeAdd    PkgInfo+                   | PackageChangeDelete PkgInfo+                   | PackageChangeInfo   PkgInfo PkgInfo+                   | PackageChangeIndexExtra String ByteString UTCTime++isPackageChangeAny :: PackageChange -> Maybe (PackageId, Maybe PkgInfo)+isPackageChangeAny (PackageChangeAdd        pkginfo) = Just (packageId pkginfo, Just pkginfo)+isPackageChangeAny (PackageChangeDelete     pkginfo) = Just (packageId pkginfo, Nothing)+isPackageChangeAny (PackageChangeInfo     _ pkginfo) = Just (packageId pkginfo, Just pkginfo)+isPackageChangeAny  PackageChangeIndexExtra {}       = Nothing++isPackageAdd :: PackageChange -> Maybe PkgInfo+isPackageAdd (PackageChangeAdd pkginfo) = Just pkginfo+isPackageAdd _                          = Nothing++isPackageDelete :: PackageChange -> Maybe PkgInfo+isPackageDelete (PackageChangeDelete pkginfo) = Just pkginfo+isPackageDelete _                             = Nothing++isPackageIndexChange ::  PackageChange -> Maybe ()+isPackageIndexChange _ = Just ()++{-+-- Other examples we may want later...+isPackageAddVersion                :: Maybe PackageId,+isPackageDeleteVersion             :: Maybe PackageId,+isPackageChangeCabalFile           :: Maybe (PackageId, CabalFileText),+isPackageChangeCabalFileUploadInfo :: Maybe (PackageId, UploadInfo),+isPackageChangeTarball             :: Maybe (PackageId, PkgTarball),+isPackageIndexExtraChange          :: Maybe (String, ByteString, UTCTime)+-}++data CoreResource = CoreResource {+    corePackagesPage    :: Resource,+    corePackagePage     :: Resource,+    coreCabalFile       :: Resource,+    corePackageTarball  :: Resource,++    -- Render resources+    indexPackageUri    :: String -> String,+    corePackageIdUri   :: String -> PackageId -> String,+    corePackageNameUri :: String -> PackageName -> String,+    coreCabalUri       :: PackageId -> String,+    coreTarballUri     :: PackageId -> String,++    -- Find a PackageId or PackageName inside a path+    packageInPath :: (MonadPlus m, FromReqURI a) => DynamicPath -> m a,++    -- TODO: This is a rather ad-hoc function. Do we really need it?+    packageTarballInPath :: MonadPlus m => DynamicPath -> m PackageId,++    -- Check that a package exists (guard fails if version is empty)+    guardValidPackageId   :: PackageId   -> ServerPartE (),+    guardValidPackageName :: PackageName -> ServerPartE (),++    -- Find a package in the package DB+    lookupPackageName :: PackageName -> ServerPartE [PkgInfo],+    lookupPackageId   :: PackageId   -> ServerPartE PkgInfo+}++initCoreFeature :: ServerEnv -> UserFeature -> IO CoreFeature+initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay,+                              serverVerbosity = verbosity} users = do+    loginfo verbosity "Initialising core feature, start"++    -- Canonical state+    packagesState <- packagesStateComponent verbosity serverStateDir++    -- Ephemeral state+    -- Additional files to put in the index tarball like preferred-versions+    extraMap <- newMemStateWHNF Map.empty++    -- Hooks+    packageChangeHook   <- newHook+    packageDownloadHook <- newHook++    rec let (feature, getIndexTarball)+              = coreFeature env users+                            packagesState extraMap indexTar+                            packageChangeHook packageDownloadHook++        -- Caches+        -- The index.tar.gz file+        indexTar <- newAsyncCacheNF getIndexTarball+                      defaultAsyncCachePolicy {+                        asyncCacheName = "index tarball",+                        asyncCacheUpdateDelay  = serverCacheDelay,+                        asyncCacheSyncInit     = False,+                        asyncCacheLogVerbosity = verbosity+                      }++    registerHookJust packageChangeHook isPackageIndexChange $ \_ ->+      prodAsyncCache indexTar++    loginfo verbosity "Initialising core feature, end"+    return feature+++packagesStateComponent :: Verbosity -> FilePath -> IO (StateComponent AcidState PackagesState)+packagesStateComponent verbosity stateDir = do+  let stateFile = stateDir </> "db" </> "PackagesState"+  st <- logTiming verbosity "Loaded PackagesState" $+          openLocalStateFrom stateFile initialPackagesState+  return StateComponent {+       stateDesc    = "Main package database"+     , stateHandle  = st+     , getState     = query st GetPackagesState+     , putState     = update st . ReplacePackagesState+     , backupState  = indexToAllVersions+     , restoreState = packagesBackup+     , resetState   = packagesStateComponent verbosity+     }++coreFeature :: ServerEnv+            -> UserFeature+            -> StateComponent AcidState PackagesState+            -> MemState (Map String (ByteString, UTCTime))+            -> AsyncCache ByteString+            -> Hook PackageChange ()+            -> Hook PackageId ()+            -> ( CoreFeature+               , IO ByteString )++coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}+            packagesState indexExtras cacheIndexTarball+            packageChangeHook packageDownloadHook+  = (CoreFeature{..}, getIndexTarball)+  where+    coreFeatureInterface = (emptyHackageFeature "core") {+        featureDesc = "Core functionality"+      , featureResources = [+            coreIndexTarball+          , corePackagesPage+          , corePackagePage+          , corePackageRedirect+          , corePackageTarball+          , coreCabalFile+          ]+      , featureState    = [abstractAcidStateComponent packagesState]+      , featureCaches   = [+            CacheComponent {+              cacheDesc       = "main package index tarball",+              getCacheMemSize = memSize <$> readAsyncCache cacheIndexTarball+            }+          , CacheComponent {+              cacheDesc       = "package index extra files",+              getCacheMemSize = memSize <$> readMemState indexExtras+            }+          ]+      , featurePostInit = syncAsyncCache cacheIndexTarball+      }++    -- the rudimentary HTML resources are for when we don't want an additional HTML feature+    coreResource = CoreResource {..}+    coreIndexTarball = (resourceAt "/packages/index.tar.gz") {+        resourceDesc = [(GET, "tarball of package descriptions")]+      , resourceGet  = [("tarball", servePackagesIndex)]+      }+    corePackagesPage = (resourceAt "/packages/.:format") {+        resourceGet = [] -- have basic packages listing?+      }+    corePackagePage = resourceAt "/package/:package.:format"+    corePackageRedirect = (resourceAt "/package/") {+        resourceDesc = [(GET,  "Redirect to /packages/")]+      , resourceGet  = [("", \_ -> seeOther "/packages/" $ toResponse ())]+      }+    corePackageTarball = (resourceAt "/package/:package/:tarball.tar.gz") {+        resourceDesc = [(GET, "Get package tarball")]+      , resourceGet  = [("tarball", servePackageTarball)]+      }+    coreCabalFile = (resourceAt "/package/:package/:cabal.cabal") {+        resourceDesc = [(GET, "Get package .cabal file")]+      , resourceGet  = [("cabal", serveCabalFile)]+      }+    indexPackageUri = \format ->+      renderResource corePackagesPage [format]+    corePackageIdUri  = \format pkgid ->+      renderResource corePackagePage [display pkgid, format]+    corePackageNameUri = \format pkgname ->+      renderResource corePackagePage [display pkgname, format]+    coreCabalUri    = \pkgid ->+      renderResource coreCabalFile [display pkgid, display (packageName pkgid)]+    coreTarballUri  = \pkgid ->+      renderResource corePackageTarball [display pkgid, display pkgid]++    packageInPath dpath = maybe mzero return (lookup "package" dpath >>= fromReqURI)++    packageTarballInPath dpath = do+      PackageIdentifier name version <- packageInPath dpath+      case lookup "tarball" dpath >>= fromReqURI of+        Nothing -> mzero+        Just pkgid@(PackageIdentifier name' version') -> do+          -- rules:+          -- * the package name and tarball name must be the same+          -- * the tarball must specify a version+          -- * the package must either have no version or the same version as the tarball+          guard $ name == name' && version' /= Version [] [] && (version == version' || version == Version [] [])+          return pkgid++    guardValidPackageId pkgid = do+      guard (pkgVersion pkgid /= Version [] [])+      void $ lookupPackageId pkgid++    guardValidPackageName pkgname =+      void $ lookupPackageName pkgname++    -- Queries+    --+    queryGetPackageIndex :: MonadIO m => m (PackageIndex PkgInfo)+    queryGetPackageIndex = return . packageList =<< queryState packagesState GetPackagesState++    -- Update transactions+    --+    updateAddPackage :: MonadIO m => PackageId+                     -> CabalFileText -> UploadInfo+                     -> Maybe PkgTarball -> m Bool+    updateAddPackage pkgid cabalFile uploadinfo mtarball = do+      mpkginfo <- updateState packagesState+                   (AddPackage pkgid cabalFile uploadinfo mtarball)+      case mpkginfo of+        Nothing -> return False+        Just pkginfo -> do+          runHook_ packageChangeHook (PackageChangeAdd pkginfo)+          return True++    updateDeletePackage :: MonadIO m => PackageId -> m Bool+    updateDeletePackage pkgid = do+      mpkginfo <- updateState packagesState (DeletePackage pkgid)+      case mpkginfo of+        Nothing -> return False+        Just pkginfo -> do+          runHook_ packageChangeHook (PackageChangeDelete pkginfo)+          return True++    updateAddPackageRevision :: MonadIO m => PackageId -> CabalFileText -> UploadInfo -> m ()+    updateAddPackageRevision pkgid cabalfile uploadinfo = do+      (moldpkginfo, newpkginfo) <- updateState packagesState (AddPackageRevision pkgid cabalfile uploadinfo)+      case moldpkginfo of+        Nothing ->+          runHook_ packageChangeHook  (PackageChangeAdd newpkginfo)+        Just oldpkginfo ->+          runHook_ packageChangeHook  (PackageChangeInfo oldpkginfo newpkginfo)++    updateAddPackageTarball :: MonadIO m => PackageId -> PkgTarball -> UploadInfo -> m Bool+    updateAddPackageTarball pkgid tarball uploadinfo = do+      mpkginfo <- updateState packagesState (AddPackageTarball pkgid tarball uploadinfo)+      case mpkginfo of+        Nothing -> return False+        Just (oldpkginfo, newpkginfo) -> do+          runHook_ packageChangeHook  (PackageChangeInfo oldpkginfo newpkginfo)+          return True++    updateSetPackageUploader pkgid userid = do+      mpkginfo <- updateState packagesState (SetPackageUploader pkgid userid)+      case mpkginfo of+        Nothing -> return False+        Just (oldpkginfo, newpkginfo) -> do+          runHook_ packageChangeHook  (PackageChangeInfo oldpkginfo newpkginfo)+          return True++    updateSetPackageUploadTime pkgid time = do+      mpkginfo <- updateState packagesState (SetPackageUploadTime pkgid time)+      case mpkginfo of+        Nothing -> return False+        Just (oldpkginfo, newpkginfo) -> do+          runHook_ packageChangeHook  (PackageChangeInfo oldpkginfo newpkginfo)+          return True++    updateArchiveIndexEntry :: MonadIO m => String -> (ByteString, UTCTime) -> m ()+    updateArchiveIndexEntry entryName entryDetails@(entryData, entryTime) = do+      modifyMemState indexExtras (Map.insert entryName entryDetails)+      runHook_ packageChangeHook (PackageChangeIndexExtra entryName entryData entryTime)++    -- Cache updates+    --+    getIndexTarball :: IO ByteString+    getIndexTarball = do+      users  <- queryGetUserDb  -- note, changes here don't automatically propagate+      index  <- queryGetPackageIndex+      extras <- readMemState indexExtras+      let indexTarball' = GZip.compress (Packages.Index.write users extras index)+      return indexTarball'++    ------------------------------------------------------------------------------+    packageError :: [MessageSpan] -> ServerPartE a+    packageError = errNotFound "Package not found"++    lookupPackageName :: PackageName -> ServerPartE [PkgInfo]+    lookupPackageName pkgname = do+      pkgsIndex <- queryGetPackageIndex+      case PackageIndex.lookupPackageName pkgsIndex pkgname of+        []   -> packageError [MText "No such package in package index"]+        pkgs -> return pkgs++    lookupPackageId :: PackageId -> ServerPartE PkgInfo+    lookupPackageId (PackageIdentifier name (Version [] [])) = do+      pkgs <- lookupPackageName name+      -- pkgs is sorted by version number and non-empty+      return (last pkgs)+    lookupPackageId pkgid = do+      pkgsIndex <- queryGetPackageIndex+      case PackageIndex.lookupPackageId pkgsIndex pkgid of+        Just pkg -> return pkg+        _ -> packageError [MText $ "No such package version for " ++ display (packageName pkgid)]++    ------------------------------------------------------------------------++    servePackagesIndex :: DynamicPath -> ServerPartE Response+    servePackagesIndex _ = do+      indexTarball <- readAsyncCache cacheIndexTarball+      return $ toResponse (Resource.IndexTarball indexTarball)++    -- result: tarball or not-found error+    servePackageTarball :: DynamicPath -> ServerPartE Response+    servePackageTarball dpath = do+      pkgid <- packageTarballInPath dpath+      guard (pkgVersion pkgid /= Version [] [])+      pkg <- lookupPackageId pkgid+      case pkgTarball pkg of+          [] -> errNotFound "Tarball not found" [MText "No tarball exists for this package version."]+          ((tb, _):_) -> do+              let blobId = pkgTarballGz tb+              file <- liftIO $ BlobStorage.fetch store blobId+              runHook_ packageDownloadHook pkgid+              return $ toResponse $ Resource.PackageTarball file blobId (pkgUploadTime pkg)++    -- result: cabal file or not-found error+    serveCabalFile :: DynamicPath -> ServerPartE Response+    serveCabalFile dpath = do+      pkg <- packageInPath dpath >>= lookupPackageId+      -- check that the cabal name matches the package+      case lookup "cabal" dpath == Just (display $ packageName pkg) of+          True  -> return $ toResponse (Resource.CabalFile (cabalFileByteString (pkgData pkg)))+          False -> mzero++packageExists, packageIdExists :: (Package pkg, Package pkg') => PackageIndex pkg -> pkg' -> Bool+packageExists   pkgs pkg = not . null $ PackageIndex.lookupPackageName pkgs (packageName pkg)+packageIdExists pkgs pkg = maybe False (const True) $ PackageIndex.lookupPackageId pkgs (packageId pkg)+
+ Distribution/Server/Features/Core/Backup.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE PatternGuards #-}++module Distribution.Server.Features.Core.Backup (+    packagesBackup,+    indexToAllVersions,+    indexToAllVersions',+    indexToCurrentVersions,+    infoToAllEntries,+    infoToCurrentEntries,+    pkgPath,+    PartialIndex,+    PartialPkg,+    partialToFullPkg,+    parsePackageId,+    doPackageImport+  ) where++import Distribution.Server.Features.Core.State++import Distribution.Server.Packages.Types+import Distribution.Server.Framework.BackupRestore+import Distribution.Server.Framework.BackupDump+import qualified Distribution.Server.Packages.PackageIndex as PackageIndex++import Distribution.Package+import Distribution.PackageDescription.Parse (parsePackageDescription)+import Distribution.ParseUtils (ParseResult(..), locatedErrorMsg)+import Distribution.Text+import Data.Version+import Text.CSV++import Data.Map (Map)+import qualified Data.Map as Map+import Data.List+import Data.Ord (comparing)+import Control.Monad.State+import qualified Distribution.Server.Util.GZip as GZip+import qualified Data.ByteString.Lazy as BS+import System.FilePath ((</>))++packagesBackup :: RestoreBackup PackagesState+packagesBackup = updatePackages Map.empty++updatePackages :: PartialIndex -> RestoreBackup PackagesState+updatePackages packageMap = RestoreBackup {+    restoreEntry = \entry -> do+      packageMap' <- doPackageImport packageMap entry+      return (updatePackages packageMap')+  , restoreFinalize = do+      results <- mapM partialToFullPkg (Map.toList packageMap)+      return $ PackagesState (PackageIndex.fromList results)+  }++type PartialIndex = Map PackageId PartialPkg++data PartialPkg = PartialPkg {+    partialCabal :: [(Int, CabalFileText)],+    partialCabalUpload :: [(Int, UploadInfo)],+    partialTarball :: [(Int, PkgTarball)],+    partialTarballUpload :: [(Int, UploadInfo)]+}++doPackageImport :: PartialIndex -> BackupEntry -> Restore PartialIndex+doPackageImport packages entry = case entry of+  BackupByteString ("package":pkgStr:rest) bs -> do+    pkgId <- parsePackageId pkgStr+    let partial = Map.findWithDefault emptyPartialPkg pkgId packages+    partial' <- case rest of+      ["uploads.csv"] -> do+        list <- importCSV "uploads.csv" bs >>= importVersionList+        return $ partial { partialCabalUpload = list }+      ["tarball.csv"] -> do+        list <- importCSV "tarball.csv" bs >>= importVersionList+        return $ partial { partialTarballUpload = list }+      [other] | Just version <- extractVersion other (packageName pkgId) ".cabal" ->+        return $ partial { partialCabal = (version, CabalFileText bs):partialCabal partial }+      _ -> return partial+    return (Map.insert pkgId partial' packages)+  BackupBlob filename@["package",pkgStr,other] blobId -> do+    pkgId <- parsePackageId pkgStr+    let partial = Map.findWithDefault emptyPartialPkg pkgId packages+    partial' <- case extractVersion other pkgId ".tar.gz" of+      Just version -> do+        bs <- restoreGetBlob blobId+        blobIdUncompressed <- restoreAddBlob $ GZip.decompressNamed (foldr1 (</>) filename) (forceLast bs)+        let tb = PkgTarball { pkgTarballGz = blobId,+                              pkgTarballNoGz = blobIdUncompressed }+        return $ partial { partialTarball = (version, tb):partialTarball partial }+      _ -> return partial+    return (Map.insert pkgId partial' packages)+  _ ->+    return packages+  where+    extractVersion name text ext = case stripPrefix (display text ++ ext) name of+      Just "" -> Just 0+      Just ('-':num) -> case reads num of+          [(version, "")] -> Just version+          _ -> Nothing+      _ -> Nothing++    -- Workaround: in zlib prior to 0.5.4.1, GZip.decompress would not fully+    -- consume the input data (because the gzip format means it knows when+    -- it has got to the end of the expected data). As a consequence the bs+    -- we get from restoreGetBlob would not have its file handle closed.+    forceLast = BS.fromChunks . forceLastBlock . BS.toChunks+    forceLastBlock []     = []+    forceLastBlock (c:[]) = c : []+    forceLastBlock (c:cs) = c : forceLastBlock cs++parsePackageId :: String -> Restore PackageId+parsePackageId pkgStr = case simpleParse pkgStr of+  Nothing    -> fail $ "Package directory " ++ show pkgStr ++ " isn't a valid package id"+  Just pkgId -> return pkgId++importVersionList :: CSV -> Restore [(Int, UploadInfo)]+importVersionList = mapM fromRecord . drop 2+  where+    fromRecord :: Record -> Restore (Int, UploadInfo)+    fromRecord [indexStr, timeStr, idStr] = do+       index <- parseRead "index" indexStr+       utcTime <- parseUTCTime "time" timeStr+       user <- parseText "user-id" idStr+       return (index, (utcTime, user))+    fromRecord x = fail $ "Error processing versions list: " ++ show x++emptyPartialPkg :: PartialPkg+emptyPartialPkg = PartialPkg [] [] [] []++partialToFullPkg :: (PackageId, PartialPkg) -> Restore PkgInfo+partialToFullPkg (pkgId, partial) = do+    cabalDex   <- liftM2 (makeRecord $ "cabal file for " ++ display pkgId)+                         partialCabal partialCabalUpload partial+    tarballDex <- liftM2 (makeRecord $ "tarball for " ++ display pkgId)+                         partialTarball partialTarballUpload partial+    case descendUploadTimes cabalDex of+      [] -> fail $ "No cabal files found for " ++ display pkgId+      ((cabal, info):cabalOld) -> case parsePackageDescription (cabalFileString cabal) of+        ParseFailed err -> fail $ show (locatedErrorMsg err)+        ParseOk _ _ -> do+            return $ PkgInfo {+                pkgInfoId = pkgId,+                pkgData = cabal,+                pkgTarball = descendUploadTimes tarballDex,+                pkgDataOld = cabalOld,+                pkgUploadData = info+            }+  where+    makeRecord :: String -> [(Int, a)] -> [(Int, UploadInfo)] -> Restore [(a, UploadInfo)]+    makeRecord item list list' = makeRecord' item 0 (mergeBy (\(i, _) (i', _) -> compare i i')+                                                     (sortBy (comparing fst) list)+                                                     (sortBy (comparing fst) list'))++    -- (OnlyInLeft = no upload entry, OnlyInRight = no file), with checks for indexes+    makeRecord' _ _ [] = return []+    makeRecord' item index (InBoth x y:xs) = if fst x == index then fmap ((snd x, snd y):) (makeRecord' item (index+1) xs)+                                                               else fail $ "Missing index " ++ show (fst x-1) ++ "for " ++ item+    makeRecord' item _ (OnlyInLeft  x:_) = fail $ item ++ " (index "++ show (fst x)+                                               ++ ") found without matching upload log entry"+    makeRecord' item _ (OnlyInRight y:_) = fail $ "Upload log entry for " ++ item ++ " (index "+                                               ++ show (fst y) ++") found, but file itself missing"++--------------------------------------------------------------------------------+-- Every tarball and cabal file ever uploaded for every single package name and version+indexToAllVersions :: PackagesState -> [BackupEntry]+indexToAllVersions st =+    let pkgList = PackageIndex.allPackages . packageList $ st+    in concatMap infoToAllEntries pkgList++-- The most recent tarball and cabal file for every single package name and version+indexToAllVersions' :: PackagesState -> [BackupEntry]+indexToAllVersions' st =+    let pkgList = PackageIndex.allPackages . packageList $ st+    in concatMap infoToCurrentEntries pkgList++-- The most recent tarball and cabal file for the most recent version of every package+indexToCurrentVersions :: PackagesState -> [BackupEntry]+indexToCurrentVersions st =+    let pkgList = PackageIndex.allPackagesByName . packageList $ st+        pkgList' = map (maximumBy (comparing pkgUploadTime)) pkgList+    in concatMap infoToCurrentEntries pkgList'++-- it's also possible to make a cabal-only export++---------- Converting PkgInfo to entries+infoToAllEntries :: PkgInfo -> [BackupEntry]+infoToAllEntries pkg =+    let pkgId = pkgInfoId pkg+        cabals   = cabalListToExport pkgId $ ((pkgData pkg, pkgUploadData pkg):pkgDataOld pkg)+        tarballs = tarballListToExport pkgId (pkgTarball pkg)+    in cabals ++ tarballs++infoToCurrentEntries :: PkgInfo -> [BackupEntry]+infoToCurrentEntries pkg =+    let pkgId = pkgInfoId pkg+        cabals   = cabalListToExport pkgId [(pkgData pkg, pkgUploadData pkg)]+        tarballs = tarballListToExport pkgId (take 1 $ pkgTarball pkg)+    in cabals ++ tarballs++----------- Converting pieces of PkgInfo to entries+cabalListToExport :: PackageId -> [(CabalFileText, UploadInfo)] -> [BackupEntry]+cabalListToExport pkgId cabalInfos = csvToBackup (pkgPath pkgId "uploads.csv") (versionListToCSV infos):+    map cabalToExport (zip [0..] cabals)+  where (cabals, infos) = unzip cabalInfos+        cabalName = display (packageName pkgId) ++ ".cabal"+        cabalToExport :: (Int, CabalFileText) -> BackupEntry+        cabalToExport (0, CabalFileText bs) = BackupByteString (pkgPath pkgId cabalName) bs+        cabalToExport (n, CabalFileText bs) = BackupByteString (pkgPath pkgId (cabalName ++ "-" ++ show n)) bs++tarballListToExport :: PackageId -> [(PkgTarball, UploadInfo)] -> [BackupEntry]+tarballListToExport pkgId tarballInfos = csvToBackup (pkgPath pkgId "tarball.csv") (versionListToCSV infos):+    map tarballToExport (zip [0..] tarballs)+  where (tarballs, infos) = unzip tarballInfos+        tarballName = display pkgId ++ ".tar.gz"+        tarballToExport :: (Int, PkgTarball) -> BackupEntry+        tarballToExport (0, tb) = blobToBackup (pkgPath pkgId tarballName) (pkgTarballGz tb)+        tarballToExport (n, tb) = blobToBackup (pkgPath pkgId (tarballName ++ "-" ++ show n)) (pkgTarballGz tb)++pkgPath :: PackageId -> String -> [String]+pkgPath pkgId file = ["package", display pkgId, file]++versionListToCSV :: [UploadInfo] -> CSV+versionListToCSV infos = [showVersion versionCSVVer]:versionCSVKey:+    map (\(index, (time, user)) -> [ show (index :: Int)+                                   , formatUTCTime time+                                   , display user]) (zip [0..] infos)+  where+    versionCSVVer = Version [0,1] ["unstable"]+    versionCSVKey = ["index", "time", "user-id"]+
+ Distribution/Server/Features/Core/State.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, BangPatterns #-}++module Distribution.Server.Features.Core.State where++import Distribution.Package+import Distribution.Server.Packages.PackageIndex (PackageIndex)+import qualified Distribution.Server.Packages.PackageIndex as PackageIndex+import Distribution.Server.Packages.Types+import Distribution.Server.Users.Types (UserId)+import Distribution.Server.Framework.MemSize++import Data.Acid     (Query, Update, makeAcidic)+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Typeable+import Control.Monad.Reader+import qualified Control.Monad.State as State+import Data.Monoid+import Data.Time (UTCTime)+import Data.List (sortBy)+import Data.Ord (comparing)+import Data.Maybe (maybeToList)+++---------------------------------- Index of metadata and tarballs+data PackagesState = PackagesState {+    packageList  :: !(PackageIndex PkgInfo)+  }+  deriving (Eq, Typeable, Show)++deriveSafeCopy 0 'base ''PackagesState++instance MemSize PackagesState where+    memSize (PackagesState a) = 2 + memSize a++initialPackagesState :: PackagesState+initialPackagesState = PackagesState {+    packageList = mempty+  }++addPackage :: PackageId -> CabalFileText -> UploadInfo -> Maybe PkgTarball+           -> Update PackagesState (Maybe PkgInfo)+addPackage pkgid cabalfile uploadinfo mtarball = do +    PackagesState pkgindex <- State.get+    case PackageIndex.lookupPackageId pkgindex pkgid of+      Just _  -> return Nothing+      Nothing -> do+        let !pkginfo = PkgInfo {+              pkgInfoId     = pkgid,+              pkgData       = cabalfile,+              pkgTarball    = [ (tarball, uploadinfo)+                              | tarball <- maybeToList mtarball ],+              pkgDataOld    = [],+              pkgUploadData = uploadinfo+            }+            pkgindex' = PackageIndex.insert pkginfo pkgindex+        State.put $! PackagesState pkgindex'+        return (Just pkginfo)++deletePackage :: PackageId -> Update PackagesState (Maybe PkgInfo)+deletePackage pkgid = do+    PackagesState pkgindex <- State.get+    case PackageIndex.lookupPackageId pkgindex pkgid of+      Nothing      -> return Nothing+      Just pkginfo -> do+        let pkgindex' = PackageIndex.deletePackageId pkgid pkgindex+        State.put $! PackagesState pkgindex'+        return (Just pkginfo)++addPackageRevision :: PackageId -> CabalFileText -> UploadInfo+                   -> Update PackagesState (Maybe PkgInfo, PkgInfo)+addPackageRevision pkgid cabalfile uploadinfo = do+    PackagesState pkgindex <- State.get+    case PackageIndex.lookupPackageId pkgindex pkgid of+      Just pkginfo -> do+        let !pkginfo' = pkginfo {+              pkgData       = cabalfile,+              pkgUploadData = uploadinfo,+              pkgDataOld    = (pkgData pkginfo, pkgUploadData pkginfo)+                            : pkgDataOld pkginfo+            }+            pkgindex' = PackageIndex.insert pkginfo pkgindex+        State.put $! PackagesState pkgindex'+        return (Just pkginfo, pkginfo')+      Nothing -> do+        let !pkginfo = PkgInfo {+              pkgInfoId     = pkgid,+              pkgData       = cabalfile,+              pkgTarball    = [],+              pkgDataOld    = [],+              pkgUploadData = uploadinfo+            }+            pkgindex' = PackageIndex.insert pkginfo pkgindex+        State.put $! PackagesState pkgindex'+        return (Nothing, pkginfo)++addPackageTarball :: PackageId -> PkgTarball -> UploadInfo+                  -> Update PackagesState (Maybe (PkgInfo, PkgInfo))+addPackageTarball pkgid tarball uploadinfo =+    alterPackage pkgid $ \pkginfo ->+      pkginfo {+        pkgTarball = (tarball, uploadinfo) : pkgTarball pkginfo+      }++setPackageUploader :: PackageId -> UserId+                   -> Update PackagesState (Maybe (PkgInfo, PkgInfo))+setPackageUploader pkgid uid =+    alterPackage pkgid $ \pkginfo ->+      pkginfo {+        pkgUploadData = (pkgUploadTime pkginfo, uid)+      }++setPackageUploadTime :: PackageId -> UTCTime+                     -> Update PackagesState (Maybe (PkgInfo, PkgInfo))+setPackageUploadTime pkgid time =+    alterPackage pkgid $ \pkginfo ->+      pkginfo {+        pkgUploadData = (time, pkgUploadUser pkginfo)+      }++alterPackage :: PackageId -> (PkgInfo -> PkgInfo)+             -> Update PackagesState (Maybe (PkgInfo, PkgInfo))+alterPackage pkgid alter = do+    PackagesState pkgindex <- State.get+    case PackageIndex.lookupPackageId pkgindex pkgid of+      Nothing      -> return Nothing+      Just pkginfo -> do+        let !pkginfo' = alter pkginfo+            pkgindex' = PackageIndex.insert pkginfo' pkgindex+        State.put $! PackagesState pkgindex'+        return (Just (pkginfo, pkginfo'))++-- Keep old versions for a bit, for acid-state log compatability++insertPkgIfAbsent :: PkgInfo -> Update PackagesState Bool+insertPkgIfAbsent pkg = do+    pkgsState <- State.get+    case PackageIndex.lookupPackageId (packageList pkgsState) (packageId pkg) of+        Nothing -> do State.put $ pkgsState { packageList = PackageIndex.insert pkg (packageList pkgsState) }+                      return True+        Just{}  -> do return False++-- could also return something to indicate existence+mergePkg :: PkgInfo -> Update PackagesState ()+mergePkg pkg = State.modify $ \pkgsState -> pkgsState { packageList = PackageIndex.insertWith mergeFunc pkg (packageList pkgsState) }+  where+    mergeFunc newPkg oldPkg =+      let cabalH : cabalT = sortDesc $ (pkgData newPkg, pkgUploadData newPkg)+                                     : (pkgData oldPkg, pkgUploadData oldPkg)+                                     : pkgDataOld newPkg+                                    ++ pkgDataOld oldPkg+          tarballs        = sortDesc $ pkgTarball newPkg+                                    ++ pkgTarball oldPkg+      in PkgInfo {+             pkgInfoId     = pkgInfoId oldPkg -- should equal pkgInfoId newPkg+           , pkgData       = fst cabalH+           , pkgTarball    = tarballs+           , pkgDataOld    = cabalT+           , pkgUploadData = snd cabalH+           }++    sortDesc :: Ord a => [(a1, (a, b))] -> [(a1, (a, b))]+    sortDesc = sortBy $ flip (comparing (fst . snd))++deletePackageVersion :: PackageId -> Update PackagesState ()+deletePackageVersion pkg = State.modify $ \pkgsState -> pkgsState { packageList = deleteVersion (packageList pkgsState) }+    where deleteVersion = PackageIndex.deletePackageId pkg++replacePackageUploader :: PackageId -> UserId -> Update PackagesState (Either String (PkgInfo, PkgInfo))+replacePackageUploader pkg uid = modifyPkgInfo pkg $ \pkgInfo -> pkgInfo { pkgUploadData = (pkgUploadTime pkgInfo, uid) }++replacePackageUploadTime :: PackageId -> UTCTime -> Update PackagesState (Either String (PkgInfo, PkgInfo))+replacePackageUploadTime pkg time = modifyPkgInfo pkg $ \pkgInfo -> pkgInfo { pkgUploadData = (time, pkgUploadUser pkgInfo) }++addTarball :: PackageId -> PkgTarball -> UploadInfo -> Update PackagesState (Either String (PkgInfo, PkgInfo))+addTarball pkg tarball uploadInfo = modifyPkgInfo pkg $ \pkgInfo -> pkgInfo { pkgTarball = (tarball, uploadInfo) : pkgTarball pkgInfo }++modifyPkgInfo :: PackageId -> (PkgInfo -> PkgInfo) -> Update PackagesState (Either String (PkgInfo, PkgInfo))+modifyPkgInfo pkg f = do+  pkgsState <- State.get+  case PackageIndex.lookupPackageId (packageList pkgsState) pkg of+    Nothing -> return (Left "No such package")+    Just pkgInfo -> do+      let pkgInfo' = f pkgInfo+      State.put $ pkgsState { packageList = PackageIndex.insert pkgInfo' (packageList pkgsState) }+      return $ Right (pkgInfo, pkgInfo')++-- |Replace all existing packages and reports+replacePackagesState :: PackagesState -> Update PackagesState ()+replacePackagesState = State.put++getPackagesState :: Query PackagesState PackagesState+getPackagesState = ask++makeAcidic ''PackagesState ['getPackagesState+                           ,'replacePackagesState+                           ,'addPackage+                           ,'deletePackage+                           ,'addPackageRevision+                           ,'addPackageTarball+                           ,'setPackageUploader+                           ,'setPackageUploadTime++                             -- Keep old versions for a bit,+                             -- for acid-state log compatability+                           ,'replacePackageUploadTime+                           ,'replacePackageUploader+                           ,'addTarball+                           ,'insertPkgIfAbsent+                           ,'mergePkg+                           ,'deletePackageVersion+                           ]+
+ Distribution/Server/Features/Crash.hs view
@@ -0,0 +1,36 @@+-- | This is strictly for debugging only. Throws various kinds of exceptions.+module Distribution.Server.Features.Crash (serverCrashFeature) where++import Distribution.Server.Framework++import Data.Maybe+import Control.Exception+import Control.Concurrent++serverCrashFeature :: HackageFeature+serverCrashFeature = (emptyHackageFeature "crash") {+    featureDesc = "Throw various kinds of exceptions (for debugging purposes)"+  , featureResources = [+        (resourceAt "/crash/throw/:userError/:delay") {+          resourceDesc = [ (GET, "Throw a user error") ]+        , resourceGet  = [ ("", throwUserError) ]+        }+      ]+  , featureState = []+  }++throwUserError :: DynamicPath -> ServerPartE Response+throwUserError dpath = liftIO $ do+  let ex :: IOError+      ex = userError $ fromJust (lookup "userError" dpath)++      delay :: Int+      delay = read $ fromJust (lookup "delay" dpath)++  if delay == 0+    then throwIO ex+    else do tid <- myThreadId+            void . forkIO $ do threadDelay delay+                               putStrLn "Throwing exception.."+                               throwTo tid ex+            return . toResponse $ "Throwing exception in " ++ show delay ++ " microseconds"
+ Distribution/Server/Features/Distro.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-}+module Distribution.Server.Features.Distro (+    DistroFeature(..),+    DistroResource(..),+    initDistroFeature+  ) where++import Distribution.Server.Framework++import Distribution.Server.Features.Core+import Distribution.Server.Features.Users++import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), nullDescription)+import Distribution.Server.Features.Distro.State+import Distribution.Server.Features.Distro.Types+import Distribution.Server.Features.Distro.Backup (dumpBackup, restoreBackup)+import Distribution.Server.Util.Parse (unpackUTF8)++import Distribution.Text (display, simpleParse)+import Distribution.Package++import Data.List (intercalate)+import Text.CSV (parseCSV)+import Data.Version (showVersion)++-- TODO:+-- 1. write an HTML view for this module, and delete the text+-- 2. use GroupResource from the Users feature+-- 3. use MServerPart to support multiple views+data DistroFeature = DistroFeature {+    distroFeatureInterface :: HackageFeature,+    distroResource   :: DistroResource,+    maintainersGroup :: DynamicPath -> IO (Maybe UserGroup),+    queryPackageStatus :: MonadIO m => PackageName -> m [(DistroName, DistroPackageInfo)]+}++instance IsHackageFeature DistroFeature where+    getFeatureInterface = distroFeatureInterface++data DistroResource = DistroResource {+    distroIndexPage :: Resource,+    distroAllPage   :: Resource,+    distroPackages  :: Resource,+    distroPackage   :: Resource+}++initDistroFeature :: ServerEnv -> UserFeature -> CoreFeature -> IO DistroFeature+initDistroFeature ServerEnv{serverStateDir, serverVerbosity = verbosity} user core = do+    loginfo verbosity "Initialising distro feature, start"+    distrosState <- distrosStateComponent serverStateDir+    let feature = distroFeature user core distrosState+    loginfo verbosity "Initialising distro feature, end"+    return feature++distrosStateComponent :: FilePath -> IO (StateComponent AcidState Distros)+distrosStateComponent stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> "Distros") initialDistros+  return StateComponent {+      stateDesc    = ""+    , stateHandle  = st+    , getState     = query st GetDistributions+    , putState     = \(Distros dists versions) -> update st (ReplaceDistributions dists versions)+    , backupState  = dumpBackup+    , restoreState = restoreBackup+    , resetState   = distrosStateComponent+    }++distroFeature :: UserFeature+              -> CoreFeature+              -> StateComponent AcidState Distros+              -> DistroFeature+distroFeature UserFeature{..}+              CoreFeature{coreResource=CoreResource{packageInPath}}+              distrosState+  = DistroFeature{..}+  where+    distroFeatureInterface = (emptyHackageFeature "distro") {+        featureResources =+          map ($distroResource) [+              distroIndexPage+            , distroAllPage+            , distroPackages+            , distroPackage+            ]+      , featureState = [abstractAcidStateComponent distrosState]+      }++    queryPackageStatus :: MonadIO m => PackageName -> m [(DistroName, DistroPackageInfo)]+    queryPackageStatus pkgname = queryState distrosState (PackageStatus pkgname)++    distroResource = DistroResource+          { distroIndexPage = (resourceAt "/distros/.:format") {+                resourceGet  = [("txt", textEnumDistros)],+                resourcePost = [("", distroPostNew)]+              }+          , distroAllPage = (resourceAt "/distro/:distro") {+                resourcePut    = [("", distroPutNew)],+                resourceDelete = [("", distroDelete)]+              }+          , distroPackages = (resourceAt "/distro/:distro/packages.:format") {+                resourceGet    = [("txt", textDistroPkgs),+                                  ("csv", csvDistroPackageList)],+                resourcePut    = [("csv", distroPackageListPut)]+              }+          , distroPackage = (resourceAt "/distro/:distro/package/:package.:format") {+                resourceGet    = [("txt", textDistroPkg)],+                resourcePut    = [("",    distroPackagePut)],+                resourceDelete = [("",    distroPackageDelete)]+              }+          }++    maintainersGroup = \dpath -> case simpleParse =<< lookup "distro" dpath of+            Nothing -> return Nothing+            Just dname -> getMaintainersGroup adminGroup dname++    textEnumDistros _ = fmap (toResponse . intercalate ", " . map display) (queryState distrosState EnumerateDistros)+    textDistroPkgs dpath = withDistroPath dpath $ \dname pkgs -> do+        let pkglines = map (\(name, info) -> display name ++ " at " ++ display (distroVersion info) ++ ": " ++ distroUrl info) $ pkgs+        return $ toResponse (unlines $ ("Packages for " ++ display dname):pkglines)+    csvDistroPackageList dpath = withDistroPath dpath $ \_dname pkgs -> do+        return $ toResponse $ packageListToCSV $ pkgs+    textDistroPkg dpath = withDistroPackagePath dpath $ \_ _ info -> return . toResponse $ show info++    -- result: see-other uri, or an error: not authenticated or not found (todo)+    distroDelete dpath = withDistroNamePath dpath $ \distro -> do+        -- authenticate Hackage admins+        -- should also check for existence here of distro here+        void $ updateState distrosState $ RemoveDistro distro+        seeOther ("/distros/") (toResponse ())++    -- result: ok response or not-found error+    distroPackageDelete dpath = withDistroPackagePath dpath $ \dname pkgname info -> do+        -- authenticate distro maintainer+        case info of+            Nothing -> notFound . toResponse $ "Package not found for " ++ display pkgname+            Just {} -> do+                void $ updateState distrosState $ DropPackage dname pkgname+                ok $ toResponse "Ok!"++    -- result: see-other response, or an error: not authenticated or not found (todo)+    distroPackagePut dpath = withDistroPackagePath dpath $ \dname pkgname _ -> lookPackageInfo $ \newPkgInfo -> do+        -- authenticate distro maintainer+        void $ updateState distrosState $ AddPackage dname pkgname newPkgInfo+        seeOther ("/distro/" ++ display dname ++ "/" ++ display pkgname) $ toResponse "Ok!"++    -- result: see-other response, or an error: not authentcated or bad request+    distroPostNew _ = lookDistroName $ \dname -> do+        success <- updateState distrosState $ AddDistro dname+        if success+            then seeOther ("/distro/" ++ display dname) $ toResponse "Ok!"+            else badRequest $ toResponse "Selected distribution name is already in use"++    distroPutNew dpath =+      withDistroNamePath dpath $ \dname -> do+        _success <- updateState distrosState $ AddDistro dname+        -- it doesn't matter if it exists already or not+        ok $ toResponse "Ok!"++    -- result: ok repsonse or not-found error+    distroPackageListPut dpath =+      withDistroPath dpath $ \dname _pkgs -> do+        -- FIXME: authenticate distro maintainer+        lookCSVFile $ \csv ->+            case csvToPackageList csv of+                Nothing -> fail $ "Could not parse CSV File to a distro package list"+                Just list -> do+                    void $ updateState distrosState $ PutDistroPackageList dname list+                    ok $ toResponse "Ok!"++    withDistroNamePath :: DynamicPath -> (DistroName -> ServerPartE Response) -> ServerPartE Response+    withDistroNamePath dpath = require (return $ simpleParse =<< lookup "distro" dpath)++    withDistroPath :: DynamicPath -> (DistroName -> [(PackageName, DistroPackageInfo)] -> ServerPartE Response) -> ServerPartE Response+    withDistroPath dpath func = withDistroNamePath dpath $ \dname -> do+        isDist <- queryState distrosState (IsDistribution dname)+        case isDist of+          False -> notFound $ toResponse "Distribution does not exist"+          True -> do+            pkgs <- queryState distrosState (DistroStatus dname)+            func dname pkgs++    -- guards on the distro existing, but not the package+    withDistroPackagePath :: DynamicPath -> (DistroName -> PackageName -> Maybe DistroPackageInfo -> ServerPartE Response) -> ServerPartE Response+    withDistroPackagePath dpath func =+      withDistroNamePath dpath $ \dname -> do+        pkgname <- packageInPath dpath+        isDist <- queryState distrosState (IsDistribution dname)+        case isDist of+          False -> notFound $ toResponse "Distribution does not exist"+          True -> do+            pkgInfo <- queryState distrosState (DistroPackageStatus dname pkgname)+            func dname pkgname pkgInfo++    lookPackageInfo :: (DistroPackageInfo -> ServerPartE Response) -> ServerPartE Response+    lookPackageInfo func = do+        mInfo <- getDataFn $ do+            pVerStr <- look "version"+            pUriStr  <- look "uri"+            case simpleParse pVerStr of+                Nothing -> mzero+                Just pVer -> return $ DistroPackageInfo pVer pUriStr+        case mInfo of+            (Left errs) -> ok $ toResponse $ unlines $ "Sorry, something went wrong there." : errs+            (Right pInfo) -> func pInfo++    lookDistroName :: (DistroName -> ServerPartE Response) -> ServerPartE Response+    lookDistroName func = withDataFn (look "distro") $ \dname -> case simpleParse dname of+        Just distro -> func distro+        _ -> badRequest $ toResponse "Not a valid distro name"++    getMaintainersGroup :: UserGroup -> DistroName -> IO (Maybe UserGroup)+    getMaintainersGroup admins dname = do+        isDist <- queryState distrosState (IsDistribution dname)+        case isDist of+          False -> return Nothing+          True  -> return . Just $ UserGroup+            { groupDesc      = maintainerDescription dname+            , queryUserList  = queryState distrosState $ GetDistroMaintainers dname+            , addUserList    = updateState distrosState . AddDistroMaintainer dname+            , removeUserList = updateState distrosState . RemoveDistroMaintainer dname+            , canAddGroup    = [admins]+            , canRemoveGroup = [admins]+            }+++maintainerDescription :: DistroName -> GroupDescription+maintainerDescription dname = nullDescription+  { groupTitle = "Maintainers"+  , groupEntity = Just (str, Just $ "/distro/" ++ display dname)+  , groupPrologue = "Maintainers for a distribution can map packages to it."+  }+  where str = display dname++-- TODO: This calls parseCSV rather that importCSV -- not sure if that+-- matters (in particular, importCSV chops off the last, extranenous,+-- null entry that parseCSV adds)+lookCSVFile :: (CSVFile -> ServerPartE Response) -> ServerPartE Response+lookCSVFile func = do+    fileContents <- expectCSV+    case parseCSV "PUT input" (unpackUTF8 fileContents) of+      Left err -> badRequest $ toResponse $ "Could not parse CSV File: " ++ show err+      Right csv -> func (CSVFile csv)++packageListToCSV :: [(PackageName, DistroPackageInfo)] -> CSVFile+packageListToCSV entries+    = CSVFile $ map (\(pn,DistroPackageInfo version url) -> [display pn, showVersion version, url]) entries++csvToPackageList :: CSVFile -> Maybe [(PackageName, DistroPackageInfo)]+csvToPackageList (CSVFile records)+    = mapM fromRecord records+ where+    fromRecord [packageStr, versionStr, uri] = do+        package <- simpleParse packageStr+        version <- simpleParse versionStr+        return (package, DistroPackageInfo version uri)+    fromRecord _ = fail $ "Invalid distribution record"
+ Distribution/Server/Features/Distro/Backup.hs view
@@ -0,0 +1,115 @@+module Distribution.Server.Features.Distro.Backup (+    dumpBackup,+    restoreBackup,++    distroUsersToExport,+    distroUsersToCSV,+    distrosToExport,+    distroToCSV+  ) where++import qualified Distribution.Server.Features.Distro.Distributions as Distros+import Distribution.Server.Features.Distro.Distributions (DistroName, Distributions(..), DistroVersions(..), DistroPackageInfo(..))+import Distribution.Server.Features.Distro.State+import Distribution.Server.Users.Group (UserList(..))+import Distribution.Server.Framework.BackupDump+import Distribution.Server.Framework.BackupRestore++import Distribution.Text+import Data.Version+import Text.CSV (CSV, Record)++import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.IntSet as IntSet+import Data.List (foldl')+import System.FilePath (takeExtension)++dumpBackup  :: Distros -> [BackupEntry]+dumpBackup allDist =+    let distros  = distDistros allDist+        versions = distVersions allDist+    in distroUsersToExport distros:distrosToExport distros versions++restoreBackup :: RestoreBackup Distros+restoreBackup =+  updateDistros Distros.emptyDistributions Distros.emptyDistroVersions Map.empty++updateDistros :: Distributions -> DistroVersions -> Map DistroName UserList -> RestoreBackup Distros+updateDistros distros versions maintainers = RestoreBackup {+    restoreEntry = \entry ->+      case entry of+        BackupByteString ["packages", distro] bs | takeExtension distro == ".csv" -> do+          csv <- importCSV distro bs+          (distros', versions') <- importDistro csv distros versions+          return (updateDistros distros' versions' maintainers)+        BackupByteString ["maintainers.csv"] bs -> do+          csv <- importCSV "maintainers.csv" bs+          maintainers' <- importMaintainers csv maintainers+          return (updateDistros distros versions maintainers')+        _ ->+          return (updateDistros distros versions maintainers)+  , restoreFinalize = do+      let distros' = foldl' (\dists (name, group) -> Distros.modifyDistroMaintainers name (const group) dists) distros (Map.toList maintainers)+      return (Distros distros' versions)+  }++importDistro :: CSV -> Distributions -> DistroVersions -> Restore (Distributions, DistroVersions)+importDistro csv dists = \versions -> do+    let [[distroStr]] = take 1 $ drop 1 csv --no bounds checking..+    distro    <- parseText "distribution name" distroStr+    dists'    <- addDistribution distro dists+    versions' <- concatM (map (fromRecord distro) (drop 3 csv)) versions+    return (dists', versions')+  where+    fromRecord :: DistroName -> Record -> DistroVersions -> Restore DistroVersions+    fromRecord distro [packageStr, versionStr, uri] versions = do+        package <- parseText "package name" packageStr+        version <- parseText "version" versionStr+        return (Distros.addPackage distro package (DistroPackageInfo version uri) versions)+    fromRecord _ x _ = fail $ "Invalid distribution record " ++ show x++addDistribution :: DistroName -> Distributions -> Restore Distributions+addDistribution distro dists = do+  case Distros.addDistro distro dists of+    Just dists' -> return dists'+    Nothing     -> fail $ "Could not add distro: " ++ display distro++importMaintainers :: CSV -> Map DistroName UserList -> Restore (Map DistroName UserList)+importMaintainers = concatM . map fromRecord . drop 2+  where+    fromRecord :: Record -> Map DistroName UserList -> Restore (Map DistroName UserList)+    fromRecord (distroStr:idStr) maintainers = do+        distro <- parseText "distribution name" distroStr+        ids <- mapM (parseRead "user id") idStr+        return (Map.insert distro (UserList $ IntSet.fromList ids) maintainers)+    fromRecord x _ = fail $ "Invalid distro maintainer record: " ++ show x++--------------------------------------------------------------------------+distroUsersToExport :: Distributions -> BackupEntry+distroUsersToExport distros = csvToBackup ["maintainers.csv"] (distroUsersToCSV assocUsers)+  where assocUsers = map (\(name, UserList ul) -> (name, IntSet.toList ul)) . Map.toList $ Distros.nameMap distros++distroUsersToCSV :: [(DistroName, [Int])] -> CSV+distroUsersToCSV users = [showVersion distrosCSVVer]:distrosCSVKey:map (\(name, ids) -> display name:map show ids) users+  where+    distrosCSVKey = ["distro", "maintainers"]+    distrosCSVVer = Version [0,1] ["unstable"]++distrosToExport :: Distributions -> DistroVersions -> [BackupEntry]+distrosToExport dists distInfo = map distroEntry (Distros.enumerate dists)+  where distroEntry distro = csvToBackup ["packages", display distro ++ ".csv"] (distroToCSV distro distInfo)++distroToCSV :: DistroName -> DistroVersions -> CSV+distroToCSV distro distInfo+    = let stats = Distros.distroStatus distro distInfo+      in ([showVersion distrosCSVVer]:) $+         ([display distro]:) $+         (distrosCSVKey:) $+         flip map stats . uncurry $+           \name (DistroPackageInfo version url) ->+               [display name, showVersion version, url]+  where+    distrosCSVKey = ["package", "version", "url"]+    distrosCSVVer = Version [0,1] ["unstable"]+
+ Distribution/Server/Features/Distro/Distributions.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE+    RecordWildCards+  #-}++module Distribution.Server.Features.Distro.Distributions+    ( DistroName(..)+    , Distributions(..)+    , emptyDistributions+    , addDistro+    , removeDistro+    , updatePackageList+    , enumerate+    , isDistribution+    , DistroVersions(..)+    , emptyDistroVersions+    , DistroPackageInfo(..)+    , addPackage+    , dropPackage+    , removeDistroVersions+    , distroStatus+    , packageStatus+    , distroPackageStatus+    , getDistroMaintainers+    , modifyDistroMaintainers+    ) where++import qualified Data.Map as Map+import qualified Data.Set as Set++import Distribution.Server.Features.Distro.Types+import qualified Distribution.Server.Users.Group as Group+import Distribution.Server.Users.Group (UserList)++import Distribution.Package++import Data.List (foldl')+import Data.Maybe (fromJust, fromMaybe)++emptyDistributions :: Distributions+emptyDistributions = Distributions Map.empty++emptyDistroVersions :: DistroVersions+emptyDistroVersions = DistroVersions Map.empty Map.empty++--- Distribution updating+isDistribution :: DistroName -> Distributions -> Bool+isDistribution distro distros+    = Map.member distro (nameMap distros)++-- | Add a distribution. Returns 'Nothing' if the+-- name is already in use.+addDistro :: DistroName -> Distributions -> Maybe Distributions+addDistro name distros+    | isDistribution name distros = Nothing+    | otherwise = Just . Distributions $ Map.insert name Group.empty (nameMap distros)+++-- | List all known distributions+enumerate :: Distributions -> [DistroName]+enumerate distros = Map.keys (nameMap distros)++--- Queries++-- | For a particular distribution, which packages do they have, and+-- at which version. This function isn't very total.+distroStatus :: DistroName -> DistroVersions -> [(PackageName, DistroPackageInfo)]+distroStatus distro distros+    = let packageNames = maybe [] Set.toList (Map.lookup distro $ distroMap distros)+          f package = let infoMap = fromJust $ Map.lookup package (packageDistroMap distros)+                          info = fromJust $ Map.lookup distro infoMap+                      in (package, info)+      in map f packageNames++-- | For a particular package, which distributions contain it and at which+-- version.+packageStatus :: PackageName -> DistroVersions -> [(DistroName, DistroPackageInfo)]+packageStatus package dv = maybe [] Map.toList (Map.lookup package $ packageDistroMap dv)++distroPackageStatus :: DistroName -> PackageName -> DistroVersions -> Maybe DistroPackageInfo+distroPackageStatus distro package dv = Map.lookup distro =<< Map.lookup package (packageDistroMap dv)++--- Removing++-- | Remove a distirbution from the list of known distirbutions+removeDistro :: DistroName -> Distributions -> Distributions+removeDistro distro distros = distros { nameMap = Map.delete distro (nameMap distros) }++-- | Drop all packages for a distribution.+removeDistroVersions :: DistroName -> DistroVersions -> DistroVersions+removeDistroVersions distro dv+    = let packageNames = maybe [] Set.toList (Map.lookup distro $ distroMap dv)+      in foldl' (flip $ dropPackage distro) dv packageNames++--- Updating++-- | Bulk update of all information for one specific distribution+updatePackageList :: DistroName -> [(PackageName, DistroPackageInfo)] -> DistroVersions -> DistroVersions+updatePackageList distro list dv = foldr (\(pn,dpi) -> addPackage distro pn dpi) (removeDistroVersions distro dv) list++-- | Flag a package as no longer being distributed+dropPackage :: DistroName -> PackageName -> DistroVersions -> DistroVersions+dropPackage distro package dv@DistroVersions{..}+    = dv+      { packageDistroMap = Map.update pUpdate package packageDistroMap+      , distroMap  = Map.update dUpdate distro distroMap+      }+ where pUpdate infoMap =+           case Map.delete distro infoMap of+             infoMap'+                 -> if Map.null infoMap'+                    then Nothing+                    else Just infoMap'++       dUpdate packageNames =+           case Set.delete package packageNames of+             packageNames'+                 -> if Set.null packageNames'+                    then Nothing+                    else Just packageNames'++-- | Add a package for a distribution. If the distribution already+-- had information for the specified package, that information is replaced.+addPackage :: DistroName -> PackageName -> DistroPackageInfo+           -> DistroVersions -> DistroVersions+addPackage distro package info dv@DistroVersions{..}+    = dv+      { packageDistroMap = Map.insertWith'+                      (const $ Map.insert distro info)+                      package+                      (Map.singleton distro info)+                      packageDistroMap++      , distroMap  = Map.insertWith  -- should be insertWith'?+                      (const $ Set.insert package)+                      distro+                      (Set.singleton package)+                      distroMap+      }++getDistroMaintainers :: DistroName -> Distributions -> Maybe UserList+getDistroMaintainers name = Map.lookup name . nameMap++modifyDistroMaintainers :: DistroName -> (UserList -> UserList) -> Distributions -> Distributions+modifyDistroMaintainers name func dists = dists {nameMap = Map.alter (Just . func . fromMaybe Group.empty) name (nameMap dists) }+
+ Distribution/Server/Features/Distro/State.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, RecordWildCards #-}++module Distribution.Server.Features.Distro.State where++import Distribution.Package (PackageName)++import qualified Distribution.Server.Features.Distro.Distributions as Dist+import Distribution.Server.Features.Distro.Distributions+    (DistroName, Distributions, DistroVersions, DistroPackageInfo)++import Distribution.Server.Users.Group (UserList)+import qualified Distribution.Server.Users.Group as Group+import Distribution.Server.Users.Types (UserId)+import Distribution.Server.Users.State ()+import Distribution.Server.Framework.MemSize++import Data.Acid     (Query, Update, makeAcidic)+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Typeable++import Data.Maybe (fromMaybe)+import Control.Monad (liftM)+import Control.Monad.State.Class (get, put, modify)+import Control.Monad.Reader.Class (ask, asks)++data Distros = Distros {+    distDistros  :: !Distributions,+    distVersions :: !DistroVersions+}+ deriving (Eq, Typeable, Show)++deriveSafeCopy 0 'base ''Distros++instance MemSize Distros where+    memSize (Distros a b) = memSize2 a b++initialDistros :: Distros+initialDistros = Distros Dist.emptyDistributions Dist.emptyDistroVersions++addDistro :: DistroName -> Update Distros Bool+addDistro name = do+    state <- get+    let distros = distDistros state+    case Dist.addDistro name distros of+        Nothing -> return False+        Just distros' -> put state{distDistros = distros'} >> return True++-- DELETES a distribution. The name may then be re-used.+-- You should also clean up the permissions DB as well.+removeDistro :: DistroName -> Update Distros ()+removeDistro distro+    = modify $ \state@Distros{..} ->+      state { distDistros  = Dist.removeDistro distro distDistros+            , distVersions = Dist.removeDistroVersions distro distVersions+            }++enumerateDistros :: Query Distros [DistroName]+enumerateDistros = asks $ Dist.enumerate . distDistros++isDistribution :: DistroName -> Query Distros Bool+isDistribution distro = asks $ Dist.isDistribution distro . distDistros++getDistributions :: Query Distros Distros+getDistributions = ask++replaceDistributions :: Distributions -> DistroVersions -> Update Distros ()+replaceDistributions distributions distroVersions = put $ Distros distributions distroVersions++addPackage :: DistroName -> PackageName -> DistroPackageInfo -> Update Distros ()+addPackage distro package info+    = modify $ \state ->+      state{ distVersions = Dist.addPackage distro package info $ distVersions state }++dropPackage :: DistroName -> PackageName -> Update Distros ()+dropPackage distro package+    = modify $ \state ->+      state{ distVersions = Dist.dropPackage distro package $ distVersions state }++distroStatus :: DistroName -> Query Distros [(PackageName, DistroPackageInfo)]+distroStatus distro+    = asks $ Dist.distroStatus distro . distVersions++putDistroPackageList :: DistroName -> [(PackageName, DistroPackageInfo)] -> Update Distros ()+putDistroPackageList distro list+    = modify $ \state->+      state{ distVersions = Dist.updatePackageList distro list $ distVersions state }++packageStatus :: PackageName -> Query Distros [(DistroName, DistroPackageInfo)]+packageStatus package+    = asks $ Dist.packageStatus package . distVersions++distroPackageStatus :: DistroName -> PackageName -> Query Distros (Maybe DistroPackageInfo)+distroPackageStatus distro package = asks $ Dist.distroPackageStatus distro package . distVersions++getDistroMaintainers :: DistroName -> Query Distros UserList+getDistroMaintainers name = liftM (fromMaybe Group.empty . Dist.getDistroMaintainers name) (asks distDistros)++modifyDistroMaintainers :: DistroName -> (UserList -> UserList) -> Update Distros ()+modifyDistroMaintainers name func = modify (\distros -> distros {distDistros = Dist.modifyDistroMaintainers name func (distDistros distros) })++addDistroMaintainer :: DistroName -> UserId -> Update Distros ()+addDistroMaintainer name uid = modifyDistroMaintainers name (Group.add uid)++removeDistroMaintainer :: DistroName -> UserId -> Update Distros ()+removeDistroMaintainer name uid = modifyDistroMaintainers name (Group.remove uid)++replaceDistroMaintainers :: DistroName -> UserList -> Update Distros ()+replaceDistroMaintainers name ulist = modifyDistroMaintainers name (const ulist)++makeAcidic+  ''Distros+  [ -- update collection of distributions+    'addDistro+  , 'removeDistro++  -- query collection of distributions+  , 'enumerateDistros+  , 'isDistribution++  -- update package versions in distros+  , 'addPackage+  , 'dropPackage++  -- query status of package versions+  , 'distroStatus+  , 'packageStatus+  , 'distroPackageStatus++  -- bulk update+  , 'putDistroPackageList++  -- import/export+  , 'getDistributions+  , 'replaceDistributions++  -- distro maintainers+  , 'getDistroMaintainers+  , 'replaceDistroMaintainers+  , 'addDistroMaintainer+  , 'removeDistroMaintainer+  ]+
+ Distribution/Server/Features/Distro/Types.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE+    DeriveDataTypeable+  , GeneralizedNewtypeDeriving+  , TemplateHaskell+  #-}++++module Distribution.Server.Features.Distro.Types where++import Distribution.Server.Framework.Instances ()+import Distribution.Server.Framework.MemSize+import Distribution.Server.Users.State()+import Distribution.Server.Users.Group (UserList)++import qualified Data.Map as Map+import qualified Data.Set as Set++import qualified Distribution.Version as Version+import Distribution.Package++import Control.Applicative ((<$>))++import Distribution.Text (Text(..))++import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint          as Disp+import qualified Data.Char as Char++import Data.SafeCopy (base, deriveSafeCopy)+import Data.Typeable+++-- | Distribution names may contain letters, numbers and punctuation.+newtype DistroName = DistroName String+ deriving (Eq, Ord, Read, Show, Typeable, MemSize)++instance Text DistroName where+  disp (DistroName name) = Disp.text name+  parse = DistroName <$> Parse.munch1 (\c -> Char.isAlphaNum c || c `elem` "-_()[]{}=$,;")+++-- | Listing of known distirbutions and their maintainers+data Distributions = Distributions {+    nameMap :: !(Map.Map DistroName UserList)+}+ deriving (Eq, Typeable, Show)++-- | Listing of which distirbutions have which version of particular+-- packages.+data DistroVersions = DistroVersions {+    packageDistroMap :: !(Map.Map PackageName (Map.Map DistroName DistroPackageInfo)),+    distroMap  :: !(Map.Map DistroName (Set.Set PackageName))+} deriving (Eq, Typeable, Show)++data DistroPackageInfo+    = DistroPackageInfo+      { distroVersion :: Version.Version+      , distroUrl     :: String+      }+ deriving (Eq, Typeable, Show)++$(deriveSafeCopy 0 'base ''DistroName)+$(deriveSafeCopy 0 'base ''Distributions)+$(deriveSafeCopy 0 'base ''DistroVersions)+$(deriveSafeCopy 0 'base ''DistroPackageInfo)++instance MemSize Distributions where+    memSize (Distributions a) = memSize1 a++instance MemSize DistroVersions where+    memSize (DistroVersions a b) = memSize2 a b++instance MemSize DistroPackageInfo where+    memSize (DistroPackageInfo a b) = memSize2 a b
+ Distribution/Server/Features/Documentation.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, PatternGuards #-}+module Distribution.Server.Features.Documentation (+    DocumentationFeature(..),+    DocumentationResource(..),+    initDocumentationFeature+  ) where++import Distribution.Server.Framework++import Distribution.Server.Features.Documentation.State+import Distribution.Server.Features.Upload+import Distribution.Server.Features.Core+import Distribution.Server.Features.TarIndexCache++import Distribution.Server.Framework.BackupRestore+import qualified Distribution.Server.Framework.ResponseContentTypes as Resource+import Distribution.Server.Framework.BlobStorage (BlobId)+import qualified Distribution.Server.Framework.BlobStorage as BlobStorage+import qualified Distribution.Server.Util.ServeTarball as ServerTarball+import Data.TarIndex (TarIndex)+import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Check as Tar++import Distribution.Text+import Distribution.Package+import Distribution.Version (Version(..))++import qualified Data.ByteString.Lazy as BSL+import qualified Data.Map as Map+import Data.Function (fix)++import Data.Aeson (toJSON)++-- TODO:+-- 1. Write an HTML view for organizing uploads+-- 2. Have cabal generate a standard doc tarball, and serve that here+data DocumentationFeature = DocumentationFeature {+    documentationFeatureInterface :: HackageFeature,++    queryHasDocumentation :: MonadIO m => PackageIdentifier -> m Bool,++    documentationResource :: DocumentationResource+}++instance IsHackageFeature DocumentationFeature where+    getFeatureInterface = documentationFeatureInterface++data DocumentationResource = DocumentationResource {+    packageDocsContent :: Resource,+    packageDocsWhole   :: Resource,+    packageDocsStats   :: Resource,++    packageDocsContentUri :: PackageId -> String,+    packageDocsWholeUri   :: String -> PackageId -> String+}++initDocumentationFeature :: String+                         -> ServerEnv+                         -> CoreResource+                         -> IO [PackageIdentifier]+                         -> UploadFeature+                         -> TarIndexCacheFeature+                         -> IO DocumentationFeature+initDocumentationFeature name+                         env@ServerEnv{serverStateDir, serverVerbosity = verbosity}+                         core+                         getPackages+                         upload+                         tarIndexCache = do+    loginfo verbosity "Initialising documentation feature, start"+    documentationState <- documentationStateComponent name serverStateDir+    let feature = documentationFeature name env core getPackages upload tarIndexCache documentationState+    loginfo verbosity "Initialising documentation feature, end"+    return feature++documentationStateComponent :: String -> FilePath -> IO (StateComponent AcidState Documentation)+documentationStateComponent name stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> name) initialDocumentation+  return StateComponent {+      stateDesc    = "Package documentation"+    , stateHandle  = st+    , getState     = query st GetDocumentation+    , putState     = update st . ReplaceDocumentation+    , backupState  = dumpBackup+    , restoreState = updateDocumentation (Documentation Map.empty)+    , resetState   = documentationStateComponent name+    }+  where+    dumpBackup doc =+        let exportFunc (pkgid, blob) = BackupBlob ([display pkgid, "documentation.tar"]) blob+        in map exportFunc . Map.toList $ documentation doc++    updateDocumentation :: Documentation -> RestoreBackup Documentation+    updateDocumentation docs = RestoreBackup {+        restoreEntry = \entry ->+          case entry of+            BackupBlob [str, "documentation.tar"] blobId | Just pkgId <- simpleParse str -> do+              docs' <- importDocumentation pkgId blobId docs+              return (updateDocumentation docs')+            _ ->+              return (updateDocumentation docs)+      , restoreFinalize = return docs+      }++    importDocumentation :: PackageId -> BlobId -> Documentation -> Restore Documentation+    importDocumentation pkgId blobId (Documentation docs) =+      return (Documentation (Map.insert pkgId blobId docs))++documentationFeature :: String+                     -> ServerEnv+                     -> CoreResource+                     -> IO [PackageIdentifier]+                     -> UploadFeature+                     -> TarIndexCacheFeature+                     -> StateComponent AcidState Documentation+                     -> DocumentationFeature+documentationFeature name+                     ServerEnv{serverBlobStore = store}+                     CoreResource{+                         packageInPath+                       , guardValidPackageId+                       , corePackagePage+                       , corePackagesPage+                       , lookupPackageId+                       }+                     getPackages+                     UploadFeature{..}+                     TarIndexCacheFeature{cachedTarIndex}+                     documentationState+  = DocumentationFeature{..}+  where+    documentationFeatureInterface = (emptyHackageFeature name) {+        featureDesc = "Maintain and display documentation"+      , featureResources =+          map ($ documentationResource) [+              packageDocsContent+            , packageDocsWhole+            , packageDocsStats+            ]+      , featureState = [abstractAcidStateComponent documentationState]+      }++    queryHasDocumentation :: MonadIO m => PackageIdentifier -> m Bool+    queryHasDocumentation pkgid = queryState documentationState (HasDocumentation pkgid)++    documentationResource = fix $ \r -> DocumentationResource {+        packageDocsContent = (extendResourcePath "/docs/.." corePackagePage) {+            resourceDesc = [ (GET, "Browse documentation") ]+          , resourceGet  = [ ("", serveDocumentation) ]+          }+      , packageDocsWhole = (extendResourcePath "/docs.:format" corePackagePage) {+            resourceDesc = [ (GET, "Download documentation")+                           , (PUT, "Upload documentation")+                           ]+          , resourceGet  = [ ("tar", serveDocumentationTar) ]+          , resourcePut  = [ ("tar", uploadDocumentation) ]+          }+      , packageDocsStats = (extendResourcePath "/docs.:format" corePackagesPage) {+            resourceDesc = [ (GET, "Get information about which packages have documentation") ]+          , resourceGet  = [ ("json", serveDocumentationStats) ]+          }+      , packageDocsContentUri = \pkgid ->+          renderResource (packageDocsContent r) [display pkgid]+      , packageDocsWholeUri = \format pkgid ->+          renderResource (packageDocsWhole r) [display pkgid, format]+      }++    serveDocumentationStats :: DynamicPath -> ServerPartE Response+    serveDocumentationStats _dpath = do+        pkgs <- mapParaM queryHasDocumentation =<< liftIO getPackages+        return . toResponse . toJSON . map aux $ pkgs+      where+        aux :: (PackageIdentifier, Bool) -> (String, Bool)+        aux (pkgId, hasDocs) = (display pkgId, hasDocs)++    serveDocumentationTar :: DynamicPath -> ServerPartE Response+    serveDocumentationTar dpath =+      withDocumentation (packageDocsWhole documentationResource)+                        dpath $ \_ blob _ -> do+        file <- liftIO $ BlobStorage.fetch store blob+        return $ toResponse $ Resource.DocTarball file blob+++    -- return: not-found error or tarball+    serveDocumentation :: DynamicPath -> ServerPartE Response+    serveDocumentation dpath = do+      withDocumentation (packageDocsContent documentationResource)+                        dpath $ \pkgid blob index -> do+        let tarball = BlobStorage.filepath store blob+            etag    = blobETag blob+        -- if given a directory, the default page is index.html+        -- the root directory within the tarball is e.g. foo-1.0-docs/+        ServerTarball.serveTarball ["index.html"] (display pkgid ++ "-docs")+                                   tarball index etag++    -- return: not-found error (parsing) or see other uri+    uploadDocumentation :: DynamicPath -> ServerPartE Response+    uploadDocumentation dpath = do+      pkgid <- packageInPath dpath+      guardValidPackageId pkgid+      guardAuthorisedAsMaintainerOrTrustee (packageName pkgid)+      -- The order of operations:+      -- * Insert new documentation into blob store+      -- * Generate the new index+      -- * Drop the index for the old tar-file+      -- * Link the new documentation to the package+      fileContents <- expectUncompressedTarball+      mres <- liftIO $ BlobStorage.addWith store fileContents+                         (\content -> return (checkDocTarball pkgid content))+      case mres of+        Left  err -> errBadRequest "Invalid documentation tarball" [MText err]+        Right ((), blobid) -> do+          updateState documentationState $ InsertDocumentation pkgid blobid+          noContent (toResponse ())++   {-+     To upload documentation using curl:++     curl -u admin:admin \+          -X PUT \+          -H "Content-Type: application/x-tar" \+          --data-binary @transformers-0.3.0.0-docs.tar \+          http://localhost:8080/package/transformers-0.3.0.0/docs++     or++     curl -u admin:admin \+          -X PUT \+          -H "Content-Type: application/x-tar" \+          -H "Content-Encoding: gzip" \+          --data-binary @transformers-0.3.0.0-docs.tar.gz \+          http://localhost:8080/package/transformers-0.3.0.0/docs++     The tarfile is expected to have the structure++        transformers-0.3.0.0-docs/index.html+        ..+   -}++    withDocumentation :: Resource -> DynamicPath+                      -> (PackageId -> BlobId -> TarIndex -> ServerPartE Response)+                      -> ServerPartE Response+    withDocumentation self dpath func = do+      pkgid <- packageInPath dpath+      -- lookupPackageId gives us the latest version if no version is specified:+      pkginfo <- lookupPackageId pkgid+      case pkgVersion pkgid of+        -- if no version is given we want to redirect to the latest version+        Version [] _ -> tempRedirect (renderResource' self dpath') (toResponse "")+          where+            latest = packageId pkginfo+            dpath' = [ if var == "package"+                         then (var, display latest)+                         else e+                     | e@(var, _) <- dpath ]+        _ -> do+          mdocs <- queryState documentationState $ LookupDocumentation pkgid+          case mdocs of+            Nothing -> errNotFound "Not Found"+                         [MText $ "There is no documentation for " ++ display pkgid]+            Just blob -> do+              index <- liftIO $ cachedTarIndex blob+              func pkgid blob index++-- Check the tar file is well formed and all files are within foo-1.0-docs/+checkDocTarball :: PackageId -> BSL.ByteString -> Either String ()+checkDocTarball pkgid =+     checkEntries+   . fmapErr (either id show) . Tar.checkTarbomb (display pkgid ++ "-docs")+   . fmapErr (either id show) . Tar.checkSecurity+   . fmapErr (either id show) . Tar.checkPortability+   . fmapErr show             . Tar.read+  where+    fmapErr f    = Tar.foldEntries Tar.Next Tar.Done (Tar.Fail . f)+    checkEntries = Tar.foldEntries (\_ remainder -> remainder) (Right ()) Left++{------------------------------------------------------------------------------+  Auxiliary+------------------------------------------------------------------------------}++mapParaM :: Monad m => (a -> m b) -> [a] -> m [(a, b)]+mapParaM f = mapM (\x -> (,) x `liftM` f x)
+ Distribution/Server/Features/Documentation/State.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-}++module Distribution.Server.Features.Documentation.State where++import Distribution.Package+import Distribution.Server.Framework.BlobStorage (BlobId)+import Data.TarIndex () -- For SafeCopy instances+import Distribution.Server.Framework.MemSize++import Data.Acid     (Query, Update, makeAcidic)+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Typeable+import Control.Monad.Reader+import qualified Control.Monad.State as State++import qualified Data.Map as Map++---------------------------------- Documentation+data Documentation = Documentation {+     documentation :: !(Map.Map PackageIdentifier BlobId)+   } deriving (Typeable, Show, Eq)++deriveSafeCopy 0 'base ''Documentation++instance MemSize Documentation where+    memSize (Documentation a) = memSize1 a++initialDocumentation :: Documentation+initialDocumentation = Documentation Map.empty++lookupDocumentation :: PackageIdentifier -> Query Documentation (Maybe BlobId)+lookupDocumentation pkgId+    = do m <- asks documentation+         return $ Map.lookup pkgId m++hasDocumentation :: PackageIdentifier -> Query Documentation Bool+hasDocumentation pkgId+    = lookupDocumentation pkgId >>= \x -> case x of+         Just{} -> return True+         _      -> return False++insertDocumentation :: PackageIdentifier -> BlobId -> Update Documentation ()+insertDocumentation pkgId blob+    = State.modify $ \doc -> doc {documentation = Map.insert pkgId blob (documentation doc)}++getDocumentation :: Query Documentation Documentation+getDocumentation = ask++-- |Replace all existing documentation+replaceDocumentation :: Documentation -> Update Documentation ()+replaceDocumentation = State.put++makeAcidic ''Documentation ['insertDocumentation+                           ,'lookupDocumentation+                           ,'hasDocumentation+                           ,'getDocumentation+                           ,'replaceDocumentation+                           ]+
+ Distribution/Server/Features/DownloadCount.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-}+-- | Download counts+--+-- We maintain+--+-- 1. In-memory (ACID): today's download counts per package version+--+-- 2. In-memory (cache): total download count over the last 30 days per package+--    (across all versions). This is computed once per day from the on-disk+--    statistics (3).+--+-- 3. On-disk: total download per package per version per day. These are stored+--    in safe-copy format, one file per package; this allows to quickly load+--    the statistics for a given package to compute custom reports.+--+-- 4. On-disk: total download per package per version per day, stored as a single+--    CSV file that we append (1) to once per day. Strictly speaking this is+--    redundant, as this information is also stored in (3).+module Distribution.Server.Features.DownloadCount (+    DownloadFeature(..)+  , DownloadResource(..)+  , initDownloadFeature+  , RecentDownloads+  ) where++import Distribution.Server.Framework+import Distribution.Server.Framework.BackupRestore++import Distribution.Server.Features.DownloadCount.State+import Distribution.Server.Features.DownloadCount.Backup+import Distribution.Server.Features.Core+import Distribution.Server.Features.Users++import Distribution.Package+import Distribution.Server.Util.CountingMap (cmFromCSV)++import Data.Time.Calendar (Day, addDays)+import Data.Time.Clock (getCurrentTime, utctDay)+import Control.Concurrent.Chan+import Control.Concurrent (forkIO)++data DownloadFeature = DownloadFeature {+    downloadFeatureInterface :: HackageFeature+  , downloadResource         :: DownloadResource+  , recentPackageDownloads   :: MonadIO m => m RecentDownloads+  }++instance IsHackageFeature DownloadFeature where+    getFeatureInterface = downloadFeatureInterface++data DownloadResource = DownloadResource {+    topDownloads :: Resource+  }++initDownloadFeature :: ServerEnv -> CoreFeature -> UserFeature -> IO DownloadFeature+initDownloadFeature serverEnv@ServerEnv{serverStateDir, serverVerbosity = verbosity} core users = do+    loginfo verbosity "Initialising download feature, start"++    inMemState     <- inMemStateComponent  serverStateDir+    let onDiskState = onDiskStateComponent serverStateDir+    totalsCache    <- newMemStateWHNF =<< computeRecentDownloads =<< getState onDiskState+    downChan       <- newChan++    let feature   = downloadFeature core users serverEnv inMemState onDiskState totalsCache downChan++    registerHook (packageDownloadHook core) (writeChan downChan)+    loginfo verbosity "Initialising download feature, end"+    return feature++inMemStateComponent :: FilePath -> IO (StateComponent AcidState InMemStats)+inMemStateComponent stateDir = do+  initSt <- initInMemStats <$> getToday+  st <- openLocalStateFrom (dcPath stateDir </> "inmem") initSt+  return StateComponent {+      stateDesc    = "Today's download counts"+    , stateHandle  = st+    , getState     = query st GetInMemStats+    , putState     = update st . ReplaceInMemStats+    , backupState  = inMemBackup+    , restoreState = inMemRestore+    , resetState   = inMemStateComponent+    }++onDiskStateComponent :: FilePath -> StateComponent OnDiskState OnDiskStats+onDiskStateComponent stateDir = StateComponent {+      stateDesc    = "All time download counts"+    , stateHandle  = OnDiskState+    , getState     = readOnDiskStats (dcPath stateDir </> "ondisk")+    , putState     = writeOnDisk stateDir Nothing ReconstructLog+    , backupState  = onDiskBackup+    , restoreState = onDiskRestore+    , resetState   = return . onDiskStateComponent+    }++data ReconstructLog = ReconstructLog | DontReconstructLog++writeOnDisk :: FilePath+            -> Maybe (MemState RecentDownloads)+            -> ReconstructLog+            -> OnDiskStats+            -> IO ()+writeOnDisk stateDir mRecentDownloads shouldReconstructLog onDiskStats = do+  writeOnDiskStats (dcPath stateDir </> "ondisk") onDiskStats++  case mRecentDownloads of+    Just recentDownloads ->+      writeMemState recentDownloads =<< computeRecentDownloads onDiskStats+    Nothing ->+      return ()++  case shouldReconstructLog of+    ReconstructLog ->+      reconstructLog (dcPath stateDir) onDiskStats+    DontReconstructLog ->+      return ()++downloadFeature :: CoreFeature+                -> UserFeature+                -> ServerEnv+                -> StateComponent AcidState   InMemStats+                -> StateComponent OnDiskState OnDiskStats+                -> MemState RecentDownloads+                -> Chan PackageId+                -> DownloadFeature++downloadFeature CoreFeature{}+                UserFeature{..}+                ServerEnv{serverStateDir}+                inMemState+                onDiskState+                recentDownloadsCache+                downloadStream+  = DownloadFeature{..}+  where+    downloadFeatureInterface = (emptyHackageFeature "download") {+        featureResources = [ topDownloads downloadResource+                           , downloadCSV+                           ]+      , featurePostInit  = void $ forkIO registerDownloads+      , featureState     = [ abstractAcidStateComponent   inMemState+                           , abstractOnDiskStateComponent onDiskState+                           ]+      , featureCaches    = [+            CacheComponent {+              cacheDesc       = "recent package downloads cache",+              getCacheMemSize = memSize <$> readMemState recentDownloadsCache+            }+          ]+      }++    recentPackageDownloads :: MonadIO m => m RecentDownloads+    recentPackageDownloads = readMemState recentDownloadsCache++    registerDownloads = forever $ do+        pkg    <- readChan downloadStream+        today  <- getToday+        today' <- query (stateHandle inMemState) RecordedToday++        when (today /= today') $ do+          -- For the first download each day we reset the in-memory stats and..+          inMemStats <- getState inMemState+          putState inMemState $ initInMemStats today++          -- Write yesterday's downloads to the log+          appendToLog (dcPath serverStateDir) inMemStats++          -- Update the on-disk statistics and recompute recent downloads+          onDiskStats' <- updateHistory inMemStats <$> getState onDiskState+          writeOnDisk serverStateDir (Just recentDownloadsCache) DontReconstructLog onDiskStats'++        updateState inMemState $ RegisterDownload pkg++    downloadResource = DownloadResource {+        topDownloads = resourceAt "/packages/top.:format"+      }++    downloadCSV = (resourceAt "/packages/downloads.:format") {+        resourceDesc = [ (GET, "Get download counts")+                       , (PUT, "Upload download counts (for import)")+                       ]+      , resourceGet  = [ ("csv", getDownloadCounts) ]+      , resourcePut  = [ ("csv", putDownloadCounts) ]+      }++    getDownloadCounts :: DynamicPath -> ServerPartE Response+    getDownloadCounts _path = do+      onDiskStats <- liftIO $ getState onDiskState+      let [BackupByteString _ bs] = onDiskBackup onDiskStats+      return $ toResponse bs++    putDownloadCounts :: DynamicPath -> ServerPartE Response+    putDownloadCounts _path = do+      guardAuthorised_ [InGroup adminGroup]+      fileContents <- expectCSV+      csv          <- importCSV "PUT input" fileContents+      onDiskStats  <- cmFromCSV csv+      liftIO $ writeOnDisk serverStateDir (Just recentDownloadsCache) ReconstructLog onDiskStats+      ok $ toResponse $ "Imported " ++ show (length csv) ++ " records\n"++{------------------------------------------------------------------------------+  Auxiliary+------------------------------------------------------------------------------}++getToday :: IO Day+getToday = utctDay <$> getCurrentTime++getRecentDayRange :: Integer -> IO DayRange+getRecentDayRange numDays = do+  lastDay <- getToday+  let firstDay  = addDays (negate numDays) lastDay+      secondDay = addDays 1 firstDay+  return [firstDay, secondDay .. lastDay]++computeRecentDownloads :: OnDiskStats -> IO RecentDownloads+computeRecentDownloads onDiskStats = do+  recentRange <- getRecentDayRange 30+  return $ initRecentDownloads recentRange onDiskStats++dcPath :: FilePath -> FilePath+dcPath stateDir = stateDir </> "db" </> "DownloadCount"
+ Distribution/Server/Features/DownloadCount/State.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE TemplateHaskell, StandaloneDeriving, GeneralizedNewtypeDeriving, DeriveDataTypeable, TypeFamilies #-}+module Distribution.Server.Features.DownloadCount.State where++import Data.Time.Calendar (Day(..))+import Data.Version (Version)+import Data.Typeable (Typeable)+import Data.Foldable (forM_)+import Control.Monad.Reader (ask, asks)+import Control.Monad.State (get, put, liftIO, execStateT, modify)+-- import Control.Monad.IO.Class (liftIO)+import qualified Data.Map as Map+import System.FilePath ((</>))+import System.Directory (+    getDirectoryContents+  , createDirectoryIfMissing+  , removeDirectoryRecursive+  )+import Control.Applicative ((<$>))+import qualified Data.ByteString.Lazy as BSL+import System.IO (withFile, IOMode (..), hPutStr)+import Text.CSV (printCSV)+import Control.Exception (evaluate, handle, IOException)++import Data.Acid+import Data.SafeCopy (base, deriveSafeCopy, safeGet, safePut)+import Data.Serialize.Get (runGetLazy)+import Data.Serialize.Put (runPutLazy)++import Distribution.Package (+    PackageId+  , PackageName+  , packageName+  , packageVersion+  )+import Distribution.Text (simpleParse, display)++import Distribution.Server.Framework.Instances ()+import Distribution.Server.Framework.MemSize+import Distribution.Server.Util.CountingMap++{------------------------------------------------------------------------------+  Data types+------------------------------------------------------------------------------}++data InMemStats = InMemStats {+    inMemToday  :: Day+  , inMemCounts :: SimpleCountingMap PackageId+  }+  deriving (Show, Eq, Typeable)++newtype OnDiskStats = OnDiskStats {+    onDiskStats :: NestedCountingMap PackageName OnDiskPerPkg+  }+  deriving (CountingMap (PackageName, (Day, Version)), Show, Eq, MemSize)++newtype OnDiskPerPkg = OnDiskPerPkg {+    onDiskPerPkgCounts :: NestedCountingMap Day (SimpleCountingMap Version)+  }+  deriving (CountingMap (Day, Version), Show, Eq, MemSize)++newtype RecentDownloads = RecentDownloads {+    recentDownloads :: SimpleCountingMap PackageName+  }+  deriving (CountingMap PackageName, Show, Eq, MemSize)++{------------------------------------------------------------------------------+  Initial instances+------------------------------------------------------------------------------}++initInMemStats :: Day -> InMemStats+initInMemStats day = InMemStats {+    inMemToday  = day+  , inMemCounts = cmEmpty+  }++type DayRange = [Day]++initRecentDownloads :: DayRange -> OnDiskStats -> RecentDownloads+initRecentDownloads dayRange (OnDiskStats (NCM _ perPackage)) =+    foldr (.) id (map goDay dayRange) cmEmpty+  where+    goDay :: Day -> RecentDownloads -> RecentDownloads+    goDay day = foldr (.) id $ map (goPackage day) (Map.toList perPackage)++    goPackage :: Day -> (PackageName, OnDiskPerPkg) -> RecentDownloads -> RecentDownloads+    goPackage day (pkgName, OnDiskPerPkg (NCM _ perDay)) =+      case Map.lookup day perDay of+        Nothing         -> id+        Just perVersion -> cmInsert pkgName (cmTotal perVersion)++{------------------------------------------------------------------------------+  Pure updates/queries+------------------------------------------------------------------------------}++updateHistory :: InMemStats -> OnDiskStats -> OnDiskStats+updateHistory (InMemStats day perPkg) =+    foldr (.) id $ map goPackage (cmToList perPkg)+  where+    goPackage :: (PackageId, Int) -> OnDiskStats -> OnDiskStats+    goPackage (pkgId, count) =+      cmInsert (packageName pkgId, (day, packageVersion pkgId)) count++{------------------------------------------------------------------------------+  MemSize+------------------------------------------------------------------------------}++instance MemSize InMemStats where+  memSize (InMemStats a b) = memSize2 a b++{------------------------------------------------------------------------------+  Serializing on-disk stats+------------------------------------------------------------------------------}++readOnDiskStats :: FilePath -> IO OnDiskStats+readOnDiskStats stateDir = flip execStateT cmEmpty $ do+    pkgs <- liftIO $ do createDirectoryIfMissing True stateDir+                        getDirectoryContents stateDir++    forM_ pkgs $ \pkgStr -> forM_ (simpleParse pkgStr) $ \pkgName -> do+      let pkgFile = stateDir </> pkgStr+      mPkgStats <- liftIO $ withFile pkgFile ReadMode $ \h ->+        -- By evaluating the Either result from the parser we force+        -- all contents to be read+        evaluate =<< (runGetLazy safeGet <$> BSL.hGetContents h)+      case mPkgStats of+        Left  _        -> return () -- Ignore files with errors+        Right pkgStats -> modify (aux pkgName pkgStats)+  where+    aux :: PackageName -> OnDiskPerPkg -> OnDiskStats -> OnDiskStats+    aux pkgName pkgStats (OnDiskStats (NCM total perPkg)) =+      -- This is correct only because we see each package name at most once+      OnDiskStats $ NCM (total + cmTotal pkgStats)+                        (Map.insert pkgName pkgStats perPkg)++writeOnDiskStats :: FilePath -> OnDiskStats -> IO ()+writeOnDiskStats stateDir (OnDiskStats (NCM _ onDisk)) = do+   -- Remove old state (ignoring exceptions)+   ignoreIOException $ removeDirectoryRecursive stateDir+   -- Write new state+   createDirectoryIfMissing True stateDir+   forM_ (Map.toList onDisk) $ \(pkgName, perPkg) -> do+     let pkgFile = stateDir </> display pkgName+     BSL.writeFile pkgFile $ runPutLazy (safePut perPkg)+  where+    ignoreIOException :: IO () -> IO ()+    ignoreIOException = handle $ \e -> let _ = e :: IOException +                                       in return ()  ++{------------------------------------------------------------------------------+  The append-only all-time log+------------------------------------------------------------------------------}++appendToLog :: FilePath -> InMemStats -> IO ()+appendToLog stateDir (InMemStats _ inMemStats) =+  withFile (stateDir </> "log") AppendMode $ \h ->+    hPutStr h $ printCSV (cmToCSV inMemStats)++reconstructLog :: FilePath -> OnDiskStats -> IO ()+reconstructLog stateDir onDisk =+  withFile (stateDir </> "log") WriteMode $ \h ->+    hPutStr h $ printCSV (cmToCSV onDisk)++{------------------------------------------------------------------------------+  ACID stuff+------------------------------------------------------------------------------}++deriveSafeCopy 0 'base ''InMemStats+deriveSafeCopy 0 'base ''OnDiskPerPkg++getInMemStats :: Query InMemStats InMemStats+getInMemStats = ask++replaceInMemStats :: InMemStats -> Update InMemStats ()+replaceInMemStats = put++recordedToday :: Query InMemStats Day+recordedToday = asks inMemToday++registerDownload :: PackageId -> Update InMemStats ()+registerDownload pkgId = do+  InMemStats day counts <- get+  put $ InMemStats day (cmInsert pkgId 1 counts)++makeAcidic ''InMemStats [ 'getInMemStats+                        , 'replaceInMemStats+                        , 'recordedToday+                        , 'registerDownload+                        ]
+ Distribution/Server/Features/EditCabalFiles.hs view
@@ -0,0 +1,450 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE NamedFieldPuns, RecordWildCards, BangPatterns,+             StandaloneDeriving, GeneralizedNewtypeDeriving #-}+module Distribution.Server.Features.EditCabalFiles (+    initEditCabalFilesFeature+  ) where++import Distribution.Server.Framework+import Distribution.Server.Framework.Templating++import Distribution.Server.Features.Users+import Distribution.Server.Features.Core+import Distribution.Server.Packages.Types+import Distribution.Server.Features.Upload++import Distribution.Package+import Distribution.Text (display)+import Distribution.PackageDescription+import Distribution.PackageDescription.Parse+         (parsePackageDescription, sourceRepoFieldDescrs)+import Distribution.PackageDescription.Check+import Distribution.ParseUtils+         ( ParseResult(..), locatedErrorMsg, PWarning(..), showPWarning )+import Distribution.Server.Util.Parse (unpackUTF8)+import Distribution.ParseUtils (FieldDescr(..))+import Distribution.Text (Text(..))+import Text.PrettyPrint as Doc+         (nest, empty, isEmpty, (<+>), colon, (<>), text, vcat, ($+$), Doc)+import Text.StringTemplate (ToSElem(..))++import Data.List+import qualified Data.Char as Char+import Data.ByteString.Lazy (ByteString)+import qualified Data.Map as Map+import Control.Monad.Error  (ErrorT, runErrorT)+import Control.Monad.Writer (MonadWriter(..), Writer, runWriter)+import Data.Time (getCurrentTime)++import qualified Data.ByteString.Lazy.Char8 as BS -- TODO: Verify that we don't need to worry about UTF8++-- | A feature to allow editing cabal files without uploading new tarballs.+--+initEditCabalFilesFeature :: ServerEnv+                          -> UserFeature -> CoreFeature -> UploadFeature+                          -> IO HackageFeature+initEditCabalFilesFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode} user core upload = do++  -- Page templates+  templates <- loadTemplates serverTemplatesMode+                 [serverTemplatesDir, serverTemplatesDir </> "EditCabalFile"]+                 ["cabalFileEditPage.html", "cabalFilePublished.html"]++  let feature = editCabalFilesFeature env templates user core upload++  return feature+++editCabalFilesFeature :: ServerEnv -> Templates+                      -> UserFeature -> CoreFeature -> UploadFeature+                      -> HackageFeature+editCabalFilesFeature _env templates+                      UserFeature{guardAuthorised}+                      CoreFeature{..}+                      UploadFeature{maintainersGroup, trusteesGroup} =+  (emptyHackageFeature "edit-cabal-files") {+    featureResources =+      [ editCabalFileResource+      ]+  , featureState = []+  }++  where+    CoreResource{..} = coreResource+    editCabalFileResource =+      (resourceAt "/package/:package/:cabal.cabal/edit")  {+        resourceDesc = [(GET,  "Page to edit package metadata")+                       ,(POST, "Modify the package metadata")],+        resourceGet  = [("html", serveEditCabalFileGet)],+        resourcePost = [("html", serveEditCabalFilePost)]+      }++    serveEditCabalFileGet :: DynamicPath -> ServerPartE Response+    serveEditCabalFileGet dpath = do+        template <- getTemplate templates "cabalFileEditPage.html"+        pkg <- packageInPath dpath >>= lookupPackageId+        let pkgname = packageName pkg+            pkgid   = packageId pkg+        -- check that the cabal name matches the package+        guard (lookup "cabal" dpath == Just (display pkgname))+        ok $ toResponse $ template+          [ "pkgid"     $= display pkgid+          , "cabalfile" $= insertRevisionField (1 + length (pkgDataOld pkg))+                             (cabalFileByteString (pkgData pkg))+          ]++    serveEditCabalFilePost :: DynamicPath -> ServerPartE Response+    serveEditCabalFilePost dpath = do+        template <- getTemplate templates "cabalFileEditPage.html"+        pkg <- packageInPath dpath >>= lookupPackageId+        let pkgname = packageName pkg+            pkgid   = packageId pkg+        -- check that the cabal name matches the package+        guard (lookup "cabal" dpath == Just (display pkgname))+        uid <- guardAuthorised [ InGroup (maintainersGroup pkgname)+                               , InGroup trusteesGroup ]+        let oldVersion = cabalFileByteString (pkgData pkg)+        newRevision <- getCabalFile+        shouldPublish <- getPublish+        case runCheck $ checkCabalFileRevision pkgid oldVersion newRevision of+          Left errs ->+            responseTemplate template pkgid newRevision+                             shouldPublish [errs] []++          Right changes+            | shouldPublish && not (null changes) -> do+                template' <- getTemplate templates "cabalFilePublished.html"+                time <- liftIO getCurrentTime+                updateAddPackageRevision pkgid (CabalFileText newRevision)+                                               (time, uid)+                ok $ toResponse $ template'+                  [ "pkgid"     $= display pkgid+                  , "cabalfile" $= newRevision+                  , "changes"   $= changes+                  ]+            | otherwise ->+                responseTemplate template pkgid newRevision+                                 shouldPublish [] changes++       where+         getCabalFile = body (lookBS "cabalfile")+         getPublish   = body $ (look "review" >> return False) `mplus`+                               (look "publish" >> return True)++         responseTemplate :: ([TemplateAttr] -> Template) -> PackageId+                          -> ByteString -> Bool -> [String] -> [Change]+                          -> ServerPartE Response+         responseTemplate template pkgid cabalFile publish errors changes =+           ok $ toResponse $ template+             [ "pkgid"     $= display pkgid+             , "cabalfile" $= cabalFile+             , "publish"   $= publish+             , "errors"    $= errors+             , "changes"   $= changes+             ]++-- TODO: Add Eq instance at source+deriving instance Eq PWarning+deriving instance Eq PackageCheck++instance ToSElem Change where+  toSElem (Change change from to) =+    toSElem (Map.fromList [("what", change)+                          ,("from", from)+                          ,("to", to)])++newtype CheckM a = CheckM { unCheckM :: ErrorT String (Writer [Change]) a }++runCheck :: CheckM () -> Either String [Change]+runCheck c = case runWriter . runErrorT . unCheckM $ c of+               (Left err, _      ) -> Left err+               (Right (), changes) -> Right changes++instance Monad CheckM where+  return         = CheckM . return+  CheckM m >>= f = CheckM (m >>= unCheckM . f)+  fail           = CheckM . throwError++data Change = Change String String String -- what, from, to+  deriving Show++logChange :: Change -> CheckM ()+logChange change = CheckM (tell [change])++type Check a = a -> a -> CheckM ()++checkCabalFileRevision :: PackageId -> Check ByteString+checkCabalFileRevision pkgid old new = do+    (pkg,  warns)  <- parseCabalFile old+    (pkg', warns') <- parseCabalFile new++    checkGenericPackageDescription pkg pkg'+    checkParserWarnings warns warns'+    checkPackageChecks  pkg   pkg'++  where+    filename = display pkgid ++ ".cabal"++    parseCabalFile fileContent =+      case parsePackageDescription . unpackUTF8 $ fileContent of+        ParseFailed      err -> fail (formatErrorMsg (locatedErrorMsg err))+        ParseOk warnings pkg -> return (pkg, warnings)++    formatErrorMsg (Nothing, msg) = msg+    formatErrorMsg (Just n,  msg) = "Line " ++ show n ++ ": " ++ msg++    checkParserWarnings warns warns' =+      case warns' \\ warns of+        []       -> return ()+        newwarns -> fail $ "New parse warning: "+                        ++ unlines (map (showPWarning filename) newwarns)++    checkPackageChecks pkg pkg' =+      let checks  = checkPackage pkg  Nothing+          checks' = checkPackage pkg' Nothing+       in case checks' \\ checks of+            []        -> return ()+            newchecks -> fail $ unlines (map explanation newchecks)++checkGenericPackageDescription :: Check GenericPackageDescription+checkGenericPackageDescription+    (GenericPackageDescription descrA flagsA libsA exesA testsA benchsA)+    (GenericPackageDescription descrB flagsB libsB exesB testsB benchsB) = do++    checkPackageDescriptions descrA descrB++    checkSame "Sorry, cannot edit the package flags"+      flagsA flagsB++    checkMaybe "Cannot add or remove library sections"+      (checkCondTree checkLibrary) libsA libsB++    checkListAssoc "Cannot add or remove executable sections"+      (checkCondTree checkExecutable) exesA exesB++    checkListAssoc "Cannot add or remove test-suite sections"+      (checkCondTree checkTestSuite) testsA testsB++    checkListAssoc "Cannot add or remove benchmark sections"+      (checkCondTree checkBenchmark) benchsA benchsB+++checkPackageDescriptions :: Check PackageDescription+checkPackageDescriptions+  (PackageDescription+     packageIdA licenseA licenseFileA+     copyrightA maintainerA authorA stabilityA testedWithA homepageA+     pkgUrlA bugReportsA sourceReposA synopsisA descriptionA+     categoryA customFieldsA _buildDependsA specVersionA buildTypeA+     _libraryA _executablesA _testSuitesA _benchmarksA dataFilesA dataDirA+     extraSrcFilesA extraTmpFilesA {-_extraHtmlFilesA-})+  (PackageDescription+     packageIdB licenseB licenseFileB+     copyrightB maintainerB authorB stabilityB testedWithB homepageB+     pkgUrlB bugReportsB sourceReposB synopsisB descriptionB+     categoryB customFieldsB _buildDependsB specVersionB buildTypeB+     _libraryB _executablesB _testSuitesB _benchmarksB dataFilesB dataDirB+     extraSrcFilesB extraTmpFilesB {-_extraHtmlFilesB-})+  = do+  checkSame "Don't be silly! You can't change the package name!"+            (packageName packageIdA) (packageName packageIdB)+  checkSame "You can't change the package version!"+            (packageVersion packageIdA) (packageVersion packageIdB)+  checkSame "Cannot change the license"+            (licenseA, licenseFileA) (licenseB, licenseFileB)+  changesOk "copyright"  id copyrightA copyrightB+  changesOk "maintainer" id maintainerA maintainerB+  changesOk "author"     id authorA authorB+  checkSame "The stability field is unused, don't bother changing it."+            stabilityA stabilityB+  checkSame "The tested-with field is unused, don't bother changing it."+            testedWithA testedWithB+  changesOk "homepage" id homepageA homepageB+  checkSame "The package-url field is unused, don't bother changing it."+            pkgUrlA pkgUrlB+  changesOk "bug-reports" id bugReportsA bugReportsB+  changesOkList changesOk "source-repository" (show . ppSourceRepo)+            sourceReposA sourceReposB+  changesOk "synopsis"    id synopsisA synopsisB+  changesOk "description" id descriptionA descriptionB+  changesOk "category"    id categoryA categoryB+  checkSame "Cannot change the Cabal spec version"+            specVersionA specVersionB+  checkSame "Cannot change the build-type"+            buildTypeA buildTypeB+  checkSame "Cannot change the data files"+            (dataFilesA, dataDirA) (dataFilesB, dataDirB)+  checkSame "Changing extra-tmp-files is a bit pointless at this stage"+            extraTmpFilesA extraTmpFilesB+  checkSame "Changing extra-source-files would not make sense!"+            extraSrcFilesA extraSrcFilesB++  checkSame "Cannot change custom/extension fields"+            (filter (\(f,_) -> f /= "x-revision") customFieldsA)+            (filter (\(f,_) -> f /= "x-revision") customFieldsB)+  checkRevision customFieldsA customFieldsB+++checkRevision :: Check [(String, String)]+checkRevision customFieldsA customFieldsB =+    checkSame ("The new x-revision must be " ++ show expectedRevision)+              newRevision expectedRevision+  where+    oldRevision = getRevision customFieldsA+    newRevision = getRevision customFieldsB+    expectedRevision = oldRevision + 1++    getRevision customFields =+      case lookup "x-revision" customFields of+        Just s  | [(n,"")] <- reads s -> n :: Int+        _                             -> 0+++checkCondTree :: Check a -> Check (CondTree ConfVar [Dependency] a)+checkCondTree checkElem+  (CondNode dataA constraintsA componentsA)+  (CondNode dataB constraintsB componentsB) = do+    checkDependencies constraintsA constraintsB+    checkList "Cannot add or remove 'if' conditionals"+              checkComponent componentsA componentsB+    checkElem dataA dataB+  where+    checkComponent (condA, ifPartA, thenPartA)+                   (condB, ifPartB, thenPartB) = do+      checkSame "Cannot change the 'if' condition expressions"+                condA condB+      checkCondTree checkElem ifPartA ifPartB+      checkMaybe "Cannot add or remove the 'else' part in conditionals"+                 (checkCondTree checkElem) thenPartA thenPartB++checkDependencies :: Check [Dependency]+checkDependencies =+  checkList "Cannot don't add or remove dependencies, \+            \just change the version constraints"+            checkDependency++checkDependency :: Check Dependency+checkDependency (Dependency pkgA verA) (Dependency pkgB verB)+  | pkgA == pkgB = changesOk ("dependency on " ++ display pkgA) display+                             verA verB+  | otherwise    = fail "Cannot change which packages are dependencies, \+                        \just their version constraints."++checkLibrary :: Check Library+checkLibrary (Library modulesA exposedA buildInfoA)+             (Library modulesB exposedB buildInfoB) = do+  checkSame "Cannot change the exposed modules" modulesA modulesB+  checkSame "Cannot change the package exposed status" exposedA exposedB+  checkBuildInfo buildInfoA buildInfoB++checkExecutable :: Check Executable+checkExecutable (Executable _nameA pathA buildInfoA)+                (Executable _nameB pathB buildInfoB) = do+  checkSame "Cannot change build information" pathA pathB+  checkBuildInfo buildInfoA buildInfoB++checkTestSuite :: Check TestSuite+checkTestSuite (TestSuite _nameA interfaceA buildInfoA _enabledA)+               (TestSuite _nameB interfaceB buildInfoB _enabledB) = do+  checkSame "Cannot change test-suite type" interfaceA interfaceB+  checkBuildInfo buildInfoA buildInfoB++checkBenchmark :: Check Benchmark+checkBenchmark (Benchmark _nameA interfaceA buildInfoA _enabledA)+               (Benchmark _nameB interfaceB buildInfoB _enabledB) = do+  checkSame "Cannot change benchmark type" interfaceA interfaceB+  checkBuildInfo buildInfoA buildInfoB++checkBuildInfo :: Check BuildInfo+checkBuildInfo =+  checkSame "Cannot change build information \+            \(just the dependency version constraints)"++changesOk :: Eq a => String -> (a -> String) -> Check a+changesOk what render a b+  | a == b    = return ()+  | otherwise = logChange (Change what (render a) (render b))++changesOkList :: (String -> (a -> String) -> Check a)+              -> String -> (a -> String) -> Check [a]+changesOkList changesOkElem what render = go+  where+    go []     []     = return ()+    go (a:_)  []     = logChange (Change ("added "   ++ what) (render a) "")+    go []     (b:_)  = logChange (Change ("removed " ++ what) "" (render b))+    go (a:as) (b:bs) = changesOkElem what render a b >> go as bs++checkSame :: Eq a => String -> Check a+checkSame msg x y | x == y    = return ()+                  | otherwise = fail msg++checkList :: String -> Check a -> Check [a]+checkList _   _         []     []     = return ()+checkList msg checkElem (x:xs) (y:ys) = checkElem x y+                                     >> checkList msg checkElem xs ys+checkList msg _         _      _      = fail msg++checkListAssoc :: Eq b => String -> Check a -> Check [(b,a)]+checkListAssoc _   _         [] [] = return ()+checkListAssoc msg checkElem ((kx,x):xs) ((ky,y):ys)+                       | kx == ky  = checkElem x y+                                  >> checkListAssoc msg checkElem xs ys+                       | otherwise = fail msg+checkListAssoc msg _         _  _  = fail msg++checkMaybe :: String -> Check a -> Check (Maybe a)+checkMaybe _   _     Nothing  Nothing  = return ()+checkMaybe _   check (Just x) (Just y) = check x y+checkMaybe msg _     _        _        = fail msg++--TODO: export from Cabal+ppSourceRepo :: SourceRepo -> Doc+ppSourceRepo repo =+    emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$+        (nest 4 (ppFields sourceRepoFieldDescrs' repo))+  where+    sourceRepoFieldDescrs' =+      filter (\fd -> fieldName fd /= "kind") sourceRepoFieldDescrs++    emptyLine :: Doc -> Doc+    emptyLine d = text " " $+$ d++    ppFields :: [FieldDescr a] -> a -> Doc+    ppFields fields x =+        vcat [ ppField name (getter x)+             | FieldDescr name getter _ <- fields]++    ppField :: String -> Doc -> Doc+    ppField name fielddoc | isEmpty fielddoc = Doc.empty+                          | otherwise        = text name <> colon <+> fielddoc+++insertRevisionField :: Int -> ByteString -> ByteString+insertRevisionField rev+    | rev == 1  = BS.unlines . insertAfterVersion . BS.lines+    | otherwise = BS.unlines . replaceRevision    . BS.lines+  where+    replaceRevision [] = []+    replaceRevision (ln:lns)+      | isField (BS.pack "x-revision") ln+      = BS.pack ("x-revision: " ++ show rev) : lns++      | otherwise+      = ln : replaceRevision lns++    insertAfterVersion [] = []+    insertAfterVersion (ln:lns)+      | isField (BS.pack "version") ln+      = ln : BS.pack ("x-revision: " ++ show rev) : lns++      | otherwise+      = ln : insertAfterVersion lns++    isField nm ln+      | BS.isPrefixOf nm (BS.map Char.toLower ln)+      , let (_, t) = BS.span (\c -> c == ' ' || c == '\t')+                             (BS.drop (BS.length nm) ln)+      , Just (':',_) <- BS.uncons t+                  = True+      | otherwise = False+
+ Distribution/Server/Features/Html.hs view
@@ -0,0 +1,1465 @@+{-# LANGUAGE DoRec, RankNTypes, NamedFieldPuns, RecordWildCards #-}+module Distribution.Server.Features.Html (+    HtmlFeature(..),+    initHtmlFeature+  ) where++import Distribution.Server.Framework+import qualified Distribution.Server.Framework.ResponseContentTypes as Resource+import Distribution.Server.Framework.Templating++import Distribution.Server.Features.Core+import Distribution.Server.Features.RecentPackages+import Distribution.Server.Features.Upload+import Distribution.Server.Features.PackageCandidates+import Distribution.Server.Features.Users+import Distribution.Server.Features.DownloadCount+import Distribution.Server.Features.Search+import Distribution.Server.Features.PreferredVersions+-- [reverse index disabled] import Distribution.Server.Features.ReverseDependencies+import Distribution.Server.Features.PackageList+import Distribution.Server.Features.Tags+import Distribution.Server.Features.Mirror+import Distribution.Server.Features.Distro+import Distribution.Server.Features.Documentation+import Distribution.Server.Features.UserDetails++import Distribution.Server.Users.Types+import qualified Distribution.Server.Users.Group as Group+import Distribution.Server.Packages.Types+import Distribution.Server.Packages.Render+import qualified Distribution.Server.Users.Users as Users+import qualified Distribution.Server.Packages.PackageIndex as PackageIndex+import Distribution.Server.Users.Group (UserGroup(..))+import Distribution.Server.Features.Distro.Distributions (DistroPackageInfo(..))+-- [reverse index disabled] import Distribution.Server.Packages.Reverse++import qualified Distribution.Server.Pages.Package as Pages+import Distribution.Server.Pages.Template+import Distribution.Server.Pages.Util+import qualified Distribution.Server.Pages.Group as Pages+-- [reverse index disabled] import qualified Distribution.Server.Pages.Reverse as Pages+import qualified Distribution.Server.Pages.Index as Pages+import Distribution.Server.Util.CountingMap (cmFind, cmToList)++import Distribution.Package+import Distribution.Version+import Distribution.Text (display)+import Distribution.PackageDescription++import Data.List (intercalate, intersperse, insert, sortBy)+import Data.Function (on)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import Control.Applicative (optional)++import Text.XHtml.Strict+import qualified Text.XHtml.Strict as XHtml+import Text.XHtml.Table (simpleTable)+import Network.URI (escapeURIString, isUnreserved)+++-- TODO: move more of the below to Distribution.Server.Pages.*, it's getting+-- close to 1K lines, way too much... it's okay to keep data-querying in here,+-- but pure HTML generation mostly needlessly clutters up the module.+-- Try to make it so no HTML combinators need to be imported.+--+-- See the TODO file for more ways to improve the HTML.+data HtmlFeature = HtmlFeature {+    htmlFeatureInterface :: HackageFeature+}++instance IsHackageFeature HtmlFeature where+    getFeatureInterface = htmlFeatureInterface++-- This feature provides the HTML view to the models of other features+-- currently it uses the xhtml package to render HTML (Text.XHtml.Strict)+--+-- This means of generating HTML is somewhat temporary, in that a more advanced+-- (and better-looking) HTML ajaxy scheme should come about later on.+initHtmlFeature :: ServerEnv -> UserFeature -> CoreFeature -> RecentPackagesFeature+                -> UploadFeature -> PackageCandidatesFeature -> VersionsFeature+                -- [reverse index disabled] -> ReverseFeature+                -> TagsFeature -> DownloadFeature+                -> ListFeature -> SearchFeature+                -> MirrorFeature -> DistroFeature+                -> DocumentationFeature+                -> DocumentationFeature+                -> UserDetailsFeature+                -> IO HtmlFeature++initHtmlFeature ServerEnv{serverTemplatesDir, serverTemplatesMode,+                          serverCacheDelay,+                          serverVerbosity = verbosity}+                user core@CoreFeature{packageChangeHook}+                packages upload+                candidates versions+                -- [reverse index disabled] reverse+                tags download+                list@ListFeature{itemUpdate}+                names mirror+                distros+                docsCore docsCandidates usersdetails = do++    loginfo verbosity "Initialising html feature, start"++    -- Page templates+    templates <- loadTemplates serverTemplatesMode+                   [serverTemplatesDir, serverTemplatesDir </> "Html"]+                   [ "maintain.html" ]++    -- do rec, tie the knot+    rec let (feature, packageIndex, packagesPage) =+              htmlFeature user core+                          packages upload+                          candidates versions+                          tags download+                          list names+                          mirror distros+                          docsCore docsCandidates+                          usersdetails+                          (htmlUtilities core tags)+                          mainCache namesCache+                          templates++        -- Index page caches+        mainCache  <- newAsyncCacheNF packageIndex+                        defaultAsyncCachePolicy {+                          asyncCacheName = "packages index page (by category)",+                          asyncCacheUpdateDelay  = serverCacheDelay,+                          asyncCacheSyncInit     = False,+                          asyncCacheLogVerbosity = verbosity+                        }++        namesCache <- newAsyncCacheNF packagesPage+                        defaultAsyncCachePolicy {+                          asyncCacheName = "packages index page (by name)",+                          asyncCacheUpdateDelay  = serverCacheDelay,+                          asyncCacheLogVerbosity = verbosity+                        }++    registerHook itemUpdate         $ \_ -> prodAsyncCache mainCache+                                         >> prodAsyncCache namesCache+    registerHook packageChangeHook  $ \_ -> prodAsyncCache mainCache+                                         >> prodAsyncCache namesCache++    loginfo verbosity "Initialising html feature, end"+    return feature++htmlFeature :: UserFeature+            -> CoreFeature+            -> RecentPackagesFeature+            -> UploadFeature+            -> PackageCandidatesFeature+            -> VersionsFeature+            -> TagsFeature+            -> DownloadFeature+            -> ListFeature+            -> SearchFeature+            -> MirrorFeature+            -> DistroFeature+            -> DocumentationFeature+            -> DocumentationFeature+            -> UserDetailsFeature+            -> HtmlUtilities+            -> AsyncCache Response+            -> AsyncCache Response+            -> Templates+            -> (HtmlFeature, IO Response, IO Response)++htmlFeature user+            core@CoreFeature{queryGetPackageIndex}+            recent upload+            candidates versions+            -- [reverse index disabled] ReverseFeature{..}+            tags download+            list@ListFeature{getAllLists}+            names+            mirror distros+            docsCore docsCandidates usersdetails+            utilities@HtmlUtilities{..}+            cachePackagesPage cacheNamesPage+            templates+  = (HtmlFeature{..}, packageIndex, packagesPage)+  where+    htmlFeatureInterface = (emptyHackageFeature "html") {+        featureResources = htmlResources+      , featureState     = []+      , featureCaches    = [+           CacheComponent {+             cacheDesc       = "packages page by category",+             getCacheMemSize = memSize <$> readAsyncCache cachePackagesPage+           }+         , CacheComponent {+             cacheDesc       = "packages page by name",+             getCacheMemSize = memSize <$> readAsyncCache cacheNamesPage+           }+         ]+      , featurePostInit = syncAsyncCache cachePackagesPage+      }++    htmlCore       = mkHtmlCore       utilities+                                      core+                                      versions+                                      upload+                                      tags+                                      docsCore+                                      download+                                      distros+                                      recent+                                      htmlTags+                                      htmlPreferred+                                      cachePackagesPage+                                      cacheNamesPage+                                      templates+    htmlUsers      = mkHtmlUsers      user usersdetails+    htmlUploads    = mkHtmlUploads    utilities upload+    htmlDownloads  = mkHtmlDownloads  utilities download+    htmlCandidates = mkHtmlCandidates utilities core versions upload docsCandidates candidates+    htmlPreferred  = mkHtmlPreferred  utilities core versions+    htmlTags       = mkHtmlTags       utilities core list tags+    htmlSearch     = mkHtmlSearch     utilities      list names++    htmlResources = concat [+        htmlCoreResources       htmlCore+      , htmlUsersResources      htmlUsers+      , htmlUploadsResources    htmlUploads+      , htmlCandidatesResources htmlCandidates+      , htmlPreferredResources  htmlPreferred+      , htmlDownloadsResources  htmlDownloads+      , htmlTagsResources       htmlTags+      , htmlSearchResources     htmlSearch+      -- and user groups. package maintainers, trustees, admins+      , htmlGroupResource user (maintainersGroupResource . uploadResource $ upload)+      , htmlGroupResource user (trusteesGroupResource    . uploadResource $ upload)+      , htmlGroupResource user (uploadersGroupResource   . uploadResource $ upload)+      , htmlGroupResource user (adminResource            . userResource   $ user)+      , htmlGroupResource user (mirrorGroupResource      . mirrorResource $ mirror)+      ]+++++      -- TODO: write HTML for reports and distros to display the information+      -- effectively reports+      {-+      , (extendResource $ reportsList reports) {+            resourceGet = [("html", serveReportsList)]+          }+      , (extendResource $ reportsPage reports) {+            resourceGet = [("html", serveReportsPage)]+          }+      -}++      -- distros+      {-+      , (extendResource $ distroIndexPage distros) {+            resourceGet = [("html", serveDistroIndex)]+          }+      , (extendResource $ distroAllPage distros) {+            resourceGet = [("html", serveDistroPackages)]+          }+      , (extendResource $ distroPackage distros) {+            resourceGet = [("html", serveDistroPackage)]+          }+      -}+++      -- reverse index (disabled)+      {-+      , (extendResource $ reversePackage reverses) {+            resourceGet = [("html", serveReverse True)]+          }+      , (extendResource $ reversePackageOld reverses) {+            resourceGet = [("html", serveReverse False)]+          }+      , (extendResource $ reversePackageAll reverses) {+            resourceGet = [("html", serveReverseFlat)]+          }+      , (extendResource $ reversePackageStats reverses) {+            resourceGet = [("html", serveReverseStats)]+          }+      , (extendResource $ reversePackages reverses) {+            resourceGet = [("html", serveReverseList)]+          }+      -}++++    -- [reverse index disabled] reverses = reverseResource+++++++    {- [reverse index disabled]+    --------------------------------------------------------------------------------+    -- Reverse+    serveReverse :: Bool -> DynamicPath -> ServerPart Response+    serveReverse isRecent dpath =+      htmlResponse $+      withPackageId dpath $ \pkgid -> do+        let pkgname = packageName pkgid+        rdisp <- case packageVersion pkgid of+                  Version [] [] -> withPackageAll pkgname   $ \_ -> revPackageName pkgname+                  _             -> withPackageVersion pkgid $ \_ -> revPackageId pkgid+        render <- (if isRecent then renderReverseRecent else renderReverseOld) pkgname rdisp+        return $ toResponse $ Resource.XHtml $ hackagePage (display pkgname ++ " - Reverse dependencies ") $+            Pages.reversePackageRender pkgid (corePackageIdUri "") revr isRecent render++    serveReverseFlat :: DynamicPath -> ServerPart Response+    serveReverseFlat dpath = htmlResponse $+                                      withPackageAllPath dpath $ \pkgname _ -> do+        revCount <- query $ GetReverseCount pkgname+        pairs <- revPackageFlat pkgname+        return $ toResponse $ Resource.XHtml $ hackagePage (display pkgname ++ "Flattened reverse dependencies") $+            Pages.reverseFlatRender pkgname (corePackageNameUri "") revr revCount pairs++    serveReverseStats :: DynamicPath -> ServerPart Response+    serveReverseStats dpath = htmlResponse $+                                       withPackageAllPath dpath $ \pkgname pkgs -> do+        revCount <- query $ GetReverseCount pkgname+        return $ toResponse $ Resource.XHtml $ hackagePage (display pkgname ++ "Reverse dependency statistics") $+            Pages.reverseStatsRender pkgname (map packageVersion pkgs) (corePackageIdUri "") revr revCount++    serveReverseList :: DynamicPath -> ServerPart Response+    serveReverseList _ = do+        let revr = reverseResource revs+        triple <- sortedRevSummary revs+        hackCount <- PackageIndex.indexSize <$> queryGetPackageIndex+        return $ toResponse $ Resource.XHtml $ hackagePage "Reverse dependencies" $+            Pages.reversePackagesRender (corePackageNameUri "") revr hackCount triple+    -}++    --------------------------------------------------------------------------------+    -- Additional package indices++    packageIndex :: IO Response+    packageIndex = do+       index <- queryGetPackageIndex+       let htmlIndex = toResponse $ Resource.XHtml $ Pages.packageIndex index+       return htmlIndex++    packagesPage :: IO Response+    packagesPage = do+        items <- liftIO $ getAllLists+        let htmlpage =+              toResponse $ Resource.XHtml $ hackagePage "All packages by name" $+                [ h2 << "All packages by name"+                , ulist ! [theclass "packages"] << map renderItem (Map.elems items)+                ]+        return htmlpage+++    {-+    -- Currently unused, mainly because not all web browsers use eager authentication-sending+    -- Setting a cookie might work here, albeit one that's stateless for the server, is not+    -- used for auth and only causes GUI changes, not permission overriding+    loginWidget :: UserResource -> ServerPart Html+    loginWidget user = do+        users <- query State.GetUserDb+        auth  <- Auth.getHackageAuth users+        return . makeLoginWidget user $ case auth of+            Left {} -> Nothing+            Right (_, uinfo) -> Just $ userName uinfo++    makeLoginWidget :: UserResource -> Maybe UserName -> Html+    makeLoginWidget user mname = case mname of+        Nothing -> anchor ! [href $ userLoginUri user Nothing] << "log in"+        Just uname -> anchor ! [href $ userPageUri user "" uname] << display uname+    -}+++{-------------------------------------------------------------------------------+  Core+-------------------------------------------------------------------------------}++data HtmlCore = HtmlCore {+    htmlCoreResources :: [Resource]+  }++mkHtmlCore :: HtmlUtilities+           -> CoreFeature+           -> VersionsFeature+           -> UploadFeature+           -> TagsFeature+           -> DocumentationFeature+           -> DownloadFeature+           -> DistroFeature+           -> RecentPackagesFeature+           -> HtmlTags+           -> HtmlPreferred+           -> AsyncCache Response+           -> AsyncCache Response+           -> Templates+           -> HtmlCore+mkHtmlCore HtmlUtilities{..}+           CoreFeature{coreResource}+           VersionsFeature{ versionsResource+                          , queryGetDeprecatedFor+                          , queryGetPreferredInfo+                          , withPackagePreferred+                          }+           UploadFeature{guardAuthorisedAsMaintainerOrTrustee}+           TagsFeature{queryTagsForPackage}+           DocumentationFeature{documentationResource, queryHasDocumentation}+           DownloadFeature{recentPackageDownloads}+           DistroFeature{queryPackageStatus}+           RecentPackagesFeature{packageRender}+           HtmlTags{..}+           HtmlPreferred{..}+           cachePackagesPage+           cacheNamesPage+           templates+  = HtmlCore{..}+  where+    cores@CoreResource{packageInPath, lookupPackageName} = coreResource+    versions = versionsResource+    docs     = documentationResource++    maintainPackage   = (resourceAt "/package/:package/maintain") {+                            resourceGet = [("html", serveMaintainPage)]+                          }++    htmlCoreResources = [+        (extendResource $ corePackagePage cores) {+            resourceDesc = [(GET, "Show detailed package information")]+          , resourceGet  = [("html", servePackagePage)]+          }+      {-+      , (extendResource $ coreIndexPage cores) {+            resourceGet = [("html", serveIndexPage)]+          }, currently in 'core' feature+      -}+      , (resourceAt "/packages/names" ) {+            resourceGet = [("html", const $ readAsyncCache cacheNamesPage)]+          }+      , (extendResource $ corePackagesPage cores) {+            resourceDesc = [(GET, "Show package index")]+          , resourceGet  = [("html", const $ readAsyncCache cachePackagesPage)]+          }+      , maintainPackage+      ]++    -- Currently the main package page is thrown together by querying a bunch+    -- of features about their attributes for the given package. It'll need+    -- reorganizing to look aesthetic, as opposed to the sleek and simple current+    -- design that takes the 1990s school of web design.+    servePackagePage :: DynamicPath -> ServerPartE Response+    servePackagePage dpath = do+      pkgid <- packageInPath dpath+      withPackagePreferred pkgid $ \pkg pkgs -> do+        -- get the PackageRender from the PkgInfo+        render <- liftIO $ packageRender pkg+        let realpkg = rendPkgId render+            pkgname = packageName realpkg+            middleHtml = Pages.renderFields render+        -- get additional information from other features+        prefInfo <- queryGetPreferredInfo pkgname+        let infoUrl = fmap (\_ -> preferredPackageUri versions "" pkgname) $ sumRange prefInfo+            beforeHtml = [Pages.renderVersion realpkg (classifyVersions prefInfo $ map packageVersion pkgs) infoUrl,+                          Pages.renderDependencies render]+        -- and other package indices+        distributions <- queryPackageStatus pkgname+        -- [reverse index disabled] revCount <- revPackageSummary realpkg+        -- We don't currently keep per-version downloads in memory+        -- (totalDown, versionDown) <- perVersionDownloads pkg+        totalDown <- cmFind pkgname `liftM` recentPackageDownloads+        let distHtml = case distributions of+                [] -> []+                _  -> [("Distributions", concatHtml . intersperse (toHtml ", ") $ map showDist distributions)]+            afterHtml  = distHtml ++ [Pages.renderDownloads totalDown {- versionDown $ packageVersion realpkg-}+                                     -- [reverse index disabled] ,Pages.reversePackageSummary realpkg revr revCount+                                     ]+        -- bottom sections, currently only documentation+        hasDocs  <- queryHasDocumentation realpkg+        let docURL | hasDocs   = Just $ packageDocsContentUri docs realpkg -- Just $ "/package" <//> display realpkg <//> "docs"+                   | otherwise = Nothing+        -- extra features like tags and downloads+        tags <- queryTagsForPackage pkgname++        let tagLinks = toHtml [anchor ! [href "/packages/tags"] << "Tags", toHtml ": ",+                               toHtml (renderTags tags)]+        deprs <- queryGetDeprecatedFor pkgname+        let deprHtml = case deprs of+              Just fors -> paragraph ! [thestyle "color: red"] << [toHtml "Deprecated", case fors of+                [] -> noHtml+                _  -> concatHtml . (toHtml " in favor of ":) . intersperse (toHtml ", ") .+                      map (\for -> anchor ! [href $ corePackageNameUri cores "" for] << display for) $ fors]+              Nothing -> noHtml+        -- and put it all together+        return $ toResponse $ Resource.XHtml $+            Pages.packagePage render [tagLinks] [deprHtml] (beforeHtml ++ middleHtml ++ afterHtml) [] docURL+      where+        showDist (dname, info) = toHtml (display dname ++ ":") ++++            anchor ! [href $ distroUrl info] << toHtml (display $ distroVersion info)++    serveMaintainPage :: DynamicPath -> ServerPartE Response+    serveMaintainPage dpath = do+      pkgname <- packageInPath dpath+      pkgs <- lookupPackageName pkgname+      guardAuthorisedAsMaintainerOrTrustee (pkgname :: PackageName)+      template <- getTemplate templates "maintain.html"+      return $ toResponse $ template+        [ "pkgname"  $= display pkgname+        , "versions" $= map (display . packageId) pkgs+        ]+++{-------------------------------------------------------------------------------+  Users+-------------------------------------------------------------------------------}++data HtmlUsers = HtmlUsers {+    htmlUsersResources :: [Resource]+  }++mkHtmlUsers :: UserFeature -> UserDetailsFeature -> HtmlUsers+mkHtmlUsers UserFeature{..} UserDetailsFeature{..} = HtmlUsers{..}+  where+    users = userResource++    htmlUsersResources = [+        -- list of users with user links; if admin, a link to add user page+        (extendResource $ userList users) {+            resourceDesc = [ (GET,  "list of users")+                           , (POST, "create a new user")+                           ]+          , resourceGet  = [ ("html", serveUserList) ]+          , resourcePost = [ ("html", \_ -> adminAddUser) ]+          }+        -- form to post to /users/+      , (resourceAt "/users/register") {+            resourceDesc = [ (GET, "show \"add user\" form") ]+          , resourceGet  = [ ("html", addUserForm) ]+          }+        -- user page with link to password form and list of groups (how to do this?)+      , (extendResource $ userPage users) {+            resourceDesc   = [ (GET,    "show user page")+                             , (DELETE, "delete the user")+                             ]+          , resourceGet    = [ ("html", serveUserPage) ]+          , resourceDelete = [ ("html", serveDeleteUser) ]+          }+        -- form to PUT password+      , (extendResource $ passwordResource users) {+            resourceDesc = [ (GET, "show password change form")+                           , (PUT, "change password")+                           ]+          , resourceGet  = [ ("html", servePasswordForm) ]+          , resourcePut  = [ ("html", servePutPassword) ]+          }+        -- form to enable or disable users (admin only)+      , (extendResource $ enabledResource users) {+            resourceDesc = [ (GET, "return if the user is enabled")+                           , (PUT, "set if the user is enabled")+                           ]+          , resourceGet  = [("html", serveEnabledForm)]+          , resourcePut  = [("html", servePutEnabled)]+          }+      ]++    serveUserList :: DynamicPath -> ServerPartE Response+    serveUserList _ = do+        userlist <- Users.enumerateActiveUsers <$> queryGetUserDb+        let hlist = unordList+                      [ anchor ! [href $ userPageUri users "" uname] << display uname+                      | (_, uinfo) <- userlist, let uname = userName uinfo ]+        ok $ toResponse $ Resource.XHtml $ hackagePage "Hackage users" [h2 << "Hackage users", hlist]++    serveUserPage :: DynamicPath -> ServerPartE Response+    serveUserPage dpath = do+      uname    <- userNameInPath dpath+      uid      <- lookupUserName uname+      udetails <- queryUserDetails uid+      let realname = maybe (display uname) (T.unpack . accountName) udetails+      uris     <- getGroupIndex uid+      uriPairs <- forM uris $ \uri -> do+          desc <- getIndexDesc uri+          return $ Pages.renderGroupName desc (Just uri)+      return $ toResponse $ Resource.XHtml $ hackagePage realname+        [ h2 << realname+        , case uriPairs of+              [] -> noHtml+              _  -> toHtml+                [ toHtml $ display uname ++ " is part of the following groups:"+                , unordList uriPairs+                ]+        ]++    addUserForm :: DynamicPath -> ServerPartE Response+    addUserForm _ =+        return $ toResponse $ Resource.XHtml $ hackagePage "Register account"+          [ paragraph << "Administrators can register new user accounts here."+          , form ! [theclass "box", XHtml.method "post", action $ userListUri users ""] <<+                [ simpleTable [] []+                    [ makeInput [thetype "text"] "username" "User name"+                    , makeInput [thetype "password"] "password" "Password"+                    , makeInput [thetype "password"] "repeat-password" "Confirm password"+                    ]+                , paragraph << input ! [thetype "submit", value "Create user"]+                ]+          ]++    servePasswordForm :: DynamicPath -> ServerPartE Response+    servePasswordForm dpath = do+      uname   <- userNameInPath dpath+      pathUid <- lookupUserName uname+      uid <- guardAuthenticated -- FIXME: why are we duplicating auth decisions in this feature?+      canChange <- canChangePassword uid pathUid+      case canChange of+          False -> errForbidden "Can't change password" [MText "You're neither this user nor an admin."]+          True -> return $ toResponse $ Resource.XHtml $ hackagePage "Change password"+            [ toHtml "Change your password. You'll be prompted for authentication upon submission, if you haven't logged in already."+            , form ! [theclass "box", XHtml.method "post", action $ userPasswordUri userResource "" uname] <<+                  [ simpleTable [] []+                      [ makeInput [thetype "password"] "password" "Password"+                      , makeInput [thetype "password"] "repeat-password" "Confirm password"+                      ]+                  , paragraph << [ hidden "_method" "PUT" --method override+                                 , input ! [thetype "submit", value "Change password"] ]+                  ]+            ]++    serveEnabledForm :: DynamicPath -> ServerPartE Response+    serveEnabledForm dpath = do+      usersdb <- queryGetUserDb+      uname <- userNameInPath dpath+      (_, userInfo) <- case Users.lookupUserName uname usersdb of+          Just (uid, uinfo) -> return (uid, uinfo)+          Nothing           -> errNotFound "No such user" [MText "No such user"]+      return $ toResponse $ Resource.XHtml $ hackagePage "Change user status"+      -- TODO: expose some of the functionality in changePassword function to determine if permissions are correct+      -- before serving this form (either admin or user)+        [ toHtml "Change the account status here."+        , form ! [theclass "box", XHtml.method "post", action $ userEnabledUri users "" uname] <<+              [ toHtml $ makeCheckbox (isEnabled userInfo) "enabled" "on" "Enable user account"+              , hidden "_method" "PUT" --method override+              , paragraph << input ! [thetype "submit", value "Change status"]+              ]+        ]+      where isEnabled userInfo = case userStatus userInfo of+                AccountEnabled _ -> True+                _                -> False++    servePutEnabled :: DynamicPath -> ServerPartE Response+    servePutEnabled dpath = do+      uname <- userNameInPath dpath+      enabledAccount uname+      return $ toResponse $ Resource.XHtml $ hackagePage "Account status set"+          [toHtml "Account status set for ", anchor ! [href $ userPageUri users "" uname] << display uname]++    serveDeleteUser :: DynamicPath -> ServerPartE Response+    serveDeleteUser dpath = do+      uname <- userNameInPath dpath+      deleteAccount uname+      let ntitle = "Deleted user"+      return $ toResponse $ Resource.XHtml $ hackagePage ntitle [toHtml ntitle]++    servePutPassword :: DynamicPath -> ServerPartE Response+    servePutPassword dpath = do+      uname <- userNameInPath dpath+      changePassword uname+      return $ toResponse $ Resource.XHtml $ hackagePage "Changed password"+          [toHtml "Changed password for ", anchor ! [href $ userPageUri users "" uname] << display uname]++{-------------------------------------------------------------------------------+  Uploads+-------------------------------------------------------------------------------}++data HtmlUploads = HtmlUploads {+    htmlUploadsResources :: [Resource]+  }++mkHtmlUploads :: HtmlUtilities -> UploadFeature -> HtmlUploads+mkHtmlUploads HtmlUtilities{..} UploadFeature{..} = HtmlUploads{..}+  where+    uploads = uploadResource++    htmlUploadsResources = [+      -- uploads+        -- serve upload result as HTML+        (extendResource $ uploadIndexPage uploads) {+            resourceDesc = [(POST, "Upload package")]+          , resourcePost = [("html", serveUploadResult)]+          }+        -- form for uploading+      , (resourceAt "/packages/upload") {+            resourceGet = [("html", serveUploadForm)]+          }+      ]++    serveUploadForm :: DynamicPath -> ServerPartE Response+    serveUploadForm _ = do+        return $ toResponse $ Resource.XHtml $ hackagePage "Upload package"+          [ h2 << "Upload package"+          , paragraph << [toHtml "See also the ", anchor ! [href "/upload"] << "upload help page", toHtml "."]+          , form ! [theclass "box", XHtml.method "post", action "/packages/", enctype "multipart/form-data"] <<+                [ input ! [thetype "file", name "package"]+                , input ! [thetype "submit", value "Upload package"]+                ]+          ]++    serveUploadResult :: DynamicPath -> ServerPartE Response+    serveUploadResult _ = do+        res <- uploadPackage+        let warns = uploadWarnings res+            pkgid = packageId (uploadDesc res)+        return $ toResponse $ Resource.XHtml $ hackagePage "Upload successful" $+          [ paragraph << [toHtml "Successfully uploaded ", packageLink pkgid, toHtml "!"]+          ] ++ case warns of+            [] -> []+            _  -> [paragraph << "There were some warnings:", unordList warns]++{-------------------------------------------------------------------------------+  Candidates+-------------------------------------------------------------------------------}++data HtmlCandidates = HtmlCandidates {+    htmlCandidatesResources :: [Resource]+  }++mkHtmlCandidates :: HtmlUtilities+                 -> CoreFeature+                 -> VersionsFeature+                 -> UploadFeature+                 -> DocumentationFeature+                 -> PackageCandidatesFeature+                 -> HtmlCandidates+mkHtmlCandidates HtmlUtilities{..}+                 CoreFeature{ coreResource = CoreResource{packageInPath}+                            , queryGetPackageIndex+                            }+                 VersionsFeature{ queryGetPreferredInfo }+                 UploadFeature{ guardAuthorisedAsMaintainer }+                 DocumentationFeature{documentationResource, queryHasDocumentation}+                 PackageCandidatesFeature{..} = HtmlCandidates{..}+  where+    candidates     = candidatesResource+    candidatesCore = candidatesCoreResource+    docs           = documentationResource++    pkgCandUploadForm = (resourceAt "/package/:package/candidate/upload") {+                            resourceGet = [("html", servePackageCandidateUpload)]+                          }+    candMaintainForm  = (resourceAt "/package/:package/candidate/maintain") {+                            resourceGet = [("html", serveCandidateMaintain)]+                          }++    htmlCandidatesResources = [+      -- candidates+        -- list of all packages which have candidates+        (extendResource $ corePackagesPage candidatesCore) {+            resourceDesc = [ (GET, "Show all package candidates")+                           , (POST, "Upload a new candidate")+                           ]+          , resourceGet  = [ ("html", serveCandidatesPage) ]+          , resourcePost = [ ("html", \_ -> postCandidate) ]+          }+        -- TODO: use custom functions, not htmlResponse+      , (extendResource $ packageCandidatesPage candidates) {+            resourceDesc = [ (GET, "Show candidate upload form")+                           , (POST, "Upload new package candidate")+                           ]+          , resourceGet  = [ ("html", servePackageCandidates pkgCandUploadForm) ]+          , resourcePost = [ ("", postPackageCandidate) ]+          }+        -- package page for a candidate+      , (extendResource $ corePackagePage candidatesCore) {+            resourceDesc   = [ (GET, "Show candidate maintenance form")+                             , (PUT, "Upload new package candidate")+                             , (DELETE, "Delete a package candidate")+                             ]+          , resourceGet    = [("html", serveCandidatePage candMaintainForm)]+          , resourcePut    = [("html", putPackageCandidate)]+          , resourceDelete = [("html", doDeleteCandidate)]+          }+        -- form for uploading candidate+      , (resourceAt "/packages/candidates/upload") {+            resourceDesc = [ (GET, "Show package candidate upload form") ]+          , resourceGet  = [ ("html", serveCandidateUploadForm) ]+          }+        -- form for uploading candidate for a specific package version+      , pkgCandUploadForm+        -- maintenance for candidate packages+      , candMaintainForm+        -- form for publishing package+      , (extendResource $ publishPage candidates) {+           resourceDesc = [ (GET, "Show candidate publish form")+                          , (POST, "Publish a package candidate")+                          ]+         , resourceGet  = [ ("html", servePublishForm) ]+         , resourcePost = [ ("html", servePostPublish) ]+         }+      ]++    serveCandidateUploadForm :: DynamicPath -> ServerPartE Response+    serveCandidateUploadForm _ = do+        return $ toResponse $ Resource.XHtml $ hackagePage "Checking and uploading candidates"+          [ h2 << "Checking and uploading candidates"+          , paragraph << [toHtml "See also the ", anchor ! [href "/upload"] << "upload help page", toHtml "."]+          , form ! [theclass "box", XHtml.method "post", action "/packages/candidates/", enctype "multipart/form-data"] <<+                [ input ! [thetype "file", name "package"]+                , input ! [thetype "submit", value "Upload candidate"]+                ]+          ]++    servePackageCandidateUpload :: DynamicPath -> ServerPartE Response+    servePackageCandidateUpload _ = do+        return $ toResponse $ Resource.XHtml $ hackagePage "Checking and uploading candidates"+          [ form ! [theclass "box", XHtml.method "post", action "/packages/candidates/", enctype "multipart/form-data"] <<+                [ input ! [thetype "file", name "package"]+                , input ! [thetype "submit", value "Upload candidate"]+                ]+          ]++    serveCandidateMaintain :: DynamicPath -> ServerPartE Response+    serveCandidateMaintain dpath = do+      candidate <- packageInPath dpath >>= lookupCandidateId+      guardAuthorisedAsMaintainer (packageName candidate)+      return $ toResponse $ Resource.XHtml $ hackagePage "Maintain candidate"+          [toHtml "Here, you can delete a candidate, publish it, upload a new one, and edit the maintainer group."]+    {-some useful URIs here: candidateUri check "" pkgid, packageCandidatesUri check "" pkgid, publishUri check "" pkgid-}+++    serveCandidatePage :: Resource -> DynamicPath -> ServerPartE Response+    serveCandidatePage maintain dpath = do+      cand <- packageInPath dpath >>= lookupCandidateId+      candRender <- liftIO $ candidateRender cand+      let PackageIdentifier pkgname version = packageId cand+          render = candPackageRender candRender+      otherVersions <- map packageVersion+                     . flip PackageIndex.lookupPackageName pkgname+                   <$> queryGetPackageIndex+      prefInfo <- queryGetPreferredInfo pkgname+      let sectionHtml = [Pages.renderVersion (packageId cand) (classifyVersions prefInfo $ insert version otherVersions) Nothing,+                         Pages.renderDependencies render] ++ Pages.renderFields render+          maintainHtml = anchor ! [href $ renderResource maintain [display $ packageId cand]] << "maintain"+      -- bottom sections, currently only documentation+      hasDocs  <- queryHasDocumentation (packageId cand)+      let docURL | hasDocs   = Just $ packageDocsContentUri docs (packageId cand) -- Just $ "/package" <//> display realpkg <//> "docs"+                 | otherwise = Nothing+      -- also utilize hasIndexedPackage :: Bool+      let warningBox = case renderWarnings candRender of+              [] -> []+              warn -> [thediv ! [theclass "notification"] << [toHtml "Warnings:", unordList warn]]+      return $ toResponse $ Resource.XHtml $+          Pages.packagePage render [maintainHtml] warningBox sectionHtml [] docURL++    servePublishForm :: DynamicPath -> ServerPartE Response+    servePublishForm dpath = do+      candidate <- packageInPath dpath >>= lookupCandidateId+      guardAuthorisedAsMaintainer (packageName candidate)+      let pkgid = packageId candidate+      packages <- queryGetPackageIndex+      case checkPublish packages candidate of+          Just err -> throwError err+          Nothing  -> do+              return $ toResponse $ Resource.XHtml $ hackagePage "Publishing candidates"+                  [form ! [theclass "box", XHtml.method "post", action $ publishUri candidatesResource "" pkgid]+                      << input ! [thetype "submit", value "Publish package"]]++    serveCandidatesPage :: DynamicPath -> ServerPartE Response+    serveCandidatesPage _ = do+        cands <- queryGetCandidateIndex+        return $ toResponse $ Resource.XHtml $ hackagePage "Package candidates"+          [ h2 << "Package candidates"+          , paragraph <<+              [ toHtml "Here follow all the candidate package versions on Hackage. "+              , thespan ! [thestyle "color: gray"] <<+                  [ toHtml "["+                  , anchor ! [href "/packages/candidates/upload"] << "upload"+                  , toHtml "]" ]+              ]+          , unordList $ map showCands $ PackageIndex.allPackagesByName cands+          ]+        -- note: each of the lists here should be non-empty, according to PackageIndex+      where showCands pkgs =+                let desc = packageDescription . pkgDesc . candPkgInfo $ last pkgs+                    pkgname = packageName desc+                in  [ anchor ! [href $ packageCandidatesUri candidates "" pkgname ] << display pkgname+                    , toHtml ": "+                    , toHtml $ intersperse (toHtml ", ") $ flip map pkgs $ \pkg ->+                         anchor ! [href $ corePackageIdUri candidatesCore "" (packageId pkg)] << display (packageVersion pkg)+                    , toHtml $ ". " ++ description desc+                    ]++    servePackageCandidates :: Resource -> DynamicPath -> ServerPartE Response+    servePackageCandidates candPkgUp dpath = do+      pkgname <- packageInPath dpath+      pkgs <- lookupCandidateName pkgname+      return $ toResponse $ Resource.XHtml $ hackagePage "Package candidates" $+        [ h3 << ("Candidates for " ++ display pkgname) ] +++        case pkgs of+          [] -> [ toHtml "No candidates exist for ", packageNameLink pkgname, toHtml ". Upload one for "+                , anchor ! [href $ renderResource candPkgUp [display pkgname]] << "this"+                , toHtml " or "+                , anchor ! [href $ "/packages/candidates/upload"] << "another"+                , toHtml " package?"+                ]+          _  -> [ unordList $ flip map pkgs $ \pkg -> anchor ! [href $ corePackageIdUri candidatesCore "" $ packageId pkg] << display (packageVersion pkg) ]++    -- TODO: make publishCandidate a member of the PackageCandidates feature, just like+    -- putDeprecated and putPreferred are for the Versions feature.+    servePostPublish :: DynamicPath -> ServerPartE Response+    servePostPublish dpath = do+        uresult <- publishCandidate dpath False+        return $ toResponse $ Resource.XHtml $ hackagePage "Publish successful" $+          [ paragraph << [toHtml "Successfully published ", packageLink (packageId $ uploadDesc uresult), toHtml "!"]+          ] ++ case uploadWarnings uresult of+            [] -> []+            warns -> [paragraph << "There were some warnings:", unordList warns]++{-------------------------------------------------------------------------------+  Preferred versions+-------------------------------------------------------------------------------}++data HtmlPreferred = HtmlPreferred {+    htmlPreferredResources :: [Resource]+  , editPreferred :: Resource+  , editDeprecated :: Resource+  }++mkHtmlPreferred :: HtmlUtilities+                -> CoreFeature+                -> VersionsFeature+                -> HtmlPreferred+mkHtmlPreferred HtmlUtilities{..}+                CoreFeature{ coreResource = CoreResource{+                               packageInPath+                             , lookupPackageName+                             }+                           }+                VersionsFeature{..} = HtmlPreferred{..}+  where+    versions = versionsResource++    editDeprecated    = (resourceAt "/package/:package/deprecated/edit") {+                            resourceGet = [("html", serveDeprecateForm)]+                          }+    editPreferred     = (resourceAt "/package/:package/preferred/edit") {+                            resourceGet = [("html", servePreferForm)]+                          }++    htmlPreferredResources = [+      -- preferred versions+        editDeprecated+      , editPreferred+      , (extendResource $ preferredResource versions) {+            resourceGet = [("html", servePreferredSummary)]+          }+      , (extendResource $ preferredPackageResource versions) {+            resourceGet = [("html", servePackagePreferred editPreferred)]+          , resourcePut = [("html", servePutPreferred)]+          }+      , (extendResource $ deprecatedResource versions) {+            resourceGet = [("html", serveDeprecatedSummary)]+          }+      , (extendResource $ deprecatedPackageResource versions) {+            resourceGet = [("html", servePackageDeprecated editDeprecated)]+          , resourcePut = [("html", servePutDeprecated )]+          }+      ]++    -- This feature is in great need of a Pages module+    serveDeprecatedSummary :: DynamicPath -> ServerPartE Response+    serveDeprecatedSummary _ = doDeprecatedsRender >>= \renders -> do+        return $ toResponse $ Resource.XHtml $ hackagePage "Deprecated packages"+          [ h2 << "Deprecated packages"+          , unordList $ flip map renders $ \(pkg, pkgs) -> [ packageNameLink pkg, toHtml ": ", deprecatedText pkgs ]+          ]++    deprecatedText :: [PackageName] -> Html+    deprecatedText []   = toHtml "deprecated"+    deprecatedText pkgs = toHtml+      [ toHtml "deprecated in favor of "+      , concatHtml $ intersperse (toHtml ", ") (map packageNameLink pkgs)+      ]++    servePackageDeprecated :: Resource -> DynamicPath -> ServerPartE Response+    servePackageDeprecated deprEdit dpath = do+      pkgname <- packageInPath dpath+      mpkg <- doDeprecatedRender pkgname+      return $ toResponse $ Resource.XHtml $ hackagePage "Deprecated status"+        [ h2 << "Deprecated status"+        , paragraph <<+            [ toHtml $ case mpkg of+                  Nothing   -> [packageNameLink pkgname, toHtml " is not deprecated"]+                  Just pkgs -> [packageNameLink pkgname, toHtml " is ", deprecatedText pkgs]+            , thespan ! [thestyle "color: gray"] <<+                [ toHtml " [maintainers: "+                , anchor ! [href $ renderResource deprEdit [display pkgname]] << "edit"+                , toHtml "]" ]+            ]+        ]++    servePreferredSummary :: DynamicPath -> ServerPartE Response+    servePreferredSummary _ = doPreferredsRender >>= \renders -> do+        return $ toResponse $ Resource.XHtml $ hackagePage "Preferred versions"+          [ h2 << "Preferred versions"+          , case renders of+                [] -> paragraph << "There are no global preferred versions."+                _  -> unordList $ flip map renders $ \(pkgname, pref) ->+                    [ packageNameLink pkgname+                    ,  unordList [varList "Preferred ranges" (rendRanges pref),+                                  varList "Deprecated versions" (map display $ rendVersions pref),+                                  toHtml ["Calculated range: ", rendSumRange pref]]+                    ]+          , paragraph <<+              [ anchor ! [href "/packages/preferred-versions"] << "preferred-versions"+              , toHtml " is the text file served with every index tarball that contains this information."+              ]+          ]+      where varList summ [] = toHtml $ summ ++ ": none"+            varList summ xs = toHtml $ summ ++ ": " ++ intercalate ", " xs++    packagePrefAbout :: Maybe Resource -> PackageName -> [Html]+    packagePrefAbout maybeEdit pkgname =+      [ paragraph <<+          [ anchor ! [href $ preferredUri versions ""] << "Preferred and deprecated versions"+          , toHtml $ " can be used to influence Cabal's decisions about which versions of "+          , packageNameLink pkgname+          , toHtml " to install. If a range of versions is preferred, it means that the installer won't install a non-preferred package version unless it is explicitly specified or if it's the only choice the installer has. Deprecating a version adds a range which excludes just that version. All of this information is collected in the "+          , anchor ! [href "/packages/preferred-versions"] << "preferred-versions"+          , toHtml " file that's included in the index tarball."+          , flip (maybe noHtml) maybeEdit $ \prefEdit -> thespan ! [thestyle "color: gray"] <<+              [ toHtml " [maintainers: "+              , anchor ! [href $ renderResource prefEdit [display pkgname]] << "edit"+              , toHtml "]" ]+          ]+      , paragraph <<+          [ toHtml "If all the available versions of a package are non-preferred or deprecated, cabal-install will treat this the same as if none of them are. This feature doesn't affect whether or not to install a package, only for selecting versions after a given package has decided to be installed. "+          , anchor ! [href $ deprecatedPackageUri versions "" pkgname] << "Entire-package deprecation"+          , toHtml " is also available, but it's separate from preferred versions."+          ]+      ]++    servePackagePreferred :: Resource -> DynamicPath -> ServerPartE Response+    servePackagePreferred prefEdit dpath = do+      pkgname <- packageInPath dpath+      pkgs    <- lookupPackageName pkgname+      pref    <- doPreferredRender pkgname+      let dtitle = display pkgname ++ ": preferred and deprecated versions"+      prefInfo <- queryGetPreferredInfo pkgname+      return $ toResponse $ Resource.XHtml $ hackagePage dtitle --needs core, preferredVersions, pkgname+        [ h2 << dtitle+        , concatHtml $ packagePrefAbout (Just prefEdit) pkgname+        , h4 << "Stored information"+        , case rendRanges pref of+              [] -> paragraph << [display pkgname ++ " has no preferred version ranges."]+              prefs -> paragraph << ["Preferred versions for " ++ display pkgname ++ ":"]+                           +++ unordList prefs+        , case rendVersions pref of+              [] -> paragraph << ["It has no deprecated versions."]+              deprs -> paragraph <<+                  [ "Explicitly deprecated versions for " ++ display pkgname ++ " include: "+                  , intercalate ", " (map display deprs)]+        , toHtml "The version range given to this package, therefore, is " +++ strong (toHtml $ rendSumRange pref)+        , h4 << "Versions affected"+        , paragraph << "Blue versions are normal versions. Green are those out of any preferred version ranges. Gray are deprecated."+        , paragraph << (snd $ Pages.renderVersion+                                  (PackageIdentifier pkgname $ Version [] [])+                                  (classifyVersions prefInfo $ map packageVersion pkgs) Nothing)+        ]++    servePutPreferred :: DynamicPath -> ServerPartE Response+    servePutPreferred dpath = do+      pkgname <- packageInPath dpath+      putPreferred pkgname+      return $ toResponse $ Resource.XHtml $ hackagePage "Set preferred versions"+        [ h2 << "Set preferred versions"+        , paragraph <<+            [ toHtml "Set the "+            , anchor ! [href $ preferredPackageUri versionsResource "" pkgname] << "preferred versions"+            , toHtml " for "+            , packageNameLink pkgname+            , toHtml "."]+        ]++    servePutDeprecated :: DynamicPath -> ServerPartE Response+    servePutDeprecated dpath = do+      pkgname <- packageInPath dpath+      wasDepr <- putDeprecated pkgname+      let dtitle = if wasDepr then "Package deprecated" else "Package undeprecated"+      return $ toResponse $ Resource.XHtml $ hackagePage dtitle+         [ h2 << dtitle+         , paragraph <<+            [ toHtml "Set the "+            , anchor ! [href $ deprecatedPackageUri versionsResource "" pkgname] << "deprecated status"+            , toHtml " for "+            , packageNameLink pkgname+            , toHtml "."]+         ]++    -- deprecated: checkbox, by: text field, space-separated list of packagenames+    serveDeprecateForm :: DynamicPath -> ServerPartE Response+    serveDeprecateForm dpath = do+      pkgname <- packageInPath dpath+      mpkg <- doDeprecatedRender pkgname+      let (isDepr, mfield) = case mpkg of+              Just pkgs -> (True, unwords $ map display pkgs)+              Nothing -> (False, "")+      return $ toResponse $ Resource.XHtml $ hackagePage "Deprecate package"+          [paragraph << [toHtml "Configure deprecation for ", packageNameLink pkgname],+           form . ulist ! [theclass "box", XHtml.method "post", action $ deprecatedPackageUri versionsResource "" pkgname] <<+            [ hidden "_method" "PUT"+            , li . toHtml $ makeCheckbox isDepr "deprecated" "on" "Deprecate package"+            , li . toHtml $ makeInput [thetype "text", value mfield] "by" "Superseded by: " ++ [br, toHtml "(Optional; space-separated list of package names)"]+            , paragraph << input ! [thetype "submit", value "Set status"]+            ]]++    -- preferred: text box (one version range per line). deprecated: list of text boxes with same name+    servePreferForm :: DynamicPath -> ServerPartE Response+    servePreferForm dpath = do+      pkgname <- packageInPath dpath+      pkgs    <- lookupPackageName pkgname+      pref    <- doPreferredRender pkgname+      let allVersions = map packageVersion pkgs+          rangesList  = rendRanges pref+          deprVersions = rendVersions pref+      return $ toResponse $ Resource.XHtml $ hackagePage "Adjust preferred versions"+          [concatHtml $ packagePrefAbout Nothing pkgname,+           form ! [theclass "box", XHtml.method "post", action $ preferredPackageUri versionsResource "" pkgname] <<+            [ hidden "_method" "PUT"+            , paragraph << "Preferred version ranges."+            , paragraph << textarea ! [name "preferred", rows $ show (4::Int), cols $ show (80::Int)] << unlines rangesList+            , paragraph << "Deprecated versions."+            , toHtml $ intersperse (toHtml " ") $ map (\v -> toHtml $ makeCheckbox (v `elem` deprVersions) "deprecated" (display v) (display v)) allVersions+            , paragraph << input ! [thetype "submit", value "Set status"]+            ]]++{-------------------------------------------------------------------------------+  Downloads+-------------------------------------------------------------------------------}++data HtmlDownloads = HtmlDownloads {+    htmlDownloadsResources :: [Resource]+  }++mkHtmlDownloads :: HtmlUtilities -> DownloadFeature -> HtmlDownloads+mkHtmlDownloads HtmlUtilities{..} DownloadFeature{..} = HtmlDownloads{..}+  where+    downs = downloadResource++    -- downloads+    htmlDownloadsResources = [+        (extendResource $ topDownloads downs) {+            resourceGet = [("html", serveDownloadTop)]+          }+      ]++    serveDownloadTop :: DynamicPath -> ServerPartE Response+    serveDownloadTop _ = do+        pkgList <- sortedPackages `liftM` recentPackageDownloads+        return $ toResponse $ Resource.XHtml $ hackagePage "Total downloads" $+          [ h2 << "Downloaded packages"+          , thediv << table << downTableRows pkgList+          ]+      where+        downTableRows pkgList =+            [ tr << [ th << "Package name", th << "Downloads" ] ] +++            [ tr ! [theclass (if odd n then "odd" else "even")] <<+                [ td << packageNameLink pkgname+                , td << [ toHtml $ (show count) ] ]+            | ((pkgname, count), n) <- zip pkgList [(1::Int)..] ]++    sortedPackages :: RecentDownloads -> [(PackageName, Int)]+    sortedPackages = sortBy (flip compare `on` snd) . cmToList++{-------------------------------------------------------------------------------+  Tags+-------------------------------------------------------------------------------}++data HtmlTags = HtmlTags {+    htmlTagsResources :: [Resource]+  , tagEdit :: Resource+  }++mkHtmlTags :: HtmlUtilities+           -> CoreFeature+           -> ListFeature+           -> TagsFeature+           -> HtmlTags+mkHtmlTags HtmlUtilities{..}+           CoreFeature{ coreResource = CoreResource{+                          packageInPath+                        , lookupPackageName+                        }+                      }+           ListFeature{makeItemList}+           TagsFeature{..} = HtmlTags{..}+  where+    tags = tagsResource++    tagEdit           = (resourceAt "/package/:package/tags/edit") {+                            resourceGet = [("html", serveTagsForm)]+                          }++    htmlTagsResources = [+        (extendResource $ tagsListing tags) {+            resourceGet = [("html", serveTagsListing)]+          }+      , (extendResource $ tagListing tags) {+            resourceGet = [("html", serveTagListing)]+          }+      , (extendResource $ packageTagsListing tags) {+            resourcePut = [("html", putPackageTags)], resourceGet = []+          }+      , tagEdit -- (extendResource $ packageTagsEdit tags) { resourceGet = [("html", serveTagsForm)] }+      ]++    serveTagsListing :: DynamicPath -> ServerPartE Response+    serveTagsListing _ = do+        tagList <- queryGetTagList+        let withCounts = filter ((>0) . snd) . map (\(tg, pkgs) -> (tg, Set.size pkgs)) $ tagList+            countSort = sortBy (flip compare `on` snd) withCounts+        return $ toResponse $ Resource.XHtml $ hackagePage "Hackage tags" $+          [ h2 << "Hackage tags"+          , h4 << "By name"+          , paragraph ! [theclass "toc"] << (intersperse (toHtml ", ") $ map (tagItem . fst) withCounts)+          , h4 << "By frequency"+          , paragraph ! [theclass "toc"] << (intersperse (toHtml ", ") $ map (toHtml . tagCountItem) countSort)+          ]+      where tagCountItem (tg, count) =+              [ tagItem tg+              , toHtml $ " (" ++ show count ++ ")"+              ]+            tagItem tg = anchor ! [href $ tagUri tags "" tg] << display tg++    serveTagListing :: DynamicPath -> ServerPartE Response+    serveTagListing dpath =+      withTagPath dpath $ \tg pkgnames -> do+        let tagd = "Packages tagged " ++ display tg+            pkgs = Set.toList pkgnames+        items <- liftIO $ makeItemList pkgs+        let (mtag, histogram) = Map.updateLookupWithKey (\_ _ -> Nothing) tg $ tagHistogram items+            -- make a 'related tags' section, so exclude this tag from the histogram+            count = fromMaybe 0 mtag+        return $ toResponse $ Resource.XHtml $ hackagePage tagd $+          [ h2 << tagd+          , case items of+                [] -> toHtml "No packages have this tag."+                _  -> toHtml+                  [ paragraph << [if count==1 then "1 package has" else show count ++ " packages have", " this tag."]+                  , paragraph ! [theclass "toc"] << [toHtml "Related tags: ", toHtml $ showHistogram histogram]+                  , ulist ! [theclass "packages"] << map renderItem items ]+          ]+     where+      showHistogram hist = (++takeHtml) . intersperse (toHtml ", ") $+            map histogramEntry $ take takeAmount sortHist+        where hsize = Map.size hist+              takeAmount = max (div (hsize*2) 3) 12+              takeHtml = if takeAmount >= hsize then [] else [toHtml ", ..."]+              sortHist = sortBy (flip compare `on` snd) $ Map.toList hist+      histogramEntry (tg', count) = anchor ! [href $ tagUri tags "" tg'] << display tg' +++ (" (" ++ show count ++ ")")++    putPackageTags :: DynamicPath -> ServerPartE Response+    putPackageTags dpath = do+      pkgname <- packageInPath dpath+      _       <- lookupPackageName pkgname -- TODO: necessary?+      putTags pkgname+      return $ toResponse $ Resource.XHtml $ hackagePage "Set tags"+          [toHtml "Put tags for ", packageNameLink pkgname]++    -- serve form for editing, to be received by putTags+    serveTagsForm :: DynamicPath -> ServerPartE Response+    serveTagsForm dpath = do+      pkgname <- packageInPath dpath+      currTags <- queryTagsForPackage pkgname+      let tagsStr = concat . intersperse ", " . map display . Set.toList $ currTags+      return $ toResponse $ Resource.XHtml $ hackagePage "Edit package tags"+        [paragraph << [toHtml "Set tags for ", packageNameLink pkgname],+         form ! [theclass "box", XHtml.method "post", action $ packageTagsUri tags "" pkgname] <<+          [ hidden "_method" "PUT"+          , dlist . ddef . toHtml $ makeInput [thetype "text", value tagsStr] "tags" "Set tags to "+          , paragraph << input ! [thetype "submit", value "Set tags"]+          ]]++{-------------------------------------------------------------------------------+  Search+-------------------------------------------------------------------------------}++data HtmlSearch = HtmlSearch {+    htmlSearchResources :: [Resource]+  }++mkHtmlSearch :: HtmlUtilities+             -> ListFeature+             -> SearchFeature+             -> HtmlSearch+mkHtmlSearch HtmlUtilities{..}+             ListFeature{makeItemList}+             SearchFeature{..} = HtmlSearch{..}+  where+    htmlSearchResources = [+        (extendResource searchPackagesResource) {+            resourceGet = [("html", servePackageFind)]+          }+      ]++    servePackageFind :: DynamicPath -> ServerPartE Response+    servePackageFind _ = do+        (mtermsStr, offset, limit) <-+          queryString $ (,,) <$> optional (look "terms")+                             <*> mplus (lookRead "offset") (pure 0)+                             <*> mplus (lookRead "limit") (pure 10)+        case mtermsStr of+          Just termsStr | terms <- words termsStr, not (null terms) -> do+            pkgnames <- searchPackages terms+            let (pageResults, moreResults) = splitAt limit (drop offset pkgnames)+            pkgDetails <- liftIO $ makeItemList pageResults+            return $ toResponse $ Resource.XHtml $+              hackagePage "Package search" $+                [ toHtml $ searchForm termsStr+                , toHtml $ resultsArea pkgDetails offset limit moreResults termsStr+                , alternativeSearch+                ]++          _ ->+            return $ toResponse $ Resource.XHtml $+              hackagePage "Text search" $+                [ toHtml $ searchForm ""+                , alternativeSearch+                ]+      where+        resultsArea pkgDetails offset limit moreResults termsStr =+            [ h2 << "Results"+            , if offset == 0+                then noHtml+                else paragraph << ("(" ++ show (fst range + 1) ++ " to "+                                       ++ show (snd range) ++ ")")+            , case pkgDetails of+                [] | offset == 0 -> toHtml "None"+                   | otherwise   -> toHtml "No more results"+                _ -> toHtml+                      [ ulist ! [theclass "packages"]+                             << map renderItem pkgDetails+                      , if null moreResults+                          then noHtml+                          else anchor ! [href moreResultsLink]+                                     << "More results..."+                      ]+            ]+          where+            range = (offset, offset + length pkgDetails)+            moreResultsLink =+                "/packages/search?"+             ++ "terms="   ++ escapeURIString isUnreserved termsStr+             ++ "&offset=" ++ show (offset + limit)+             ++ "&limit="  ++ show limit++        searchForm termsStr =+          [ h2 << "Package search"+          , form ! [theclass "box", XHtml.method "GET", action "/packages/search"] <<+              [ input ! [value termsStr, name "terms", identifier "terms"]+              , toHtml " "+              , input ! [thetype "submit", value "Search"]+              ]+          ]++        alternativeSearch =+          paragraph <<+            [ toHtml "Alternatively, if you are looking for a particular function then try "+            , anchor ! [href "http://holumbus.fh-wedel.de/hayoo/hayoo.html"] << "Hayoo"+            , toHtml " or "+            , anchor ! [href "http://www.haskell.org/hoogle/"] << "Hoogle"+            ]++{-------------------------------------------------------------------------------+  Groups+-------------------------------------------------------------------------------}++htmlGroupResource :: UserFeature -> GroupResource -> [Resource]+htmlGroupResource UserFeature{..} r@(GroupResource groupR userR getGroup) =+  [ (extendResource groupR) {+        resourceDesc = [ (GET, "Show list of users")+                       , (POST, "Udd a user to the group")+                       ]+      , resourceGet  = [ ("html", getList) ]+      , resourcePost = [ ("html", postUser) ]+      }+  , (extendResource userR) {+        resourceDesc   = [ (DELETE, "Delete a user from the group") ]+      , resourceDelete = [ ("html", deleteFromGroup) ]+      }+  , (extendResourcePath "/edit" groupR) {+        resourceDesc = [ (GET, "Show edit form for the group") ]+      , resourceGet  = [ ("html", getEditList) ]+      }+  ]+  where+    getList dpath = do+        group    <- getGroup dpath+        userDb   <- queryGetUserDb+        userlist <- liftIO . queryUserList $ group+        let unames = [ Users.userIdToName userDb uid+                     | uid   <- Group.enumerate userlist ]+        let baseUri = renderResource' groupR dpath+        return . toResponse . Resource.XHtml $ Pages.groupPage+            unames baseUri (False, False) (groupDesc group)+    getEditList dpath = do+        group    <- getGroup dpath+        (canAdd, canDelete) <- lookupGroupEditAuth group+        userDb   <- queryGetUserDb+        userlist <- liftIO . queryUserList $ group+        let unames = [ Users.userIdToName userDb uid+                     | uid   <- Group.enumerate userlist ]+        let baseUri = renderResource' groupR dpath+        return . toResponse . Resource.XHtml $ Pages.groupPage+            unames baseUri (canAdd, canDelete) (groupDesc group)+    postUser dpath = do+        group <- getGroup dpath+        groupAddUser group dpath+        goToList dpath+    deleteFromGroup dpath = do+        group <- getGroup dpath+        groupDeleteUser group dpath+        goToList dpath+    goToList dpath = seeOther (renderResource' (groupResource r) dpath) (toResponse ())++{-------------------------------------------------------------------------------+  Util+-------------------------------------------------------------------------------}++htmlUtilities :: CoreFeature -> TagsFeature -> HtmlUtilities+htmlUtilities CoreFeature{coreResource}+              TagsFeature{tagsResource} = HtmlUtilities{..}+  where+    packageLink :: PackageId -> Html+    packageLink pkgid = anchor ! [href $ corePackageIdUri cores "" pkgid] << display pkgid++    packageNameLink :: PackageName -> Html+    packageNameLink pkgname = anchor ! [href $ corePackageNameUri cores "" pkgname] << display pkgname++    renderItem :: PackageItem -> Html+    renderItem item = li ! classes <<+          [ packageNameLink pkgname+          , toHtml $ " " ++ ptype (itemHasLibrary item) (itemNumExecutables item)+                         ++ ": " ++ itemDesc item+          , " (" +++ renderTags (itemTags item) +++ ")"+          ]+      where pkgname = itemName item+            ptype _ 0 = "library"+            ptype lib num = (if lib then "library and " else "")+                         ++ (case num of 1 -> "program"; _ -> "programs")+            classes = case classList of [] -> []; _ -> [theclass $ unwords classList]+            classList = (case itemDeprecated item of Nothing -> []; _ -> ["deprecated"])++    renderTags :: Set Tag -> [Html]+    renderTags tags = intersperse (toHtml ", ")+        (map (\tg -> anchor ! [href $ tagUri tagsResource "" tg] << display tg)+          $ Set.toList tags)++    cores = coreResource++data HtmlUtilities = HtmlUtilities {+    packageLink :: PackageId -> Html+  , packageNameLink :: PackageName -> Html+  , renderItem :: PackageItem -> Html+  , renderTags :: Set Tag -> [Html]+  }+
+ Distribution/Server/Features/LegacyPasswds.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, RankNTypes, NamedFieldPuns, RecordWildCards, DoRec, BangPatterns #-}+module Distribution.Server.Features.LegacyPasswds (+    initLegacyPasswdsFeature,+    LegacyPasswdsFeature(..),+  ) where++import Prelude hiding (abs)++import Distribution.Server.Framework+import Distribution.Server.Framework.Templating+import Distribution.Server.Framework.BackupDump+import Distribution.Server.Framework.BackupRestore++import qualified Distribution.Server.Features.LegacyPasswds.Auth as LegacyAuth++import Distribution.Server.Features.Users++import Distribution.Server.Users.Types+import qualified Distribution.Server.Users.Types as Users+import qualified Distribution.Server.Users.Users as Users+import qualified Distribution.Server.Framework.Auth as Auth++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import qualified Data.ByteString.Lazy.Char8 as LBS -- ASCII data only (password hashes)++import Data.Typeable (Typeable)+import Data.SafeCopy (base, deriveSafeCopy)+import Control.Monad.Reader (ask)+import Control.Monad.State (get, put)++import Distribution.Text (display)+import Data.Version+import Text.CSV (CSV, Record)+import Network.URI (URI(..), uriToString)+++-- | A feature to help porting accounts from the old central+-- hackage.haskell.org server. It is not needed by new installations.+--+data LegacyPasswdsFeature = LegacyPasswdsFeature {+    legacyPasswdsFeatureInterface :: HackageFeature+}++instance IsHackageFeature LegacyPasswdsFeature where+  getFeatureInterface = legacyPasswdsFeatureInterface++-------------------------+-- Types of stored data+--++newtype LegacyPasswdsTable = LegacyPasswdsTable (IntMap LegacyAuth.HtPasswdHash)+  deriving (Eq, Show, Typeable)++emptyLegacyPasswdsTable :: LegacyPasswdsTable+emptyLegacyPasswdsTable = LegacyPasswdsTable IntMap.empty++lookupUserLegacyPasswd :: LegacyPasswdsTable -> UserId -> Maybe LegacyAuth.HtPasswdHash+lookupUserLegacyPasswd (LegacyPasswdsTable tbl) (UserId uid) =+    IntMap.lookup uid tbl++$(deriveSafeCopy 0 'base ''LegacyPasswdsTable)++instance MemSize LegacyPasswdsTable where+    memSize (LegacyPasswdsTable a) = memSize1 a++------------------------------+-- State queries and updates+--++getLegacyPasswdsTable :: Query LegacyPasswdsTable LegacyPasswdsTable+getLegacyPasswdsTable = ask++replaceLegacyPasswdsTable :: LegacyPasswdsTable -> Update LegacyPasswdsTable ()+replaceLegacyPasswdsTable = put++setUserLegacyPasswd :: UserId -> LegacyAuth.HtPasswdHash -> Update LegacyPasswdsTable ()+setUserLegacyPasswd (UserId uid) udetails = do+    LegacyPasswdsTable tbl <- get+    put $! LegacyPasswdsTable (IntMap.insert uid udetails tbl)++deleteUserLegacyPasswd :: UserId -> Update LegacyPasswdsTable Bool+deleteUserLegacyPasswd (UserId uid) = do+    LegacyPasswdsTable tbl <- get+    if IntMap.member uid tbl+      then do put $! LegacyPasswdsTable (IntMap.delete uid tbl)+              return True+      else return False+++makeAcidic ''LegacyPasswdsTable [+    --queries+    'getLegacyPasswdsTable,+    --updates+    'replaceLegacyPasswdsTable,+    'setUserLegacyPasswd,+    'deleteUserLegacyPasswd+  ]+++---------------------+-- State components+--++legacyPasswdsStateComponent :: FilePath -> IO (StateComponent AcidState LegacyPasswdsTable)+legacyPasswdsStateComponent stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> "LegacyPasswds") emptyLegacyPasswdsTable+  return StateComponent {+      stateDesc    = "Support for upgrading accounts from htpasswd-style passwords"+    , stateHandle  = st+    , getState     = query st GetLegacyPasswdsTable+    , putState     = update st . ReplaceLegacyPasswdsTable+    , backupState  = \users -> [csvToBackup ["htpasswd.csv"] (legacyPasswdsToCSV users)]+    , restoreState = legacyPasswdsBackup+    , resetState   = legacyPasswdsStateComponent+    }++----------------------------+-- Data backup and restore+--++legacyPasswdsBackup :: RestoreBackup LegacyPasswdsTable+legacyPasswdsBackup = updatePasswdsBackup []++updatePasswdsBackup :: [(UserId, LegacyAuth.HtPasswdHash)] -> RestoreBackup LegacyPasswdsTable+updatePasswdsBackup upasswds = RestoreBackup {+    restoreEntry = \entry -> case entry of+      BackupByteString ["htpasswd.csv"] bs -> do+        when (not (null upasswds)) (fail "legacyPasswdsBackup: found multiple htpasswd.csv files")+        csv <- importCSV "htpasswd.csv" bs+        upasswds' <- importHtPasswds csv+        return (updatePasswdsBackup upasswds')+      _ ->+        return (updatePasswdsBackup upasswds)+  , restoreFinalize =+      let tbl =  IntMap.fromList [ (uid, htpasswd)+                                 | (UserId uid, htpasswd) <- upasswds ] in+      return $! LegacyPasswdsTable tbl+  }++importHtPasswds :: CSV -> Restore [(UserId, LegacyAuth.HtPasswdHash)]+importHtPasswds = sequence . map fromRecord . drop 2+  where+    fromRecord :: Record -> Restore (UserId, LegacyAuth.HtPasswdHash)+    fromRecord [idStr, htpasswdStr] = do+        uid <- parseText "user id" idStr+        return (uid, LegacyAuth.HtPasswdHash htpasswdStr)++    fromRecord x = fail $ "Error processing user details record: " ++ show x++legacyPasswdsToCSV :: LegacyPasswdsTable -> CSV+legacyPasswdsToCSV (LegacyPasswdsTable tbl)+    = ([display version]:) $+      (headers:) $++      flip map (IntMap.toList tbl) $ \(uid, LegacyAuth.HtPasswdHash passwdhash) ->+      [ display (UserId uid)+      , passwdhash+      ]+ where+    headers = ["uid", "htpasswd"]+    version = Version [0,1] []++----------------------------------------+-- Feature definition & initialisation+--++initLegacyPasswdsFeature :: ServerEnv -> UserFeature -> IO LegacyPasswdsFeature+initLegacyPasswdsFeature env@ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} users = do++  -- Canonical state+  legacyPasswdsState <- legacyPasswdsStateComponent serverStateDir++  -- Page templates+  templates <- loadTemplates serverTemplatesMode+                 [serverTemplatesDir, serverTemplatesDir </> "LegacyPasswds"]+                 ["htpasswd-upgrade.html", "htpasswd-upgrade-success.html"]++  let feature = legacyPasswdsFeature env legacyPasswdsState templates users++  return feature++legacyPasswdsFeature :: ServerEnv+                     -> StateComponent AcidState LegacyPasswdsTable+                     -> Templates+                     -> UserFeature+                     -> LegacyPasswdsFeature+legacyPasswdsFeature env legacyPasswdsState templates UserFeature{..}+  = LegacyPasswdsFeature {..}++  where+    legacyPasswdsFeatureInterface = (emptyHackageFeature "legacy-passwds") {+        featureDesc      = "Support for upgrading accounts from htpasswd-style passwords"+      , featureResources = [htpasswordResource, htpasswordUpgradeResource]+      , featureState     = [abstractAcidStateComponent legacyPasswdsState]+      , featureCaches    = []+      , featurePostInit  = interceptUserAuthFail+      }++    -- Resources+    --++    htpasswordResource = (resourceAt "/user/:username/htpasswd") {+            resourceDesc = [ (PUT, "Set a legacy password for a user account") ],+            resourcePut  = [ ("", handleUserHtpasswdPut) ]+          }++    htpasswordUpgradeResource = (resourceAt "/users/htpasswd-upgrade") {+            resourceDesc = [ (GET, "Upgrade a user account with a legacy password") ],+            resourceGet  = [ ("html", handleUserAuthUpgradeGet) ],+            resourcePost = [ ("", handleUserAuthUpgradePost) ]+          }++    -- Request handlers+    --++    handleUserAuthUpgradeGet :: DynamicPath -> ServerPartE Response+    handleUserAuthUpgradeGet _ = do+        template <- getTemplate templates "htpasswd-upgrade.html"+        ok $ toResponse $ template []++    queryLegacyPasswds :: MonadIO m => m LegacyPasswdsTable+    queryLegacyPasswds = queryState legacyPasswdsState GetLegacyPasswdsTable++    handleUserHtpasswdPut :: DynamicPath -> ServerPartE Response+    handleUserHtpasswdPut dpath = do+        _            <- guardAuthorised [InGroup adminGroup]+        users        <- queryGetUserDb+        uname        <- userNameInPath dpath+        (uid, uinfo) <- maybe errNoSuchUser return (Users.lookupUserName uname users)+        when (userStatus uinfo /= Users.AccountDisabled Nothing) errHasAuth+        passwdhash   <- expectTextPlain+        when (not $ validHtpasswd passwdhash) errBadHash+        let htpasswd = LegacyAuth.HtPasswdHash (LBS.unpack passwdhash)+        updateState legacyPasswdsState $ SetUserLegacyPasswd uid htpasswd+        noContent $ toResponse ()+      where+        validHtpasswd str = LBS.length str == 13+        errNoSuchUser = errNotFound "No such user" [MText "No such user"]+        errHasAuth    = errBadRequest "Clashing auth details" [MText "The user already has auth info"]+        errBadHash    = errBadRequest "Invalid htpasswd hash" [MText "Only classic htpasswd crypt() passwords are supported."]++    handleUserAuthUpgradePost :: DynamicPath -> ServerPartE Response+    handleUserAuthUpgradePost _ = do+        users              <- queryGetUserDb+        legacyPasswds      <- queryLegacyPasswds+        (uid, uinfo, passwd) <- LegacyAuth.guardAuthenticated+                                  (RealmName "Old Hackage site")+                                  users+                                  (lookupUserLegacyPasswd legacyPasswds)+        when (userStatus uinfo /= Users.AccountDisabled Nothing) errHasAuth+        let auth = Users.UserAuth (Auth.newPasswdHash Auth.hackageRealm (userName uinfo) passwd)+        updateSetUserAuth uid auth+        updateSetUserEnabledStatus uid True+        updateState legacyPasswdsState (DeleteUserLegacyPasswd uid)+        template <- getTemplate templates "htpasswd-upgrade-success.html"+        ok $ toResponse $ template []+      where+        errHasAuth = errForbidden "Cannot set new password"+          [MText $ "The account is not in a state where upgrading the "+                ++ "authentication is allowed. If this is unexpected, "+                ++ "please contact an administrator."]++    interceptUserAuthFail :: IO ()+    interceptUserAuthFail = do+      registerHook authFailHook onAuthFail++    onAuthFail :: Auth.AuthError -> IO (Maybe ErrorResponse)+    -- For the case where a user tries to authenticate as a user who's account+    -- is disabled with no password, we check if that user has a legacy+    -- htpassword. If so, we direct them to a page where they can log in with+    -- the old account details.+    -- Note that we have not authenticated the user yet, so we have to be very+    -- careful about what info we reveal. Technically we are revealing+    -- something here: the fact that the user exists and has an old htpasswd.+    onAuthFail (Auth.UserStatusError uid+                  UserInfo { userStatus = AccountDisabled Nothing }) = do+        legacyPasswds <- queryLegacyPasswds+        case lookupUserLegacyPasswd legacyPasswds uid of+          Nothing -> return Nothing+          Just _  -> return (Just err)+      where+        err = ErrorResponse 403 [] "Account needs to be re-enabled" msg+        msg = [ MText $ "Hackage has been upgraded to use a more secure login "+                     ++ "system. Please go to "+              , MLink abs rel+              , MText $ " to re-enable your account and for more details about "+                     ++ "this change." ]+        rel = renderResource htpasswordUpgradeResource []+        abs = uriToString id ((serverBaseURI env) { uriPath = rel }) ""++    onAuthFail _ = return Nothing+
+ Distribution/Server/Features/LegacyPasswds/Auth.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving,+             TemplateHaskell, ForeignFunctionInterface, PatternGuards #-}+module Distribution.Server.Features.LegacyPasswds.Auth (+   HtPasswdHash(..),+   guardAuthenticated,+  ) where++import Distribution.Server.Framework.AuthTypes+import Distribution.Server.Framework.Error+import Distribution.Server.Framework.MemSize+import Distribution.Server.Users.Types (UserId, UserName(..), UserInfo)+import qualified Distribution.Server.Users.Users as Users+import Distribution.Server.Framework.AuthCrypt (BasicAuthInfo(..))++import Happstack.Server++import qualified Data.ByteString.Base64 as Base64+import Control.Monad+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Typeable (Typeable)++import Foreign.C.String+import System.IO.Unsafe (unsafePerformIO)+import Control.Concurrent.MVar (MVar, newMVar, withMVar)++import qualified Data.ByteString.Char8 as BS -- TODO: Verify that we don't need to worry about UTF8 here++---------------------------+-- Old-style crypt() auth+--++-- compatible with apache htpasswd files using CRYPT format:+--+-- http://httpd.apache.org/docs/2.2/misc/password_encryptions.html+--++-- | These are the *old* crypt format password hashes (salted DES: perl crypt).+-- Not the same as the new hashes we store in 'PasswdHash'.+--+newtype HtPasswdHash = HtPasswdHash String+  deriving (Eq, Show, Typeable, MemSize)++$(deriveSafeCopy 0 'base ''HtPasswdHash)++checkCryptAuthInfo :: HtPasswdHash -> BasicAuthInfo -> Bool+checkCryptAuthInfo (HtPasswdHash hash) (BasicAuthInfo _ _ (PasswdPlain passwd))+  = crypt passwd hash == hash++foreign import ccall unsafe "crypt" cCrypt :: CString-> CString -> CString++crypt :: String -- ^ Payload+      -> String -- ^ Salt+      -> String -- ^ Hash+crypt key seed = unsafePerformIO $ withMVar cryptMVar $ \_ -> do+    k <- newCAString key+    s <- newCAString seed+    peekCAString $ cCrypt k s++cryptMVar :: MVar ()+cryptMVar = unsafePerformIO $ newMVar ()+{-# NOINLINE cryptMVar #-}++--------------------+-- HTTP Basic auth+--++guardAuthenticated :: RealmName -> Users.Users+                   -> (UserId -> Maybe HtPasswdHash)+                   -> ServerPartE (UserId, UserInfo, PasswdPlain)+guardAuthenticated realm users getHtPasswdHash = do+    req <- askRq+    either (authError realm) return $+      case getHeaderAuth req of+        Just ahdr -> checkBasicAuth users getHtPasswdHash realm ahdr+        Nothing   -> Left NoAuthError+  where+    getHeaderAuth :: Request -> Maybe BS.ByteString+    getHeaderAuth req+      | Just hdr <- getHeader "authorization" req+      , BS.isPrefixOf (BS.pack "Basic ") hdr+      = Just (BS.drop 6 hdr)++      | otherwise+      = Nothing++checkBasicAuth :: Users.Users -> (UserId -> Maybe HtPasswdHash) -> RealmName -> BS.ByteString+               -> Either AuthError (UserId, UserInfo, PasswdPlain)+checkBasicAuth users getHtPasswdHash realm ahdr = do+    authInfo     <- getBasicAuthInfo realm ahdr       ?! UnrecognizedAuthError+    let uname    = basicUsername authInfo+    (uid, uinfo) <- Users.lookupUserName uname users  ?! NoSuchUserError+    passwdhash   <- getHtPasswdHash uid               ?! NoSuchUserError+    guard (checkCryptAuthInfo passwdhash authInfo)    ?! PasswordMismatchError+    return (uid, uinfo, basicPasswd authInfo)++getBasicAuthInfo :: RealmName -> BS.ByteString -> Maybe BasicAuthInfo+getBasicAuthInfo realm authHeader+  | Just (username, pass) <- splitHeader authHeader+  = Just BasicAuthInfo {+           basicRealm    = realm,+           basicUsername = UserName username,+           basicPasswd   = PasswdPlain pass+         }+  | otherwise = Nothing+  where+    splitHeader h = case Base64.decode h of+                    Left _ -> Nothing+                    Right xs ->+                        case break (':' ==) $ BS.unpack xs of+                          (username, ':' : pass) -> Just (username, pass)+                          _                      -> Nothing++setBasicAuthChallenge :: RealmName -> ServerPartE ()+setBasicAuthChallenge (RealmName realmName) = do+    addHeaderM headerName headerValue+  where+    headerName  = "WWW-Authenticate"+    headerValue = "Basic realm=\"" ++ realmName ++ "\""++authError :: RealmName -> AuthError -> ServerPartE a+authError realm err = do+  setBasicAuthChallenge  realm+  finishWith (showAuthError err)++data AuthError = NoAuthError | UnrecognizedAuthError | NoSuchUserError+               | PasswordMismatchError+  deriving Show++showAuthError :: AuthError -> Response+showAuthError err = case err of+    NoAuthError           -> withRsCode 401 $ toResponse "No authorization provided."+    UnrecognizedAuthError -> withRsCode 400 $ toResponse "Authorization scheme not recognized."+    NoSuchUserError       -> withRsCode 401 $ toResponse "Username or password incorrect."+    PasswordMismatchError -> withRsCode 401 $ toResponse "Username or password incorrect."+  where+    withRsCode c r = r { rsCode = c }+
+ Distribution/Server/Features/LegacyRedirects.hs view
@@ -0,0 +1,149 @@+module Distribution.Server.Features.LegacyRedirects (+    legacyRedirectsFeature+  ) where++import Distribution.Server.Framework+import Distribution.Server.Features.Upload++import Distribution.Package+         ( PackageIdentifier(..), packageName, PackageId )+import Distribution.Text+         ( display, simpleParse )++import Data.Version ( Version (..) )++import qualified System.FilePath.Posix as Posix (joinPath, splitExtension)+++-- | A feature to provide redirection for URLs that existed in the first+-- incarnation of the hackage server.+--+legacyRedirectsFeature :: UploadFeature -> HackageFeature+legacyRedirectsFeature upload = (emptyHackageFeature "legacy") {+    -- get rid of trailing resource and manually create a mapping?+    featureResources =+      [ (resourceAt "/..") {+            resourceGet = [("", \_ -> serveLegacyGets)]+          , resourcePost = [("", \_ -> serveLegacyPosts upload)]+          }+      ]+  , featureState = []+  }++-- | Support for the old URL scheme from the first version of hackage.+--++-- | POST for package upload, particularly for cabal-install compatibility.+--+-- "check" no longer exists; it's now "candidates", and probably+-- provides too different functionality to redirect+serveLegacyPosts :: UploadFeature -> ServerPartE Response+serveLegacyPosts upload = msum+  [ dir "packages" $ msum+      [ dir "upload" $ movedUpload+    --, postedMove "check"  "/check"+      ]+  , dir "cgi-bin" $ dir "hackage-scripts" $ msum+      [ dir "protected" $ dir "upload-pkg" $ movedUpload+    --, postedMove "check"  "/check"+      ]+  , dir "upload" movedUpload+  ]+  where++    -- We assume we don't need to serve a fancy HTML response+    movedUpload :: ServerPartE Response+    movedUpload = nullDir >> do+      upResult <- uploadPackage upload+      ok $ toResponse $ unlines $ uploadWarnings upResult++++-- | GETs, both for cabal-install to use, and for links scattered throughout the web.+serveLegacyGets :: ServerPartE Response+serveLegacyGets = msum+  [ simpleMove "00-index.tar.gz" "/packages/index.tar.gz"+  , dir "packages" $ msum+      [ dir "archive" $ serveArchiveTree+      , simpleMove "hackage.html"    "/"+      , simpleMove "00-index.tar.gz" "/packages/index.tar.gz"+        --also search.html, advancedsearch.html, accounts.html, and admin.html+      ]+  , dir "cgi-bin" $ dir "hackage-scripts" $ msum+      [ dir "package" $ path $ \packageId -> method GET >> nullDir >>+          (movedPermanently ("/package/" ++ display (packageId :: PackageId)) $+           toResponse "")+      ]+  , dir "package" $ path $ \fileName -> method GET >> nullDir >>+      case Posix.splitExtension fileName of+        (fileName', ".gz") -> case Posix.splitExtension fileName' of+          (packageStr, ".tar") -> case simpleParse packageStr of+            Just pkgid ->+              movedPermanently (packageTarball pkgid) $ toResponse ""+            _ -> mzero+          _ -> mzero+        _ -> mzero+  ]+  where+    -- HTTP 301 is suitable for permanently redirecting pages+    simpleMove from to = dir from $ method GET >> nullDir >> movedPermanently to (toResponse "")++-- Some of the old-style paths may contain a version number+-- or the text 'latest'. We represent the path '$pkgName/latest'+-- as a package id of '$pkgName' in the new url schemes.++data VersionOrLatest+    = V Version+    | Latest++instance FromReqURI VersionOrLatest where+    fromReqURI "latest" = Just Latest+    fromReqURI str = V <$> fromReqURI str++volToVersion :: VersionOrLatest -> Version+volToVersion Latest = Version [] []+volToVersion (V v)  = v++serveArchiveTree :: ServerPartE Response+serveArchiveTree = msum+  [ dir "pkg-list.html" $ method GET >> nullDir >> movedPermanently "/packages/" (toResponse "")+  , dir "package" $ path $ \fileName -> method GET >> nullDir >>+   case Posix.splitExtension fileName of+    (fileName', ".gz") -> case Posix.splitExtension fileName' of+       (packageStr, ".tar") -> case simpleParse packageStr of+          Just pkgid ->+            movedPermanently (packageTarball pkgid) $ toResponse ""+          _ -> mzero+       _ -> mzero+    _ -> mzero+  , dir "00-index.tar.gz" $ method GET >> nullDir >> movedPermanently "/packages/index.tar.gz" (toResponse "")+  , path $ \name -> do+     msum+      [ path $ \version ->+        let pkgid = PackageIdentifier {pkgName = name, pkgVersion = volToVersion version}+        in msum+         [ let dirName = display pkgid ++ ".tar.gz"+           in dir dirName $ method GET >> nullDir >>+              movedPermanently (packageTarball pkgid) (toResponse "")++         , let fileName = display name ++ ".cabal"+           in dir fileName $ method GET >> nullDir >>+              movedPermanently (cabalPath pkgid) (toResponse "")++         , dir "doc" $ dir "html" $ remainingPath $ \paths ->+             let doc = Posix.joinPath paths+             in method GET >> nullDir >>+                movedPermanently (docPath pkgid doc) (toResponse "")+         ]+      ]+  ]+  where+    docPath pkgid file = "/package/" ++ display pkgid ++ "/" ++ "docs/" ++ file++    cabalPath pkgid = "/package/" ++ display pkgid ++ "/"+                   ++ display (packageName pkgid) ++ ".cabal"++packageTarball :: PackageId -> String+packageTarball pkgid = "/package/" ++ display pkgid+                    ++ "/" ++ display pkgid ++ ".tar.gz"+
+ Distribution/Server/Features/Mirror.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE DoRec, RankNTypes, ScopedTypeVariables,+             NamedFieldPuns, RecordWildCards #-}+module Distribution.Server.Features.Mirror (+    MirrorFeature(..),+    MirrorResource(..),+    initMirrorFeature+  ) where++import Distribution.Server.Framework hiding (formatTime)++import Distribution.Server.Features.Core+import Distribution.Server.Features.Users++import Distribution.Server.Users.State+import Distribution.Server.Packages.Types+import Distribution.Server.Users.Backup+import Distribution.Server.Users.Types+import Distribution.Server.Users.Users hiding (lookupUserName)+import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), nullDescription)+import qualified Distribution.Server.Framework.BlobStorage as BlobStorage+import qualified Distribution.Server.Packages.Unpack as Upload+import Distribution.Server.Framework.BackupDump+import Distribution.Server.Util.Parse (unpackUTF8)++import Distribution.PackageDescription.Parse (parsePackageDescription)+import Distribution.ParseUtils (ParseResult(..), locatedErrorMsg, showPWarning)++import Data.Time.Clock (getCurrentTime)+import Data.Time.Format (formatTime, parseTime)+import System.Locale (defaultTimeLocale)+import qualified Distribution.Server.Util.GZip as GZip++import Distribution.Package+import Distribution.Text+++data MirrorFeature = MirrorFeature {+    mirrorFeatureInterface :: HackageFeature,+    mirrorResource :: MirrorResource,+    mirrorGroup :: UserGroup+}++instance IsHackageFeature MirrorFeature where+    getFeatureInterface = mirrorFeatureInterface++data MirrorResource = MirrorResource {+    mirrorPackageTarball :: Resource,+    mirrorPackageUploadTime :: Resource,+    mirrorPackageUploader :: Resource,+    mirrorCabalFile :: Resource,+    mirrorGroupResource :: GroupResource+}++-------------------------------------------------------------------------+initMirrorFeature :: ServerEnv -> CoreFeature -> UserFeature -> IO MirrorFeature+initMirrorFeature env@ServerEnv{serverStateDir, serverVerbosity = verbosity}+                  core user@UserFeature{..} = do+    loginfo verbosity "Initialising mirror feature, start"++    -- Canonical state+    mirrorersState <- mirrorersStateComponent serverStateDir++    -- Tie the knot with a do-rec+    rec let (feature, mirrorersGroupDesc)+              = mirrorFeature env core user+                              mirrorersState mirrorersG mirrorR++        (mirrorersG, mirrorR) <- groupResourceAt "/packages/mirrorers" mirrorersGroupDesc++    loginfo verbosity "Initialising mirror feature, end"+    return feature++mirrorersStateComponent :: FilePath -> IO (StateComponent AcidState MirrorClients)+mirrorersStateComponent stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> "MirrorClients") initialMirrorClients+  return StateComponent {+      stateDesc    = "Mirror clients"+    , stateHandle  = st+    , getState     = query st GetMirrorClients+    , putState     = update st . ReplaceMirrorClients . mirrorClients+    , backupState  = \(MirrorClients clients) -> [csvToBackup ["clients.csv"] $ groupToCSV clients]+    , restoreState = MirrorClients <$> groupBackup ["clients.csv"]+    , resetState   = mirrorersStateComponent+    }++mirrorFeature :: ServerEnv+              -> CoreFeature+              -> UserFeature+              -> StateComponent AcidState MirrorClients+              -> UserGroup+              -> GroupResource+              -> (MirrorFeature, UserGroup)++mirrorFeature ServerEnv{serverBlobStore = store}+              CoreFeature{ coreResource = coreResource@CoreResource{+                             packageInPath+                           , packageTarballInPath+                           , lookupPackageId+                           }+                         , updateAddPackageRevision+                         , updateAddPackageTarball+                         , updateSetPackageUploadTime+                         , updateSetPackageUploader+                         }+              UserFeature{..}+              mirrorersState mirrorGroup mirrorGroupResource+  = (MirrorFeature{..}, mirrorersGroupDesc)+  where+    mirrorFeatureInterface = (emptyHackageFeature "mirror") {+        featureDesc = "Support direct (PUT) tarball uploads and overrides"+      , featureResources =+          map ($mirrorResource) [+              mirrorPackageTarball+            , mirrorPackageUploadTime+            , mirrorPackageUploader+            , mirrorCabalFile+            ] +++            [ groupResource     mirrorGroupResource+            , groupUserResource mirrorGroupResource+            ]+      , featureState = [abstractAcidStateComponent mirrorersState]+      }++    mirrorResource = MirrorResource {+        mirrorPackageTarball = (extendResource $ corePackageTarball coreResource) {+            resourceDesc = [ (PUT, "Upload or replace a package tarball") ]+          , resourcePut  = [ ("", tarballPut) ]+          }+      , mirrorPackageUploadTime = (extendResourcePath "/upload-time" $ corePackagePage coreResource) {+            resourceDesc = [ (GET, "Get a package upload time")+                           , (PUT, "Replace package upload time")+                           ]+          , resourceGet  = [ ("", uploadTimeGet) ]+          , resourcePut  = [ ("", uploadTimePut) ]+          }+      , mirrorPackageUploader = (extendResourcePath "/uploader" $ corePackagePage coreResource) {+            resourceDesc = [ (GET, "Get a package uploader (username)")+                           , (PUT, "Replace a package uploader")+                           ]+          , resourceGet  = [ ("", uploaderGet) ]+          , resourcePut  = [ ("", uploaderPut) ]+          }+      , mirrorCabalFile = (extendResource $ coreCabalFile coreResource) {+            resourceDesc = [ (PUT, "Replace a package description" ) ]+          , resourcePut  = [ ("", cabalPut) ]+          }+      , mirrorGroupResource+      }++    mirrorersGroupDesc = UserGroup {+        groupDesc      = nullDescription { groupTitle = "Mirror clients" },+        queryUserList  = queryState  mirrorersState   GetMirrorClientsList,+        addUserList    = updateState mirrorersState . AddMirrorClient,+        removeUserList = updateState mirrorersState . RemoveMirrorClient,+        canRemoveGroup = [adminGroup],+        canAddGroup    = [adminGroup]+    }+++    -- result: error from unpacking, bad request error, or warning lines+    --+    -- curl -u admin:admin \+    --      -X PUT \+    --      -H "Content-Type: application/x-gzip" \+    --      --data-binary @$1 \+    --      http://localhost:8080/package/$PACKAGENAME/$PACKAGEID.tar.gz+    tarballPut :: DynamicPath -> ServerPartE Response+    tarballPut dpath = do+        uid         <- guardAuthorised [InGroup mirrorGroup]+        pkgid       <- packageTarballInPath dpath+        fileContent <- expectCompressedTarball+        time        <- liftIO getCurrentTime+        let uploadinfo = (time, uid)+        res <- liftIO $ BlobStorage.addWith store fileContent $ \fileContent' ->+                 let filename = display pkgid <.> "tar.gz"+                 in case Upload.unpackPackageRaw filename fileContent' of+                      Left err -> return $ Left err+                      Right x ->+                          do let decompressedContent = GZip.decompressNamed filename fileContent'+                             blobIdDecompressed <- BlobStorage.add store decompressedContent+                             return $ Right (x, blobIdDecompressed)+        case res of+          Left err -> badRequest (toResponse err)+          Right ((((pkg, _pkgStr), warnings), blobIdDecompressed), blobId) -> do+            let tarball = PkgTarball { pkgTarballGz   = blobId,+                                       pkgTarballNoGz = blobIdDecompressed }+            existed <- updateAddPackageTarball (packageId pkg) tarball uploadinfo+            if existed+              then return . toResponse $ unlines warnings+              else errNotFound "Package not found" []++    uploaderGet dpath = do+      pkg    <- packageInPath dpath >>= lookupPackageId+      userdb <- queryGetUserDb+      return $ toResponse $ display (userIdToName userdb (pkgUploadUser pkg))++    uploaderPut :: DynamicPath -> ServerPartE Response+    uploaderPut dpath = do+        guardAuthorised_ [InGroup mirrorGroup]+        pkgid <- packageInPath dpath+        nameContent <- expectTextPlain+        let uname = UserName (unpackUTF8 nameContent)+        uid <- lookupUserName uname+        existed <- updateSetPackageUploader pkgid uid+        if existed+          then return $ toResponse "Updated uploader OK"+          else errNotFound "Package not found" []++    uploadTimeGet :: DynamicPath -> ServerPartE Response+    uploadTimeGet dpath = do+      pkg <- packageInPath dpath >>= lookupPackageId+      return $ toResponse $ formatTime defaultTimeLocale "%c" (pkgUploadTime pkg)++    -- curl -H 'Content-Type: text/plain' -u admin:admin -X PUT -d "Tue Oct 18 20:54:28 UTC 2010" http://localhost:8080/package/edit-distance-0.2.1/upload-time+    uploadTimePut :: DynamicPath -> ServerPartE Response+    uploadTimePut dpath = do+        guardAuthorised_ [InGroup mirrorGroup]+        pkgid <- packageInPath dpath+        timeContent <- expectTextPlain+        case parseTime defaultTimeLocale "%c" (unpackUTF8 timeContent) of+          Nothing -> errBadRequest "Could not parse upload time" []+          Just t  -> do+            existed <- updateSetPackageUploadTime pkgid t+            if existed+              then return $ toResponse "Updated upload time OK"+              else errNotFound "Package not found" []++    -- return: error from parsing, bad request error, or warning lines+    cabalPut :: DynamicPath -> ServerPartE Response+    cabalPut dpath = do+        uid <- guardAuthorised [InGroup mirrorGroup]+        pkgid :: PackageId <- packageInPath dpath+        fileContent <- expectTextPlain+        time <- liftIO getCurrentTime+        let uploadData = (time, uid)+        case parsePackageDescription . unpackUTF8 $ fileContent of+            ParseFailed err -> badRequest (toResponse $ show (locatedErrorMsg err))+            ParseOk _ pkg | pkgid /= packageId pkg ->+                errBadRequest "Wrong package Id"+                  [MText $ "Expected " ++ display pkgid+                        ++ " but found " ++ display (packageId pkg)]+            ParseOk warnings pkg -> do+                updateAddPackageRevision (packageId pkg)+                                         (CabalFileText fileContent) uploadData+                let filename = display pkgid <.> "cabal"+                return . toResponse $ unlines $ map (showPWarning filename) warnings+
+ Distribution/Server/Features/PackageCandidates.hs view
@@ -0,0 +1,429 @@+{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-}+module Distribution.Server.Features.PackageCandidates (+    PackageCandidatesFeature(..),+    PackageCandidatesResource(..),+    initPackageCandidatesFeature,++    CandidateRender(..),+    CandPkgInfo(..),+  ) where++import Distribution.Server.Framework++import Distribution.Server.Features.PackageCandidates.Types+import Distribution.Server.Features.PackageCandidates.State+import Distribution.Server.Features.PackageCandidates.Backup++import Distribution.Server.Features.Core+import Distribution.Server.Features.Upload+import Distribution.Server.Features.Users+import Distribution.Server.Features.TarIndexCache++import Distribution.Server.Packages.Types+import Distribution.Server.Packages.Render+import Distribution.Server.Packages.ChangeLog+import qualified Distribution.Server.Users.Types as Users+import qualified Distribution.Server.Users.Group as Group+import qualified Distribution.Server.Framework.BlobStorage as BlobStorage+import qualified Distribution.Server.Packages.PackageIndex as PackageIndex+import Distribution.Server.Packages.PackageIndex (PackageIndex)+import qualified Distribution.Server.Framework.ResponseContentTypes as Resource++import Distribution.Server.Util.ServeTarball (serveTarEntry, serveTarball)+import qualified Data.TarIndex as TarIndex++import Distribution.Text+import Distribution.Package++import Data.Version+import Data.Function (fix)+import Data.List (find)+import Data.Time.Clock (getCurrentTime)+import Control.Monad.Error (ErrorT(..))++data PackageCandidatesFeature = PackageCandidatesFeature {+    candidatesFeatureInterface :: HackageFeature,+    candidatesCoreResource     :: CoreResource,+    candidatesResource         :: PackageCandidatesResource,++    -- queries+    queryGetCandidateIndex :: MonadIO m => m (PackageIndex CandPkgInfo),++    postCandidate         :: ServerPartE Response,+    postPackageCandidate  :: DynamicPath -> ServerPartE Response,+    putPackageCandidate   :: DynamicPath -> ServerPartE Response,+    doDeleteCandidate     :: DynamicPath -> ServerPartE Response,+    uploadCandidate       :: (PackageId -> Bool) -> ServerPartE CandPkgInfo,+    publishCandidate      :: DynamicPath -> Bool -> ServerPartE UploadResult,+    checkPublish          :: PackageIndex PkgInfo -> CandPkgInfo -> Maybe ErrorResponse,+    candidateRender       :: CandPkgInfo -> IO CandidateRender,++    lookupCandidateName :: PackageName -> ServerPartE [CandPkgInfo],+    lookupCandidateId   :: PackageId -> ServerPartE CandPkgInfo+}++instance IsHackageFeature PackageCandidatesFeature where+    getFeatureInterface = candidatesFeatureInterface++    -- There can also be build reports as well as documentation for proposed+    -- versions.+    -- These features check for existence of a package in the *main* index,+    -- but it should be possible to hijack their indices to support candidates,+    -- perhaps by them having a Filter for whether a package-version exists+    -- (since they don't need any other info than the PackageId).+    -- Unfortunately, some problems exist when both a candidate and actual version+    -- of the same package exist simultaneously, so may want to hook into+    -- UploadFeature's canUploadPackage to ensure this won't happen, and to+    -- force deletion on publication.++{-+  Mapping:+  candidatesPage      -> corePackagesPage+  candidatePage       -> corePackagePage+  candidateCabal      -> coreCabalFile+  candidateTarball    -> corePackageTarball++  candidatesUri       -> indexPackageUri+  candidateUri        -> corePackageUri+  candidateTarballUri -> coreTarballUri+  candidateCabalUri   -> coreCabalUri+-}++data PackageCandidatesResource = PackageCandidatesResource {+    packageCandidatesPage :: Resource,+    publishPage           :: Resource,+    packageCandidatesUri  :: String -> PackageName -> String,+    publishUri            :: String -> PackageId -> String,++    -- TODO: Why don't the following entries have a corresponding entry+    -- in CoreResource?+    candidateContents     :: Resource,+    candidateChangeLog    :: Resource,+    candidateChangeLogUri :: PackageId -> String+}++-- candidates can be published at any time; there can be multiple candidates per package+-- they can be deleted, but it's not required++data CandidateRender = CandidateRender {+    candPackageRender :: PackageRender,+    renderWarnings :: [String],+    hasIndexedPackage :: Bool+}+++-- URI generation (string-based), using maps; user groups+initPackageCandidatesFeature :: ServerEnv+                             -> UserFeature+                             -> CoreFeature+                             -> UploadFeature+                             -> TarIndexCacheFeature+                             -> IO PackageCandidatesFeature+initPackageCandidatesFeature env@ServerEnv{serverStateDir} user core upload tarIndexCache = do+    candidatesState <- candidatesStateComponent serverStateDir+    return $ candidatesFeature env user core upload tarIndexCache candidatesState++candidatesStateComponent :: FilePath -> IO (StateComponent AcidState CandidatePackages)+candidatesStateComponent stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> "CandidatePackages") initialCandidatePackages+  return StateComponent {+      stateDesc    = "Candidate packages"+    , stateHandle  = st+    , getState     = query st GetCandidatePackages+    , putState     = update st . ReplaceCandidatePackages+    , resetState   = candidatesStateComponent+    , backupState  = backupCandidates+    , restoreState = restoreCandidates+  }++candidatesFeature :: ServerEnv+                  -> UserFeature+                  -> CoreFeature+                  -> UploadFeature+                  -> TarIndexCacheFeature+                  -> StateComponent AcidState CandidatePackages+                  -> PackageCandidatesFeature+candidatesFeature ServerEnv{serverBlobStore = store}+                  UserFeature{..}+                  CoreFeature{ coreResource=core@CoreResource{packageInPath, packageTarballInPath}+                             , queryGetPackageIndex+                             , updateAddPackage+                             }+                  UploadFeature{..}+                  TarIndexCacheFeature{cachedPackageTarIndex}+                  candidatesState+  = PackageCandidatesFeature{..}+  where+    candidatesFeatureInterface = (emptyHackageFeature "candidates") {+        featureDesc = "Support for package candidates"+      , featureResources =+          map ($candidatesCoreResource) [+              corePackagesPage+            , corePackagePage+            , coreCabalFile+            , corePackageTarball+            ] +++          map ($candidatesResource) [+              publishPage+            , candidateContents+            , candidateChangeLog+            ]+      , featureState = [abstractAcidStateComponent candidatesState]+      }++    queryGetCandidateIndex :: MonadIO m => m (PackageIndex CandPkgInfo)+    queryGetCandidateIndex = return . candidateList =<< queryState candidatesState GetCandidatePackages++    candidatesCoreResource = fix $ \r -> CoreResource {+-- TODO: There is significant overlap between this definition and the one in Core+        corePackagesPage = resourceAt "/packages/candidates/.:format"+      , corePackagePage = resourceAt "/package/:package/candidate.:format"+      , coreCabalFile = (resourceAt "/package/:package/candidate/:cabal.cabal") {+            resourceDesc = [(GET, "Candidate .cabal file")]+          , resourceGet  = [("cabal", serveCandidateCabal)]+          }+      , corePackageTarball = (resourceAt "/package/:package/candidate/:tarball.tar.gz") {+            resourceDesc = [(GET, "Candidate tarball")]+          , resourceGet  = [("tarball", serveCandidateTarball)]+          }+      , indexPackageUri = \format ->+          renderResource (corePackagesPage r) [format]+      , corePackageIdUri = \format pkgid ->+          renderResource (corePackagePage r) [display pkgid, format]+      , corePackageNameUri = \format pkgname ->+          renderResource (corePackagePage r) [display pkgname, format]+      , coreTarballUri = \pkgid ->+          renderResource (corePackageTarball r) [display pkgid, display pkgid]+      , coreCabalUri = \pkgid ->+          renderResource (coreCabalFile r) [display pkgid, display (packageName pkgid)]+      , packageInPath+      , packageTarballInPath+      , guardValidPackageId   = void . lookupCandidateId+      , guardValidPackageName = void . lookupCandidateName+      , lookupPackageName     = fmap (map candPkgInfo) . lookupCandidateName+      , lookupPackageId       = fmap candPkgInfo . lookupCandidateId+      }++    candidatesResource = fix $ \r -> PackageCandidatesResource {+        packageCandidatesPage = resourceAt "/package/:package/candidates/.:format"+      , publishPage = resourceAt "/package/:package/candidate/publish.:format"+      , candidateContents = (resourceAt "/package/:package/candidate/src/..") {+            resourceGet = [("", serveContents)]+          }+      , candidateChangeLog = (resourceAt "/package/:package/candidate/changelog") {+            resourceGet = [("changelog", serveChangeLog)]+          }+      , packageCandidatesUri = \format pkgname ->+          renderResource (packageCandidatesPage r) [display pkgname, format]+      , publishUri = \format pkgid ->+          renderResource (publishPage r) [display pkgid, format]+      , candidateChangeLogUri = \pkgid ->+          renderResource (candidateChangeLog candidatesResource) [display pkgid, display (packageName pkgid)]+      }++    postCandidate :: ServerPartE Response+    postCandidate = do+        pkgInfo <- uploadCandidate (const True)+        seeOther (corePackageIdUri candidatesCoreResource "" $ packageId pkgInfo) (toResponse ())++    -- POST to /:package/candidates/+    postPackageCandidate :: DynamicPath -> ServerPartE Response+    postPackageCandidate dpath = do+      name <- packageInPath dpath+      pkgInfo <- uploadCandidate ((==name) . packageName)+      seeOther (corePackageIdUri candidatesCoreResource "" $ packageId pkgInfo) (toResponse ())++    -- PUT to /:package-version/candidate+    -- FIXME: like delete, PUT shouldn't redirect+    putPackageCandidate :: DynamicPath -> ServerPartE Response+    putPackageCandidate dpath = do+      pkgid <- packageInPath dpath+      guard (packageVersion pkgid /= Version [] [])+      pkgInfo <- uploadCandidate (==pkgid)+      seeOther (corePackageIdUri candidatesCoreResource "" $ packageId pkgInfo) (toResponse ())++    -- FIXME: DELETE should not redirect, but rather return ServerPartE ()+    doDeleteCandidate :: DynamicPath -> ServerPartE Response+    doDeleteCandidate dpath = do+      candidate <- packageInPath dpath >>= lookupCandidateId+      guardAuthorisedAsMaintainer (packageName candidate)+      void $ updateState candidatesState $ DeleteCandidate (packageId candidate)+      seeOther (packageCandidatesUri candidatesResource "" $ packageName candidate) $ toResponse ()++    serveCandidateTarball :: DynamicPath -> ServerPartE Response+    serveCandidateTarball dpath = do+      pkg <- packageTarballInPath dpath >>= lookupCandidateId+      case pkgTarball (candPkgInfo pkg) of+        [] -> mzero --candidate's tarball does not exist+        ((tb, _):_) -> do+            let blobId = pkgTarballGz tb+            file <- liftIO $ BlobStorage.fetch store blobId+            ok $ toResponse $ Resource.PackageTarball file blobId (pkgUploadTime $ candPkgInfo pkg)++    --withFormat :: DynamicPath -> (String -> a) -> a+    --TODO: use something else for nice html error pages+    serveCandidateCabal :: DynamicPath -> ServerPartE Response+    serveCandidateCabal dpath = do+      pkg <- packageInPath dpath >>= lookupCandidateId+      guard (lookup "cabal" dpath == Just (display $ packageName pkg))+      return $ toResponse (Resource.CabalFile (cabalFileByteString $ pkgData $ candPkgInfo pkg))++    uploadCandidate :: (PackageId -> Bool) -> ServerPartE CandPkgInfo+    uploadCandidate isRight = do+        regularIndex <- queryGetPackageIndex+        -- ensure that the user has proper auth if the package exists+        (uid, uresult, tarball) <- extractPackage $ \uid info ->+                                     processCandidate isRight regularIndex uid info+        now <- liftIO getCurrentTime+        let (UploadResult pkg pkgStr _) = uresult+            pkgid      = packageId pkg+            cabalfile  = CabalFileText pkgStr+            uploadinfo = (now, uid)+            candidate = CandPkgInfo {+                candPkgInfo = PkgInfo {+                                pkgInfoId     = pkgid,+                                pkgData       = cabalfile,+                                pkgTarball    = [(tarball, uploadinfo)],+                                pkgUploadData = uploadinfo,+                                pkgDataOld    = []+                              },+                candWarnings = uploadWarnings uresult,+                candPublic = True -- do withDataFn+            }+        void $ updateState candidatesState $ AddCandidate candidate+        let group = maintainersGroup (packageName pkgid)+        liftIO $ Group.addUserList group uid+        return candidate++    -- | Helper function for uploadCandidate.+    processCandidate :: (PackageId -> Bool) -> PackageIndex PkgInfo -> Users.UserId -> UploadResult -> IO (Maybe ErrorResponse)+    processCandidate isRight state uid res = do+        let pkg = packageId (uploadDesc res)+        if not (isRight pkg)+          then uploadFailed "Name of package or package version does not match"+          else do+            pkgGroup <- Group.queryUserList (maintainersGroup (packageName pkg))+            if packageExists state pkg && not (uid `Group.member` pkgGroup)+              then uploadFailed "Not authorized to upload a candidate for this package"+              else return Nothing+      where uploadFailed = return . Just . ErrorResponse 403 [] "Upload failed" . return . MText++    publishCandidate :: DynamicPath -> Bool -> ServerPartE UploadResult+    publishCandidate dpath doDelete = do+      packages <- queryGetPackageIndex+      candidate <- packageInPath dpath >>= lookupCandidateId+      -- check authorization to upload - must already be a maintainer+      uid <- guardAuthorised [InGroup (maintainersGroup (packageName candidate))]+      -- check if package or later already exists+      case checkPublish packages candidate of+        Just failed -> throwError failed+        Nothing -> do+          -- run filters+          let pkgInfo = candPkgInfo candidate+              uresult = UploadResult (pkgDesc pkgInfo) (cabalFileByteString $ pkgData pkgInfo) (candWarnings candidate)+          time <- liftIO getCurrentTime+          let uploadInfo = (time, uid)+              ((tarball,_):_) = pkgTarball pkgInfo +          success <- updateAddPackage (packageId candidate) (pkgData pkgInfo)+                                      uploadInfo (Just tarball)+          --FIXME: share code here with upload+          -- currently we do not create the initial maintainer group etc.+          if success+            then do+              -- delete when requested: "moving" the resource+              -- should this be required? (see notes in PackageCandidatesResource)+              when doDelete $ updateState candidatesState $ DeleteCandidate (packageId candidate)+              return uresult+            else errForbidden "Upload failed" [MText "Package already exists."]+++    -- | Helper function for publishCandidate that ensures it's safe to insert into the main index.+    checkPublish :: PackageIndex PkgInfo -> CandPkgInfo -> Maybe ErrorResponse+    checkPublish packages candidate = do+        let pkgs = PackageIndex.lookupPackageName packages (packageName candidate)+            candVersion = packageVersion candidate+        case find ((== candVersion) . packageVersion) pkgs of+            Just {} -> Just $ ErrorResponse 403 [] "Publish failed" [MText "Package name and version already exist in the database"]+            Nothing  -> Nothing++    ------------------------------------------------------------------------------++    candidateRender :: CandPkgInfo -> IO CandidateRender+    candidateRender cand = do+           users  <- queryGetUserDb+           index  <- queryGetPackageIndex+           mChangeLog <- packageChangeLog (candPkgInfo cand)+           let showChangeLogLink = case mChangeLog of Right _ -> True ; _ -> False+           render <- doPackageRender users (candPkgInfo cand) showChangeLogLink+           return $ CandidateRender {+             candPackageRender = render { rendPkgUri = rendPkgUri render ++ "/candidate" },+             renderWarnings = candWarnings cand,+             hasIndexedPackage = not . null $ PackageIndex.lookupPackageName index (packageName cand)+           }++    ------------------------------------------------------------------------------++    -- Find all candidates for a package (there may be none)+    -- It is not an error if a package has no candidates, but it is an error+    -- when the package itself does not exist. We therefore check the Core+    -- package database to check if the package exists.+    lookupCandidateName :: PackageName -> ServerPartE [CandPkgInfo]+    lookupCandidateName pkgname = do+      guardValidPackageName core pkgname+      state <- queryState candidatesState GetCandidatePackages+      return $ PackageIndex.lookupPackageName (candidateList state) pkgname++    -- TODO: Unlike the corresponding function in core, we don't return the+    -- "latest" candidate when Version is empty. Should we?+    -- (If we change that, we should move the 'guard' to 'guardValidPackageId')+    lookupCandidateId :: PackageId -> ServerPartE CandPkgInfo+    lookupCandidateId pkgid = do+      guard (pkgVersion pkgid /= Version [] [])+      state <- queryState candidatesState GetCandidatePackages+      case PackageIndex.lookupPackageId (candidateList state) pkgid of+        Just pkg -> return pkg+        _ -> errNotFound "Candidate not found" [MText $ "No such candidate version for " ++ display (packageName pkgid)]++{-------------------------------------------------------------------------------+  TODO: everything below is an (almost) direct duplicate of corresponding+  functionality in PackageContents. We could factor this out, although there+  isn't any "interesting" code here.+-------------------------------------------------------------------------------}++    -- result: changelog or not-found error+    serveChangeLog :: DynamicPath -> ServerPartE Response+    serveChangeLog dpath = do+      pkg        <- packageInPath dpath >>= lookupCandidateId+      mChangeLog <- liftIO $ packageChangeLog (candPkgInfo pkg)+      case mChangeLog of+        Left err ->+          errNotFound "Changelog not found" [MText err]+        Right (fp, etag, offset, name) ->+          liftIO $ serveTarEntry fp offset name etag++    -- return: not-found error or tarball+    serveContents :: DynamicPath -> ServerPartE Response+    serveContents dpath = do+      pkg      <- packageInPath dpath >>= lookupCandidateId+      mTarball <- liftIO $ packageTarball (candPkgInfo pkg)+      case mTarball of+        Left err ->+          errNotFound "Could not serve package contents" [MText err]+        Right (fp, etag, index) ->+          serveTarball ["index.html"] (display (packageId pkg)) fp index etag++    packageTarball :: PkgInfo -> IO (Either String (FilePath, ETag, TarIndex.TarIndex))+    packageTarball PkgInfo{pkgTarball = (pkgTarball, _) : _} = do+      let blobid = pkgTarballNoGz pkgTarball+          fp     = BlobStorage.filepath store blobid+          etag   = blobETag blobid+      index <- cachedPackageTarIndex pkgTarball+      return $ Right (fp, etag, index)+    packageTarball _ =+      return $ Left "No tarball found"++    packageChangeLog :: PkgInfo -> IO (Either String (FilePath, ETag, TarIndex.TarEntryOffset, FilePath))+    packageChangeLog pkgInfo = runErrorT $ do+      (fp, etag, index) <- ErrorT $ packageTarball pkgInfo+      (offset, fname)   <- ErrorT $ return (findChangeLog pkgInfo index)+      return (fp, etag, offset, fname)
+ Distribution/Server/Features/PackageCandidates/Backup.hs view
@@ -0,0 +1,102 @@+module Distribution.Server.Features.PackageCandidates.Backup where++import Distribution.Server.Framework.BackupRestore+import Distribution.Server.Framework.BackupDump+import Distribution.Server.Features.PackageCandidates.State+import Distribution.Server.Features.PackageCandidates.Types+import Distribution.Server.Features.Core.Backup as CoreBackup+import qualified Distribution.Server.Packages.PackageIndex as PackageIndex+import Distribution.Package (PackageId, packageId)+import Text.CSV (CSV)+import Data.Version (Version(Version), showVersion)+import Data.Map (Map)+import qualified Data.Map as Map++{-------------------------------------------------------------------------------+  Restore backup+-------------------------------------------------------------------------------}++data PartialCandidate = PartialCandidate {+    partialWarnings :: [String]+  , partialPublic   :: Bool+  }++type PartialCandidates = Map PackageId PartialCandidate++restoreCandidates :: RestoreBackup CandidatePackages+restoreCandidates = updateCandidates Map.empty Map.empty++-- We keep the partial packages separate from the rest of the candidate info+-- so that we can reuse more of CoreBackup+updateCandidates :: PartialIndex -> PartialCandidates -> RestoreBackup CandidatePackages+updateCandidates packageMap candidateMap = RestoreBackup {+    restoreEntry = \entry -> do+      packageMap'   <- doPackageImport   packageMap   entry+      candidateMap' <- doCandidateImport candidateMap entry+      return (updateCandidates packageMap' candidateMap')+  , restoreFinalize = do+      let combined = combineMaps packageMap candidateMap+      results <- mapM mkCandidate (Map.toList combined)+      return $ CandidatePackages (PackageIndex.fromList results)+  }+  where+    mkCandidate :: (PackageId, (Maybe PartialPkg, Maybe PartialCandidate)) -> Restore CandPkgInfo+    mkCandidate (pkgId, (Just partialPkg, Just partialCand)) = do+      pkg <- CoreBackup.partialToFullPkg (pkgId, partialPkg)+      return CandPkgInfo { candPkgInfo  = pkg+                         , candWarnings = partialWarnings partialCand+                         , candPublic   = partialPublic   partialCand+                         }+    mkCandidate (pkgId, (Nothing, Just _)) =+      fail $ show pkgId ++ ": candidate.csv without corresponding package"+    mkCandidate (pkgId, (Just _, Nothing)) =+      fail $ show pkgId ++ ": missing candidate.csv"+    mkCandidate _ =+      fail "mkCandidate: the impossible happened"++combineMaps :: Ord k => Map k a -> Map k b -> Map k (Maybe a, Maybe b)+combineMaps map1 map2 =+  let map1' = Map.map (\x -> (Just x, Nothing)) map1+      map2' = Map.map (\y -> (Nothing, Just y)) map2+  in Map.unionWith (\e1 e2 -> (fst e1, snd e2)) map1' map2'++doCandidateImport :: PartialCandidates -> BackupEntry -> Restore PartialCandidates+doCandidateImport candidates (BackupByteString ["package", pkgStr, "candidate.csv"] bs) = do+  pkgId <- CoreBackup.parsePackageId pkgStr+  csv <- importCSV "candidate.csv" bs+  partial <- case csv of+    [_version, ["public", public], "warnings" : warnings] ->+      return PartialCandidate { partialWarnings = warnings+                              , partialPublic   = read public+                              }+    _ ->+      fail "candidate.csv has an invalid format"+  return (Map.insert pkgId partial candidates)+doCandidateImport candidates _ =+  return candidates++{-------------------------------------------------------------------------------+  Create backup+-------------------------------------------------------------------------------}++backupCandidates :: CandidatePackages -> [BackupEntry]+backupCandidates st = concatMap backupCandidate candidates+  where+    candidates :: [CandPkgInfo]+    candidates = PackageIndex.allPackages (candidateList st)++backupCandidate :: CandPkgInfo -> [BackupEntry]+backupCandidate candidate =+    csvToBackup (CoreBackup.pkgPath (packageId candidate) "candidate.csv")+                (backupExtraInfo candidate)+  : CoreBackup.infoToAllEntries (candPkgInfo candidate)++-- | Backup the information CandPkgInfo adds on top of PkgInfo+backupExtraInfo :: CandPkgInfo -> CSV+backupExtraInfo candidate = [+    [showVersion versionCSV]+  , ["public", show (candPublic candidate)]+  , "warnings" : candWarnings candidate+  ]+  where+    versionCSV = Version [0,1] ["unstable"]
+ Distribution/Server/Features/PackageCandidates/State.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-}++module Distribution.Server.Features.PackageCandidates.State where++import Distribution.Server.Features.PackageCandidates.Types+import Distribution.Server.Framework.MemSize++import qualified Distribution.Server.Packages.PackageIndex as PackageIndex+import Distribution.Package++import Data.Acid     (Query, Update, makeAcidic)+import Data.SafeCopy (deriveSafeCopy, base)+import Data.Typeable+import Control.Monad.Reader+import qualified Control.Monad.State as State+import Data.Monoid+++---------------------------------- Index of candidate tarballs and metadata+-- boilerplate code based on PackagesState+data CandidatePackages = CandidatePackages {+    candidateList :: !(PackageIndex.PackageIndex CandPkgInfo)+} deriving (Typeable, Show, Eq)++deriveSafeCopy 0 'base ''CandidatePackages++instance MemSize CandidatePackages where+    memSize (CandidatePackages a) = memSize1 a++initialCandidatePackages :: CandidatePackages+initialCandidatePackages = CandidatePackages {+    candidateList = mempty+  }++replaceCandidate :: CandPkgInfo -> Update CandidatePackages ()+replaceCandidate pkg = State.modify $ \candidates -> candidates { candidateList = replaceVersions (candidateList candidates) }+    where replaceVersions = PackageIndex.insert pkg . PackageIndex.deletePackageName (packageName pkg)++addCandidate :: CandPkgInfo -> Update CandidatePackages ()+addCandidate pkg = State.modify $ \candidates -> candidates { candidateList = addVersion (candidateList candidates) }+    where addVersion = PackageIndex.insert pkg++deleteCandidate :: PackageId -> Update CandidatePackages ()+deleteCandidate pkg = State.modify $ \candidates -> candidates { candidateList = deleteVersion (candidateList candidates) }+    where deleteVersion = PackageIndex.deletePackageId pkg++deleteCandidates :: PackageName -> Update CandidatePackages ()+deleteCandidates pkg = State.modify $ \candidates -> candidates { candidateList = deleteVersions (candidateList candidates) }+    where deleteVersions = PackageIndex.deletePackageName pkg++-- |Replace all existing packages and reports+replaceCandidatePackages :: CandidatePackages -> Update CandidatePackages ()+replaceCandidatePackages = State.put++getCandidatePackages :: Query CandidatePackages CandidatePackages+getCandidatePackages = ask+++makeAcidic ''CandidatePackages ['getCandidatePackages+                               ,'replaceCandidatePackages+                               ,'replaceCandidate+                               ,'addCandidate+                               ,'deleteCandidate+                               ,'deleteCandidates+                               ]+
+ Distribution/Server/Features/PackageCandidates/Types.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Server.Features.Check.Types+-- Copyright   :  (c) Matthew Gruen 2010+-- License     :  BSD-like+--+-- Data types for the candidate feature+-----------------------------------------------------------------------------+module Distribution.Server.Features.PackageCandidates.Types where++import Distribution.Server.Packages.Types (PkgInfo(..))+import Distribution.Server.Framework.Instances ()+import Distribution.Server.Framework.MemSize++import Distribution.Package+         ( PackageIdentifier(..), Package(..) )++import qualified Data.Serialize as Serialize+import Data.Serialize (Serialize)+import Data.Typeable (Typeable)+import Data.SafeCopy+++------------------------------------------------------+-- | The information we keep about a candidate package.+--+-- It's currently possible to have candidates for packages which don't exist yet.+--+data CandPkgInfo = CandPkgInfo {+    -- there should be one ByteString and one BlobId per candidate.+    -- this was enforced in the types.. but it's easier to just+    -- reuse PkgInfo for the task.+    candPkgInfo :: !PkgInfo,+    -- | Warnings to display at the top of the package page.+    candWarnings   :: ![String],+    -- | Whether to allow non-maintainers to view the page or not.+    candPublic :: !Bool+} deriving (Show, Typeable, Eq)++candInfoId :: CandPkgInfo -> PackageIdentifier+candInfoId = pkgInfoId . candPkgInfo++deriveSafeCopy 0 'base ''CandPkgInfo++instance Package CandPkgInfo where packageId = candInfoId++instance Serialize CandPkgInfo where+  put pkgInfo = do+    Serialize.put (candPkgInfo pkgInfo)+    Serialize.put (candWarnings pkgInfo)+    Serialize.put (candPublic pkgInfo)++  get = do+    pkgInfo <- Serialize.get+    warning <- Serialize.get+    public  <- Serialize.get+    return CandPkgInfo {+        candPkgInfo = pkgInfo,+        candWarnings = warning,+        candPublic = public+    }++instance MemSize CandPkgInfo where+    memSize (CandPkgInfo a b c) = memSize3 a b c
+ Distribution/Server/Features/PackageContents.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-}+module Distribution.Server.Features.PackageContents (+    PackageContentsFeature(..),+    PackageContentsResource(..),+    initPackageContentsFeature+  ) where++import Distribution.Server.Framework+import qualified Distribution.Server.Framework.BlobStorage as BlobStorage++import Distribution.Server.Features.Core+import Distribution.Server.Features.TarIndexCache++import Distribution.Server.Packages.Types+import Distribution.Server.Packages.ChangeLog+import Distribution.Server.Util.ServeTarball (serveTarEntry, serveTarball)+import qualified Data.TarIndex as TarIndex++import Distribution.Text+import Distribution.Package++import Control.Monad.Error (ErrorT(..))++data PackageContentsFeature = PackageContentsFeature {+    packageFeatureInterface :: HackageFeature,+    packageContentsResource :: PackageContentsResource,++    -- Functionality exported to other features+    packageTarball   :: PkgInfo -> IO (Either String (FilePath, ETag, TarIndex.TarIndex)),+    packageChangeLog :: PkgInfo -> IO (Either String (FilePath, ETag, TarIndex.TarEntryOffset, FilePath))+}++instance IsHackageFeature PackageContentsFeature where+    getFeatureInterface = packageFeatureInterface++data PackageContentsResource = PackageContentsResource {+    packageContents             :: Resource,+    packageContentsChangeLog    :: Resource,+    packageContentsChangeLogUri :: PackageId -> String+}++initPackageContentsFeature :: ServerEnv+                           -> CoreFeature+                           -> TarIndexCacheFeature+                           -> IO PackageContentsFeature+initPackageContentsFeature env@ServerEnv{serverVerbosity = verbosity}+                           core+                           tarIndexCache = do+    loginfo verbosity "Initialising package-contents feature, start"++    let feature = packageContentsFeature env core tarIndexCache++    loginfo verbosity "Initialising package-contents feature, end"+    return feature++packageContentsFeature :: ServerEnv+                       -> CoreFeature+                       -> TarIndexCacheFeature+                       -> PackageContentsFeature++packageContentsFeature ServerEnv{serverBlobStore = store}+                       CoreFeature{ coreResource = CoreResource{+                                      packageInPath+                                    , lookupPackageId+                                    }+                                  }+                       TarIndexCacheFeature{cachedPackageTarIndex}+  = PackageContentsFeature{..}+  where+    packageFeatureInterface = (emptyHackageFeature "package-contents") {+        featureResources =+          map ($ packageContentsResource) [+              packageContents+            , packageContentsChangeLog+            ]+      , featureState = []+      , featureDesc = "The PackageContents feature shows the contents of packages and caches their TarIndexes"+      }++    packageContentsResource = PackageContentsResource {+          packageContents = (resourceAt "/package/:package/src/..") {+              resourceGet = [("", serveContents)]+            }+        , packageContentsChangeLog = (resourceAt "/package/:package/changelog") {+              resourceGet = [("changelog", serveChangeLog)]+            }+        , packageContentsChangeLogUri = \pkgid ->+            renderResource (packageContentsChangeLog packageContentsResource) [display pkgid, display (packageName pkgid)]+        }++{-------------------------------------------------------------------------------+  TODO: everything below is duplicated in PackageCandidates.+-------------------------------------------------------------------------------}++    -- result: changelog or not-found error+    serveChangeLog :: DynamicPath -> ServerPartE Response+    serveChangeLog dpath = do+      pkg        <- packageInPath dpath >>= lookupPackageId+      mChangeLog <- liftIO $ packageChangeLog pkg+      case mChangeLog of+        Left err ->+          errNotFound "Changelog not found" [MText err]+        Right (fp, etag, offset, name) ->+          liftIO $ serveTarEntry fp offset name etag++    -- return: not-found error or tarball+    serveContents :: DynamicPath -> ServerPartE Response+    serveContents dpath = do+      pkg      <- packageInPath dpath >>= lookupPackageId+      mTarball <- liftIO $ packageTarball pkg+      case mTarball of+        Left err ->+          errNotFound "Could not serve package contents" [MText err]+        Right (fp, etag, index) ->+          serveTarball ["index.html"] (display (packageId pkg)) fp index etag++    packageTarball :: PkgInfo -> IO (Either String (FilePath, ETag, TarIndex.TarIndex))+    packageTarball PkgInfo{pkgTarball = (pkgTarball, _) : _} = do+      let blobid = pkgTarballNoGz pkgTarball+          fp     = BlobStorage.filepath store blobid+          etag   = blobETag blobid+      index <- cachedPackageTarIndex pkgTarball+      return $ Right (fp, etag, index)+    packageTarball _ =+      return $ Left "No tarball found"++    packageChangeLog :: PkgInfo -> IO (Either String (FilePath, ETag, TarIndex.TarEntryOffset, FilePath))+    packageChangeLog pkgInfo = runErrorT $ do+      (fp, etag, index) <- ErrorT $ packageTarball pkgInfo+      (offset, fname)   <- ErrorT $ return (findChangeLog pkgInfo index)+      return (fp, etag, offset, fname)
+ Distribution/Server/Features/PreferredVersions.hs view
@@ -0,0 +1,368 @@+{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, PatternGuards, OverloadedStrings #-}+module Distribution.Server.Features.PreferredVersions (+    VersionsFeature(..),+    VersionsResource(..),+    initVersionsFeature,++    PreferredInfo(..),+    VersionStatus(..),+    classifyVersions,++    PreferredRender(..),+  ) where++import Distribution.Server.Framework++import Distribution.Server.Features.PreferredVersions.State+import Distribution.Server.Features.PreferredVersions.Backup++import Distribution.Server.Features.Core+import Distribution.Server.Features.Upload+import Distribution.Server.Features.Tags++import qualified Distribution.Server.Packages.PackageIndex as PackageIndex+import Distribution.Server.Packages.Types++import Distribution.Package+import Distribution.Version+import Distribution.Text++import Data.Either   (rights)+import Data.Function (fix)+import Data.List (intercalate, find)+import Data.Maybe (isJust, fromMaybe, catMaybes)+import Data.Time.Clock (getCurrentTime)+import Control.Arrow (second)+import Control.Applicative (optional)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.ByteString.Lazy.Char8 as BS (pack) -- Only used for ASCII data+import Data.Aeson (Value(..))+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text           as Text+import qualified Data.Vector         as Vector++data VersionsFeature = VersionsFeature {+    versionsFeatureInterface :: HackageFeature,++    queryGetPreferredInfo :: MonadIO m => PackageName -> m PreferredInfo,+    queryGetDeprecatedFor :: MonadIO m => PackageName -> m (Maybe [PackageName]),++    versionsResource :: VersionsResource,+    preferredHook  :: Hook (PackageName, PreferredInfo) (),+    deprecatedHook :: Hook (PackageName, Maybe [PackageName]) (),+    putDeprecated :: PackageName -> ServerPartE Bool,+    putPreferred  :: PackageName -> ServerPartE (),+    updateDeprecatedTags :: IO (),++    doPreferredRender     :: PackageName -> ServerPartE PreferredRender,+    doDeprecatedRender    :: PackageName -> ServerPartE (Maybe [PackageName]),+    doPreferredsRender    :: MonadIO m => m [(PackageName, PreferredRender)],+    doDeprecatedsRender   :: MonadIO m => m [(PackageName, [PackageName])],+    makePreferredVersions :: MonadIO m => m String,+    withPackagePreferred     :: forall a. PackageId -> (PkgInfo -> [PkgInfo] -> ServerPartE a) -> ServerPartE a,+    withPackagePreferredPath :: forall a. DynamicPath -> (PkgInfo -> [PkgInfo] -> ServerPartE a) -> ServerPartE a+}++instance IsHackageFeature VersionsFeature where+    getFeatureInterface = versionsFeatureInterface+++data VersionsResource = VersionsResource {+    preferredResource :: Resource,+    preferredText :: Resource,+    preferredPackageResource :: Resource,+    deprecatedResource :: Resource,+    deprecatedPackageResource :: Resource,++    preferredUri :: String -> String,+    preferredPackageUri :: String -> PackageName -> String,+    deprecatedUri :: String -> String,+    deprecatedPackageUri :: String -> PackageName -> String+}++data PreferredRender = PreferredRender {+    rendSumRange :: String,+    rendRanges   :: [String],+    rendVersions :: [Version]+} deriving (Show, Eq)+++initVersionsFeature :: ServerEnv -> CoreFeature -> UploadFeature -> TagsFeature -> IO VersionsFeature+initVersionsFeature ServerEnv{serverStateDir, serverVerbosity = verbosity}+                    core upload tags = do+    loginfo verbosity "Initialising versions feature, start"+    preferredState <- preferredStateComponent serverStateDir+    preferredHook  <- newHook+    deprecatedHook <- newHook+    let feature = versionsFeature core upload tags+                             preferredState preferredHook deprecatedHook+    loginfo verbosity "Initialising versions feature, end"+    return feature++preferredStateComponent :: FilePath -> IO (StateComponent AcidState PreferredVersions)+preferredStateComponent stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> "PreferredVersions") initialPreferredVersions+  return StateComponent {+      stateDesc    = "Preferred package versions"+    , stateHandle  = st+    , getState     = query st GetPreferredVersions+    , putState     = update st . ReplacePreferredVersions+    , resetState   = preferredStateComponent+    , backupState  = backupPreferredVersions+    , restoreState = restorePreferredVersions+    }++versionsFeature :: CoreFeature+                -> UploadFeature+                -> TagsFeature+                -> StateComponent AcidState PreferredVersions+                -> Hook (PackageName, PreferredInfo) ()+                -> Hook (PackageName, Maybe [PackageName]) ()+                -> VersionsFeature++versionsFeature CoreFeature{ coreResource=CoreResource{ packageInPath+                                                      , guardValidPackageName+                                                      , lookupPackageName+                                                      }+                           , queryGetPackageIndex+                           , updateArchiveIndexEntry+                           }+                UploadFeature{..}+                TagsFeature{..}+                preferredState+                preferredHook+                deprecatedHook+  = VersionsFeature{..}+  where+    versionsFeatureInterface = (emptyHackageFeature "versions") {+        featureResources =+          map ($versionsResource) [+              preferredResource+            , preferredPackageResource+            , deprecatedResource+            , deprecatedPackageResource+            , preferredText+            ]+        --FIXME: don't we need to set the preferred-versions on init?+      , featurePostInit = updateDeprecatedTags+      , featureState    = [abstractAcidStateComponent preferredState]+      }++    queryGetPreferredInfo :: MonadIO m => PackageName -> m PreferredInfo+    queryGetPreferredInfo name = queryState preferredState (GetPreferredInfo name)++    queryGetDeprecatedFor :: MonadIO m => PackageName -> m (Maybe [PackageName])+    queryGetDeprecatedFor name = queryState preferredState (GetDeprecatedFor name)++    updateDeprecatedTags = do+      pkgs <- fmap (Map.keys . deprecatedMap) $ queryState preferredState GetPreferredVersions+      setCalculatedTag (Tag "deprecated") (Set.fromDistinctAscList pkgs)++    updatePackageDeprecation :: MonadIO m => PackageName -> Maybe [PackageName] -> m ()+    updatePackageDeprecation pkgname deprs = liftIO $ do+      updateState preferredState $ SetDeprecatedFor pkgname deprs+      runHook_ deprecatedHook (pkgname, deprs)+      updateDeprecatedTags++    versionsResource = fix $ \r -> VersionsResource+      { preferredResource        = resourceAt "/packages/preferred.:format"+      , preferredPackageResource = resourceAt "/package/:package/preferred.:format"+      , preferredText = (resourceAt "/packages/preferred-versions") {+            resourceGet = [("txt", \_ -> textPreferred)]+          }+      , deprecatedResource = (resourceAt "/packages/deprecated.:format") {+            resourceGet = [("json", handlePackagesDeprecatedGet)]+          }+      , deprecatedPackageResource = (resourceAt "/package/:package/deprecated.:format") {+            resourceGet = [("json", handlePackageDeprecatedGet) ],+            resourcePut = [("json", handlePackageDeprecatedPut) ]+          }+      , preferredUri = \format ->+          renderResource (preferredResource r) [format]+      , preferredPackageUri = \format pkgid ->+          renderResource (preferredPackageResource r) [display pkgid, format]+      , deprecatedUri = \format ->+          renderResource (deprecatedResource r) [format]+      , deprecatedPackageUri = \format pkgid ->+          renderResource (deprecatedPackageResource r) [display pkgid, format]+      }++    textPreferred = fmap toResponse makePreferredVersions++    handlePackagesDeprecatedGet _ = do+      deprPkgs <- deprecatedMap <$> queryState preferredState GetPreferredVersions+      return $ toResponse $ array+          [ object+              [ ("deprecated-package", string $ display deprPkg)+              , ("in-favour-of", array [ string $ display pkg+                                       | pkg <- replacementPkgs ])+              ]+          | (deprPkg, replacementPkgs) <- Map.toList deprPkgs ]++    handlePackageDeprecatedGet dpath = do+      pkgname <- packageInPath dpath+      guardValidPackageName pkgname+      mdep <- queryState preferredState (GetDeprecatedFor pkgname)+      return $ toResponse $+        object+            [ ("is-deprecated", Bool (isJust mdep))+            , ("in-favour-of", array [ string $ display pkg+                                     | pkg <- fromMaybe [] mdep ])+            ]++    handlePackageDeprecatedPut dpath = do+      pkgname <- packageInPath dpath+      guardValidPackageName pkgname+      guardAuthorisedAsMaintainerOrTrustee pkgname+      jv <- expectAesonContent+      case jv of+        Object o+          | fields <- HashMap.toList o+          , Just (Bool deprecated) <- lookup "is-deprecated" fields+          , Just (Array strs)      <- lookup "in-favour-of"  fields+          , let asPackage (String s) = simpleParse (Text.unpack s)+                asPackage _          = Nothing+                mpkgs = map asPackage (Vector.toList strs)+          , all isJust mpkgs+          -> do let deprecatedInfo | deprecated = Just (catMaybes mpkgs)+                                   | otherwise  = Nothing+                updatePackageDeprecation pkgname deprecatedInfo+                ok $ toResponse ()+        _ -> errBadRequest "bad json format or content" []++    ---------------------------+    -- This is a function used by the HTML feature to select the version to display.+    -- It could be enhanced by displaying a search page in the case of failure,+    -- which is outside of the scope of this feature.+    withPackagePreferred :: PackageId -> (PkgInfo -> [PkgInfo] -> ServerPartE a) -> ServerPartE a+    withPackagePreferred pkgid func = do+      pkgIndex <- queryGetPackageIndex+      case PackageIndex.lookupPackageName pkgIndex (packageName pkgid) of+            []   ->  packageError [MText "No such package in package index"]+            pkgs  | pkgVersion pkgid == Version [] [] -> queryState preferredState (GetPreferredInfo $ packageName pkgid) >>= \info -> do+                let rangeToCheck = sumRange info+                case maybe id (\r -> filter (flip withinRange r . packageVersion)) rangeToCheck pkgs of+                    -- no preferred version available, choose latest from list ordered by version+                    []    -> func (last pkgs) pkgs+                    -- return latest preferred version+                    pkgs' -> func (last pkgs') pkgs+            pkgs -> case find ((== packageVersion pkgid) . packageVersion) pkgs of+                Nothing  -> packageError [MText $ "No such package version for " ++ display (packageName pkgid)]+                Just pkg -> func pkg pkgs+      where packageError = errNotFound "Package not found"++    withPackagePreferredPath :: DynamicPath -> (PkgInfo -> [PkgInfo] -> ServerPartE a) -> ServerPartE a+    withPackagePreferredPath dpath func = do+      pkgid <- packageInPath dpath+      withPackagePreferred pkgid func++    putPreferred :: PackageName -> ServerPartE ()+    putPreferred pkgname = do+      pkgs <- lookupPackageName pkgname+      guardAuthorisedAsMaintainerOrTrustee pkgname+      pref <- optional $ fmap lines $ look "preferred"+      depr <- optional $ fmap (rights . map snd . filter ((=="deprecated") . fst)) $ lookPairs+      case sequence . map simpleParse =<< pref of+          Just prefs -> case sequence . map simpleParse =<< depr of+              Just deprs -> case all (`elem` map packageVersion pkgs) deprs of+                  True  -> do+                      void $ updateState preferredState $ SetPreferredRanges pkgname prefs+                      void $ updateState preferredState $ SetDeprecatedVersions pkgname deprs+                      newInfo <- queryState preferredState $ GetPreferredInfo pkgname+                      prefVersions <- makePreferredVersions+                      now <- liftIO getCurrentTime+                      updateArchiveIndexEntry "preferred-versions" (BS.pack prefVersions, now)+                      runHook_ preferredHook (pkgname, newInfo)+                      return ()+                  False -> preferredError "Not all of the selected versions are in the main index."+              Nothing -> preferredError "Version could not be parsed."+          Nothing -> preferredError "Expected format of the preferred ranges field is one version range per line, e.g. '<2.3 || 3.*' (see Cabal documentation for the syntax)."+      where+        preferredError = errBadRequest "Preferred ranges failed" . return . MText++    putDeprecated :: PackageName -> ServerPartE Bool+    putDeprecated pkgname = do+      guardValidPackageName pkgname+      guardAuthorisedAsMaintainerOrTrustee pkgname+      index  <- queryGetPackageIndex+      isDepr <- optional $ look "deprecated"+      case isDepr of+          Just {} -> do+              depr <- optional $ fmap words $ look "by"+              case sequence . map simpleParse =<< depr of+                  Just deprs -> case filter (null . PackageIndex.lookupPackageName index) deprs of+                      [] -> case any (== pkgname) deprs of+                              True -> deprecatedError $ "You can not deprecate a package in favor of itself!"+                              _ -> do+                                doUpdates (Just deprs)+                                return True+                      pkgs -> deprecatedError $ "Some superseding packages aren't in the main index: " ++ intercalate ", " (map display pkgs)+                  Nothing -> deprecatedError "Expected format of the 'superseded by' field is a list of package names separated by spaces."+          Nothing -> do+              doUpdates Nothing+              return False+      where+        deprecatedError = errBadRequest "Deprecation failed" . return . MText+        doUpdates deprs = do+            void $ updateState preferredState $ SetDeprecatedFor pkgname deprs+            runHook_ deprecatedHook (pkgname, deprs)+            liftIO $ updateDeprecatedTags++    renderPrefInfo :: PreferredInfo -> PreferredRender+    renderPrefInfo pref = PreferredRender {+        rendSumRange = maybe "-any" display $ sumRange pref,+        rendRanges = map display $ preferredRanges pref,+        rendVersions = deprecatedVersions pref+    }++    doPreferredRender :: PackageName -> ServerPartE PreferredRender+    doPreferredRender pkgname = do+      guardValidPackageName pkgname+      pref <- queryState preferredState $ GetPreferredInfo pkgname+      return $ renderPrefInfo pref++    doDeprecatedRender :: PackageName -> ServerPartE (Maybe [PackageName])+    doDeprecatedRender pkgname = do+      guardValidPackageName pkgname+      queryState preferredState $ GetDeprecatedFor pkgname++    doPreferredsRender :: MonadIO m => m [(PackageName, PreferredRender)]+    doPreferredsRender = queryState preferredState GetPreferredVersions >>=+        return . map (second renderPrefInfo) . Map.toList . preferredMap++    doDeprecatedsRender :: MonadIO m => m [(PackageName, [PackageName])]+    doDeprecatedsRender = queryState preferredState GetPreferredVersions >>=+        return . Map.toList . deprecatedMap++    makePreferredVersions :: MonadIO m => m String+    makePreferredVersions = queryState preferredState GetPreferredVersions >>= \(PreferredVersions prefs _) -> do+        return . unlines . (topText++) . map (display . uncurry Dependency) . Map.toList $ Map.mapMaybe sumRange prefs+    -- note: setting noVersion is kind of useless..+    -- $ unionWith const (Map.mapMaybe sumRange deprs) (Map.map (const noVersion) prefs)+      where+        -- hard coded..+        topText =+          [ "-- A global set of preferred versions."+          , "--"+          , "-- This is to indicate a current recommended version, to allow stable and"+          , "-- experimental versions to co-exist on hackage and to help transitions"+          , "-- between major API versions."+          , "--"+          , "-- Tools like cabal-install take these preferences into account when"+          , "-- constructing install plans."+          , "--"+          ]++{------------------------------------------------------------------------------+  Some aeson auxiliary functions+------------------------------------------------------------------------------}++array :: [Value] -> Value+array = Array . Vector.fromList++object :: [(Text.Text, Value)] -> Value+object = Object . HashMap.fromList++string :: String -> Value+string = String . Text.pack
+ Distribution/Server/Features/PreferredVersions/Backup.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE RecordWildCards, ViewPatterns #-}+module Distribution.Server.Features.PreferredVersions.Backup+  ( restorePreferredVersions+  , backupPreferredVersions+  ) where++import Distribution.Server.Framework.BackupRestore+import Distribution.Server.Framework.BackupDump+import Distribution.Server.Features.PreferredVersions.State+import Data.Version (Version(..))+import Distribution.Text (Text, display, simpleParse)+import Distribution.Package (PackageName)+import Distribution.Version (VersionRange)+import qualified Data.Map as Map+import Control.Applicative ((<$>))+import Text.CSV (CSV, Record)+import Control.Monad (guard)++{-------------------------------------------------------------------------------+  Restore backup+-------------------------------------------------------------------------------}++restorePreferredVersions :: RestoreBackup PreferredVersions+restorePreferredVersions = updatePreferredVersions emptyPreferredVersions++updatePreferredVersions :: PreferredVersions -> RestoreBackup PreferredVersions+updatePreferredVersions st = RestoreBackup {+    restoreEntry    = \entry -> updatePreferredVersions <$> importEntry st entry+  , restoreFinalize = return st+  }++importEntry :: PreferredVersions -> BackupEntry -> Restore PreferredVersions+importEntry st (BackupByteString ["package", pkgstr, "preferred.csv"] bs) = do+  pkg <- parsePackageName pkgstr+  csv <- importCSV "preferred.csv" bs+  importPreferredCSV st pkg csv+importEntry st (BackupByteString ["package", pkgstr, "deprecated.csv"] bs) = do+  pkg <- parsePackageName pkgstr+  csv <- importCSV "deprecated.csv" bs+  importDeprecatedCSV st pkg csv+importEntry st _ = return st++importPreferredCSV :: PreferredVersions+                   -> PackageName+                   -> CSV+                   -> Restore PreferredVersions+importPreferredCSV st pkg ( _version+                          : (match "preferredRanges"    -> Just ranges)+                          : (match "deprecatedVersions" -> Just deprecated)+                          : (optionalSumRange           -> Just sumRange)+                          ) = do+  let info = PreferredInfo { preferredRanges    = ranges+                           , deprecatedVersions = deprecated+                           , sumRange           = sumRange+                           }+  return st { preferredMap = Map.insert pkg info (preferredMap st) }+importPreferredCSV _ _ _ = fail "Failed to read preferred.csv"++importDeprecatedCSV :: PreferredVersions+                    -> PackageName+                    -> CSV+                    -> Restore PreferredVersions+importDeprecatedCSV st pkg [ _version+                           , match "deprecatedFor" -> Just deprecatedFor+                           ] =+  return st { deprecatedMap = Map.insert pkg deprecatedFor (deprecatedMap st) }+importDeprecatedCSV _ _ _ = fail "Failed to read deprecated.csv"++match :: Text a => String -> Record -> Maybe [a]+match header (header' : xs) = guard (header == header') >> mapM simpleParse xs+match _ _ = Nothing++-- Outer maybe is Nothing on a parsing error; the inner maybe is because+-- the version range is optional+optionalSumRange :: CSV -> Maybe (Maybe VersionRange)+optionalSumRange [] = Just Nothing+optionalSumRange [["sumRange", simpleParse -> Just range]] = Just (Just range)+optionalSumRange _ = Nothing++parsePackageName :: String -> Restore PackageName+parsePackageName (simpleParse -> Just name) = return name+parsePackageName str = fail $ "Could not parse package name '" ++ str ++ "'"++{-------------------------------------------------------------------------------+  Create backup+-------------------------------------------------------------------------------}++backupPreferredVersions :: PreferredVersions -> [BackupEntry]+backupPreferredVersions (PreferredVersions preferredMap deprecatedMap) =+     map backupPreferredInfo (Map.toList preferredMap)+  ++ map backupDeprecated (Map.toList deprecatedMap)++backupPreferredInfo :: (PackageName, PreferredInfo) -> BackupEntry+backupPreferredInfo (name, PreferredInfo {..}) =+    csvToBackup (pkgPath name "preferred.csv") $ [+        [display versionCSV]+      , "preferredRanges" : map display preferredRanges+      , "deprecatedVersions" : map display deprecatedVersions+      ] ++ case sumRange of+             Nothing           -> []+             Just versionRange -> [["sumRange", display versionRange]]+  where+    versionCSV = Version [0,1] ["unstable"]++backupDeprecated :: (PackageName, [PackageName]) -> BackupEntry+backupDeprecated (name, deprecatedFor) =+    csvToBackup (pkgPath name "deprecated.csv") [+        [display versionCSV]+      , "deprecatedFor" : map display deprecatedFor+      ]+  where+    versionCSV = Version [0,1] ["unstable"]++pkgPath :: PackageName -> String -> [String]+pkgPath pkgname file = ["package", display pkgname, file]+
+ Distribution/Server/Features/PreferredVersions/State.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-}++module Distribution.Server.Features.PreferredVersions.State where++import Distribution.Server.Framework.Instances ()+import Distribution.Server.Framework.MemSize++import Distribution.Package+import Distribution.Version++import Data.Acid  (Query, Update, makeAcidic)+import Data.Maybe (isJust, fromMaybe)+import Data.Typeable (Typeable)+import Control.Arrow (second)+import Control.Monad (ap)+import Control.Monad.State (put, modify)+import Control.Monad.Reader (ask, asks)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Set (Set)+import qualified Data.Set as Set++data PreferredVersions = PreferredVersions {+    preferredMap  :: Map PackageName PreferredInfo,+    deprecatedMap :: Map PackageName [PackageName]+} deriving (Typeable, Show, Eq)++emptyPreferredVersions :: PreferredVersions+emptyPreferredVersions = PreferredVersions Map.empty Map.empty++data PreferredInfo = PreferredInfo {+    preferredRanges :: [VersionRange],+    deprecatedVersions :: [Version],+    sumRange :: Maybe VersionRange+} deriving (Typeable, Show, Eq)++emptyPreferredInfo :: PreferredInfo+emptyPreferredInfo = PreferredInfo [] [] Nothing++consolidateRanges :: [VersionRange] -> [Version] -> Maybe VersionRange+consolidateRanges ranges depr =+    let range = simplifyVersionRange $ foldr intersectVersionRanges anyVersion (map notThisVersion depr ++ ranges)+    in if isAnyVersion range || isNoVersion range+        then Nothing+        else Just range++data VersionStatus = NormalVersion | DeprecatedVersion | UnpreferredVersion deriving (Show, Typeable, Eq, Ord, Enum)++getVersionStatus :: PreferredInfo -> Version -> VersionStatus+getVersionStatus info version = case version `elem` deprecatedVersions info of+    True  -> DeprecatedVersion+    False -> case maybe True (withinRange version) (sumRange info) of+        True  -> NormalVersion+        False -> UnpreferredVersion++classifyVersions :: PreferredInfo -> [Version] -> [(Version, VersionStatus)]+classifyVersions (PreferredInfo [] [] _) = map (flip (,) NormalVersion)+classifyVersions info = map ((,) `ap` getVersionStatus info)++partitionVersions :: PreferredInfo -> [Version] -> ([Version], [Version], [Version])+partitionVersions info versions = if (not . isJust $ sumRange info) then (versions, [], []) else go versions+  where go :: [Version] -> ([Version], [Version], [Version]) -- foldr-type approach+        go (v:vs) = let ~(norm, depr, unpref) = go vs in case getVersionStatus info v of+            NormalVersion -> (v:norm, depr, unpref)+            DeprecatedVersion -> (norm, v:depr, unpref)+            UnpreferredVersion -> (norm, depr, v:unpref)+        go [] = ([], [], [])+------------------------------------------+$(deriveSafeCopy 0 'base ''PreferredVersions)+$(deriveSafeCopy 0 'base ''PreferredInfo)+$(deriveSafeCopy 0 'base ''VersionStatus)++instance MemSize PreferredVersions where+    memSize (PreferredVersions a b) = memSize2 a b++instance MemSize PreferredInfo where+    memSize (PreferredInfo a b c) = memSize3 a b c++initialPreferredVersions :: PreferredVersions+initialPreferredVersions = emptyPreferredVersions++setPreferredRanges :: PackageName -> [VersionRange] -> Update PreferredVersions ()+setPreferredRanges name ranges = alterPreferredInfo name $ \p ->+    p { preferredRanges = ranges }++setDeprecatedVersions :: PackageName -> [Version] -> Update PreferredVersions ()+setDeprecatedVersions name versions = alterPreferredInfo name $ \p ->+    p { deprecatedVersions = versions }++alterPreferredInfo :: PackageName -> (PreferredInfo -> PreferredInfo) -> Update PreferredVersions ()+alterPreferredInfo name func = modify $ \p -> p { preferredMap = Map.alter (res . func . fromMaybe emptyPreferredInfo) name $ preferredMap p }+  where res (PreferredInfo [] [] _) = Nothing+        res (PreferredInfo ranges depr _) = Just (PreferredInfo ranges depr $ consolidateRanges ranges depr)++getPreferredInfo :: PackageName -> Query PreferredVersions PreferredInfo+getPreferredInfo name = asks $ Map.findWithDefault emptyPreferredInfo name . preferredMap++setDeprecatedFor :: PackageName -> Maybe [PackageName] -> Update PreferredVersions ()+setDeprecatedFor name forName = modify $ \p -> p { deprecatedMap = Map.alter (const forName) name $ deprecatedMap p }++getDeprecatedFor :: PackageName -> Query PreferredVersions (Maybe [PackageName])+getDeprecatedFor name = asks $ Map.lookup name . deprecatedMap++isDeprecated :: PackageName -> Query PreferredVersions Bool+isDeprecated name = asks $ Map.member name . deprecatedMap++getPreferredVersions :: Query PreferredVersions PreferredVersions+getPreferredVersions = ask++replacePreferredVersions :: PreferredVersions -> Update PreferredVersions ()+replacePreferredVersions = put++makeAcidic ''PreferredVersions ['setPreferredRanges+                               ,'setDeprecatedVersions+                               ,'getPreferredInfo+                               ,'setDeprecatedFor+                               ,'getDeprecatedFor+                               ,'isDeprecated+                               ,'getPreferredVersions+                               ,'replacePreferredVersions+                               ]++---------------+maybeBestVersion :: PreferredInfo -> [Version] -> Set Version -> Maybe (Version, Maybe VersionStatus)+maybeBestVersion info allVersions versions = if null allVersions || Set.null versions then Nothing else Just $ findBestVersion info allVersions versions++{-+findBestVersion attempts to find the best version to display out of a set+of versions. The quality of a given version is encoded in a pair (VersionStatus,+Bool). If the version is a NormalVersion, then the boolean indicates whether if+it the most recently uploaded preferred version (and all higher versions are+either deprecated or unpreferred). Otherwise, if it  is a DeprecatedVersion or+UnpreferredVersion, the boolean indicates that it is the maximum of all uploaded+versions.++The list of available versions is scanned from the back (most recent) to the+front (first one uploaded). If a 'better' version is found than the current+best version, it is replaced. If no better version can be found, the algorithm+finishes up. The exact ordering is defined as:++1. (NormalVersion, True) means the latest preferred version of the package is+available. This option may appear anywhere, although it is always seen before+(NormalVersion, False). In this case, the algorithm finishes up.++2. (UnpreferredVersion, True) means the latest available version of the package+is not preferred, but the latest preferred version is not available. If this+option appears anywhere, it will be the most recent version in the set,+excluding deprecated versions.++3. (NormalVersion, False) means neither the actual latest version nor the+preferred latest version are available, but there is some preferred version+that's available. It can only be scanned after (NormalVersion, True) and+(UnpreferredVersion, True), so the algorithm finishes up in this case.+4. (UnpreferredVersion, False) means no preferred versions are available, and+only an older version is available. It is still possible to see a NormalVersion+after this option, so the algorithm continues.++5. (DeprecatedVersion, True) and (DeprecatedVersion, False) mean only a+deprecated version is available. This is not so great.++This is a bit complex but I think it has the most intuitive result, and is+rather efficient in 99% of cases.++The version set and version list should both be non-empty; otherwise this+function is partial. Use maybeBestVersion for a safe check.++-}+findBestVersion :: PreferredInfo -> [Version] -> Set Version -> (Version, Maybe VersionStatus)+findBestVersion info allVersions versions =+    let topStatus = getVersionStatus info maxVersion+    in if maxAllVersion == maxVersion && topStatus == NormalVersion+        then (maxVersion, Just NormalVersion) -- most common case+        else second classifyOpt $ newSearch (reverse $ Set.toList versions) (maxVersion, (topStatus, True))+  where+    maxVersion = Set.findMax versions+    maxAllVersion = last allVersions++    newestPreferred = case filter ((==NormalVersion) . (infoMap Map.!)) $ allVersions of+        []    -> Nothing+        prefs -> Just $ last prefs++    infoMap = Map.fromDistinctAscList $ classifyVersions info allVersions++    newSearch (v:vs) _ = case infoMap Map.! v of+        NormalVersion | v == maxAllVersion -> (v, (NormalVersion, True))+        NormalVersion -> oldSearch vs (v, (NormalVersion, False))+        DeprecatedVersion -> newSearch vs (v, (DeprecatedVersion, True))+        UnpreferredVersion -> oldSearch vs (v, (UnpreferredVersion, True))+    newSearch [] opt = opt++    oldSearch (v:vs) opt = case infoMap Map.! v of+        NormalVersion -> replaceBetter opt (v, (NormalVersion, newestPreferred == Just v))+        other -> oldSearch vs $ replaceBetter opt (v, (other, False))+    oldSearch [] opt = opt++    replaceBetter keep@(_, old) replace@(_, new) = if optionPrefs new > optionPrefs old then replace else keep++    optionPrefs :: (VersionStatus, Bool) -> Int+    optionPrefs opt = case opt of+        (NormalVersion, True) -> 4+        (UnpreferredVersion, True) -> 3+        (NormalVersion, False) -> 2+        (UnpreferredVersion, False) -> 1+        _ -> 0++    classifyOpt opt = case opt of+        (NormalVersion, True) -> Just NormalVersion+        (UnpreferredVersion, True) -> Just UnpreferredVersion+        (DeprecatedVersion, _) -> Just DeprecatedVersion+        _ -> Nothing+
+ Distribution/Server/Features/RecentPackages.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE DoRec, RankNTypes, NamedFieldPuns, RecordWildCards #-}+module Distribution.Server.Features.RecentPackages (+    RecentPackagesFeature(..),+    RecentPackagesResource(..),+    initRecentPackagesFeature,+  ) where++import Distribution.Server.Framework++import Distribution.Server.Features.Core+import Distribution.Server.Features.Users+import Distribution.Server.Features.PackageContents (PackageContentsFeature(..))++import Distribution.Server.Packages.Types+import Distribution.Server.Packages.Render++import qualified Distribution.Server.Packages.PackageIndex as PackageIndex+import qualified Distribution.Server.Framework.ResponseContentTypes as Resource++import Data.Time.Clock (getCurrentTime)+import Data.List (sortBy)+import Data.Ord (comparing)+++-- the goal is to have the HTML modules import /this/ one, not the other way around+import qualified Distribution.Server.Pages.Recent as Pages++data RecentPackagesFeature = RecentPackagesFeature {+    recentPackagesFeatureInterface :: HackageFeature,+    recentPackagesResource :: RecentPackagesResource,++    -- necessary information for the representation of a package resource+    packageRender :: PkgInfo -> IO PackageRender+    -- other informational hooks: perhaps a simplified CondTree so a browser script can dynamically change the package page based on flags+}++instance IsHackageFeature RecentPackagesFeature where+    getFeatureInterface = recentPackagesFeatureInterface++data RecentPackagesResource = RecentPackagesResource {+    -- replace with log resource+    recentPackages :: Resource+}++initRecentPackagesFeature :: ServerEnv+                          -> UserFeature+                          -> CoreFeature+                          -> PackageContentsFeature+                          -> IO RecentPackagesFeature+initRecentPackagesFeature env@ServerEnv{serverCacheDelay, serverVerbosity = verbosity}+                          user+                          core@CoreFeature{packageChangeHook}+                          packageContents = do+    loginfo verbosity "Initialising recentPackages feature, start"++    -- recent caches. in lieu of an ActionLog+    -- TODO: perhaps a hook, recentUpdated :: HookList ([PkgInfo] -> IO ())+    rec let (feature, updateRecentCache) =+              recentPackagesFeature env user core packageContents+                                    cacheRecent++        cacheRecent <- newAsyncCacheNF updateRecentCache+                         defaultAsyncCachePolicy {+                           asyncCacheName = "recent uploads (html,rss)",+                           asyncCacheUpdateDelay  = serverCacheDelay,+                           asyncCacheSyncInit     = False,+                           asyncCacheLogVerbosity = verbosity+                         }++    registerHookJust packageChangeHook isPackageChangeAny $ \_ ->+      prodAsyncCache cacheRecent++    loginfo verbosity "Initialising recentPackages feature, end"+    return feature+++recentPackagesFeature :: ServerEnv+                      -> UserFeature+                      -> CoreFeature+                      -> PackageContentsFeature+                      -> AsyncCache (Response, Response)+                      -> (RecentPackagesFeature, IO (Response, Response))++recentPackagesFeature env+                      UserFeature{..}+                      CoreFeature{..}+                      PackageContentsFeature{packageChangeLog}+                      cacheRecent+  = (RecentPackagesFeature{..}, updateRecentCache)+  where+    recentPackagesFeatureInterface = (emptyHackageFeature "recentPackages") {+        featureResources = map ($recentPackagesResource) [recentPackages]+      , featureState     = []+      , featureCaches    = [+            CacheComponent {+              cacheDesc       = "recents packages page (html, rss)",+              getCacheMemSize = memSize <$> readAsyncCache cacheRecent+            }+          ]+      , featurePostInit = syncAsyncCache cacheRecent+      }++    recentPackagesResource = RecentPackagesResource {+        recentPackages = (resourceAt "/recent.:format") {+            resourceGet = [+                ("html", const $ liftM fst $ readAsyncCache cacheRecent)+              , ("rss",  const $ liftM snd $ readAsyncCache cacheRecent)+              ]+          }+      }++    packageRender pkg = do+      users <- queryGetUserDb+      changeLog <- packageChangeLog pkg+      let showChangeLogLink = case changeLog of Right _ -> True ; _ -> False+      doPackageRender users pkg showChangeLogLink++    updateRecentCache = do+        -- TODO: move the html version to the HTML feature+        pkgIndex <- queryGetPackageIndex+        users <- queryGetUserDb+        now   <- getCurrentTime+        let recentChanges = reverse $ sortBy (comparing pkgUploadTime) (PackageIndex.allPackages pkgIndex)+            xmlRepresentation = toResponse $ Resource.XHtml $ Pages.recentPage users recentChanges+            rssRepresentation = toResponse $ Pages.recentFeed users (serverBaseURI env) now recentChanges+        return (xmlRepresentation, rssRepresentation)++{-+data SimpleCondTree = SimpleCondNode [Dependency] [(Condition ConfVar, SimpleCondTree, SimpleCondTree)]+                    | SimpleCondLeaf+    deriving (Show, Eq)++doMakeCondTree :: GenericPackageDescription -> [(String, SimpleCondTree)]+doMakeCondTree desc = map (\lib -> ("library", makeCondTree lib)) (maybeToList $ condLibrary desc)+                   ++ map (\(exec, tree) -> (exec, makeCondTree tree)) (condExecutables desc)+  where+    makeCondTree (CondNode _ deps comps) = case deps of+        [] -> SimpleCondLeaf+        _  -> SimpleCondNode deps $ map makeCondComponents comps+    makeCondComponents (cond, tree, mtree) = (cond, makeCondTree tree, maybe SimpleCondLeaf makeCondTree mtree)+-}++++
+ Distribution/Server/Features/Search.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, DoRec #-}+module Distribution.Server.Features.Search (+    SearchFeature(..),+    initSearchFeature,+  ) where++import Distribution.Server.Framework+import Distribution.Server.Framework.Templating++import Distribution.Server.Features.Core++import Distribution.Server.Features.Search.PkgSearch+import qualified Distribution.Server.Features.Search.SearchEngine as SearchEngine+import qualified Distribution.Server.Packages.PackageIndex as PackageIndex++import Distribution.Server.Packages.Types++import Distribution.Package+import Distribution.PackageDescription.Configuration (flattenPackageDescription)++import qualified Data.Text as T+++data SearchFeature = SearchFeature {+    searchFeatureInterface :: HackageFeature,++    searchPackagesResource :: Resource,++    searchPackages :: MonadIO m => [String] -> m [PackageName]+}++instance IsHackageFeature SearchFeature where+    getFeatureInterface = searchFeatureInterface+++initSearchFeature :: ServerEnv -> CoreFeature -> IO SearchFeature+initSearchFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode, serverVerbosity = verbosity}+                 core@CoreFeature{..} = do+    loginfo verbosity "Initialising search feature, start"++    templates <- loadTemplates serverTemplatesMode+                   [serverTemplatesDir, serverTemplatesDir </> "Search"]+                   [ "opensearch.xml"]++    searchEngineState <- newMemStateWHNF initialPkgSearchEngine++    let feature = searchFeature env core+                                searchEngineState templates++    loginfo verbosity "Initialising search feature, end"+    return feature+++searchFeature :: ServerEnv+              -> CoreFeature+              -> MemState PkgSearchEngine+              -> Templates+              -> SearchFeature++searchFeature ServerEnv{serverBaseURI} CoreFeature{..}+              searchEngineState templates+  = SearchFeature{..}+  where+    searchFeatureInterface = (emptyHackageFeature "search") {+        featureResources =+          [ searchOpenSearchResource+          , searchPackagesResource+--          , searchSuggestResource+          ]+      , featureState  = []+      , featureCaches = [+            CacheComponent {+              cacheDesc       = "package search engine",+              getCacheMemSize = memSize <$> readMemState searchEngineState+            }+          ]+      , featurePostInit = postInit+      }++    searchOpenSearchResource = (resourceAt "/packages/opensearch.xml") {+        resourceDesc = [(GET, "An OpenSearch description of the package search")],+        resourceGet  = [("xml", handlerGetOpenSearch)]+      }+    -- /packages/search?terms=happstack+    searchPackagesResource = (resourceAt "/packages/search.:format") {+        resourceDesc = [(GET, "Search for packages matching query terms")]+--        resourceGet  = [("json", handlerGetOpenSearch)]+      }++--  searchSuggestResource = (resourceAt "/packages/suggest.:format") {+--      resourceDesc = [(GET, "An OpenSearch description of the package search")]+--      resourceGet = [("json", \_ -> suggestJson)]+--    }++    getSearchDoc = flattenPackageDescription . pkgDesc++    postInit = do+      pkgindex <- queryGetPackageIndex+      let pkgs = map (getSearchDoc . last)+               . PackageIndex.allPackagesByName $ pkgindex+          se = SearchEngine.insertDocs pkgs initialPkgSearchEngine+      writeMemState searchEngineState se++      registerHookJust packageChangeHook isPackageChangeAny $ \(pkgid, _) ->+        updatePackage (packageName pkgid)++    updatePackage :: PackageName -> IO ()+    updatePackage pkgname = do+      index <- queryGetPackageIndex+      let pkgs = PackageIndex.lookupPackageName index pkgname+      case reverse pkgs of+         []      -> modifyMemState searchEngineState+                      (SearchEngine.deleteDoc pkgname)+         (pkg:_) -> modifyMemState searchEngineState+                      (SearchEngine.insertDoc (getSearchDoc pkg))++    -- Returns list of query results+    searchPackages :: MonadIO m => [String] -> m [PackageName]+    searchPackages terms = do+        se <- readMemState searchEngineState+        let results = SearchEngine.query se (map T.pack terms)+        return results++    handlerGetOpenSearch :: DynamicPath -> ServerPartE Response+    handlerGetOpenSearch _ = do+      template <- getTemplate templates "opensearch.xml"+      let xmlstr = renderTemplate (template ["serverhost" $= show serverBaseURI])+      return $ toResponse (OpenSearchXml xmlstr)++{-+    suggestJson :: ServerPartE Response+    suggestJson =+    --TODO: open search supports a suggest / autocomplete system+-}
+ Distribution/Server/Features/StaticFiles.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE NamedFieldPuns, RecordWildCards, BangPatterns #-}+module Distribution.Server.Features.StaticFiles (+    initStaticFilesFeature+  ) where++import Distribution.Server.Framework+import Distribution.Server.Framework.Templating++import Text.XHtml.Strict (Html, toHtml, anchor, (<<), (!), href, paragraph)+import qualified Text.XHtml.Strict as XHtml++import Data.List hiding (find)+import System.FilePath+import System.Directory (getDirectoryContents)++-- | A feature to provide the top level files on the site (using templates)+-- and also serve the genuinely static files.+--+initStaticFilesFeature :: ServerEnv+                       -> IO HackageFeature+initStaticFilesFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode} = do++  -- Page templates+  templates <- loadTemplates serverTemplatesMode+                 [serverTemplatesDir]+                 ["index.html", "hackageErrorPage.txt", "hackageErrorPage.html"]++  staticFiles <- find (isSuffixOf ".html.st") serverTemplatesDir++  let feature = staticFilesFeature env templates staticFiles++  return feature++-- Simpler version of Syhstem.FilePath.Find (which requires unix-compat)+find :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+find p dirPath = do+  contents <- getDirectoryContents dirPath+  return (filter p contents)++staticFilesFeature :: ServerEnv -> Templates -> [FilePath] -> HackageFeature+staticFilesFeature ServerEnv{serverStaticDir} templates staticFiles =+  (emptyHackageFeature "static-files") {+    featureResources =+      [ (resourceAt "/") {+            resourceGet  = [("", \_ -> serveStaticIndexTemplate)]+          }+-- TODO: we currently cannot use /.. here because then we cannot use it for+-- the legacy redirects feature.+--      , (resourceAt "/..") {+--            resourceGet  = [("", \_ -> serveStaticTemplates)]+--          }+      , (resourceAt "/static/..") {+            resourceGet  = [("", \_ -> serveStaticDirFiles)]+          }+      ] +++      [ (resourceAt ("/" ++ filename)) {+            resourceGet  = [("", \_ -> serveStaticToplevelFile mimetype filename)]+          }+      | (filename, mimetype) <- toplevelFiles ]+        +++      [ (resourceAt ("/" ++ dropExtension name)) {+            resourceGet  = [("", \_ -> serveStaticTemplate name)]+          }+      | name <- toplevelTemplates ]+  , featureState = []+  , featureErrHandlers = [("txt",  textErrorPage)+                         ,("html", htmlErrorPage)]+  }++  where+    serveStaticDirFiles :: ServerPartE Response+    serveStaticDirFiles =+      serveDirectory DisableBrowsing [] serverStaticDir++    serveStaticToplevelFile :: String -> FilePath -> ServerPartE Response+    serveStaticToplevelFile mimetype filename =+      serveFile (asContentType mimetype) (serverStaticDir </> filename)++    serveStaticTemplate :: String -> ServerPartE Response+    serveStaticTemplate = serveTemplate++--    serveStaticTemplates :: ServerPartE Response+--    serveStaticTemplates =+--      path $ \name -> do+--        nullDir+--        noTrailingSlash --TODO: redirect to non-slash version+--        serveTemplate (name ++ ".html")++    serveStaticIndexTemplate :: ServerPartE Response+    serveStaticIndexTemplate =+      serveTemplate "index.html"++    serveTemplate :: String -> ServerPartE Response+    serveTemplate name = do+      mtemplate <- tryGetTemplate templates name+      case mtemplate of+        Nothing       -> mzero+        Just template -> ok $ toResponse $ template []++    textErrorPage (ErrorResponse errCode hdrs errTitle message) = do+        template <- getTemplate templates "hackageErrorPage.txt"+        let formattedMessage = messageToText message+            response = toResponse $ template+              [ "errorTitle"   $= errTitle+              , "errorMessage" $= formattedMessage+              ]+        return $ response {+          rsCode    = errCode,+          rsHeaders = addHeaders (rsHeaders response) hdrs+        }++    htmlErrorPage :: ErrorResponse -> ServerPartE Response+    htmlErrorPage (ErrorResponse errCode hdrs errTitle message) = do+        template <- getTemplate templates "hackageErrorPage.html"+        let formattedMessage = paragraph << errorToHtml message+            response = toResponse $ template+              [ "errorTitle"   $= errTitle+              , "errorMessage" $= XHtml.showHtmlFragment formattedMessage+              ]+        return $ response {+          rsCode    = errCode,+          rsHeaders = addHeaders (rsHeaders response) hdrs+        }++    toplevelFiles     = [("favicon.ico", "image/x-icon")]+    toplevelTemplates = map dropExtension staticFiles++addHeaders :: Headers -> [(String, String)] -> Headers+addHeaders hdrs hdrs' = foldl' (\h (k,v) -> addHeader k v h) hdrs (reverse hdrs')++errorToHtml :: [MessageSpan] -> [Html]+errorToHtml []               = []+errorToHtml (MText x    :xs) = toHtml x: errorToHtml xs+errorToHtml (MLink x url:xs) = (anchor ! [href url] << x): errorToHtml xs
+ Distribution/Server/Features/Tags.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE BangPatterns, RankNTypes, NamedFieldPuns, RecordWildCards #-}++module Distribution.Server.Features.Tags (+    TagsFeature(..),+    TagsResource(..),+    initTagsFeature,++    Tag(..),+    constructTagIndex+  ) where++import Control.Applicative (optional)++import Distribution.Server.Framework+import Distribution.Server.Framework.BackupDump++import Distribution.Server.Features.Tags.State+import Distribution.Server.Features.Tags.Backup++import Distribution.Server.Features.Core+import Distribution.Server.Features.Upload++import qualified Distribution.Server.Packages.PackageIndex as PackageIndex+import Distribution.Server.Packages.PackageIndex (PackageIndex)+import Distribution.Server.Packages.Types+import Distribution.Server.Packages.Render (categorySplit)++import Distribution.Text+import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Configuration+import Distribution.License++import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Function (fix)+import Data.List (foldl')+import Data.Char (toLower)+++data TagsFeature = TagsFeature {+    tagsFeatureInterface :: HackageFeature,++    tagsResource :: TagsResource,++    queryGetTagList     :: forall m. MonadIO m => m [(Tag, Set PackageName)],+    queryTagsForPackage :: forall m. MonadIO m => PackageName -> m (Set Tag),++    -- All package names that were modified, and all tags that were modified+    -- In almost all cases, one of these will be a singleton. Happstack+    -- functions should be used to query the resultant state.+    tagsUpdated :: Hook (Set PackageName, Set Tag) (),+    -- Calculated tags are used so that other features can reserve a+    -- tag for their own use (a calculated, rather than freely+    -- assignable, tag). It is a subset of the main mapping.+    --+    -- This feature itself defines a few such tags: libary, executable,+    -- and license tags, as well as package categories on+    -- initial import.+    setCalculatedTag :: Tag -> Set PackageName -> IO (),++    withTagPath :: forall a. DynamicPath -> (Tag -> Set PackageName -> ServerPartE a) -> ServerPartE a,+    collectTags :: forall m. MonadIO m => Set PackageName -> m (Map PackageName (Set Tag)),+    putTags     :: PackageName -> ServerPartE ()++}++instance IsHackageFeature TagsFeature where+    getFeatureInterface = tagsFeatureInterface++data TagsResource = TagsResource {+    tagsListing :: Resource,+    tagListing :: Resource,+    packageTagsListing :: Resource,+    packageTagsEdit :: Resource,++    tagUri :: String -> Tag -> String,+    tagsUri :: String -> String,+    packageTagsUri :: String -> PackageName -> String+}++initTagsFeature :: ServerEnv -> CoreFeature -> UploadFeature -> IO TagsFeature+initTagsFeature ServerEnv{serverStateDir} core@CoreFeature{..} upload = do+    tagsState <- tagsStateComponent serverStateDir+    specials  <- newMemStateWHNF emptyPackageTags+    updateTag <- newHook++    let feature = tagsFeature core upload tagsState specials updateTag+    registerHookJust packageChangeHook isPackageChangeAny $ \(pkgid, mpkginfo) ->+      case mpkginfo of+        Nothing      -> return ()+        Just pkginfo -> do+          let pkgname = packageName pkgid+              tags = Set.fromList . constructImmutableTags . pkgDesc $ pkginfo+          updateState tagsState . SetPackageTags pkgname $ tags+          runHook_ tagsUpdated (pkgs, tags)++    return feature++tagsStateComponent :: FilePath -> IO (StateComponent AcidState PackageTags)+tagsStateComponent stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> "Tags") initialPackageTags+  return StateComponent {+      stateDesc    = "Package tags"+    , stateHandle  = st+    , getState     = query st GetPackageTags+    , putState     = update st . ReplacePackageTags+    , backupState  = \pkgTags -> [csvToBackup ["tags.csv"] $ tagsToCSV pkgTags]+    , restoreState = tagsBackup+    , resetState   = tagsStateComponent+    }++tagsFeature :: CoreFeature+            -> UploadFeature+            -> StateComponent AcidState PackageTags+            -> MemState PackageTags+            -> Hook (Set PackageName, Set Tag) ()+            -> TagsFeature++tagsFeature CoreFeature{ queryGetPackageIndex+                       , coreResource = CoreResource { guardValidPackageName }+                       }+            UploadFeature{ guardAuthorisedAsMaintainerOrTrustee }+            tagsState+            calculatedTags+            tagsUpdated+  = TagsFeature{..}+  where+    tagsResource = fix $ \r -> TagsResource+        { tagsListing = resourceAt "/packages/tags/.:format"+        , tagListing = resourceAt "/packages/tag/:tag.:format"+        , packageTagsListing = resourceAt "/package/:package/tags.:format"+        , packageTagsEdit    = resourceAt "/package/:package/tags/edit"+        , tagUri = \format tag -> renderResource (tagListing r) [display tag, format]+        , tagsUri = \format -> renderResource (tagsListing r) [format]+        , packageTagsUri = \format pkgname -> renderResource (packageTagsListing r) [display pkgname, format]+      -- for more fine-tuned tag manipulation, could also define:+      -- * DELETE /package/:package/tag/:tag (remove single tag)+      -- * POST /package/:package\/tags (add single tag)+      -- renaming tags and deleting them are also supported as happstack-state+      -- operations, but make sure this wouldn't circumvent calculated tags.+        }++    tagsFeatureInterface = (emptyHackageFeature "tags") {+        featureResources =+          map ($tagsResource) [+              tagsListing+            , tagListing+            , packageTagsListing+            ]+      , featurePostInit = initImmutableTags+      , featureState    = [abstractAcidStateComponent tagsState]+      , featureCaches   = [+            CacheComponent {+              cacheDesc       = "calculated tags",+              getCacheMemSize = memSize <$> readMemState calculatedTags+            }+          ]+      }++    initImmutableTags :: IO ()+    initImmutableTags = do+            index <- queryGetPackageIndex+            let calcTags = tagPackages $ constructImmutableTagIndex index+            forM_ (Map.toList calcTags) $ uncurry setCalculatedTag++    queryGetTagList :: MonadIO m => m [(Tag, Set PackageName)]+    queryGetTagList = queryState tagsState GetTagList++    queryTagsForPackage :: MonadIO m => PackageName -> m (Set Tag)+    queryTagsForPackage pkgname = queryState tagsState (TagsForPackage pkgname)++    setCalculatedTag :: Tag -> Set PackageName -> IO ()+    setCalculatedTag tag pkgs = do+      modifyMemState calculatedTags (setTag tag pkgs)+      void $ updateState tagsState $ SetTagPackages tag pkgs+      runHook_ tagsUpdated (pkgs, Set.singleton tag)++    withTagPath :: DynamicPath -> (Tag -> Set PackageName -> ServerPartE a) -> ServerPartE a+    withTagPath dpath func = case simpleParse =<< lookup "tag" dpath of+        Nothing -> mzero+        Just tag -> do+            pkgs <- queryState tagsState $ PackagesForTag tag+            func tag pkgs++    collectTags :: MonadIO m => Set PackageName -> m (Map PackageName (Set Tag))+    collectTags pkgs = do+        pkgMap <- liftM packageTags $ queryState tagsState GetPackageTags+        return $ Map.fromDistinctAscList . map (\pkg -> (pkg, Map.findWithDefault Set.empty pkg pkgMap)) $ Set.toList pkgs++    putTags :: PackageName -> ServerPartE ()+    putTags pkgname = do+      guardValidPackageName pkgname+      guardAuthorisedAsMaintainerOrTrustee pkgname+      mtags <- optional $ look "tags"+      case simpleParse =<< mtags of+          Just (TagList tags) -> do+              calcTags <- fmap (packageToTags pkgname) $ readMemState calculatedTags+              let tagSet = Set.fromList tags `Set.union` calcTags+              void $ updateState tagsState $ SetPackageTags pkgname tagSet+              runHook_ tagsUpdated (Set.singleton pkgname, tagSet)+              return ()+          Nothing -> errBadRequest "Tags not recognized" [MText "Couldn't parse your tag list. It should be comma separated with any number of alphanumerical tags. Tags can also also have -+#*."]++-- initial tags, on import+constructTagIndex :: PackageIndex PkgInfo -> PackageTags+constructTagIndex = foldl' addToTags emptyPackageTags . PackageIndex.allPackagesByName+  where addToTags pkgTags pkgList =+            let info = pkgDesc $ last pkgList+                pkgname = packageName info+                categoryTags = Set.fromList . constructCategoryTags . packageDescription $ info+                immutableTags = Set.fromList . constructImmutableTags $ info+            in setTags pkgname (Set.union categoryTags immutableTags) pkgTags++-- tags on startup+constructImmutableTagIndex :: PackageIndex PkgInfo -> PackageTags+constructImmutableTagIndex = foldl' addToTags emptyPackageTags . PackageIndex.allPackagesByName+  where addToTags calcTags pkgList =+            let info = pkgDesc $ last pkgList+                !pn = packageName info+                !tags = constructImmutableTags info+            in setTags pn (Set.fromList tags) calcTags++-- These are constructed when a package is uploaded/on startup+constructCategoryTags :: PackageDescription -> [Tag]+constructCategoryTags = map (tagify . map toLower) . fillMe . categorySplit . category+  where+    fillMe [] = ["unclassified"]+    fillMe xs = xs++-- These are reassigned as immutable tags+constructImmutableTags :: GenericPackageDescription -> [Tag]+constructImmutableTags genDesc =+    let desc = flattenPackageDescription genDesc+        !l = license desc+        !hl = hasLibs desc+        !he = hasExes desc+    in licenseToTag l+    ++ (if hl then [Tag "library"] else [])+    ++ (if he then [Tag "program"] else [])+  where+    licenseToTag :: License -> [Tag]+    licenseToTag l = case l of+        GPL  _ -> [Tag "gpl"]+        LGPL _ -> [Tag "lgpl"]+        BSD3 -> [Tag "bsd3"]+        BSD4 -> [Tag "bsd4"]+        MIT  -> [Tag "mit"]+        PublicDomain -> [Tag "public-domain"]+        AllRightsReserved -> [Tag "all-rights-reserved"]+        _ -> []+
+ Distribution/Server/Features/Tags/State.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, GeneralizedNewtypeDeriving #-}++module Distribution.Server.Features.Tags.State where++import Distribution.Server.Framework.Instances ()+import Distribution.Server.Framework.MemSize++import qualified Distribution.ParseUtils   as Parse+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Text+import Distribution.Package+import qualified Text.PrettyPrint as Disp++import Data.Acid (Query, Update, makeAcidic)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Control.Monad (liftM2)+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Typeable (Typeable)+import qualified Data.Char as Char+import Data.Maybe (fromMaybe)+import Data.List (foldl')+import Control.Monad.State (get, put, modify)+import Control.Monad.Reader (ask, asks)+import Control.DeepSeq++newtype TagList = TagList [Tag] deriving (Show, Typeable)+instance Text TagList where+    disp (TagList tags) = Disp.hsep . Disp.punctuate Disp.comma $ map disp tags+    parse = fmap TagList $ Parse.skipSpaces >> Parse.parseCommaList parse++-- A tag is a string describing a package; presently the preferred word-separation+-- character is the dash.+newtype Tag = Tag String deriving (Show, Typeable, Ord, Eq, NFData, MemSize)+instance Text Tag where+    disp (Tag tag) = Disp.text tag+    parse = do+        -- adding 'many1 $ do' here would allow multiword tags.+        -- spaces aren't very aesthetic in URIs, though.+        strs <- do+            t <- liftM2 (:) (Parse.satisfy tagInitialChar)+               $ Parse.munch1 tagLaterChar+            Parse.skipSpaces+            return t+        return $ Tag strs++tagInitialChar, tagLaterChar :: Char -> Bool+-- reserve + and - first-letters for queries+tagInitialChar c = Char.isAlphaNum c || c `elem` ".#*"+tagLaterChar   c = Char.isAlphaNum c || c `elem` "-+#*."++-- mutilates a string to appease the parser+tagify :: String -> Tag+tagify (x:xs) = Tag $ (if tagInitialChar x then (x:) else id) $ tagify' xs+  where tagify' (c:cs) | tagLaterChar c = c:tagify' cs+        tagify' (c:cs) | c `elem` " /\\" = '-':tagify' cs -- dash is the preferred word separator?+        tagify' (_:cs) = tagify' cs+        tagify' [] = []+tagify [] = Tag ""++data PackageTags = PackageTags {+    -- the primary index+    packageTags :: Map PackageName (Set Tag),+    -- a secondary reverse mapping+    tagPackages :: Map Tag (Set PackageName)+} deriving (Eq, Show, Typeable)++emptyPackageTags :: PackageTags+emptyPackageTags = PackageTags Map.empty Map.empty++tagToPackages :: Tag -> PackageTags -> Set PackageName+tagToPackages tag = Map.findWithDefault Set.empty tag . tagPackages++packageToTags :: PackageName -> PackageTags -> Set Tag+packageToTags pkg = Map.findWithDefault Set.empty pkg . packageTags++alterTags :: PackageName -> Maybe (Set Tag) -> PackageTags -> PackageTags+alterTags name mtagList (PackageTags tags packages) =+    let tagList = fromMaybe Set.empty mtagList+        oldTags = Map.findWithDefault Set.empty name tags+        adjustPlusTags pkgMap tag' = addSetMap tag' name pkgMap+        adjustMinusTags pkgMap tag' = removeSetMap tag' name pkgMap+        packages' = flip (foldl' adjustPlusTags) (Set.toList $ Set.difference tagList oldTags)+                  $ foldl' adjustMinusTags packages (Set.toList $ Set.difference oldTags tagList)+    in PackageTags (Map.alter (const mtagList) name tags) packages'++setTags :: PackageName -> Set Tag -> PackageTags -> PackageTags+setTags pkgname tagList = alterTags pkgname (keepSet tagList)++deletePackageTags :: PackageName -> PackageTags -> PackageTags+deletePackageTags name = alterTags name Nothing++addTag :: PackageName -> Tag -> PackageTags -> Maybe PackageTags+addTag name tag (PackageTags tags packages) =+    let existing = Map.findWithDefault Set.empty name tags+    in case tag `Set.member` existing of+        True  -> Nothing+        False -> Just $ PackageTags (addSetMap name tag tags)+                                    (addSetMap tag name packages)++removeTag :: PackageName -> Tag -> PackageTags -> Maybe PackageTags+removeTag name tag (PackageTags tags packages) =+    let existing = Map.findWithDefault Set.empty name tags+    in case tag `Set.member` existing of+        True -> Just $ PackageTags (removeSetMap name tag tags)+                                   (removeSetMap tag name packages)+        False -> Nothing++addSetMap :: (Ord k, Ord a) => k -> a -> Map k (Set a) -> Map k (Set a)+addSetMap key val = Map.alter (Just . Set.insert val . fromMaybe Set.empty) key++removeSetMap :: (Ord k, Ord a) => k -> a -> Map k (Set a) -> Map k (Set a)+removeSetMap key val = Map.update (keepSet . Set.delete val) key++alterTag :: Tag -> Maybe (Set PackageName) -> PackageTags -> PackageTags+alterTag tag mpkgList (PackageTags tags packages) =+    let pkgList = fromMaybe Set.empty mpkgList+        oldPkgs = Map.findWithDefault Set.empty tag packages+        adjustPlusPkgs tagMap name' = addSetMap name' tag tagMap+        adjustMinusPkgs tagMap name' = removeSetMap name' tag tagMap+        tags' = flip (foldl' adjustPlusPkgs) (Set.toList $ Set.difference pkgList oldPkgs)+              $ foldl' adjustMinusPkgs tags (Set.toList $ Set.difference oldPkgs pkgList)+    in PackageTags tags' (Map.alter (const mpkgList) tag packages)++keepSet :: Ord a => Set a -> Maybe (Set a)+keepSet s = if Set.null s then Nothing else Just s++-- these three are not currently exposed as happstack-state functions+setTag :: Tag -> Set PackageName -> PackageTags -> PackageTags+setTag tag pkgs = alterTag tag (keepSet pkgs)++deleteTag :: Tag -> PackageTags -> PackageTags+deleteTag tag = alterTag tag Nothing++renameTag :: Tag -> Tag -> PackageTags -> PackageTags+renameTag tag tag' pkgTags@(PackageTags _ packages) =+    let oldPkgs = Map.findWithDefault Set.empty tag packages+    in setTag tag' oldPkgs . deleteTag tag $ pkgTags+-------------------------------------------------------------------------------++$(deriveSafeCopy 0 'base ''Tag)+$(deriveSafeCopy 0 'base ''PackageTags)++instance NFData PackageTags where+    rnf (PackageTags a b) = rnf a `seq` rnf b++instance MemSize PackageTags where+    memSize (PackageTags a b) = memSize2 a b++initialPackageTags :: PackageTags+initialPackageTags = emptyPackageTags++tagsForPackage :: PackageName -> Query PackageTags (Set Tag)+tagsForPackage name = asks $ Map.findWithDefault Set.empty name . packageTags++packagesForTag :: Tag -> Query PackageTags (Set PackageName)+packagesForTag tag = asks $ Map.findWithDefault Set.empty tag . tagPackages++getTagList :: Query PackageTags [(Tag, Set PackageName)]+getTagList = asks $ Map.toList . tagPackages++getPackageTags :: Query PackageTags PackageTags+getPackageTags = ask++replacePackageTags :: PackageTags -> Update PackageTags ()+replacePackageTags = put++setPackageTags :: PackageName -> Set Tag -> Update PackageTags ()+setPackageTags name tagList = modify $ setTags name tagList++setTagPackages :: Tag -> Set PackageName -> Update PackageTags ()+setTagPackages tag pkgList = modify $ setTag tag pkgList++-- | Tag a package. Returns True if the element was inserted, and False if+-- the tag as already present (same result though)+addPackageTag :: PackageName -> Tag -> Update PackageTags Bool+addPackageTag name tag = do+    pkgTags <- get+    case addTag name tag pkgTags of+        Nothing -> return False+        Just pkgTags' -> put pkgTags' >> return True++-- | Untag a package. Return True if the element was removed, and False if+-- it wasn't there in the first place (again, same outcome)+removePackageTag :: PackageName -> Tag -> Update PackageTags Bool+removePackageTag name tag = do+    pkgTags <- get+    case removeTag name tag pkgTags of+        Nothing -> return False+        Just pkgTags' -> put pkgTags' >> return True++makeAcidic ''PackageTags ['tagsForPackage+                         ,'packagesForTag+                         ,'getTagList+                         ,'getPackageTags+                         ,'replacePackageTags+                         ,'setPackageTags+                         ,'setTagPackages+                         ,'addPackageTag+                         ,'removePackageTag+                         ]+
+ Distribution/Server/Features/TarIndexCache.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}+-- | The tar index cache provides generic support for caching a tarball's+-- TarIndex; this is used by various other modules.+module Distribution.Server.Features.TarIndexCache (+    TarIndexCacheFeature(..)+  , initTarIndexCacheFeature+  ) where++import Control.Exception (throwIO)+import Data.Serialize (runGetLazy, runPutLazy)+import Data.SafeCopy (safeGet, safePut)++import Distribution.Server.Framework+import Distribution.Server.Framework.BlobStorage+import Distribution.Server.Framework.BackupRestore+import Distribution.Server.Features.TarIndexCache.State+import Distribution.Server.Features.Users+import Distribution.Server.Packages.Types (PkgTarball(..))+import Data.TarIndex+import Distribution.Server.Util.ServeTarball (constructTarIndex)++import qualified Data.Map as Map+import Data.Aeson (toJSON)++data TarIndexCacheFeature = TarIndexCacheFeature {+    tarIndexCacheFeatureInterface :: HackageFeature+  , cachedTarIndex        :: BlobId -> IO TarIndex+  , cachedPackageTarIndex :: PkgTarball -> IO TarIndex+  }++instance IsHackageFeature TarIndexCacheFeature where+  getFeatureInterface = tarIndexCacheFeatureInterface++initTarIndexCacheFeature :: ServerEnv -> UserFeature -> IO TarIndexCacheFeature+initTarIndexCacheFeature env@ServerEnv{serverStateDir} users = do+  tarIndexCache <- tarIndexCacheStateComponent serverStateDir+  return $ tarIndexCacheFeature env users tarIndexCache++tarIndexCacheStateComponent :: FilePath -> IO (StateComponent AcidState TarIndexCache)+tarIndexCacheStateComponent stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> "TarIndexCache") initialTarIndexCache+  return StateComponent {+      stateDesc    = "Mapping from tarball blob IDs to tarindex blob IDs"+    , stateHandle  = st+    , getState     = query st GetTarIndexCache+    , putState     = update st . ReplaceTarIndexCache+    , resetState   = tarIndexCacheStateComponent+    -- We don't backup the tar indices, but reconstruct them on demand+    , backupState  = \_ -> []+    , restoreState = RestoreBackup {+                         restoreEntry    = error "The impossible happened"+                       , restoreFinalize = return initialTarIndexCache+                       }+    }++tarIndexCacheFeature :: ServerEnv+                     -> UserFeature+                     -> StateComponent AcidState TarIndexCache+                     -> TarIndexCacheFeature+tarIndexCacheFeature ServerEnv{serverBlobStore = store}+                     UserFeature{..}+                     tarIndexCache =+   TarIndexCacheFeature{..}+  where+    tarIndexCacheFeatureInterface :: HackageFeature+    tarIndexCacheFeatureInterface = (emptyHackageFeature "tarIndexCache") {+        featureDesc  = "Generic cache for tarball indices"+        -- We don't want to compare blob IDs+        -- (TODO: We could potentially check that if a package occurs in both+        -- packages then both caches point to identical tar indices, but for+        -- that we would need to be in IO)+      , featureState = [abstractAcidStateComponent' (\_ _ -> []) tarIndexCache]+      , featureResources = [+            (resourceAt "/server-status/tarindices.:format") {+                resourceDesc   = [ (GET,    "Which tar indices have been generated?")+                                 , (DELETE, "Delete all tar indices (will be regenerated on the fly)")+                                 ]+              , resourceGet    = [ ("json", \_ -> serveTarIndicesStatus) ]+              , resourceDelete = [ ("",     \_ -> deleteTarIndices) ]+              }+          ]+      }++    -- This is the heart of this feature+    cachedTarIndex :: BlobId -> IO TarIndex+    cachedTarIndex tarBallBlobId = do+      mTarIndexBlobId <- queryState tarIndexCache (FindTarIndex tarBallBlobId)+      case mTarIndexBlobId of+        Just tarIndexBlobId -> do+          serializedTarIndex <- fetch store tarIndexBlobId+          case runGetLazy safeGet serializedTarIndex of+            Left  err      -> throwIO (userError err)+            Right tarIndex -> return tarIndex+        Nothing -> do+          tarBall        <- fetch store tarBallBlobId+          tarIndex       <- case constructTarIndex tarBall of+                              Left  err      -> throwIO (userError err)+                              Right tarIndex -> return tarIndex+          tarIndexBlobId <- add store (runPutLazy (safePut tarIndex))+          updateState tarIndexCache (SetTarIndex tarBallBlobId tarIndexBlobId)+          return tarIndex++    cachedPackageTarIndex :: PkgTarball -> IO TarIndex+    cachedPackageTarIndex = cachedTarIndex . pkgTarballNoGz++    serveTarIndicesStatus :: ServerPartE Response+    serveTarIndicesStatus = do+      TarIndexCache state <- liftIO $ getState tarIndexCache+      return . toResponse . toJSON . Map.toList $ state++    -- | With curl:+    --+    -- > curl -X DELETE http://admin:admin@localhost:8080/server-status/tarindices+    deleteTarIndices :: ServerPartE Response+    deleteTarIndices = do+      guardAuthorised_ [InGroup adminGroup]+      -- TODO: This resets the tar indices _state_ only, we don't actually+      -- remove any blobs+      liftIO $ putState tarIndexCache initialTarIndexCache+      ok $ toResponse "Ok!"
+ Distribution/Server/Features/TarIndexCache/State.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable, NamedFieldPuns #-}+module Distribution.Server.Features.TarIndexCache.State (+    TarIndexCache(..)+  , initialTarIndexCache+  , GetTarIndexCache(GetTarIndexCache)+  , ReplaceTarIndexCache(ReplaceTarIndexCache)+  , FindTarIndex(FindTarIndex)+  , SetTarIndex(SetTarIndex)+  ) where++-- TODO: use strict map? (Can we rely on containers >= 0.5?)++import Data.Typeable (Typeable)+import Control.Monad.Reader (ask, asks)+import Control.Monad.State (put, modify)+import Data.Map (Map)+import qualified Data.Map as Map+import Control.Applicative ((<$>))++import Data.Acid (Query, Update, makeAcidic)+import Data.SafeCopy (base, deriveSafeCopy)++import Distribution.Server.Framework.BlobStorage+import Distribution.Server.Framework.MemSize++data TarIndexCache = TarIndexCache {+    tarIndexCacheMap :: Map BlobId BlobId+  }+  deriving (Eq, Show, Typeable)++$(deriveSafeCopy 0 'base ''TarIndexCache)++instance MemSize TarIndexCache where+  memSize st = 2 + memSize (tarIndexCacheMap st)++initialTarIndexCache :: TarIndexCache+initialTarIndexCache = TarIndexCache (Map.empty)++getTarIndexCache :: Query TarIndexCache TarIndexCache+getTarIndexCache = ask++replaceTarIndexCache :: TarIndexCache -> Update TarIndexCache ()+replaceTarIndexCache = put++getTarIndexCacheMap :: Query TarIndexCache (Map BlobId BlobId)+getTarIndexCacheMap = asks tarIndexCacheMap++modifyTarIndexCacheMap :: (Map BlobId BlobId -> Map BlobId BlobId)+                       -> Update TarIndexCache ()+modifyTarIndexCacheMap f = modify $ \st@TarIndexCache{tarIndexCacheMap} ->+                             st { tarIndexCacheMap = f tarIndexCacheMap }++findTarIndex :: BlobId -> Query TarIndexCache (Maybe BlobId)+findTarIndex blobId = Map.lookup blobId <$> getTarIndexCacheMap++setTarIndex :: BlobId -> BlobId -> Update TarIndexCache ()+setTarIndex tar index = modifyTarIndexCacheMap (Map.insert tar index)++makeAcidic ''TarIndexCache [+    'getTarIndexCache+  , 'replaceTarIndexCache+  , 'findTarIndex+  , 'setTarIndex+  ]
+ Distribution/Server/Features/Upload.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE DoRec, RankNTypes, NamedFieldPuns, RecordWildCards #-}+module Distribution.Server.Features.Upload (+    UploadFeature(..),+    UploadResource(..),+    initUploadFeature,+    UploadResult(..),+  ) where++import Distribution.Server.Framework+import Distribution.Server.Framework.BackupDump++import Distribution.Server.Features.Upload.State+import Distribution.Server.Features.Upload.Backup++import Distribution.Server.Features.Core+import Distribution.Server.Features.Users++import Distribution.Server.Users.Backup+import Distribution.Server.Packages.Types+import qualified Distribution.Server.Users.Types as Users+import qualified Distribution.Server.Users.Group as Group+import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), nullDescription)+import qualified Distribution.Server.Framework.BlobStorage as BlobStorage+import qualified Distribution.Server.Packages.Unpack as Upload+import Distribution.Server.Packages.PackageIndex (PackageIndex)+import qualified Distribution.Server.Packages.PackageIndex as PackageIndex++import Data.Maybe (fromMaybe)+import Data.Time.Clock (getCurrentTime)+import Data.Function (fix)+import Data.ByteString.Lazy (ByteString)++import Distribution.Package+import Distribution.PackageDescription (GenericPackageDescription)+import Distribution.Text (display)+import qualified Distribution.Server.Util.GZip as GZip+++data UploadFeature = UploadFeature {+    uploadFeatureInterface :: HackageFeature,++    uploadResource     :: UploadResource,+    uploadPackage      :: ServerPartE UploadResult,++    --TODO: consider moving the trustee and/or per-package maintainer groups+    --      lower down in the feature hierarchy; many other features want to+    --      use the trustee group purely for auth decisions+    trusteesGroup      :: UserGroup,+    uploadersGroup     :: UserGroup,+    maintainersGroup   :: PackageName -> UserGroup,++    guardAuthorisedAsMaintainer          :: PackageName -> ServerPartE (),+    guardAuthorisedAsMaintainerOrTrustee :: PackageName -> ServerPartE (),++    extractPackage     :: (Users.UserId -> UploadResult -> IO (Maybe ErrorResponse))+                       -> ServerPartE (Users.UserId, UploadResult, PkgTarball)+}++instance IsHackageFeature UploadFeature where+    getFeatureInterface = uploadFeatureInterface++data UploadResource = UploadResource {+    uploadIndexPage :: Resource,+    deletePackagePage  :: Resource,+    maintainersGroupResource :: GroupResource,+    trusteesGroupResource    :: GroupResource,+    uploadersGroupResource   :: GroupResource,+    packageMaintainerUri :: String -> PackageId -> String,+    trusteeUri  :: String -> String,+    uploaderUri :: String -> String+}++data UploadResult = UploadResult {+    uploadDesc :: !GenericPackageDescription,+    uploadCabal :: !ByteString,+    uploadWarnings :: ![String]+}++initUploadFeature :: ServerEnv -> CoreFeature -> UserFeature -> IO UploadFeature+initUploadFeature env@ServerEnv{serverStateDir}+                  core@CoreFeature{..} user@UserFeature{..} = do++    -- Canonical state+    trusteesState    <- trusteesStateComponent    serverStateDir+    uploadersState   <- uploadersStateComponent   serverStateDir+    maintainersState <- maintainersStateComponent serverStateDir++    -- Recusively tie the knot: the feature contains new user group resources+    -- but we make the functions needed to create those resources along with+    -- the feature+    rec let (feature,+             getTrusteesGroup, getUploadersGroup, makeMaintainersGroup)+              = uploadFeature env core user+                              trusteesState    trusteesGroup    trusteesGroupResource+                              uploadersState   uploadersGroup   uploadersGroupResource+                              maintainersState maintainersGroup maintainersGroupResource++        (trusteesGroup,  trusteesGroupResource) <-+          groupResourceAt "/packages/trustees"  (getTrusteesGroup  [adminGroup])++        (uploadersGroup, uploadersGroupResource) <-+          groupResourceAt "/packages/uploaders" (getUploadersGroup [adminGroup])++        pkgNames <- PackageIndex.packageNames <$> queryGetPackageIndex+        (maintainersGroup, maintainersGroupResource) <-+          groupResourcesAt "/package/:package/maintainers"+                           (makeMaintainersGroup [adminGroup, trusteesGroup])+                           (\pkgname -> [("package", display pkgname)])+                           (packageInPath coreResource)+                           pkgNames++    return feature++trusteesStateComponent :: FilePath -> IO (StateComponent AcidState HackageTrustees)+trusteesStateComponent stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> "HackageTrustees") initialHackageTrustees+  return StateComponent {+      stateDesc    = "Trustees"+    , stateHandle  = st+    , getState     = query st GetHackageTrustees+    , putState     = update st . ReplaceHackageTrustees . trusteeList+    , backupState  = \(HackageTrustees trustees) -> [csvToBackup ["trustees.csv"] $ groupToCSV trustees]+    , restoreState = HackageTrustees <$> groupBackup ["trustees.csv"]+    , resetState   = trusteesStateComponent+    }++uploadersStateComponent :: FilePath -> IO (StateComponent AcidState HackageUploaders)+uploadersStateComponent stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> "HackageUploaders") initialHackageUploaders+  return StateComponent {+      stateDesc    = "Uploaders"+    , stateHandle  = st+    , getState     = query st GetHackageUploaders+    , putState     = update st . ReplaceHackageUploaders . uploaderList+    , backupState  = \(HackageUploaders uploaders) -> [csvToBackup ["uploaders.csv"] $ groupToCSV uploaders]+    , restoreState = HackageUploaders <$> groupBackup ["uploaders.csv"]+    , resetState   = uploadersStateComponent+    }++maintainersStateComponent :: FilePath -> IO (StateComponent AcidState PackageMaintainers)+maintainersStateComponent stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> "PackageMaintainers") initialPackageMaintainers+  return StateComponent {+      stateDesc    = "Package maintainers"+    , stateHandle  = st+    , getState     = query st AllPackageMaintainers+    , putState     = update st . ReplacePackageMaintainers+    , backupState  = \(PackageMaintainers mains) -> [maintToExport mains]+    , restoreState = maintainerBackup+    , resetState   = maintainersStateComponent+    }++uploadFeature :: ServerEnv+              -> CoreFeature+              -> UserFeature+              -> StateComponent AcidState HackageTrustees    -> UserGroup -> GroupResource+              -> StateComponent AcidState HackageUploaders   -> UserGroup -> GroupResource+              -> StateComponent AcidState PackageMaintainers -> (PackageName -> UserGroup) -> GroupResource+              -> (UploadFeature,+                  [UserGroup] -> UserGroup,+                  [UserGroup] -> UserGroup,+                  [UserGroup] -> PackageName -> UserGroup)++uploadFeature ServerEnv{serverBlobStore = store}+              CoreFeature{ coreResource+                         , queryGetPackageIndex+                         , updateAddPackage+                         }+              UserFeature{..}+              trusteesState    trusteesGroup    trusteesGroupResource+              uploadersState   uploadersGroup   uploadersGroupResource+              maintainersState maintainersGroup maintainersGroupResource+   = ( UploadFeature {..}+     , getTrusteesGroup, getUploadersGroup, makeMaintainersGroup)+   where+    uploadFeatureInterface = (emptyHackageFeature "upload") {+        featureDesc = "Support for package uploads, and define groups for trustees, uploaders, and package maintainers"+      , featureResources =+            [ uploadIndexPage uploadResource+            , groupResource     maintainersGroupResource+            , groupUserResource maintainersGroupResource+            , groupResource     trusteesGroupResource+            , groupUserResource trusteesGroupResource+            , groupResource     uploadersGroupResource+            , groupUserResource uploadersGroupResource+            ]+      , featureState = [+            abstractAcidStateComponent trusteesState+          , abstractAcidStateComponent uploadersState+          , abstractAcidStateComponent maintainersState+          ]+      }++    uploadResource = UploadResource+          { uploadIndexPage      = (extendResource (corePackagesPage coreResource)) { resourcePost = [] }+          , deletePackagePage    = (extendResource (corePackagePage coreResource))  { resourceDelete = [] }+          , maintainersGroupResource = maintainersGroupResource+          , trusteesGroupResource    = trusteesGroupResource+          , uploadersGroupResource   = uploadersGroupResource++          , packageMaintainerUri = \format pkgname -> renderResource+                                     (groupResource maintainersGroupResource) [display pkgname, format]+          , trusteeUri  = \format -> renderResource (groupResource trusteesGroupResource)  [format]+          , uploaderUri = \format -> renderResource (groupResource uploadersGroupResource) [format]+          }++    --------------------------------------------------------------------------------+    -- User groups and authentication+    getTrusteesGroup :: [UserGroup] -> UserGroup+    getTrusteesGroup canModify = fix $ \u -> UserGroup {+        groupDesc = trusteeDescription,+        queryUserList  = queryState  trusteesState   GetTrusteesList,+        addUserList    = updateState trusteesState . AddHackageTrustee,+        removeUserList = updateState trusteesState . RemoveHackageTrustee,+        canAddGroup    = [u] ++ canModify,+        canRemoveGroup = canModify+    }++    getUploadersGroup :: [UserGroup] -> UserGroup+    getUploadersGroup canModify = UserGroup {+        groupDesc      = uploaderDescription,+        queryUserList  = queryState  uploadersState   GetUploadersList,+        addUserList    = updateState uploadersState . AddHackageUploader,+        removeUserList = updateState uploadersState . RemoveHackageUploader,+        canAddGroup    = canModify,+        canRemoveGroup = canModify+    }++    makeMaintainersGroup :: [UserGroup] -> PackageName -> UserGroup+    makeMaintainersGroup canModify name = fix $ \u -> UserGroup {+        groupDesc      = maintainerDescription name,+        queryUserList  = queryState  maintainersState $ GetPackageMaintainers name,+        addUserList    = updateState maintainersState . AddPackageMaintainer name,+        removeUserList = updateState maintainersState . RemovePackageMaintainer name,+        canAddGroup    = [u] ++ canModify,+        canRemoveGroup = [u] ++ canModify+      }++    maintainerDescription :: PackageName -> GroupDescription+    maintainerDescription pkgname = GroupDescription+      { groupTitle = "Maintainers"+      , groupEntity = Just (pname, Just $ "/package/" ++ pname)+      , groupPrologue  = "Maintainers for a package can upload new versions and adjust other attributes in the package database."+      }+      where pname = display pkgname++    trusteeDescription :: GroupDescription+    trusteeDescription = nullDescription { groupTitle = "Package trustees", groupPrologue = "Package trustees are essentially maintainers for the entire package database. They can edit package maintainer groups and upload any package." }++    uploaderDescription :: GroupDescription+    uploaderDescription = nullDescription { groupTitle = "Package uploaders", groupPrologue = "Package uploaders allowed to upload packages. If a package already exists then you also need to be in the maintainer group for that package." }++    guardAuthorisedAsMaintainer :: PackageName -> ServerPartE ()+    guardAuthorisedAsMaintainer pkgname =+      guardAuthorised_ [InGroup (maintainersGroup pkgname)]++    guardAuthorisedAsMaintainerOrTrustee :: PackageName -> ServerPartE ()+    guardAuthorisedAsMaintainerOrTrustee pkgname =+      guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup]+++    ----------------------------------------------------++    -- This is the upload function. It returns a generic result for multiple formats.+    uploadPackage :: ServerPartE UploadResult+    uploadPackage = do+        guardAuthorised_ [InGroup uploadersGroup]+        pkgIndex <- queryGetPackageIndex+        (uid, uresult, tarball) <- extractPackage $ \uid info ->+                                     processUpload pkgIndex uid info+        now <- liftIO getCurrentTime+        let (UploadResult pkg pkgStr _) = uresult+            pkgid      = packageId pkg+            cabalfile  = CabalFileText pkgStr+            uploadinfo = (now, uid)+        success <- updateAddPackage pkgid cabalfile uploadinfo (Just tarball)+        if success+          then do+             -- make package maintainers group for new package+            let existedBefore = packageExists pkgIndex pkgid+            when (not existedBefore) $+                liftIO $ addUserList (maintainersGroup (packageName pkgid)) uid+            return uresult+          -- this is already checked in processUpload, and race conditions are highly unlikely but imaginable+          else errForbidden "Upload failed" [MText "Package already exists."]++    -- This is a processing funtion for extractPackage that checks upload-specific requirements.+    -- Does authentication, though not with requirePackageAuth, because it has to be IO.+    -- Some other checks can be added, e.g. if a package with a later version exists+    processUpload :: PackageIndex PkgInfo -> Users.UserId -> UploadResult -> IO (Maybe ErrorResponse)+    processUpload state uid res = do+        let pkg = packageId (uploadDesc res)+        pkgGroup <- queryUserList (maintainersGroup (packageName pkg))+        if packageIdExists state pkg+          then uploadError versionExists --allow trustees to do this?+          else if packageExists state pkg && not (uid `Group.member` pkgGroup)+                 then uploadError (notMaintainer pkg)+                 else return Nothing+      where+        uploadError = return . Just . ErrorResponse 403 [] "Upload failed" . return . MText+        versionExists = "This version of the package has already been uploaded.\n\nAs a matter of "+                     ++ "policy we do not allow package tarballs to be changed after a release "+                     ++ "(so we can guarantee stable md5sums etc). The usual recommendation is "+                     ++ "to upload a new version, and if necessary blacklist the existing one. "+                     ++ "In extraordinary circumstances, contact the administrators."+        notMaintainer pkg = "You are not authorised to upload new versions of this package. The "+                     ++ "package '" ++ display (packageName pkg) ++ "' exists already and you "+                     ++ "are not a member of the maintainer group for this package.\n\n"+                     ++ "If you believe you should be a member of the maintainer group for this "+                     ++ "package, then ask an existing maintainer to add you to the group. If "+                     ++ "this is a package name clash, please pick another name or talk to the "+                     ++ "maintainers of the existing package."++    -- This function generically extracts a package, useful for uploading, checking,+    -- and anything else in the standard user-upload pipeline.+    extractPackage :: (Users.UserId -> UploadResult -> IO (Maybe ErrorResponse))+                   -> ServerPartE (Users.UserId, UploadResult, PkgTarball)+    extractPackage processFunc =+        withDataFn (lookInput "package") $ \input ->+            case inputValue input of -- HS6 this has been updated to use the new file upload support in HS6, but has not been tested at all+              (Right _) -> errBadRequest "Upload failed" [MText "package field in form data is not a file."]+              (Left file) ->+                  let fileName    = (fromMaybe "noname" $ inputFilename input)+                  in upload fileName file+      where+        upload name file =+         do -- initial check to ensure logged in.+            --FIXME: this should have been covered earlier+            uid <- guardAuthenticated+            let processPackage :: ByteString -> IO (Either ErrorResponse (UploadResult, BlobStorage.BlobId))+                processPackage content' = do+                    -- as much as it would be nice to do requirePackageAuth in here,+                    -- processPackage is run in a handle bracket+                    case Upload.unpackPackage name content' of+                      Left err -> return . Left $ ErrorResponse 400 [] "Invalid package" [MText err]+                      Right ((pkg, pkgStr), warnings) -> do+                        let uresult = UploadResult pkg pkgStr warnings+                        res <- processFunc uid uresult+                        case res of+                            Nothing ->+                                do let decompressedContent = GZip.decompressNamed file content'+                                   blobIdDecompressed <- BlobStorage.add store decompressedContent+                                   return . Right $ (uresult, blobIdDecompressed)+                            Just err -> return . Left $ err+            mres <- liftIO $ BlobStorage.consumeFileWith store file processPackage+            case mres of+                Left  err -> throwError err+                Right ((res, blobIdDecompressed), blobId) ->+                    return (uid, res, tarball)+                  where+                    tarball = PkgTarball { pkgTarballGz   = blobId,+                                           pkgTarballNoGz = blobIdDecompressed }
+ Distribution/Server/Features/Upload/Backup.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE PatternGuards #-}++module Distribution.Server.Features.Upload.Backup (+    maintainerBackup,+    maintToExport,+    maintToCSV+  ) where++import Distribution.Server.Features.Upload.State++import Distribution.Server.Users.Group (UserList(..))+import Distribution.Server.Framework.BackupRestore+import Distribution.Server.Framework.BackupDump++import Distribution.Package+import Distribution.Text+import Data.Version+import Text.CSV (CSV, Record)++import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.IntSet as IntSet++-------------------------------------------------------------------------------+-- Maintainer groups backup+maintainerBackup :: RestoreBackup PackageMaintainers+maintainerBackup = updateMaintainers Map.empty++updateMaintainers :: Map PackageName UserList -> RestoreBackup PackageMaintainers+updateMaintainers mains = RestoreBackup {+    restoreEntry = \entry -> do+      case entry of+        BackupByteString ["maintainers.csv"] bs -> do+          csv    <- importCSV "maintainers.csv" bs+          mains' <- importMaintainers csv mains+          return (updateMaintainers mains')+        _ ->+          return (updateMaintainers mains)+  , restoreFinalize =+      return $ PackageMaintainers (mains)+  }++importMaintainers :: CSV -> Map PackageName UserList -> Restore (Map PackageName UserList)+importMaintainers = concatM . map fromRecord . drop 2+  where+    fromRecord :: Record -> Map PackageName UserList -> Restore (Map PackageName UserList)+    fromRecord (packageStr:idStr) mains = do+        pkgname <- parseText "package name" packageStr+        ids <- mapM (parseRead "user id") idStr+        return (Map.insert pkgname (UserList $ IntSet.fromList ids) mains)+    fromRecord x _ = fail $ "Invalid package maintainer record: " ++ show x++maintToExport :: Map PackageName UserList -> BackupEntry+maintToExport pkgmap = csvToBackup ["maintainers.csv"] (maintToCSV assocUsers)+  where assocUsers = map (\(name, UserList ul) -> (name, IntSet.toList ul))+                   $ Map.toList pkgmap++maintToCSV :: [(PackageName, [Int])] -> CSV+maintToCSV users = [showVersion pkgCSVVer]:pkgCSVKey:+    map (\(name, ids) -> display name:map show ids) users+  where+    pkgCSVKey = ["package", "maintainers"]+    pkgCSVVer = Version [0,1] ["unstable"]+
+ Distribution/Server/Features/Upload/State.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-}++module Distribution.Server.Features.Upload.State where++import Distribution.Server.Framework.Instances ()+import Distribution.Server.Framework.MemSize++import Distribution.Package+import qualified Distribution.Server.Users.Group as Group+import Distribution.Server.Users.Group (UserList)+import Distribution.Server.Users.Types (UserId)++import Data.Acid     (Query, Update, makeAcidic)+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Typeable+import Control.Monad.Reader+import qualified Control.Monad.State as State+import Data.Maybe (fromMaybe)++import qualified Data.Map as Map++-------------------------------- Maintainer list+data PackageMaintainers = PackageMaintainers {+    maintainers :: Map.Map PackageName UserList+} deriving (Eq, Show, Typeable)++deriveSafeCopy 0 'base ''PackageMaintainers++instance MemSize PackageMaintainers where+    memSize (PackageMaintainers a) = memSize1 a++initialPackageMaintainers :: PackageMaintainers+initialPackageMaintainers = PackageMaintainers Map.empty++getPackageMaintainers :: PackageName -> Query PackageMaintainers UserList+getPackageMaintainers name = asks $ fromMaybe Group.empty . Map.lookup name . maintainers++modifyPackageMaintainers :: PackageName -> (UserList -> UserList) -> Update PackageMaintainers ()+modifyPackageMaintainers name func = State.modify (\pm -> pm {maintainers = alterFunc (maintainers pm) })+    where alterFunc = Map.alter (Just . func . fromMaybe Group.empty) name++addPackageMaintainer :: PackageName -> UserId -> Update PackageMaintainers ()+addPackageMaintainer name uid = modifyPackageMaintainers name (Group.add uid)++removePackageMaintainer :: PackageName -> UserId -> Update PackageMaintainers ()+removePackageMaintainer name uid = modifyPackageMaintainers name (Group.remove uid)++setPackageMaintainers :: PackageName -> UserList -> Update PackageMaintainers ()+setPackageMaintainers name ulist = modifyPackageMaintainers name (const ulist)++allPackageMaintainers :: Query PackageMaintainers PackageMaintainers+allPackageMaintainers = ask++replacePackageMaintainers :: PackageMaintainers -> Update PackageMaintainers ()+replacePackageMaintainers = State.put++makeAcidic ''PackageMaintainers ['getPackageMaintainers+                                ,'addPackageMaintainer+                                ,'removePackageMaintainer+                                ,'setPackageMaintainers+                                ,'replacePackageMaintainers+                                ,'allPackageMaintainers+                                ]++-------------------------------- Trustee list+-- this could be reasonably merged into the above, as a PackageGroups data structure+data HackageTrustees = HackageTrustees {+    trusteeList :: !UserList+} deriving (Show, Typeable, Eq)++deriveSafeCopy 0 'base ''HackageTrustees++instance MemSize HackageTrustees where+    memSize (HackageTrustees a) = memSize1 a++initialHackageTrustees :: HackageTrustees+initialHackageTrustees = HackageTrustees Group.empty++getHackageTrustees :: Query HackageTrustees HackageTrustees+getHackageTrustees = ask++getTrusteesList :: Query HackageTrustees UserList+getTrusteesList = asks trusteeList++modifyHackageTrustees :: (UserList -> UserList) -> Update HackageTrustees ()+modifyHackageTrustees func = State.modify (\ht -> ht {trusteeList = func (trusteeList ht) })++addHackageTrustee :: UserId -> Update HackageTrustees ()+addHackageTrustee uid = modifyHackageTrustees (Group.add uid)++removeHackageTrustee :: UserId -> Update HackageTrustees ()+removeHackageTrustee uid = modifyHackageTrustees (Group.remove uid)++replaceHackageTrustees :: UserList -> Update HackageTrustees ()+replaceHackageTrustees ulist = modifyHackageTrustees (const ulist)++makeAcidic ''HackageTrustees ['getHackageTrustees+                             ,'getTrusteesList+                             ,'addHackageTrustee+                             ,'removeHackageTrustee+                             ,'replaceHackageTrustees+                             ]++-------------------------------- Uploader list+data HackageUploaders = HackageUploaders {+    uploaderList :: !UserList+} deriving (Show, Typeable, Eq)++$(deriveSafeCopy 0 'base ''HackageUploaders)++instance MemSize HackageUploaders where+    memSize (HackageUploaders a) = memSize1 a++initialHackageUploaders :: HackageUploaders+initialHackageUploaders = HackageUploaders Group.empty++getHackageUploaders :: Query HackageUploaders HackageUploaders+getHackageUploaders = ask++getUploadersList :: Query HackageUploaders UserList+getUploadersList = asks uploaderList++modifyHackageUploaders :: (UserList -> UserList) -> Update HackageUploaders ()+modifyHackageUploaders func = State.modify (\ht -> ht {uploaderList = func (uploaderList ht) })++addHackageUploader :: UserId -> Update HackageUploaders ()+addHackageUploader uid = modifyHackageUploaders (Group.add uid)++removeHackageUploader :: UserId -> Update HackageUploaders ()+removeHackageUploader uid = modifyHackageUploaders (Group.remove uid)++replaceHackageUploaders :: UserList -> Update HackageUploaders ()+replaceHackageUploaders ulist = modifyHackageUploaders (const ulist)++makeAcidic ''HackageUploaders ['getHackageUploaders+                              ,'getUploadersList+                              ,'addHackageUploader+                              ,'removeHackageUploader+                              ,'replaceHackageUploaders+                              ]
+ Distribution/Server/Features/UserDetails.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, RankNTypes, NamedFieldPuns, RecordWildCards, DoRec, BangPatterns, CPP #-}+module Distribution.Server.Features.UserDetails (+    initUserDetailsFeature,+    UserDetailsFeature(..),++    AccountDetails(..),+    AccountKind(..)+  ) where++import Distribution.Server.Framework+import Distribution.Server.Framework.BackupDump+import Distribution.Server.Framework.BackupRestore++import Distribution.Server.Features.Users+import Distribution.Server.Features.Core++import Distribution.Server.Users.Types++import Data.SafeCopy (base, deriveSafeCopy)++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Aeson as Aeson+import Data.Aeson.TH++import Data.Typeable (Typeable)+import Control.Monad.Reader (ask)+import Control.Monad.State (get, put)++import Distribution.Text (display)+import Data.Version+import Text.CSV (CSV, Record)+++-- | A feature to store extra information about users like email addresses.+--+data UserDetailsFeature = UserDetailsFeature {+    userDetailsFeatureInterface :: HackageFeature,++    queryUserDetails  :: UserId -> MonadIO m => m (Maybe AccountDetails),+    updateUserDetails :: UserId -> AccountDetails -> MonadIO m => m ()+}++instance IsHackageFeature UserDetailsFeature where+  getFeatureInterface = userDetailsFeatureInterface+++-------------------------+-- Types of stored data+--++data AccountDetails = AccountDetails {+                        accountName         :: !Text,+                        accountContactEmail :: !Text,+                        accountKind         :: Maybe AccountKind,+                        accountAdminNotes   :: !Text+                      }+  deriving (Eq, Show, Typeable)+++data AccountKind = AccountKindRealUser | AccountKindSpecial+  deriving (Eq, Show, Typeable)++newtype UserDetailsTable = UserDetailsTable (IntMap AccountDetails)+  deriving (Eq, Show, Typeable)++emptyAccountDetails :: AccountDetails+emptyAccountDetails   = AccountDetails T.empty T.empty Nothing T.empty+emptyUserDetailsTable :: UserDetailsTable+emptyUserDetailsTable = UserDetailsTable IntMap.empty++$(deriveSafeCopy 0 'base ''AccountDetails)+$(deriveSafeCopy 0 'base ''AccountKind)+$(deriveSafeCopy 0 'base ''UserDetailsTable)++instance MemSize AccountDetails where+    memSize (AccountDetails a b c d) = memSize4 a b c d++instance MemSize AccountKind where+    memSize _ = memSize0++instance MemSize UserDetailsTable where+    memSize (UserDetailsTable a) = memSize1 a+++------------------------------+-- State queries and updates+--++getUserDetailsTable :: Query UserDetailsTable UserDetailsTable+getUserDetailsTable = ask++replaceUserDetailsTable :: UserDetailsTable -> Update UserDetailsTable ()+replaceUserDetailsTable = put++lookupUserDetails :: UserId -> Query UserDetailsTable (Maybe AccountDetails)+lookupUserDetails (UserId uid) = do+    UserDetailsTable tbl <- ask+    return $! IntMap.lookup uid tbl++setUserDetails :: UserId -> AccountDetails -> Update UserDetailsTable ()+setUserDetails (UserId uid) udetails = do+    UserDetailsTable tbl <- get+    put $! UserDetailsTable (IntMap.insert uid udetails tbl)++deleteUserDetails :: UserId -> Update UserDetailsTable Bool+deleteUserDetails (UserId uid) = do+    UserDetailsTable tbl <- get+    if IntMap.member uid tbl+      then do put $! UserDetailsTable (IntMap.delete uid tbl)+              return True+      else return False++setUserNameContact :: UserId -> Text -> Text -> Update UserDetailsTable ()+setUserNameContact (UserId uid) name email = do+    UserDetailsTable tbl <- get+    put $! UserDetailsTable (IntMap.alter upd uid tbl)+  where+    upd Nothing         = Just emptyAccountDetails { accountName = name, accountContactEmail = email }+    upd (Just udetails) = Just udetails            { accountName = name, accountContactEmail = email }++setUserAdminInfo :: UserId -> Maybe AccountKind -> Text -> Update UserDetailsTable ()+setUserAdminInfo (UserId uid) akind notes = do+    UserDetailsTable tbl <- get+    put $! UserDetailsTable (IntMap.alter upd uid tbl)+  where+    upd Nothing         = Just emptyAccountDetails { accountKind = akind, accountAdminNotes = notes }+    upd (Just udetails) = Just udetails            { accountKind = akind, accountAdminNotes = notes }++makeAcidic ''UserDetailsTable [+    --queries+    'getUserDetailsTable,+    'lookupUserDetails,+    --updates+    'replaceUserDetailsTable,+    'setUserDetails,+    'setUserNameContact,+    'setUserAdminInfo,+    'deleteUserDetails+  ]+++---------------------+-- State components+--++userDetailsStateComponent :: FilePath -> IO (StateComponent AcidState UserDetailsTable)+userDetailsStateComponent stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> "UserDetails") emptyUserDetailsTable+  return StateComponent {+      stateDesc    = "Extra details associated with user accounts, email addresses etc"+    , stateHandle  = st+    , getState     = query st GetUserDetailsTable+    , putState     = update st . ReplaceUserDetailsTable+    , backupState  = \users -> [csvToBackup ["users.csv"] (userDetailsToCSV users)]+    , restoreState = userDetailsBackup+    , resetState   = userDetailsStateComponent+    }++----------------------------+-- Data backup and restore+--++userDetailsBackup :: RestoreBackup UserDetailsTable+userDetailsBackup = updateUserBackup emptyUserDetailsTable++updateUserBackup :: UserDetailsTable -> RestoreBackup UserDetailsTable+updateUserBackup users = RestoreBackup {+    restoreEntry = \entry -> case entry of+      BackupByteString ["users.csv"] bs -> do+        csv <- importCSV "users.csv" bs+        users' <- importUserDetails csv users+        return (updateUserBackup users')+      _ ->+        return (updateUserBackup users)+  , restoreFinalize =+     return users+  }++importUserDetails :: CSV -> UserDetailsTable -> Restore UserDetailsTable+importUserDetails = concatM . map fromRecord . drop 2+  where+    fromRecord :: Record -> UserDetailsTable -> Restore UserDetailsTable+    fromRecord [idStr, nameStr, emailStr, kindStr, notesStr] (UserDetailsTable tbl) = do+        UserId uid <- parseText "user id" idStr+        akind      <- parseKind kindStr+        let udetails = AccountDetails {+                        accountName         = T.pack nameStr,+                        accountContactEmail = T.pack emailStr,+                        accountKind         = akind,+                        accountAdminNotes   = T.pack notesStr+                      }+        return $! UserDetailsTable (IntMap.insert uid udetails tbl)++    fromRecord x _ = fail $ "Error processing user details record: " ++ show x++    parseKind ""        = return Nothing+    parseKind "real"    = return (Just AccountKindRealUser)+    parseKind "special" = return (Just AccountKindSpecial)+    parseKind sts       = fail $ "unable to parse account kind: " ++ sts++userDetailsToCSV :: UserDetailsTable -> CSV+userDetailsToCSV (UserDetailsTable tbl)+    = ([showVersion userCSVVer]:) $+      (userdetailsCSVKey:) $++      flip map (IntMap.toList tbl) $ \(uid, udetails) ->+      [ display (UserId uid)+      , T.unpack (accountName udetails)  --FIXME: apparently the csv lib doesn't do unicode properly+      , T.unpack (accountContactEmail udetails)+      , infoToAccountKind udetails+      , T.unpack (accountAdminNotes udetails)+      ]++ where+    userdetailsCSVKey =+       [ "uid"+       , "realname"+       , "email"+       , "kind"+       , "notes"+       ]+    userCSVVer = Version [0,2] []++    -- one of "enabled" "disabled" or "deleted"+    infoToAccountKind :: AccountDetails -> String+    infoToAccountKind udetails = case accountKind udetails of+      Nothing                  -> ""+      Just AccountKindRealUser -> "real"+      Just AccountKindSpecial  -> "special"++----------------------------------------+-- Feature definition & initialisation+--++initUserDetailsFeature :: ServerEnv -> UserFeature -> CoreFeature -> IO UserDetailsFeature+initUserDetailsFeature ServerEnv{serverStateDir} users core = do++  -- Canonical state+  usersDetailsState <- userDetailsStateComponent serverStateDir++  let feature = userDetailsFeature usersDetailsState users core++  --TODO: link up to user feature to delete++  return feature+++userDetailsFeature :: StateComponent AcidState UserDetailsTable+                   -> UserFeature+                   -> CoreFeature+                   -> UserDetailsFeature+userDetailsFeature userDetailsState UserFeature{..} CoreFeature{..}+  = UserDetailsFeature {..}++  where+    userDetailsFeatureInterface = (emptyHackageFeature "user-details") {+        featureDesc      = "Extra information about user accounts, email addresses etc."+      , featureResources = [userNameContactResource, userAdminInfoResource]+      , featureState     = [abstractAcidStateComponent userDetailsState]+      , featureCaches    = []+      }++    -- Resources+    --++    userNameContactResource =+      (resourceAt "/user/:username/name-contact.:format") {+        resourceDesc   = [ (GET,    "get the name and contact details of a user account")+                         , (PUT,    "set the name and contact details of a user account")+                         , (DELETE, "delete the name and contact details of a user account")+                         ]+      , resourceGet    = [ ("json", handlerGetUserNameContact) ]+      , resourcePut    = [ ("json", handlerPutUserNameContact) ]+      , resourceDelete = [ ("",     handlerDeleteUserNameContact) ]+      }++    userAdminInfoResource =+      (resourceAt "/user/:username/admin-info.:format") {+        resourceDesc   = [ (GET,    "get the administrators' notes for a user account")+                         , (PUT,    "set the administrators' notes for a user account")+                         , (DELETE, "delete the administrators' notes for a user account")+                         ]+      , resourceGet    = [ ("json", handlerGetAdminInfo) ]+      , resourcePut    = [ ("json", handlerPutAdminInfo) ]+      , resourceDelete = [ ("", handlerDeleteAdminInfo) ]+      }++    -- Queries and updates+    --++    queryUserDetails :: UserId -> MonadIO m => m (Maybe AccountDetails)+    queryUserDetails uid = queryState userDetailsState (LookupUserDetails uid)++    updateUserDetails :: UserId -> AccountDetails -> MonadIO m => m ()+    updateUserDetails uid udetails = do+      updateState userDetailsState (SetUserDetails uid udetails)++    -- Request handlers+    --++    handlerGetUserNameContact :: DynamicPath -> ServerPartE Response+    handlerGetUserNameContact dpath = do+        uid <- lookupUserName =<< userNameInPath dpath+        guardAuthorised_ [IsUserId uid, InGroup adminGroup]+        udetails <- queryUserDetails uid+        return $ toResponse (Aeson.toJSON (render udetails))+      where+        render Nothing = NameAndContact T.empty T.empty+        render (Just (AccountDetails { accountName, accountContactEmail })) =+            NameAndContact {+              ui_name                = accountName,+              ui_contactEmailAddress = accountContactEmail+            }++    handlerPutUserNameContact :: DynamicPath -> ServerPartE Response+    handlerPutUserNameContact dpath = do+        uid <- lookupUserName =<< userNameInPath dpath+        guardAuthorised_ [IsUserId uid, InGroup adminGroup]+        NameAndContact name email <- expectAesonContent+        updateState userDetailsState (SetUserNameContact uid name email)+        noContent $ toResponse ()++    handlerDeleteUserNameContact :: DynamicPath -> ServerPartE Response+    handlerDeleteUserNameContact dpath = do+        uid <- lookupUserName =<< userNameInPath dpath+        guardAuthorised_ [IsUserId uid, InGroup adminGroup]+        updateState userDetailsState (SetUserNameContact uid T.empty T.empty)+        noContent $ toResponse ()++    handlerGetAdminInfo :: DynamicPath -> ServerPartE Response+    handlerGetAdminInfo dpath = do+        guardAuthorised_ [InGroup adminGroup]+        uid <- lookupUserName =<< userNameInPath dpath+        udetails <- queryUserDetails uid+        return $ toResponse (Aeson.toJSON (render udetails))+      where+        render Nothing = AdminInfo Nothing T.empty+        render (Just (AccountDetails { accountKind, accountAdminNotes })) =+            AdminInfo {+              ui_accountKind = accountKind,+              ui_notes       = accountAdminNotes+            }++    handlerPutAdminInfo :: DynamicPath -> ServerPartE Response+    handlerPutAdminInfo dpath = do+        guardAuthorised_ [InGroup adminGroup]+        uid <- lookupUserName =<< userNameInPath dpath+        AdminInfo akind notes <- expectAesonContent+        updateState userDetailsState (SetUserAdminInfo uid akind notes)+        noContent $ toResponse ()++    handlerDeleteAdminInfo :: DynamicPath -> ServerPartE Response+    handlerDeleteAdminInfo dpath = do+        guardAuthorised_ [InGroup adminGroup]+        uid <- lookupUserName =<< userNameInPath dpath+        updateState userDetailsState (SetUserAdminInfo uid Nothing T.empty)+        noContent $ toResponse ()+++data NameAndContact = NameAndContact { ui_name  :: Text, ui_contactEmailAddress :: Text }+data AdminInfo      = AdminInfo      { ui_accountKind :: Maybe AccountKind, ui_notes :: Text }+++#if MIN_VERSION_aeson(0,6,2)+$(deriveJSON defaultOptions{fieldLabelModifier = drop 3} ''NameAndContact)+$(deriveJSON defaultOptions{fieldLabelModifier = drop 3} ''AdminInfo)+$(deriveJSON defaultOptions                              ''AccountKind)+#else+$(deriveJSON (drop 3) ''NameAndContact)+$(deriveJSON (drop 3) ''AdminInfo)+$(deriveJSON id       ''AccountKind)+#endif
+ Distribution/Server/Features/UserSignup.hs view
@@ -0,0 +1,655 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving,+   TypeFamilies, TemplateHaskell,+   RankNTypes, NamedFieldPuns, RecordWildCards, BangPatterns #-}+module Distribution.Server.Features.UserSignup (+    initUserSignupFeature,+    UserSignupFeature(..),+  ) where++import Distribution.Server.Framework+import Distribution.Server.Framework.Templating+import Distribution.Server.Framework.BackupDump+import Distribution.Server.Framework.BackupRestore++import Distribution.Server.Features.Users+import Distribution.Server.Features.UserDetails++import Distribution.Server.Users.Types+import qualified Distribution.Server.Users.Users as Users++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS -- Only used for ASCII data+import qualified Data.ByteString.Base16 as Base16+import Data.Char (isSpace, isPrint, isAlphaNum)++import Data.Typeable (Typeable)+import Control.Monad.Reader (ask)+import Control.Monad.State (get, put)+import Data.SafeCopy (base, deriveSafeCopy)++import Distribution.Text (display)+import Data.Time (UTCTime, getCurrentTime)+import Text.CSV (CSV, Record)+import System.IO+import Network.Mail.Mime+import Network.URI (URI(..), URIAuth(..))+++-- | A feature to allow open account signup, and password reset,+-- both with email confirmation.+--+data UserSignupFeature = UserSignupFeature {+    userSignupFeatureInterface :: HackageFeature+}++instance IsHackageFeature UserSignupFeature where+  getFeatureInterface = userSignupFeatureInterface+++-----------------+-- Signup flow:+--+-- GET  account request page+-- POST account request, including username and email+--      suitable fail if username taken+--      does not yet create or reserve the account+--      makes entry in signup table, with random nonce+--      send email to user with link to account confirm+-- GET  account confirm page (with nonce in url)+-- POST account confirm (with nonce in url)+--      finally create account.+--+--+-- Reset flow:+--+-- GET  password reset request page+-- POST username and email+--      makes entry in reset table, with random nonce+--      send email to user with link to reset+-- GET  password change page (with nonce in url)+-- POST password change (with nonce in url)+--      set new password+--++-------------------------+-- Types of stored data+--++data SignupResetInfo = SignupInfo {+                         signupUserName     :: !Text,+                         signupRealName     :: !Text,+                         signupContactEmail :: !Text,+                         nonceTimestamp     :: !UTCTime+                       }+                     | ResetInfo {+                         resetUserId        :: !UserId,+                         nonceTimestamp     :: !UTCTime+                     }+  deriving (Eq, Show, Typeable)++newtype SignupResetTable = SignupResetTable (Map Nonce SignupResetInfo)+  deriving (Eq, Show, Typeable, MemSize)++newtype Nonce = Nonce ByteString+  deriving (Eq, Ord, Show, Typeable, MemSize)++emptySignupResetTable :: SignupResetTable+emptySignupResetTable = SignupResetTable Map.empty++instance MemSize SignupResetInfo where+    memSize (SignupInfo a b c d) = memSize4 a b c d+    memSize (ResetInfo  a b)     = memSize2 a b++$(deriveSafeCopy 0 'base ''SignupResetInfo)+$(deriveSafeCopy 0 'base ''SignupResetTable)+$(deriveSafeCopy 0 'base ''Nonce)++------------------------------+-- Nonces+--++newRandomNonce :: IO Nonce+newRandomNonce = do+  raw <- withFile "/dev/urandom" ReadMode $ \h ->+           BS.hGet h 10+  return $! Nonce (Base16.encode raw)++renderNonce :: Nonce -> String+renderNonce (Nonce nonce) = BS.unpack nonce++------------------------------+-- State queries and updates+--++getSignupResetTable :: Query SignupResetTable SignupResetTable+getSignupResetTable = ask++replaceSignupResetTable :: SignupResetTable -> Update SignupResetTable ()+replaceSignupResetTable = put++lookupSignupResetInfo :: Nonce -> Query SignupResetTable (Maybe SignupResetInfo)+lookupSignupResetInfo nonce = do+    SignupResetTable tbl <- ask+    return $! Map.lookup nonce tbl++addSignupResetInfo :: Nonce -> SignupResetInfo -> Update SignupResetTable Bool+addSignupResetInfo nonce info = do+    SignupResetTable tbl <- get+    if not (Map.member nonce tbl)+      then do put $! SignupResetTable (Map.insert nonce info tbl)+              return True+      else return False+++deleteSignupResetInfo :: Nonce -> Update SignupResetTable ()+deleteSignupResetInfo nonce = do+    SignupResetTable tbl <- get+    put $! SignupResetTable (Map.delete nonce tbl)++makeAcidic ''SignupResetTable [+    --queries+    'getSignupResetTable,+    'lookupSignupResetInfo,+    --updates+    'replaceSignupResetTable,+    'addSignupResetInfo,+    'deleteSignupResetInfo+  ]+++---------------------+-- State components+--++signupResetStateComponent :: FilePath -> IO (StateComponent AcidState SignupResetTable)+signupResetStateComponent stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> "UserSignupReset") emptySignupResetTable+  return StateComponent {+      stateDesc    = "State to keep track of outstanding requests for user signup and password resets"+    , stateHandle  = st+    , getState     = query st GetSignupResetTable+    , putState     = update st . ReplaceSignupResetTable+    , backupState  = \tbl -> [csvToBackup ["signups.csv"] (signupInfoToCSV tbl)+                             ,csvToBackup ["resets.csv"]  (resetInfoToCSV  tbl)]+    , restoreState = signupResetBackup+    , resetState   = signupResetStateComponent+    }++----------------------------+-- Data backup and restore+--++signupResetBackup :: RestoreBackup SignupResetTable+signupResetBackup = go []+  where+   go :: [(Nonce, SignupResetInfo)] -> RestoreBackup SignupResetTable+   go st =+     RestoreBackup {+       restoreEntry = \entry -> case entry of+         BackupByteString ["signups.csv"] bs -> do+           csv <- importCSV "signups.csv" bs+           signups <- importSignupInfo csv+           return (go (signups ++ st))++         BackupByteString ["resets.csv"] bs -> do+           csv <- importCSV "resets.csv" bs+           resets <- importResetInfo csv+           return (go (resets ++ st))++         _ -> return (go st)++     , restoreFinalize =+        return (SignupResetTable (Map.fromList st))+     }++importSignupInfo :: CSV -> Restore [(Nonce, SignupResetInfo)]+importSignupInfo = sequence . map fromRecord . drop 2+  where+    fromRecord :: Record -> Restore (Nonce, SignupResetInfo)+    fromRecord [nonceStr, usernameStr, realnameStr, emailStr, timestampStr] = do+        timestamp <- parseUTCTime "timestamp" timestampStr+        let nonce      = Nonce (BS.pack nonceStr)+            signupinfo = SignupInfo {+              signupUserName     = T.pack usernameStr,+              signupRealName     = T.pack realnameStr,+              signupContactEmail = T.pack emailStr,+              nonceTimestamp     = timestamp+            }+        return (nonce, signupinfo)+    fromRecord x = fail $ "Error processing signup info record: " ++ show x++signupInfoToCSV :: SignupResetTable -> CSV+signupInfoToCSV (SignupResetTable tbl)+    = ["0.1"]+    : [ "token", "username", "realname", "email", "timestamp" ]+    : [ [ renderNonce nonce+        , T.unpack signupUserName+        , T.unpack signupRealName+        , T.unpack signupContactEmail+        , formatUTCTime nonceTimestamp+        ]+      | (nonce, SignupInfo{..}) <- Map.toList tbl ]++importResetInfo :: CSV -> Restore [(Nonce, SignupResetInfo)]+importResetInfo = sequence . map fromRecord . drop 2+  where+    fromRecord :: Record -> Restore (Nonce, SignupResetInfo)+    fromRecord [nonceStr, useridStr, timestampStr] = do+        userid <- parseText "userid" useridStr+        timestamp <- parseUTCTime "timestamp" timestampStr+        let nonce      = Nonce (BS.pack nonceStr)+            signupinfo = ResetInfo {+              resetUserId    = userid,+              nonceTimestamp = timestamp+            }+        return (nonce, signupinfo)+    fromRecord x = fail $ "Error processing signup info record: " ++ show x++resetInfoToCSV :: SignupResetTable -> CSV+resetInfoToCSV (SignupResetTable tbl)+    = ["0.1"]+    : [ "token", "userid", "timestamp" ]+    : [ [ renderNonce nonce+        , display resetUserId+        , formatUTCTime nonceTimestamp+        ]+      | (nonce, ResetInfo{..}) <- Map.toList tbl ]+++----------------------------------------+-- Feature definition & initialisation+--++initUserSignupFeature :: ServerEnv+                      -> UserFeature+                      -> UserDetailsFeature+                      -> IO UserSignupFeature+initUserSignupFeature env@ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode}+                      users userdetails = do++  -- Canonical state+  signupResetState <- signupResetStateComponent serverStateDir++  -- Page templates+  templates <- loadTemplates serverTemplatesMode+                 [serverTemplatesDir, serverTemplatesDir </> "UserSignupReset"]+                 [ "SignupRequest", "SignupConfirmationEmail"+                 , "SignupEmailSent", "SignupConfirm"+                 , "ResetRequest", "ResetConfirmationEmail"+                 , "ResetEmailSent", "ResetConfirm" ]++  let feature = userSignupFeature env users userdetails+                                  signupResetState templates++  return feature+++userSignupFeature :: ServerEnv+                  -> UserFeature+                  -> UserDetailsFeature+                  -> StateComponent AcidState SignupResetTable+                  -> Templates+                  -> UserSignupFeature+userSignupFeature ServerEnv{serverBaseURI} UserFeature{..} UserDetailsFeature{..}+                  signupResetState templates+  = UserSignupFeature {..}++  where+    userSignupFeatureInterface = (emptyHackageFeature "user-signup-reset") {+        featureDesc      = "Extra information about user accounts, email addresses etc."+      , featureResources = [signupRequestsResource,+                            signupRequestResource,+                            resetRequestsResource,+                            resetRequestResource]+      , featureState     = [abstractAcidStateComponent signupResetState]+      , featureCaches    = []+      }++    -- Resources+    --++    signupRequestsResource =+      (resourceAt "/users/register-request") {+        resourceDesc = [ (GET,  "Page to let you make a request for an account")+                       , (POST, "Create a new account signup request") ]+      , resourceGet  = [ ("", handlerGetSignupRequestNew) ]+      , resourcePost = [ ("", handlerPostSignupRequestNew) ]+      }++    signupRequestResource =+      (resourceAt "/users/register-request/:nonce") {+        resourceDesc = [ (GET,  "Page for confirming outstanding signup request")+                       , (POST, "Confirm signup request and create the new account") ]+      , resourceGet  = [ ("", handlerGetSignupRequestOutstanding) ]+      , resourcePost = [ ("", handlerPostSignupRequestOutstanding) ]+      }++    resetRequestsResource =+      (resourceAt "/users/password-reset") {+        resourceDesc = [ (GET,  "Page to let you make a request for a password reset")+                       , (POST, "Create a new password reset request") ]+      , resourceGet  = [ ("", handlerGetResetRequestNew) ]+      , resourcePost = [ ("", handlerPostResetRequestNew) ]+      }++    resetRequestResource =+      (resourceAt "/users/password-reset/:nonce") {+        resourceDesc = [ (GET,  "Page for confirming password reset request and entering new password")+                       , (POST, "Confirm password reset and set new password") ]+      , resourceGet  = [ ("", handlerGetResetRequestOutstanding) ]+      , resourcePost = [ ("", handlerPostResetRequestOutstanding) ]+      }+++    -- Queries and updates+    --++    querySignupInfo :: Nonce -> MonadIO m => m (Maybe SignupResetInfo)+    querySignupInfo nonce =+            queryState signupResetState (LookupSignupResetInfo nonce)+        >>= return . justSignupInfo+      where+        justSignupInfo (Just info@SignupInfo{}) = Just info+        justSignupInfo _                        = Nothing++    queryResetInfo :: Nonce -> MonadIO m => m (Maybe SignupResetInfo)+    queryResetInfo nonce =+            queryState signupResetState (LookupSignupResetInfo nonce)+        >>= return . justResetInfo+      where+        justResetInfo (Just info@ResetInfo{}) = Just info+        justResetInfo _                       = Nothing++    updateAddSignupResetInfo :: Nonce -> SignupResetInfo -> MonadIO m => m Bool+    updateAddSignupResetInfo nonce signupInfo =+        updateState signupResetState (AddSignupResetInfo nonce signupInfo)++    updateDeleteSignupResetInfo :: Nonce -> MonadIO m => m ()+    updateDeleteSignupResetInfo nonce =+        updateState signupResetState (DeleteSignupResetInfo nonce)++    -- Request handlers+    --++    nonceInPath :: MonadPlus m => DynamicPath -> m Nonce+    nonceInPath dpath = maybe mzero return (Nonce . BS.pack <$> lookup "nonce" dpath)++    lookupSignupInfo :: Nonce -> ServerPartE SignupResetInfo+    lookupSignupInfo nonce = querySignupInfo nonce+                         >>= maybe (errNoNonce "account signup") return++    lookupResetInfo :: Nonce -> ServerPartE SignupResetInfo+    lookupResetInfo nonce = queryResetInfo nonce+                        >>= maybe (errNoNonce "password reset") return++    errNoNonce thing = errNotFound "Not found"+      [MText $ "The " ++ thing ++ " token does not exist. It could be that it "+            ++ "has been used already, or that it has expired."]++    handlerGetSignupRequestNew :: DynamicPath -> ServerPartE Response+    handlerGetSignupRequestNew _ = do+        template <- getTemplate templates "SignupRequest"+        ok $ toResponse $ template []++    handlerPostSignupRequestNew :: DynamicPath -> ServerPartE Response+    handlerPostSignupRequestNew _ = do+        templateEmail        <- getTemplate templates "SignupConfirmationEmail"+        templateConfirmation <- getTemplate templates "SignupEmailSent"++        (username, realname, useremail) <- lookUserNameEmail++        nonce     <- liftIO newRandomNonce+        timestamp <- liftIO getCurrentTime+        let signupInfo = SignupInfo {+              signupUserName     = username,+              signupRealName     = realname,+              signupContactEmail = useremail,+              nonceTimestamp     = timestamp+            }++        let mailFrom = Address (Just (T.pack "Hackage website"))+                               (T.pack ("noreply@" ++ uriRegName ourHost))+            mail     = (emptyMail mailFrom) {+              mailTo      = [Address (Just realname) useremail],+              mailHeaders = [(BS.pack "Subject",+                              T.pack "Hackage account confirmation")],+              mailParts   = [[Part (T.pack "text/plain; charset=utf-8")+                                    None Nothing [] mailBody]]+            }+            mailBody = renderTemplate $ templateEmail+              [ "realname"    $= realname+              , "confirmlink" $= show serverBaseURI {+                                   uriPath = "/users/register-request/"+                                          ++ renderNonce nonce+                                 }+              , "serverhost"  $= show serverBaseURI+              ]+            Just ourHost = uriAuthority serverBaseURI++        updateAddSignupResetInfo nonce signupInfo++        liftIO $ renderSendMail mail --TODO: if we need any configuration of+                                     -- sendmail stuff, has to go here++        resp 202 $ toResponse $+          templateConfirmation+            [ "useremail" $= useremail ]+      where+        lookUserNameEmail = do+          (username, realname, useremail) <-+            msum [ body $ (,,) <$> lookText' "username"+                               <*> lookText' "realname"+                               <*> lookText' "email"+                 , errBadRequest "Missing form fields" [] ]++          guardValidLookingUserName username+          guardValidLookingName     realname+          guardValidLookingEmail    useremail++          return (username, realname, useremail)++        guardValidLookingName str = either errBadUserName return $ do+          guard (T.length str <= 70) ?! "Sorry, we didn't expect names to be longer than 70 characters."+          guard (T.all isPrint str)  ?! "Unexpected character in name, please use only printable Unicode characters."++        guardValidLookingUserName str = either errBadRealName return $ do+          guard (T.length str <= 50)    ?! "Sorry, we didn't expect login names to be longer than 50 characters."+          guard (T.all isAsciiChar str) ?! "Sorry, login names have to be ASCII characters only, no spaces or symbols."+          where+            isAsciiChar c = c < '\127' && isAlphaNum c++        guardValidLookingEmail str = either errBadEmail return $ do+          guard (T.length str <= 100)     ?! "Sorry, we didn't expect email addresses to be longer than 100 characters."+          guard (T.all isPrint str)       ?! "Unexpected character in email address, please use only printable Unicode characters."+          guard hasAtSomewhere            ?! "Oops, that doesn't look like an email address."+          guard (T.all (not.isSpace) str) ?! "Oops, no spaces in email addresses please."+          guard (T.all (not.isAngle) str) ?! "Please use just the email address, not \"name\" <person@example.com> style."+          where+            isAngle c = c == '<' || c == '>'+            hasAtSomewhere =+              let (before, after) = T.span (/= '@') str+               in T.length before >= 1+               && T.length after  >  1++        errBadUserName err = errBadRequest "Problem with login name" [MText err]+        errBadRealName err = errBadRequest "Problem with name"[MText err]+        errBadEmail    err = errBadRequest "Problem with email address" [MText err]+++    handlerGetSignupRequestOutstanding :: DynamicPath -> ServerPartE Response+    handlerGetSignupRequestOutstanding dpath = do+        nonce <- nonceInPath dpath+        SignupInfo {..} <- lookupSignupInfo nonce+        template <- getTemplate templates "SignupConfirm"+        resp 202 $ toResponse $+          template+            [ "realname"  $= signupRealName+            , "username"  $= signupUserName+            , "useremail" $= signupContactEmail+            , "posturl"   $= renderResource signupRequestResource+                                [renderNonce nonce]+            ]++    handlerPostSignupRequestOutstanding :: DynamicPath -> ServerPartE Response+    handlerPostSignupRequestOutstanding dpath = do+        nonce <- nonceInPath dpath+        SignupInfo {..} <- lookupSignupInfo nonce+        (passwd, passwdRepeat) <- lookPasswd+        when (passwd /= passwdRepeat) errPasswdMismatch+        updateDeleteSignupResetInfo nonce+        timenow <- liftIO getCurrentTime+        let username    = UserName (T.unpack signupUserName)+            userauth    = newUserAuth username (PasswdPlain passwd)+            acctDetails = AccountDetails {+              accountName         = signupRealName,+              accountContactEmail = signupContactEmail,+              accountKind         = Just AccountKindRealUser,+              accountAdminNotes   = T.pack $ "Account created by "+                                          ++ "self-registration at "+                                          ++ show timenow+            }+        uid <- updateAddUser username userauth+           >>= either errNameClash return+        updateUserDetails uid acctDetails+        seeOther (userPageUri userResource "" username) (toResponse ())+      where+        lookPasswd = body $ (,) <$> look "password"+                                <*> look "repeat-password"+        errPasswdMismatch =+          errBadRequest "Password mismatch"+            [MText $ "The two copies of the password did not match. "+                  ++ "Check and try again."]+        errNameClash Users.ErrUserNameClash =+          errBadRequest "Account login name already taken"+            [MText $ "Sorry! In the time between requesting the account and "+                  ++ "now, the login username was registered by someone else. "+                  ++ "You can make a new account request at "+            ,MLink "/users/signup-request" "/users/signup-request"]++    -- Password reset handlers++    handlerGetResetRequestNew :: DynamicPath -> ServerPartE Response+    handlerGetResetRequestNew _ = do+        template <- getTemplate templates "ResetRequest"+        ok $ toResponse $ template []++    handlerPostResetRequestNew :: DynamicPath -> ServerPartE Response+    handlerPostResetRequestNew _ = do+        templateEmail        <- getTemplate templates "ResetConfirmationEmail"+        templateConfirmation <- getTemplate templates "ResetEmailSent"++        (supplied_username, supplied_useremail) <- lookUserNameEmail+        (uid, uinfo) <- lookupUserNameFull supplied_username+        mudetails    <- queryUserDetails uid++        guardEmailMatches mudetails supplied_useremail+        AccountDetails{..} <- guardSuitableAccountType uinfo mudetails++        nonce     <- liftIO newRandomNonce+        timestamp <- liftIO getCurrentTime+        let resetInfo = ResetInfo {+              resetUserId    = uid,+              nonceTimestamp = timestamp+            }+        let mailFrom = Address (Just (T.pack "Hackage website"))+                               (T.pack ("noreply@" ++ uriRegName ourHost))+            mail     = (emptyMail mailFrom) {+              mailTo      = [Address (Just accountName) accountContactEmail],+              mailHeaders = [(BS.pack "Subject",+                              T.pack "Hackage password reset confirmation")],+              mailParts   = [[Part (T.pack "text/plain; charset=utf-8")+                                    None Nothing [] mailBody]]+            }+            mailBody = renderTemplate $ templateEmail+              [ "realname"    $= accountName+              , "confirmlink" $= show serverBaseURI {+                                   uriPath = "/users/password-reset/"+                                          ++ renderNonce nonce+                                 }+              , "serverhost"  $= show serverBaseURI+              ]+            Just ourHost = uriAuthority serverBaseURI++        updateAddSignupResetInfo nonce resetInfo++        liftIO $ renderSendMail mail --TODO: if we need any configuration of+                                     -- sendmail stuff, has to go here++        resp 202 $ toResponse $+          templateConfirmation+            [ "useremail" $= accountContactEmail ]+      where+        lookUserNameEmail :: ServerPartE (UserName, Text)+        lookUserNameEmail =+          msum [ body $ (,) <$> (UserName <$> look "username")+                            <*> lookText' "email"+               , errBadRequest "Missing form fields" [] ]++        guardEmailMatches (Just AccountDetails {accountContactEmail}) useremail+          | accountContactEmail == useremail = return ()+        guardEmailMatches _ _ =+          errForbidden "Wrong account details"+            [MText "Sorry, that does not match any account details we have on file."]++    guardSuitableAccountType (UserInfo { userStatus = AccountEnabled{} })+                             (Just udetails@AccountDetails {+                               accountKind = Just AccountKindRealUser+                              }) = return udetails+    guardSuitableAccountType _ _ =+      errForbidden "Cannot reset password for this account"+        [MText $ "Sorry, the self-service password reset system cannot be "+              ++ "used for this account at this time."]+++    handlerGetResetRequestOutstanding :: DynamicPath -> ServerPartE Response+    handlerGetResetRequestOutstanding dpath = do+        nonce                    <- nonceInPath dpath+        ResetInfo{resetUserId}   <- lookupResetInfo nonce+        uinfo@UserInfo{userName} <- lookupUserInfo resetUserId+        mudetails                <- queryUserDetails resetUserId+        AccountDetails{..}       <- guardSuitableAccountType uinfo mudetails++        template <- getTemplate templates "ResetConfirm"+        resp 202 $ toResponse $+          template+            [ "realname"  $= accountName+            , "username"  $= display userName+            , "useremail" $= accountContactEmail+            , "posturl"   $= renderResource resetRequestResource+                                [renderNonce nonce]+            ]++    handlerPostResetRequestOutstanding :: DynamicPath -> ServerPartE Response+    handlerPostResetRequestOutstanding dpath = do+        nonce                    <- nonceInPath dpath+        ResetInfo{resetUserId}   <- lookupResetInfo nonce+        uinfo@UserInfo{userName} <- lookupUserInfo resetUserId+        mudetails                <- queryUserDetails resetUserId+        AccountDetails{..}       <- guardSuitableAccountType uinfo mudetails++        (passwd, passwdRepeat) <- lookPasswd+        when (passwd /= passwdRepeat) errPasswdMismatch++        let userauth = newUserAuth userName (PasswdPlain passwd)++        updateDeleteSignupResetInfo nonce+        updateSetUserAuth resetUserId userauth >>= maybe (return ()) errDeleted+        --TODO: confirmation page?+        seeOther (userPageUri userResource "" userName) (toResponse ())+      where+        lookPasswd = body $ (,) <$> look "password"+                                <*> look "repeat-password"+        errPasswdMismatch =+          errBadRequest "Password mismatch"+            [MText $ "The two copies of the password did not match. "+                  ++ "Check and try again."]++        errDeleted (Right Users.ErrDeletedUser) =+          errForbidden "Account deleted"+            [MText "Cannot set a new password as the user account has just been deleted."]+        errDeleted (Left Users.ErrNoSuchUserId) =+          errInternalError [MText "No such user id!"]
+ Distribution/Server/Features/Users.hs view
@@ -0,0 +1,641 @@+{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, DoRec, BangPatterns, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Distribution.Server.Features.Users (+    initUserFeature,+    UserFeature(..),+    UserResource(..),++    GroupResource(..),+  ) where++import Distribution.Server.Framework+import Distribution.Server.Framework.BackupDump+import qualified Distribution.Server.Framework.Auth as Auth++import Distribution.Server.Users.Types+import Distribution.Server.Users.State+import Distribution.Server.Users.Backup+import qualified Distribution.Server.Users.Users as Users+import qualified Distribution.Server.Users.Group as Group+import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), UserList, nullDescription)++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Maybe (fromMaybe)+import Data.Function (fix)+import Control.Applicative (optional)+import Data.Aeson (Value(..))+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Vector         as Vector+import qualified Data.Text           as Text++import Distribution.Text (display, simpleParse)+++-- | A feature to allow manipulation of the database of users.+--+data UserFeature = UserFeature {+    userFeatureInterface :: HackageFeature,++    userResource :: UserResource,++    userAdded :: Hook () (), --TODO: delete, other status changes?+    adminGroup :: UserGroup,++    -- Authorisation+    guardAuthorised_   :: [PrivilegeCondition] -> ServerPartE (),+    guardAuthorised    :: [PrivilegeCondition] -> ServerPartE UserId,+    guardAuthenticated :: ServerPartE UserId,+    authFailHook       :: Hook Auth.AuthError (Maybe ErrorResponse),++    queryGetUserDb    :: forall m. MonadIO m => m Users.Users,++    newUserAuth       :: UserName -> PasswdPlain -> UserAuth,+    updateAddUser     :: forall m. MonadIO m => UserName -> UserAuth -> m (Either Users.ErrUserNameClash UserId),+    updateSetUserEnabledStatus :: MonadIO m => UserId -> Bool+                               -> m (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser)),+    updateSetUserAuth :: MonadIO m => UserId -> UserAuth+                      -> m (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser)),++    groupAddUser        :: UserGroup -> DynamicPath -> ServerPartE (),+    groupDeleteUser     :: UserGroup -> DynamicPath -> ServerPartE (),++    userNameInPath      :: forall m. MonadPlus m => DynamicPath -> m UserName,+    lookupUserName      :: UserName -> ServerPartE UserId,+    lookupUserNameFull  :: UserName -> ServerPartE (UserId, UserInfo),+    lookupUserInfo      :: UserId -> ServerPartE UserInfo,++    changePassword      :: UserName -> ServerPartE (),+    canChangePassword   :: forall m. MonadIO m => UserId -> UserId -> m Bool,+    newUserWithAuth     :: String -> PasswdPlain -> PasswdPlain -> ServerPartE UserName,+    adminAddUser        :: ServerPartE Response,+    enabledAccount      :: UserName -> ServerPartE (),+    deleteAccount       :: UserName -> ServerPartE (),+    groupResourceAt     :: String -> UserGroup -> IO (UserGroup, GroupResource),+    groupResourcesAt    :: forall a. String -> (a -> UserGroup)+                                            -> (a -> DynamicPath)+                                            -> (DynamicPath -> ServerPartE a)+                                            -> [a]+                                            -> IO (a -> UserGroup, GroupResource),+    lookupGroupEditAuth :: UserGroup -> ServerPartE (Bool, Bool),+    getGroupIndex       :: forall m. (Functor m, MonadIO m) => UserId -> m [String],+    getIndexDesc        :: forall m. MonadIO m => String -> m GroupDescription+}++instance IsHackageFeature UserFeature where+  getFeatureInterface = userFeatureInterface++data UserResource = UserResource {+    userList :: Resource,+    userPage :: Resource,+    passwordResource :: Resource,+    enabledResource  :: Resource,+    adminResource :: GroupResource,++    userListUri :: String -> String,+    userPageUri :: String -> UserName -> String,+    userPasswordUri :: String -> UserName -> String,+    userEnabledUri  :: String -> UserName -> String,+    adminPageUri :: String -> String+}++instance FromReqURI UserName where+  fromReqURI = simpleParse++data GroupResource = GroupResource {+    groupResource :: Resource,+    groupUserResource :: Resource,+    getGroup :: DynamicPath -> ServerPartE UserGroup+}++-- This is a mapping of UserId -> group URI and group URI -> description.+-- Like many reverse mappings, it is probably rather volatile. Still, it is+-- a secondary concern, as user groups should be defined by each feature+-- and not global, to be perfectly modular.+data GroupIndex = GroupIndex {+    usersToGroupUri :: !(IntMap (Set String)),+    groupUrisToDesc :: !(Map String GroupDescription)+}+emptyGroupIndex :: GroupIndex+emptyGroupIndex = GroupIndex IntMap.empty Map.empty++instance MemSize GroupIndex where+    memSize (GroupIndex a b) = memSize2 a b++-- TODO: add renaming+initUserFeature :: ServerEnv -> IO UserFeature+initUserFeature ServerEnv{serverStateDir} = do++  -- Canonical state+  usersState  <- usersStateComponent  serverStateDir+  adminsState <- adminsStateComponent serverStateDir++  -- Ephemeral state+  groupIndex   <- newMemStateWHNF emptyGroupIndex++  -- Extension hooks+  userAdded     <- newHook+  authFailHook  <- newHook++  -- Slightly tricky: we have an almost recursive knot between the group+  -- resource management functions, and creating the admin group+  -- resource that is part of the user feature.+  --+  -- Instead of trying to pull it apart, we just use a 'do rec'+  --+  rec let (feature@UserFeature{groupResourceAt}, adminGroupDesc)+            = userFeature usersState+                          adminsState+                          groupIndex+                          userAdded authFailHook+                          adminG adminR++      (adminG, adminR) <- groupResourceAt "/users/admins/" adminGroupDesc++  return feature++usersStateComponent :: FilePath -> IO (StateComponent AcidState Users.Users)+usersStateComponent stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> "Users") initialUsers+  return StateComponent {+      stateDesc    = "List of users"+    , stateHandle  = st+    , getState     = query st GetUserDb+    , putState     = update st . ReplaceUserDb+    , backupState  = \users -> [csvToBackup ["users.csv"] (usersToCSV users)]+    , restoreState = userBackup+    , resetState   = usersStateComponent+    }++adminsStateComponent :: FilePath -> IO (StateComponent AcidState HackageAdmins)+adminsStateComponent stateDir = do+  st <- openLocalStateFrom (stateDir </> "db" </> "HackageAdmins") initialHackageAdmins+  return StateComponent {+      stateDesc    = "Admins"+    , stateHandle  = st+    , getState     = query st GetHackageAdmins+    , putState     = update st . ReplaceHackageAdmins . adminList+    , backupState  = \(HackageAdmins admins) -> [csvToBackup ["admins.csv"] (groupToCSV admins)]+    , restoreState = HackageAdmins <$> groupBackup ["admins.csv"]+    , resetState   = adminsStateComponent+    }++userFeature :: StateComponent AcidState Users.Users+            -> StateComponent AcidState HackageAdmins+            -> MemState GroupIndex+            -> Hook () ()+            -> Hook Auth.AuthError (Maybe ErrorResponse)+            -> UserGroup+            -> GroupResource+            -> (UserFeature, UserGroup)+userFeature  usersState adminsState+             groupIndex userAdded authFailHook+             adminGroup adminResource+  = (UserFeature {..}, adminGroupDesc)+  where+    userFeatureInterface = (emptyHackageFeature "users") {+        featureDesc = "Manipulate the user database."+      , featureResources =+          map ($ userResource)+            [ userList+            , userPage+            , passwordResource+            , enabledResource+            ]+          ++ [+              groupResource adminResource+            , groupUserResource adminResource+            ]+      , featureState = [+            abstractAcidStateComponent usersState+          , abstractAcidStateComponent adminsState+          ]+      , featureCaches = [+            CacheComponent {+              cacheDesc       = "user group index",+              getCacheMemSize = memSize <$> readMemState groupIndex+            }+          ]+      }++    userResource = fix $ \r -> UserResource {+        userList = (resourceAt "/users/.:format")+      , userPage = (resourceAt "/user/:username.:format") {+            resourceDesc   = [ (PUT,    "create user")+                             , (DELETE, "delete user")+                             ]+          , resourcePut    = [ ("", handleUserPut) ]+          , resourceDelete = [ ("", handleUserDelete) ]+          }+      , passwordResource = resourceAt "/user/:username/password.:format"+                           --TODO: PUT+      , enabledResource  = resourceAt "/user/:username/enabled.:format"+                           --TODO: GET & PUT+      , adminResource = adminResource++      , userListUri = \format ->+          renderResource (userList r) [format]+      , userPageUri = \format uname ->+          renderResource (userPage r) [display uname, format]+      , userPasswordUri = \format uname ->+          renderResource (passwordResource r) [display uname, format]+      , userEnabledUri  = \format uname ->+          renderResource (enabledResource  r) [display uname, format]+      , adminPageUri = \format ->+          renderResource (groupResource adminResource) [format]+      }+++    queryGetUserDb :: MonadIO m => m Users.Users+    queryGetUserDb = queryState usersState GetUserDb++    updateAddUser :: MonadIO m => UserName -> UserAuth -> m (Either Users.ErrUserNameClash UserId)+    updateAddUser uname auth = updateState usersState (AddUserEnabled uname auth)++    updateSetUserEnabledStatus :: MonadIO m => UserId -> Bool+                               -> m (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser))+    updateSetUserEnabledStatus uid isenabled = updateState usersState (SetUserEnabledStatus uid isenabled)++    updateSetUserAuth :: MonadIO m => UserId -> UserAuth+                      -> m (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser))+    updateSetUserAuth uid auth = updateState usersState (SetUserAuth uid auth)++    --+    -- Authorisation: authentication checks and privilege checks+    --+    guardAuthorised_ :: [PrivilegeCondition] -> ServerPartE ()+    guardAuthorised_ = void . guardAuthorised++    guardAuthorised :: [PrivilegeCondition] -> ServerPartE UserId+    guardAuthorised privconds = do+        users <- queryGetUserDb+        uid   <- guardAuthenticatedWithErrHook users+        Auth.guardPriviledged users uid privconds+        return uid++    guardAuthenticated :: ServerPartE UserId+    guardAuthenticated = do+        users   <- queryGetUserDb+        guardAuthenticatedWithErrHook users++    guardAuthenticatedWithErrHook :: Users.Users -> ServerPartE UserId+    guardAuthenticatedWithErrHook users = do+        (uid,_) <- Auth.checkAuthenticated realm users+                   >>= either handleAuthError return+        return uid+      where+        realm = Auth.hackageRealm --TODO: should be configurable++        handleAuthError :: Auth.AuthError -> ServerPartE a+        handleAuthError err = do+          defaultResponse  <- Auth.authErrorResponse realm err+          overrideResponse <- msum <$> runHook authFailHook err+          throwError (fromMaybe defaultResponse overrideResponse)++    -- result: either not-found, not-authenticated, or 204 (success)+    deleteAccount :: UserName -> ServerPartE ()+    deleteAccount uname = do+      void $ guardAuthorised [InGroup adminGroup]+      uid <- lookupUserName uname+      void $ updateState usersState (DeleteUser uid)++    -- result: not-found, not authenticated, or ok (success)+    enabledAccount :: UserName -> ServerPartE ()+    enabledAccount uname = do+      _        <- guardAuthorised [InGroup adminGroup]+      uid      <- lookupUserName uname+      enabled  <- optional $ look "enabled"+      -- for a checkbox, presence in data string means 'checked'+      let isenabled = maybe False (const True) enabled+      void $ updateState usersState (SetUserEnabledStatus uid isenabled)++    handleUserPut :: DynamicPath -> ServerPartE Response+    handleUserPut dpath = do+      _        <- guardAuthorised [InGroup adminGroup]+      username <- userNameInPath dpath+      muid     <- updateState usersState $ AddUserDisabled username+      case muid of+        -- the only possible error is that the user exists already+        -- but that's ok too+        Left  _ -> noContent $ toResponse ()+        Right _ -> noContent $ toResponse ()++    handleUserDelete :: DynamicPath -> ServerPartE Response+    handleUserDelete dpath = do+      _    <- guardAuthorised [InGroup adminGroup]+      uid  <- lookupUserName =<< userNameInPath dpath+      merr <- updateState usersState $ DeleteUser uid+      case merr of+        Nothing   -> noContent $ toResponse ()+        --TODO: need to be able to delete user by name to fix this race condition+        Just _err -> errInternalError [MText "uid does not exist (but lookup was sucessful)"]+++    -- | Resources representing the collection of known users.+    --+    -- Features:+    --+    -- * listing the collection of users+    -- * adding and deleting users+    -- * enabling and disabling accounts+    -- * changing user's name and password+    --++    userNameInPath :: forall m. MonadPlus m => DynamicPath -> m UserName+    userNameInPath dpath = maybe mzero return (simpleParse =<< lookup "username" dpath)++    lookupUserName :: UserName -> ServerPartE UserId+    lookupUserName = fmap fst . lookupUserNameFull++    lookupUserNameFull :: UserName -> ServerPartE (UserId, UserInfo)+    lookupUserNameFull uname = do+        users <- queryState usersState GetUserDb+        case Users.lookupUserName uname users of+          Just u  -> return u+          Nothing -> userLost "Could not find user: not presently registered"+      where userLost = errNotFound "User not found" . return . MText+            --FIXME: 404 is only the right error for operating on User resources+            -- not when users are being looked up for other reasons, like setting+            -- ownership of packages. In that case needs errBadRequest++    lookupUserInfo :: UserId -> ServerPartE UserInfo+    lookupUserInfo uid = do+        users <- queryState usersState GetUserDb+        case Users.lookupUserId uid users of+          Just uinfo -> return uinfo+          Nothing    -> errInternalError [MText "user id does not exist"]++    adminAddUser :: ServerPartE Response+    adminAddUser = do+        -- with this line commented out, self-registration is allowed+        guardAuthorised_ [InGroup adminGroup]+        reqData <- getDataFn lookUserNamePasswords+        case reqData of+            (Left errs) -> errBadRequest "Error registering user"+                       ((MText "Username, password, or repeated password invalid.") : map MText errs)+            (Right (ustr, pwd1, pwd2)) -> do+                uname <- newUserWithAuth ustr (PasswdPlain pwd1) (PasswdPlain pwd2)+                seeOther ("/user/" ++ display uname) (toResponse ())+       where lookUserNamePasswords = do+                 (,,) <$> look "username"+                      <*> look "password"+                      <*> look "repeat-password"++    newUserWithAuth :: String -> PasswdPlain -> PasswdPlain -> ServerPartE UserName+    newUserWithAuth _ pwd1 pwd2 | pwd1 /= pwd2 = errBadRequest "Error registering user" [MText "Entered passwords do not match"]+    newUserWithAuth userNameStr password _ =+      case simpleParse userNameStr of+        Nothing -> errBadRequest "Error registering user" [MText "Not a valid user name!"]+        Just uname -> do+          let auth = newUserAuth uname password+          muid <- updateState usersState $ AddUserEnabled uname auth+          case muid of+            Left Users.ErrUserNameClash -> errForbidden "Error registering user" [MText "A user account with that user name already exists."]+            Right _                     -> return uname++    -- Arguments: the auth'd user id, the user path id (derived from the :username)+    canChangePassword :: MonadIO m => UserId -> UserId -> m Bool+    canChangePassword uid userPathId = do+        admins <- queryState adminsState GetAdminList+        return $ uid == userPathId || (uid `Group.member` admins)++    --FIXME: this thing is a total mess!+    -- Do admins need to change user's passwords? Why not just reset passwords & (de)activate accounts.+    changePassword :: UserName -> ServerPartE ()+    changePassword username = do+        uid <- lookupUserName username+        guardAuthorised [IsUserId uid, InGroup adminGroup]+        passwd1 <- look "password"        --TODO: fail rather than mzero if missing+        passwd2 <- look "repeat-password"+        when (passwd1 /= passwd2) $+          forbidChange "Copies of new password do not match or is an invalid password (ex: blank)"+        let passwd = PasswdPlain passwd1+            auth   = newUserAuth username passwd+        res <- updateState usersState (SetUserAuth uid auth)+        case res of+          Nothing -> return ()+          Just (Left  Users.ErrNoSuchUserId) -> errInternalError [MText "user id lookup failure"]+          Just (Right Users.ErrDeletedUser)  -> forbidChange "Cannot set passwords for deleted users"+      where+        forbidChange = errForbidden "Error changing password" . return . MText++    newUserAuth :: UserName -> PasswdPlain -> UserAuth+    newUserAuth name pwd = UserAuth (Auth.newPasswdHash Auth.hackageRealm name pwd)++    ------ User group management+    adminGroupDesc :: UserGroup+    adminGroupDesc = UserGroup {+          groupDesc      = nullDescription { groupTitle = "Hackage admins" },+          queryUserList  = queryState adminsState GetAdminList,+          addUserList    = updateState adminsState . AddHackageAdmin,+          removeUserList = updateState adminsState . RemoveHackageAdmin,+          canAddGroup    = [adminGroupDesc],+          canRemoveGroup = [adminGroupDesc]+        }++    groupAddUser :: UserGroup -> DynamicPath -> ServerPartE ()+    groupAddUser group _ = do+        guardAuthorised_ (map InGroup (canAddGroup group))+        users <- queryState usersState GetUserDb+        muser <- optional $ look "user"+        case muser of+            Nothing -> addError "Bad request (could not find 'user' argument)"+            Just ustr -> case simpleParse ustr >>= \uname -> Users.lookupUserName uname users of+                Nothing      -> addError $ "No user with name " ++ show ustr ++ " found"+                Just (uid,_) -> liftIO $ addUserList group uid+       where addError = errBadRequest "Failed to add user" . return . MText++    groupDeleteUser :: UserGroup -> DynamicPath -> ServerPartE ()+    groupDeleteUser group dpath = do+      guardAuthorised_ (map InGroup (canRemoveGroup group))+      uid <- lookupUserName =<< userNameInPath dpath+      liftIO $ removeUserList group uid++    lookupGroupEditAuth :: UserGroup -> ServerPartE (Bool, Bool)+    lookupGroupEditAuth group = do+      addList    <- liftIO . Group.queryGroups $ canAddGroup group+      removeList <- liftIO . Group.queryGroups $ canRemoveGroup group+      uid <- guardAuthenticated+      let (canAdd, canDelete) = (uid `Group.member` addList, uid `Group.member` removeList)+      if not (canAdd || canDelete)+          then errForbidden "Forbidden" [MText "Can't edit permissions for user group"]+          else return (canAdd, canDelete)++    ------------ Encapsulation of resources related to editing a user group.++    -- | Registers a user group for external display. It takes the index group+    -- mapping (groupIndex from UserFeature), the base uri of the group, and a+    -- UserGroup object with all the necessary hooks. The base uri shouldn't+    -- contain any dynamic or varying components. It returns the GroupResource+    -- object, and also an adapted UserGroup that updates the cache. You should+    -- use this in order to keep the index updated.+    groupResourceAt :: String -> UserGroup -> IO (UserGroup, GroupResource)+    groupResourceAt uri group = do+        let mainr = resourceAt uri+            descr = groupDesc group+            groupUri = renderResource mainr []+            group' = group+              { addUserList = \uid -> do+                    addGroupIndex uid groupUri descr+                    addUserList group uid+              , removeUserList = \uid -> do+                    removeGroupIndex uid groupUri+                    removeUserList group uid+              }+        ulist <- queryUserList group+        initGroupIndex ulist groupUri descr+        let groupr = GroupResource {+                groupResource = (extendResourcePath "/.:format" mainr) {+                    resourceDesc = [ (GET, "Description of the group and a list of its members (defined in 'users' feature)") ]+                  , resourceGet  = [ ("json", handleUserGroupGet groupr) ]+                  }+              , groupUserResource = (extendResourcePath "/user/:username.:format" mainr) {+                    resourceDesc   = [ (PUT, "Add a user to the group (defined in 'users' feature)")+                                     , (DELETE, "Remove a user from the group (defined in 'users' feature)")+                                     ]+                  , resourcePut    = [ ("", handleUserGroupUserPut groupr) ]+                  , resourceDelete = [ ("", handleUserGroupUserDelete groupr) ]+                  }+              , getGroup = \_ -> return group'+              }+        return (group', groupr)++    -- | Registers a collection of user groups for external display. These groups+    -- are usually backing a separate collection. Like groupResourceAt, it takes the+    -- index group mapping and a base uri The base uri can contain varying path+    -- components, so there should be a group-generating function that, given a+    -- DynamicPath, yields the proper UserGroup. The final argument is the initial+    -- list of DynamicPaths to build the initial group index. Like groupResourceAt,+    -- this function returns an adaptor function that keeps the index updated.+    groupResourcesAt :: String+                     -> (a -> UserGroup)+                     -> (a -> DynamicPath)+                     -> (DynamicPath -> ServerPartE a)+                     -> [a]+                     -> IO (a -> UserGroup, GroupResource)+    groupResourcesAt uri mkGroup mkPath getGroupData initialGroupData = do+        let mainr = resourceAt uri+        sequence_+          [ do let group = mkGroup x+                   dpath = mkPath x+               ulist <- queryUserList group+               initGroupIndex ulist (renderResource' mainr dpath) (groupDesc group)+          | x <- initialGroupData ]++        let mkGroup' x =+              let group = mkGroup x+                  dpath = mkPath x+               in group {+                    addUserList = \uid -> do+                        addGroupIndex uid (renderResource' mainr dpath) (groupDesc group)+                        addUserList group uid+                  , removeUserList = \uid -> do+                        removeGroupIndex uid (renderResource' mainr dpath)+                        removeUserList group uid+                  }++            groupr = GroupResource {+                groupResource = (extendResourcePath "/.:format" mainr) {+                    resourceDesc = [ (GET, "Description of the group and a list of the members (defined in 'users' feature)") ]+                  , resourceGet  = [ ("json", handleUserGroupGet groupr) ]+                  }+              , groupUserResource = (extendResourcePath "/user/:username.:format" mainr) {+                    resourceDesc   = [ (PUT,    "Add a user to the group (defined in 'users' feature)")+                                     , (DELETE, "Delete a user from the group (defined in 'users' feature)")+                                     ]+                  , resourcePut    = [ ("", handleUserGroupUserPut groupr) ]+                  , resourceDelete = [ ("", handleUserGroupUserDelete groupr) ]+                  }+              , getGroup = \dpath -> mkGroup' <$> getGroupData dpath+              }+        return (mkGroup', groupr)++    handleUserGroupGet groupr dpath = do+      group    <- getGroup groupr dpath+      userDb   <- queryGetUserDb+      userlist <- liftIO $ queryUserList group+      let unames = [ Users.userIdToName userDb uid+                   | uid <- Group.enumerate userlist ]+      return . toResponse $+          object [+            ("title",       string $ groupTitle $ groupDesc group)+          , ("description", string $ groupPrologue $ groupDesc group)+          , ("members",     array [ string $ display uname+                                    | uname <- unames ])+          ]++    --TODO: add handleUserGroupUserPost for the sake of the html frontend+    --      and then remove groupAddUser & groupDeleteUser+    handleUserGroupUserPut groupr dpath = do+      group <- getGroup groupr dpath+      guardAuthorised_ (map InGroup (canAddGroup group))+      uid <- lookupUserName =<< userNameInPath dpath+      liftIO $ addUserList group uid+      goToList groupr dpath++    handleUserGroupUserDelete groupr dpath = do+      group <- getGroup groupr dpath+      guardAuthorised_ (map InGroup (canRemoveGroup group))+      uid <- lookupUserName =<< userNameInPath dpath+      liftIO $ removeUserList group uid+      goToList groupr dpath++    goToList group dpath = seeOther (renderResource' (groupResource group) dpath)+                                    (toResponse ())++    ---------------------------------------------------------------+    addGroupIndex :: MonadIO m => UserId -> String -> GroupDescription -> m ()+    addGroupIndex (UserId uid) uri desc =+        modifyMemState groupIndex $+          adjustGroupIndex+            (IntMap.insertWith Set.union uid (Set.singleton uri))+            (Map.insert uri desc)++    removeGroupIndex :: MonadIO m => UserId -> String -> m ()+    removeGroupIndex (UserId uid) uri =+        modifyMemState groupIndex $+          adjustGroupIndex+            (IntMap.update (keepSet . Set.delete uri) uid)+            id+      where+        keepSet m = if Set.null m then Nothing else Just m++    initGroupIndex :: MonadIO m => UserList -> String -> GroupDescription -> m ()+    initGroupIndex ulist uri desc =+        modifyMemState groupIndex $+          adjustGroupIndex+            (IntMap.unionWith Set.union (IntMap.fromList . map mkEntry $ Group.enumerate ulist))+            (Map.insert uri desc)+      where+        mkEntry (UserId uid) = (uid, Set.singleton uri)++    getGroupIndex :: (Functor m, MonadIO m) => UserId -> m [String]+    getGroupIndex (UserId uid) =+      liftM (maybe [] Set.toList . IntMap.lookup uid . usersToGroupUri) $ readMemState groupIndex++    getIndexDesc :: MonadIO m => String -> m GroupDescription+    getIndexDesc uri =+      liftM (Map.findWithDefault nullDescription uri . groupUrisToDesc) $ readMemState groupIndex++    -- partitioning index modifications, a cheap combinator+    adjustGroupIndex :: (IntMap (Set String) -> IntMap (Set String))+                     -> (Map String GroupDescription -> Map String GroupDescription)+                     -> GroupIndex -> GroupIndex+    adjustGroupIndex f g (GroupIndex a b) = GroupIndex (f a) (g b)++{------------------------------------------------------------------------------+  Some aeson auxiliary functions+------------------------------------------------------------------------------}++array :: [Value] -> Value+array = Array . Vector.fromList++object :: [(Text.Text, Value)] -> Value+object = Object . HashMap.fromList++string :: String -> Value+string = String . Text.pack
+ Distribution/Server/Framework.hs view
@@ -0,0 +1,54 @@+-- | Re-export the common parts of the server framework.+--+module Distribution.Server.Framework (++    module Happstack.Server,+    module Data.Acid,+    module Distribution.Server.Framework.MemState,+    module Distribution.Server.Framework.Cache,+    module Distribution.Server.Framework.MemSize,++    module Distribution.Server.Framework.Auth,+    module Distribution.Server.Framework.Feature,+    module Distribution.Server.Framework.ServerEnv,+    module Distribution.Server.Framework.Resource,+    module Distribution.Server.Framework.RequestContentTypes,+    module Distribution.Server.Framework.ResponseContentTypes,+    module Distribution.Server.Framework.Hook,+    module Distribution.Server.Framework.Error,+    module Distribution.Server.Framework.Logging,+    module Distribution.Server.Util.Happstack,++    module Data.Monoid,+    module Control.Applicative,+    module Control.Monad,+    module Control.Monad.Trans,+    module System.FilePath,++  ) where++import Happstack.Server++import Data.Acid+import Distribution.Server.Framework.MemState+import Distribution.Server.Framework.Cache+import Distribution.Server.Framework.MemSize++import Distribution.Server.Framework.Auth (PrivilegeCondition(..))+import Distribution.Server.Framework.Feature+import Distribution.Server.Framework.ServerEnv+import Distribution.Server.Framework.Resource+import Distribution.Server.Framework.RequestContentTypes+import Distribution.Server.Framework.ResponseContentTypes+import Distribution.Server.Framework.Hook+import Distribution.Server.Framework.Error+import Distribution.Server.Framework.Logging++import Distribution.Server.Util.Happstack+++import Data.Monoid (Monoid(..))+import Control.Applicative (Applicative(..), (<$>))+import Control.Monad+import Control.Monad.Trans (MonadIO, liftIO)+import System.FilePath ((</>), (<.>))
+ Distribution/Server/Framework/Auth.hs view
@@ -0,0 +1,349 @@+-- | Server methods to do user authentication.+--+-- We authenticate clients using HTTP Basic or Digest authentication and we+-- authorise users based on membership of particular user groups.+--+{-# LANGUAGE PatternGuards #-}+module Distribution.Server.Framework.Auth (+    -- * Checking authorisation+    guardAuthorised,++    -- ** Realms+    RealmName,+    hackageRealm,+    adminRealm,++    -- ** Creating password hashes+    newPasswdHash,+    UserName,+    PasswdPlain,+    PasswdHash,++    -- ** Special cases+    guardAuthenticated, checkAuthenticated,+    guardPriviledged,   checkPriviledged,+    PrivilegeCondition(..),++    -- ** Errors+    AuthError(..),+    authErrorResponse,+  ) where++import Distribution.Server.Users.Types (UserId, UserName(..), UserAuth(..), UserInfo)+import qualified Distribution.Server.Users.Types as Users+import qualified Distribution.Server.Users.Users as Users+import qualified Distribution.Server.Users.Group as Group+import Distribution.Server.Framework.AuthCrypt+import Distribution.Server.Framework.AuthTypes+import Distribution.Server.Framework.Error+import Distribution.Server.Util.Happstack (rqRealMethod)++import Happstack.Server++import Control.Monad.Trans (MonadIO, liftIO)+import qualified Data.ByteString.Char8 as BS -- Only used for Digest headers++import Control.Monad+import qualified Data.ByteString.Base64 as Base64+import Data.Char (intToDigit, isAsciiLower)+import System.Random (randomRs, newStdGen)+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Text.ParserCombinators.ReadP as Parse+import Data.Maybe (listToMaybe)+import Data.List  (intercalate)+++------------------------------------------------------------------------+-- Main auth methods+--++hackageRealm, adminRealm :: RealmName+hackageRealm = RealmName "Hackage"+adminRealm   = RealmName "Hackage admin"+++-- | Check that the client is authenticated and is authorised to perform some+-- priviledged action.+--+-- We check that:+--+--   * the client has supplied appropriate authentication credentials for a+--      known enabled user account;+--   * is a member of a given group of users who are permitted to perform+--     certain priviledged actions.+--+guardAuthorised :: RealmName -> Users.Users -> [PrivilegeCondition]+                -> ServerPartE UserId+guardAuthorised realm users privconds = do+    (uid, _) <- guardAuthenticated realm users+    guardPriviledged users uid privconds+    return uid+++-- | Check that the client is authenticated. Returns the information about the+-- user account that the client authenticates as.+--+-- This checks the client has supplied appropriate authentication credentials+-- for a known enabled user account.+--+-- It only checks the user is known, it does not imply that the user is+-- authorised to do anything in particular, see 'guardAuthorised'.+--+guardAuthenticated :: RealmName -> Users.Users -> ServerPartE (UserId, UserInfo)+guardAuthenticated realm users = do+    authres <- checkAuthenticated realm users+    case authres of+      Left  autherr -> throwError =<< authErrorResponse realm autherr+      Right info    -> return info++checkAuthenticated :: ServerMonad m => RealmName -> Users.Users -> m (Either AuthError (UserId, UserInfo))+checkAuthenticated realm users = do+    req <- askRq+    return $ case getHeaderAuth req of+      Just (BasicAuth,  ahdr) -> checkBasicAuth  users realm ahdr+      Just (DigestAuth, ahdr) -> checkDigestAuth users       ahdr req+      Nothing                 -> Left NoAuthError+  where+    getHeaderAuth :: Request -> Maybe (AuthType, BS.ByteString)+    getHeaderAuth req =+        case getHeader "authorization" req of+          Just hdr+            |  BS.isPrefixOf (BS.pack "Digest ") hdr+            -> Just (DigestAuth, BS.drop 7 hdr)++            |  BS.isPrefixOf (BS.pack "Basic ") hdr+            -> Just (BasicAuth,  BS.drop 6 hdr)+          _ -> Nothing++data AuthType = BasicAuth | DigestAuth+++data PrivilegeCondition = InGroup    Group.UserGroup+                        | IsUserId   UserId+                        | AnyKnownUser++-- | Check that a given user is permitted to perform certain priviledged+-- actions.+--+-- This is based on whether the user is a mamber of a particular group of+-- priviledged users.+--+-- It only checks if the user is in the priviledged user group, it does not+-- imply that the current client has been authenticated, see 'guardAuthorised'.+--+guardPriviledged :: Users.Users -> UserId -> [PrivilegeCondition] -> ServerPartE ()+guardPriviledged users uid privconds = do+  allok <- checkPriviledged users uid privconds+  when (not allok) $+    errForbidden "Forbidden" [MText "No access for this resource."]++checkPriviledged :: MonadIO m => Users.Users -> UserId -> [PrivilegeCondition] -> m Bool+checkPriviledged _users _uid [] = return False++checkPriviledged users uid (InGroup ugroup:others) = do+  uset <- liftIO $ Group.queryUserList ugroup+  if Group.member uid uset+    then return True+    else checkPriviledged users uid others++checkPriviledged users uid (IsUserId uid':others) =+  if uid == uid'+    then return True+    else checkPriviledged users uid others++checkPriviledged _ _ (AnyKnownUser:_) = return True+++------------------------------------------------------------------------+-- Basic auth method+--++-- | Use HTTP Basic auth to authenticate the client as an active enabled user.+--+checkBasicAuth :: Users.Users -> RealmName -> BS.ByteString+               -> Either AuthError (UserId, UserInfo)+checkBasicAuth users realm ahdr = do+    authInfo     <- getBasicAuthInfo realm ahdr       ?! UnrecognizedAuthError+    let uname    = basicUsername authInfo+    (uid, uinfo) <- Users.lookupUserName uname users  ?! NoSuchUserError uname+    uauth        <- getUserAuth uinfo                 ?! UserStatusError uid uinfo+    let passwdhash = getPasswdHash uauth+    guard (checkBasicAuthInfo passwdhash authInfo)    ?! PasswordMismatchError uid uinfo+    return (uid, uinfo)++getBasicAuthInfo :: RealmName -> BS.ByteString -> Maybe BasicAuthInfo+getBasicAuthInfo realm authHeader+  | Just (username, pass) <- splitHeader authHeader+  = Just BasicAuthInfo {+           basicRealm    = realm,+           basicUsername = UserName username,+           basicPasswd   = PasswdPlain pass+         }+  | otherwise = Nothing+  where+    splitHeader h = case Base64.decode h of+                    Left _ -> Nothing+                    Right xs ->+                        case break (':' ==) $ BS.unpack xs of+                        (username, ':' : pass) -> Just (username, pass)+                        _ -> Nothing++{-+We don't actually want to offer basic auth. It's not something we want to+encourage and some browsers (like firefox) end up prompting the user for+failing auth once for each auth method that the server offers. So if we offer+both digest and auth then the user gets prompted twice when they try to cancel+the auth.++Note that we still accept basic auth if the client offers it pre-emptively.++headerBasicAuthChallenge :: RealmName -> (String, String)+headerBasicAuthChallenge (RealmName realmName) =+    (headerName, headerValue)+  where+    headerName  = "WWW-Authenticate"+    headerValue = "Basic realm=\"" ++ realmName ++ "\""+-}++------------------------------------------------------------------------+-- Digest auth method+--++-- See RFC 2617 http://www.ietf.org/rfc/rfc2617++-- Digest auth TODO:+-- * support domain for the protection space (otherwise defaults to whole server)+-- * nonce generation is not ideal: consists just of a random number+-- * nonce is not checked+-- * opaque is not used++-- | Use HTTP Digest auth to authenticate the client as an active enabled user.+--+checkDigestAuth :: Users.Users -> BS.ByteString -> Request+                -> Either AuthError (UserId, UserInfo)+checkDigestAuth users ahdr req = do+    authInfo     <- getDigestAuthInfo ahdr req         ?! UnrecognizedAuthError+    let uname    = digestUsername authInfo+    (uid, uinfo) <- Users.lookupUserName uname users   ?! NoSuchUserError uname+    uauth        <- getUserAuth uinfo                  ?! UserStatusError uid uinfo+    let passwdhash = getPasswdHash uauth+    guard (checkDigestAuthInfo passwdhash authInfo)    ?! PasswordMismatchError uid uinfo+    -- TODO: if we want to prevent replay attacks, then we must check the+    -- nonce and nonce count and issue stale=true replies.+    return (uid, uinfo)++-- | retrieve the Digest auth info from the headers+--+getDigestAuthInfo :: BS.ByteString -> Request -> Maybe DigestAuthInfo+getDigestAuthInfo authHeader req = do+    authMap    <- parseDigestHeader authHeader+    username   <- Map.lookup "username" authMap+    nonce      <- Map.lookup "nonce"    authMap+    response   <- Map.lookup "response" authMap+    uri        <- Map.lookup "uri"      authMap+    let mb_qop  = Map.lookup "qop"      authMap+    qopInfo    <- case mb_qop of+                    Just "auth" -> do+                      nc     <- Map.lookup "nc"     authMap+                      cnonce <- Map.lookup "cnonce" authMap+                      return (QopAuth nc cnonce)+                    Nothing -> return QopNone+                    _       -> mzero+    return DigestAuthInfo {+       digestUsername = UserName username,+       digestNonce    = nonce,+       digestResponse = response,+       digestURI      = uri,+       digestRqMethod = show (rqRealMethod req),+       digestQoP      = qopInfo+    }+  where+    -- Parser derived from RFCs 2616 and 2617+    parseDigestHeader :: BS.ByteString -> Maybe (Map String String)+    parseDigestHeader =+        fmap Map.fromList . parse . BS.unpack+      where+        parse :: String -> Maybe [(String, String)]+        parse s = listToMaybe [ x | (x, "") <- Parse.readP_to_S parser s ]++        parser :: Parse.ReadP [(String, String)]+        parser = Parse.skipSpaces+              >> Parse.sepBy1 nameValuePair+                       (Parse.skipSpaces >> Parse.char ',' >> Parse.skipSpaces)++        nameValuePair = do+          theName <- Parse.munch1 isAsciiLower+          void $ Parse.char '='+          theValue <- quotedString+          return (theName, theValue)++        quotedString :: Parse.ReadP String+        quotedString =+          join Parse.between+               (Parse.char '"')+               (Parse.many $ (Parse.char '\\' >> Parse.get) Parse.<++ Parse.satisfy (/='"'))+              Parse.<++ (liftM2 (:) (Parse.satisfy (/='"')) (Parse.munch (/=',')))++headerDigestAuthChallenge :: RealmName -> IO (String, String)+headerDigestAuthChallenge (RealmName realmName) = do+    nonce <- liftIO generateNonce+    return (headerName, headerValue nonce)+  where+    headerName = "WWW-Authenticate"+    -- Note that offering both qop=\"auth,auth-int\" can confuse some browsers+    -- e.g. see http://code.google.com/p/chromium/issues/detail?id=45194+    -- TODO: can't even offer qop="auth" because the HTTP package does it wrong+    headerValue nonce =+      "Digest " +++      intercalate ", "+        [ "realm="     ++ inQuotes realmName+        , "qop="       ++ inQuotes ""+        , "nonce="     ++ inQuotes nonce+        , "opaque="    ++ inQuotes ""+        ]+    generateNonce = fmap (take 32 . map intToDigit . randomRs (0, 15)) newStdGen+    inQuotes s = '"' : s ++ ['"']+++------------------------------------------------------------------------+-- Common+--++getUserAuth :: UserInfo -> Maybe UserAuth+getUserAuth userInfo =+  case Users.userStatus userInfo of+    Users.AccountEnabled auth -> Just auth+    _                         -> Nothing++getPasswdHash :: UserAuth -> PasswdHash+getPasswdHash (UserAuth hash) = hash+++------------------------------------------------------------------------+-- Errors+--++data AuthError = NoAuthError+               | UnrecognizedAuthError+               | NoSuchUserError       UserName+               | UserStatusError       UserId UserInfo+               | PasswordMismatchError UserId UserInfo+  deriving Show++authErrorResponse :: MonadIO m => RealmName -> AuthError -> m ErrorResponse+authErrorResponse realm autherr = do+    digestHeader   <- liftIO (headerDigestAuthChallenge realm)+    return $! (toErrorResponse autherr) { errorHeaders = [digestHeader] }+  where+    toErrorResponse :: AuthError -> ErrorResponse+    toErrorResponse NoAuthError =+      ErrorResponse 401 [] "No authorization provided" []++    toErrorResponse UnrecognizedAuthError =+      ErrorResponse 400 [] "Authorization scheme not recognized" []++    -- we don't want to leak info for the other cases, so same message for them all:+    toErrorResponse _ =+      ErrorResponse 401 [] "Username or password incorrect" []+
+ Distribution/Server/Framework/AuthCrypt.hs view
@@ -0,0 +1,86 @@+module Distribution.Server.Framework.AuthCrypt (+   PasswdPlain(..),+   PasswdHash(..),+   newPasswdHash,+   checkBasicAuthInfo,+   BasicAuthInfo(..),+   checkDigestAuthInfo,+   DigestAuthInfo(..),+   QopInfo(..),+  ) where++import Distribution.Server.Framework.AuthTypes+import Distribution.Server.Users.Types (UserName(..))++import Data.Digest.Pure.MD5 (md5)+import qualified Data.ByteString.Lazy.Char8 as BS.Lazy -- Only used for ASCII data+import Data.List (intercalate)++-- Hashed passwords are stored in the format:+--+-- @md5 (username ++ ":" ++ realm ++ ":" ++ password)@.+--+-- This format enables us to use either the basic or digest+-- HTTP authentication methods.++-- | Create a new 'PasswdHash' suitable for safe permanent storage.+--+newPasswdHash :: RealmName -> UserName -> PasswdPlain -> PasswdHash+newPasswdHash (RealmName realmName) (UserName userName) (PasswdPlain passwd) =+    PasswdHash $ md5HexDigest [userName, realmName, passwd]++------------------+-- HTTP Basic auth+--++data BasicAuthInfo = BasicAuthInfo {+       basicRealm    :: RealmName,+       basicUsername :: UserName,+       basicPasswd   :: PasswdPlain+     }++checkBasicAuthInfo :: PasswdHash -> BasicAuthInfo -> Bool+checkBasicAuthInfo hash (BasicAuthInfo realmName userName pass) =+    newPasswdHash realmName userName pass == hash++------------------+-- HTTP Digest auth+--++data DigestAuthInfo = DigestAuthInfo {+       digestUsername :: UserName,+       digestNonce    :: String,+       digestResponse :: String,+       digestURI      :: String,+       digestRqMethod :: String,+       digestQoP      :: QopInfo+     }+  deriving Show++data QopInfo = QopNone+             | QopAuth {+                 digestNonceCount  :: String,+                 digestClientNonce :: String+               }+          -- | QopAuthInt+  deriving Show++-- See RFC 2617 http://www.ietf.org/rfc/rfc2617+--+checkDigestAuthInfo :: PasswdHash -> DigestAuthInfo -> Bool+checkDigestAuthInfo (PasswdHash passwdHash)+                (DigestAuthInfo _username nonce response uri method qopinfo) =+    hash3 == response+  where+    hash1  = passwdHash+    hash2  = md5HexDigest [method, uri]+    hash3  = case qopinfo of+               QopNone           -> md5HexDigest [hash1, nonce, hash2]+               QopAuth nc cnonce -> md5HexDigest [hash1, nonce, nc, cnonce, "auth", hash2]++------------------+-- Utils+--++md5HexDigest :: [String] -> String+md5HexDigest = show . md5 . BS.Lazy.pack . intercalate ":"
+ Distribution/Server/Framework/AuthTypes.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-}+module Distribution.Server.Framework.AuthTypes where++import Distribution.Server.Framework.MemSize++import Data.Binary (Binary)+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Typeable (Typeable)++-- | A plain, unhashed password. Careful what you do with them.+--+newtype PasswdPlain = PasswdPlain String+  deriving Eq++-- | A password hash. It actually contains the hash of the username, passowrd+-- and realm.+--+-- Hashed passwords are stored in the format+-- @md5 (username ++ ":" ++ realm ++ ":" ++ password)@. This format enables+-- us to use either the basic or digest HTTP authentication methods.+--+newtype PasswdHash = PasswdHash String+  deriving (Eq, Ord, Show, Binary, Typeable, MemSize)++newtype RealmName = RealmName String+  deriving (Show, Eq)++$(deriveSafeCopy 0 'base ''PasswdPlain)+$(deriveSafeCopy 0 'base ''PasswdHash)+
+ Distribution/Server/Framework/BackupDump.hs view
@@ -0,0 +1,193 @@+{-+Create a tarball with the structured defined by each individual feature.+-}++{-# LANGUAGE ScopedTypeVariables #-}++module Distribution.Server.Framework.BackupDump (+    dumpServerBackup,+    csvToBackup,+    blobToBackup,++    testBlobsExist+  ) where++import Text.CSV hiding (csv)++import Distribution.Server.Framework.BackupRestore (BackupEntry(..))+import qualified Distribution.Server.Framework.BlobStorage as Blob+import Distribution.Server.Framework.BlobStorage (BlobStorage, BlobId)+import Distribution.Server.Framework.Logging+import Distribution.Server.Util.Parse (packUTF8)++import qualified Data.ByteString.Lazy as BS+import qualified Codec.Compression.GZip as GZip (compress)+import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Entry as Tar++import Control.Exception as Exception+import Control.Concurrent.MVar+import Control.Concurrent.Async as Async++import Control.Monad (liftM, forM, unless)+import System.FilePath+import System.Directory+import System.Posix.Files as Posix (createLink)+import System.Locale+import System.IO.Unsafe (unsafeInterleaveIO)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Time++-- Making backups is rather expensive in terms of disk I/O because we have+-- a lot of large static files (like package tarballs and docs).+--+-- So we use backup scheme where we share the static blob files between all+-- the backups. We use a tarball file per backup plus a shared directory of+-- blob files. We don't overwrite the blobs if they already exist. That way,+-- backups only pay the disk I/O cost of new blobs and of the other non-blob+-- data. we can end up writing as little as 10Mb rather than 20Gb.+--+-- The layout looks like this:+--+-- > backups/blobs/${blobid}+-- > backups/backup-2013-03-01.tar.gz+--+-- Then inside the tar.gz we have entries like:+--+-- > backup-2013-03-01/core/package/zlib-0.2/zlib.cabal+-- > backup-2013-03-01/core/package/zlib-0.2/zlib-0.2.tar.gz+-- >   -> ../../../../blobs/ecfdf802c16bab706b6985de57c73663+--+-- If you were to unpack the .tar.gz, that symlink would point to the file+--+-- > backups/blobs/ecfdf802c16bab706b6985de57c73663+--++dumpServerBackup :: Verbosity -> FilePath -> Maybe String -> BlobStorage -> Bool+                 -> [(String, IO [BackupEntry])] -> IO ()+dumpServerBackup verbosity backupDir tarfileTemplate store linkBlobs backupActions = do++    now <- getCurrentTime+    let template    = fromMaybe defaultTarfileTemplate tarfileTemplate+        tarfileName = substTemplate template now+        tarfilePath = backupDir </> tarfileName <.> "tar.gz"+        blobDir     = backupDir </> "blobs"++    lognotice verbosity $ "Writing backup tarball " ++ tarfilePath ++ "\n"+                       ++ "with blob files in " ++ blobDir++    createDirectoryIfMissing False backupDir+    createDirectoryIfMissing False blobDir++    entriesChan <- newChan+    let writeEntry = writeChan entriesChan++    let writeTarEntries = do+          entries <- getChanContents entriesChan+          BS.writeFile tarfilePath (GZip.compress (Tar.write entries))++    Async.withAsync writeTarEntries $ \tarWriter -> do+      Async.link tarWriter++      processEntries verbosity store tarfileName blobDir linkBlobs+                               writeEntry backupActions+      closeChan entriesChan++      Async.wait tarWriter+    lognotice verbosity "Backup complete"++  where+    defaultTarfileTemplate = "backup-" ++ iso8601DateFormat Nothing+    substTemplate = formatTime defaultTimeLocale++    -- MVar as 1-place chan+    newChan      = newEmptyMVar+    writeChan ch = putMVar ch . Just+    closeChan ch = putMVar ch Nothing+    getChanContents :: MVar (Maybe a) -> IO [a]+    getChanContents ch = unsafeInterleaveIO $ do+        mx <- takeMVar ch+        case mx of+          Nothing -> return []+          Just x  -> do xs <- getChanContents ch+                        return (x:xs)++processEntries :: Verbosity+               -> BlobStorage -> FilePath -> FilePath -> Bool+               -> (Tar.Entry -> IO ())+               -> [(String, IO [BackupEntry])]+               -> IO ()+processEntries verbosity store tarfileName blobDir linkBlobs writeEntry featureMap =+    sequence_+      [ do loginfo verbosity $ "Exporting " ++ featureName ++ " feature state"+           entries <- ioEntries+           sequence_+             [ processEntry verbosity store tarfileName blobDir linkBlobs featureName+                            writeEntry entry+             | entry <- entries ]+           loginfo verbosity $ "Export for " ++ featureName ++ " complete"+      | (featureName, ioEntries) <- featureMap ]+++processEntry :: Verbosity -> BlobStorage -> FilePath -> FilePath -> Bool -> String+             -> (Tar.Entry -> IO ())+             -> BackupEntry+             -> IO ()+processEntry _verbosity _store tarfileName _blobDir _linkBlobs featureName writeEntry+  (BackupByteString path bs) = do++  tarPath <- either exportError return $+             Tar.toTarPath False (mkTarPath tarfileName featureName path)+  writeEntry (Tar.fileEntry tarPath bs)++processEntry verbosity store tarfileName blobDir linkBlobs featureName writeEntry+    (BackupBlob path blobId) = do++    blobExists <- doesFileExist (Blob.filepath store blobId)+    if blobExists+      then do+        let blobName = Blob.blobMd5 blobId+            blobPath = blobDir </> blobName+            -- go back to the root of the tarball. 'path' here would be something like+            -- a/b/c/filename, which we store in+            -- backup-2013-03-01/feature/a/b/c/filename; in this example, we want+            -- to go back 4 directories, which is @length path + 1@+            -- (because 'path' includes the filename)+            relRoot  = joinPath (replicate (length path + 1) "..")+            blobLink = relRoot </> "blobs" </> blobName++        entryPath   <- either exportError return $+                       Tar.toTarPath False (mkTarPath tarfileName featureName path)+        linkTarget  <- maybe (fail "Could not generate link target") return $+                       Tar.toLinkTarget blobLink++        writeBlob blobPath blobId+        writeEntry (Tar.simpleEntry entryPath (Tar.SymbolicLink linkTarget))+      else+        lognotice verbosity $ "Warning: skipping non-existent blob " ++ show blobId ++ " (" ++ foldr1 (</>) path ++ ")"+  where+    -- blobPath is the path in the backup, not the original+    writeBlob blobPath blobid = do+      exists <- doesFileExist blobPath+      unless exists $+        if linkBlobs+          then Posix.createLink (Blob.filepath store blobid) blobPath+          else Blob.fetch store blobid >>= BS.writeFile blobPath++exportError :: String -> IO a+exportError err = fail $ "Error in export: " ++ err++mkTarPath :: FilePath -> String -> [FilePath] -> FilePath+mkTarPath tarfileName featureName ps = joinPath (tarfileName : featureName : ps)++csvToBackup :: [String] -> CSV -> BackupEntry+csvToBackup fpath csv = BackupByteString fpath $ packUTF8 (printCSV csv)++blobToBackup :: [String] -> BlobId -> BackupEntry+blobToBackup = BackupBlob++testBlobsExist :: BlobStorage -> [Blob.BlobId] -> IO [String]+testBlobsExist store blobs+  = liftM catMaybes $ forM blobs $ \blob -> do+       (Blob.fetch store blob >> return Nothing) `Exception.catch`+         \e -> return $ Just $ "Could not open blob " ++ show blob ++ ": " ++ show (e :: IOError)
+ Distribution/Server/Framework/BackupRestore.hs view
@@ -0,0 +1,452 @@+{-# LANGUAGE RankNTypes, RecordWildCards, GeneralizedNewtypeDeriving, BangPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Distribution.Server.Framework.BackupRestore (+    BackupEntry(..),+    restoreServerBackup,+    importBlank,++    importCSV,+    parseText,+    parseRead,+    parseUTCTime, formatUTCTime,++    equalTarBall,++    module Distribution.Server.Util.Merge,++    -- * We are slowly transitioning to a pure restore process+    -- Once that transition is complete this will replace RestoreBackup+    RestoreBackup(..),+    restoreBackupUnimplemented,+    concatM,+    Restore,+    restoreAddBlob,+    restoreGetBlob,++    AbstractRestoreBackup(..),+    abstractRestoreBackup+  ) where++import qualified Distribution.Server.Framework.BlobStorage as Blob+import Distribution.Server.Framework.BlobStorage (BlobStorage, BlobId)++import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import Distribution.Server.Util.GZip (decompressNamed)+import Control.Applicative+import Control.Monad.State+import Control.Monad.Error+import Control.Monad.Writer+import Data.Time (UTCTime)+import qualified Data.Time as Time+import System.Locale++import Distribution.Server.Util.Merge+import Distribution.Server.Util.Parse (unpackUTF8)+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BS (readFile)+import qualified Data.Map as Map+import Data.Ord (comparing)+import System.FilePath ((</>), takeDirectory, splitDirectories)+import System.Directory (doesFileExist, doesDirectoryExist)+import Text.CSV hiding (csv)+import Distribution.Text+import Data.Map (Map)+import Data.List (sortBy)+++--------------------------------------------------------------------------------+-- Creating/restoring backups                                                 --+--------------------------------------------------------------------------------++data BackupEntry =+    BackupByteString [FilePath] ByteString+  | BackupBlob [FilePath] BlobId++data RestoreBackup st = RestoreBackup {+    restoreEntry    :: BackupEntry -> Restore (RestoreBackup st)+  , restoreFinalize :: Restore st+  }++instance Functor RestoreBackup where+  f `fmap` RestoreBackup {..} = RestoreBackup {+      restoreEntry    = liftM (fmap f) . restoreEntry+    , restoreFinalize = liftM f restoreFinalize+    }++restoreBackupUnimplemented :: RestoreBackup st+restoreBackupUnimplemented = RestoreBackup {+    restoreEntry    = const (return restoreBackupUnimplemented)+  , restoreFinalize = fail "Backup unimplemented"+  }++data AbstractRestoreBackup = AbstractRestoreBackup {+    abstractRestoreEntry    :: BlobStorage -> BackupEntry -> IO (Either String AbstractRestoreBackup)+  , abstractRestoreFinalize :: BlobStorage -> IO (Either String (IO ()))+  }++abstractRestoreBackup :: (st -> IO ()) -> RestoreBackup st -> AbstractRestoreBackup+abstractRestoreBackup putSt = go+  where+    go RestoreBackup {..} = AbstractRestoreBackup {+        abstractRestoreEntry = \store entry ->+          liftM go    <$> (runRestore store $ restoreEntry entry)+      , abstractRestoreFinalize = \store ->+          liftM putSt <$> (runRestore store $ restoreFinalize)+      }++instance Monoid AbstractRestoreBackup where+  mempty = AbstractRestoreBackup {+      abstractRestoreEntry = \_ _ -> return . Right $ mempty+    , abstractRestoreFinalize = \_ -> return . Right $ return ()+    }+  mappend (AbstractRestoreBackup run fin) (AbstractRestoreBackup run' fin') = AbstractRestoreBackup {+      abstractRestoreEntry = \store entry -> do+         res <- run store entry+         case res of+           Right backup -> do+             res' <- run' store entry+             return $ fmap (mappend backup) res'+           Left bad -> return $ Left bad+    , abstractRestoreFinalize = \store -> do+         res <- fin store+         case res of+           Right finalizer -> do+             res' <- fin' store+             return $ fmap (finalizer >>) res'+           Left bad -> return $ Left bad+    }++--------------------------------------------------------------------------------+-- Utilities for creating RestoreBackup objects                               --+--------------------------------------------------------------------------------++concatM :: (Monad m) => [a -> m a] -> (a -> m a)+concatM fs = foldr (>=>) return fs++importCSV :: Monad m => FilePath -> ByteString -> m CSV+importCSV filename inp = case parseCSV filename (unpackUTF8 inp) of+    Left err  -> fail (show err)+    Right csv -> return (chopLastRecord csv)+  where+    -- | Chops off the last entry if it's null.+    -- I'm not sure why parseCSV does this, but it's+    -- irritating.+    chopLastRecord [] = []+    chopLastRecord ([""]:[]) = []+    chopLastRecord (x:xs) = x : chopLastRecord xs++parseRead :: (Read a, Monad m) => String -> String -> m a+parseRead label str = case reads str of+    [(value, "")] -> return value+    _ -> fail $ "Unable to parse " ++ label ++ ": " ++ show str++parseUTCTime :: Monad m => String -> String -> m UTCTime+parseUTCTime label str =+    case Time.parseTime defaultTimeLocale timeFormatSpec str of+      Nothing -> fail $ "Unable to parse UTC timestamp " ++ label ++ ": " ++ str+      Just x  -> return x++formatUTCTime :: UTCTime -> String+formatUTCTime = Time.formatTime defaultTimeLocale timeFormatSpec++timeFormatSpec :: String+timeFormatSpec = "%Y-%m-%d %H:%M:%S%Q %z"++-- Parse a string, throw an error if it's bad+parseText :: (Text a, Monad m) => String -> String -> m a+parseText label text = case simpleParse text of+    Nothing -> fail $ "Unable to parse " ++ label ++ ": " ++ show text+    Just a -> return a++{-------------------------------------------------------------------------------+  Restore Monad++  This is a free monad. Monad laws:++  LEFT IDENTITY++    return x >>= f+  = RestoreDone x >>= f+  = f x++  RIGHT IDENTITY++    m >>= return+  = m >>= RestoreDone++  Induction on m:++    1.   RestoreDone x >>= RestoreDone+       = RestoreDone x+    2.   RestoreFail err >>= RestoreDone+       = RestoreFail err+    3.   RestoreAddBLob bs f >>= RestoreDone+       = RestoreAddBlob bs $ \bid -> f bid >>= RestoreDone+           { by induction }+       = RestoreAddBlob bs $ \bid -> f bid+           { eta reduction }+       = RestoreAddBlob bs f+    4. Analogous to (3).++  ASSOCIATIVITY++    You'll have to take my word for it :-)+-------------------------------------------------------------------------------}+++data Restore a = RestoreDone a+               | RestoreFail String+               | RestoreAddBlob ByteString (BlobId -> Restore a)+               | RestoreGetBlob BlobId (ByteString -> Restore a)++instance Monad Restore where+  return = RestoreDone+  fail   = RestoreFail+  RestoreDone x        >>= g = g x+  RestoreFail err      >>= _ = RestoreFail err+  RestoreAddBlob bs  f >>= g = RestoreAddBlob bs  $ \bid -> f bid >>= g+  RestoreGetBlob bid f >>= g = RestoreGetBlob bid $ \bs  -> f bs  >>= g++instance Functor Restore where+  fmap = liftM++instance Applicative Restore where+  pure      = return+  mf <*> mx = do f <- mf ; x <- mx ; return (f x)++runRestore :: BlobStorage -> Restore a -> IO (Either String a)+runRestore store = go+  where+    go :: forall a. Restore a -> IO (Either String a)+    go (RestoreDone a)        = return (Right a)+    go (RestoreFail err)      = return (Left err)+    go (RestoreAddBlob bs f)  = Blob.add   store bs  >>= go . f+    go (RestoreGetBlob bid f) = Blob.fetch store bid >>= go . f++restoreAddBlob :: ByteString -> Restore BlobId+restoreAddBlob = (`RestoreAddBlob` RestoreDone)++restoreGetBlob :: BlobId -> Restore ByteString+restoreGetBlob = (`RestoreGetBlob` RestoreDone)++--------------------------------------------------------------------------------+-- Import a backup                                                            --+--------------------------------------------------------------------------------++-- featureBackups must contain a SINGLE entry for each feature+restoreServerBackup :: BlobStorage -> FilePath -> Bool+                    -> [(String, AbstractRestoreBackup)] -> IO (Maybe String)+restoreServerBackup store tarFile consumeBlobs featureBackups = do+    checkBlobDirExists+    tar <- BS.readFile tarFile+    finalizers <- evalImport store blobdir consumeBlobs featureBackups $ do+        fromEntries . Tar.read . decompressNamed tarFile $ tar+        finalizeBackups store (map fst featureBackups)+    completeBackups finalizers+  where+    blobdir = takeDirectory tarFile </> "blobs"+    checkBlobDirExists = do+      exists <- doesDirectoryExist blobdir+      when (not exists) $ fail $+           "Expected to find the blobs directory in the same location as the "+        ++ "tar file " ++ tarFile++-- A variant of importTar that finalizes immediately.+importBlank :: BlobStorage -> [(String, AbstractRestoreBackup)] -> IO (Maybe String)+importBlank store featureBackups = do+    finalizers <- evalImport store "not-used" False featureBackups $+        finalizeBackups store (map fst featureBackups)+    completeBackups finalizers++-- | Call restoreFinalize for every backup. Caller must ensure that every+-- feature name is in the map.+finalizeBackups :: BlobStorage -> [String] -> Import [IO ()]+finalizeBackups store list = forM list $ \name -> do+    features <- gets importStates+    liftIO $ putStrLn $ "finalising data for feature " ++ name+    mbackup  <- liftIO $ abstractRestoreFinalize (features Map.! name) store+    case mbackup of+        Left err       -> fail $ "Error restoring data for feature " ++ name+                              ++ ":" ++ err+        Right finalize -> return finalize++completeBackups :: Either String [IO ()] -> IO (Maybe String)+completeBackups res = case res of+    Left err -> return $ Just err+    Right putSt -> sequence_ putSt >> return Nothing++-- internal import utils++newtype Import a = Import { unImp :: StateT ImportState (ErrorT String IO) a }+  deriving (Monad, MonadIO, MonadState ImportState)++evalImport :: BlobStorage -> FilePath -> Bool+           -> [(String, AbstractRestoreBackup)]+           -> Import a -> IO (Either String a)+evalImport store blobdir consumeBlobs featureBackups imp =+    runErrorT (evalStateT (unImp imp) initState)+  where+    initState = initialImportState store blobdir consumeBlobs featureBackups++data ImportState = ImportState {+    -- | The 'RestoreBackup' of each state+    importStates    :: !(Map String AbstractRestoreBackup),++    -- | The blob storage we are writing to+    importBlobStore :: BlobStorage,++    -- | The backup blob dir we are reading from+    importBlobDir   :: FilePath,++    -- | If we should work in a mode where we destructively consume the blobs+    -- from the blob dir when adding them into the blob store. You might want+    -- to do this is to reduce the amount of disk I\/O, but you obviously have+    -- to be rather careful with it.+    importConsumeBlobs :: Bool,++    -- | We often read the same blob more than once, so this caches+    -- the blobs we've written as a map from blobid-string to blobid.+    importBlobsWritten :: Map String BlobId+  }++initialImportState :: BlobStorage -> FilePath -> Bool+                   -> [(String, AbstractRestoreBackup)]+                   -> ImportState+initialImportState store blobdir consumeBlobs featureBackups = ImportState {+    importStates    = Map.fromList featureBackups,+    importBlobStore = store,+    importBlobDir   = blobdir,+    importConsumeBlobs = consumeBlobs,+    importBlobsWritten = Map.empty+  }++updateImportState :: String -> AbstractRestoreBackup -> Import ()+updateImportState feature !backup = do+  st <- get+  put $! st { importStates = Map.insert feature backup (importStates st) }++lookupBlobWritten :: String -> Import (Maybe BlobId)+lookupBlobWritten blobidstr = gets (Map.lookup blobidstr . importBlobsWritten)++addBlobsWritten :: String -> BlobId -> Import ()+addBlobsWritten blobidstr !blobid = do+  st <- get+  put $! st {+    importBlobsWritten = Map.insert blobidstr blobid (importBlobsWritten st)+  }+++fromEntries :: Tar.Entries Tar.FormatError -> Import ()+fromEntries Tar.Done        = return ()+fromEntries (Tar.Fail err)  = fail $ "Problem in backup tarball: " ++ show err+fromEntries (Tar.Next x xs) = fromEntry x >> fromEntries xs++fromEntry :: Tar.Entry -> Import ()+fromEntry entry =+    case Tar.entryContent entry of+      Tar.NormalFile bytes _  -> fromFile (Tar.entryPath entry) bytes+      Tar.Directory {}        -> return () -- ignore directory entries+      Tar.SymbolicLink target -> fromLink (Tar.entryPath entry) (Tar.fromLinkTarget target)+      _ -> fail $ "Unexpected entry in backup tarball: " ++ Tar.entryPath entry++fromFile :: FilePath -> ByteString -> Import ()+fromFile path contents = fromBackupEntry path (`BackupByteString` contents)++fromLink :: FilePath -> FilePath -> Import ()+fromLink path linkTarget+  -- links have format "../../../blobs/${blobId}" (for some number of "../"s)+  | (blobIdStr : "blobs" : _) <- reverse (splitDirectories linkTarget) = do+      blobdir <- gets importBlobDir+      let blobFile = blobdir </> blobIdStr+      blobId <- checkBlobWrittenCache blobIdStr+                  (checkBlobFileExists blobFile >> importBlobFile blobFile)+      checkBlobIdAsExpected blobId blobIdStr blobFile+      fromBackupEntry path (`BackupBlob` blobId)++  | otherwise = fail $ "Unexpected tar link entry: " ++ path+                                           ++ " -> " ++ linkTarget+  where+    checkBlobWrittenCache blobIdStr getBlobId = do+      mblobId <- lookupBlobWritten blobIdStr+      case mblobId of+        Just blobId -> return blobId+        Nothing     -> do+          blobId <- getBlobId+          addBlobsWritten blobIdStr blobId+          return blobId++    importBlobFile blobFile = do+      store        <- gets importBlobStore+      consumeBlobs <- gets importConsumeBlobs+      if consumeBlobs+        then liftIO $ Blob.consumeFile store blobFile+        else liftIO $ Blob.add store =<< BS.readFile blobFile++    checkBlobFileExists blobFile = do+      exists <- liftIO $ doesFileExist blobFile+      when (not exists) $ fail $ "Missing blob file " ++ blobFile+                       ++ "\nneeded by backup entry " ++ path++    checkBlobIdAsExpected blobId blobIdStr blobFile =+      when (Blob.blobMd5 blobId /= blobIdStr) $+        fail $ "Incorrect blob file " ++ blobFile+            ++ "\nit actually has an md5sum of " ++ Blob.blobMd5 blobId+++fromBackupEntry :: FilePath -> ([FilePath] -> BackupEntry) -> Import ()+fromBackupEntry path mkEntry+  | (_rootdir:featureName:pathEnd) <- splitDirectories path = do+  store         <- gets importBlobStore+  featureStates <- gets importStates+  case Map.lookup featureName featureStates of+    Just restorer -> do+      res <- liftIO $ abstractRestoreEntry restorer store (mkEntry pathEnd)+      case res of+        Left e          -> fail $ "Error importing '" ++ path ++ "' :" ++ e+        Right restorer' -> updateImportState featureName restorer'+    Nothing -> fail $ "Backup tarball contains file for unknown feature: " ++ featureName+fromBackupEntry path _ = fail $ "Backup tarball contains unexpected file: " ++ path+++--------------------------------------------------------------------------------+-- Compare tarballs                                                           --+--------------------------------------------------------------------------------++-- Used to compare export/import tarballs for equality by the backup/restore test:+equalTarBall :: ByteString -- ^ "Before" tarball+             -> ByteString -- ^ "After" tarball+             -> [String]+equalTarBall tar1 tar2 = do+  let entries :: Either String ([Tar.Entry], [Tar.Entry])+      entries = do+        entries1 <- sortBy (comparing Tar.entryTarPath) <$> readTar "before" tar1+        entries2 <- sortBy (comparing Tar.entryTarPath) <$> readTar "after"  tar2+        return (entries1, entries2)+  case entries of+    Left err -> [err]+    Right (entries1, entries2) ->+      flip concatMap (mergeBy (comparing Tar.entryTarPath) entries1 entries2) $ \mr -> case mr of+          OnlyInLeft  entry -> [Tar.entryPath entry ++ " only in 'before' tarball"]+          OnlyInRight entry -> [Tar.entryPath entry ++ " only in 'after' tarball"]+          InBoth entry1 entry2 -> concat [+                checkEq "content" Tar.entryContent,+                checkEq "permissions" Tar.entryPermissions,+                checkEq "ownership" Tar.entryOwnership+                -- Don't particularly care about modification time/tar format+              ]+            where+              tarPath = Tar.entryPath entry1+              checkEq :: Eq a => String -> (Tar.Entry -> a) -> [String]+              checkEq what f = if (f entry1 /= f entry2)+                                 then [tarPath ++ ": " ++ what ++ " did not match"]+                                 else []+  where+    readTar :: Monad m => String -> ByteString -> m [Tar.Entry]+    readTar err = entriesToList err . Tar.read++    entriesToList :: (Monad m, Show a) => String -> Tar.Entries a -> m [Tar.Entry]+    entriesToList err (Tar.Next entry entries) = liftM (entry :) $ entriesToList err entries+    entriesToList _   Tar.Done                 = return []+    entriesToList err (Tar.Fail s)             = fail ("Could not read '" ++ err ++ "' tarball: " ++ show s)
+ Distribution/Server/Framework/BlobStorage.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving,+             ScopedTypeVariables, BangPatterns, CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Server.BlobStorage+-- Copyright   :  Duncan Coutts <duncan@haskell.org>+--+-- Maintainer  :  Duncan Coutts <duncan@haskell.org>+-- Stability   :  alpha+-- Portability :  portable+--+-- Persistent storage for blobs of data.+--+module Distribution.Server.Framework.BlobStorage (+    BlobStorage,+    BlobId,+    blobMd5,+    open,+    add,+    addWith,+    consumeFile,+    consumeFileWith,+    fetch,+    filepath,+  ) where++import Distribution.Server.Framework.MemSize++import qualified Data.ByteString.Lazy as BSL+import qualified Data.Digest.Pure.MD5 as MD5+import Data.Typeable (Typeable)+import Data.Serialize+import System.FilePath ((</>))+import Control.Exception (handle, throwIO, evaluate, bracket)+import Control.Monad+import Data.SafeCopy+import System.Directory+import System.IO+import Data.Aeson++-- For the lazy MD5 computation+import Data.Digest.Pure.MD5 (MD5Digest, MD5Context)+import Crypto.Classes (initialCtx, updateCtx, finalize, blockLength)+import Crypto.Types (ByteLength)+import qualified Crypto.Util (for)+import qualified Data.ByteString as BSS++-- For fsync+import System.Posix.Types (Fd(..))+#ifndef mingw32_HOST_OS+import Foreign.C.Error (throwErrnoIfMinus1_)+import Foreign.C.Types (CInt(..))+import System.Posix.IO (+    handleToFd+  , openFd+  , closeFd+  , defaultFileFlags+  , OpenMode(ReadOnly)+  )+#endif++-- | An id for a blob. The content of the blob is stable.+--+newtype BlobId = BlobId MD5Digest+  deriving (Eq, Ord, Show, Serialize, Typeable)++instance ToJSON BlobId where+  toJSON (BlobId md5digest) = toJSON (show md5digest)++blobMd5 :: BlobId -> String+blobMd5 (BlobId digest) = show digest++instance SafeCopy BlobId where+  putCopy = contain . put+  getCopy = contain get++instance MemSize BlobId where+  memSize _ = 7 --TODO: pureMD5 package wastes 5 words!++-- | A persistent blob storage area. Blobs can be added and retrieved but+-- not removed or modified.+--+newtype BlobStorage = BlobStorage FilePath -- ^ location of the store++-- | Which directory do we store a blob ID in?+directory :: BlobStorage -> BlobId -> FilePath+directory (BlobStorage storeDir) (BlobId hash) = storeDir </> take 2 str+    where str = show hash++filepath :: BlobStorage -> BlobId -> FilePath+filepath store bid@(BlobId hash) = directory store bid </> str+    where str = show hash++incomingDir :: BlobStorage -> FilePath+incomingDir (BlobStorage storeDir) = storeDir </> "incoming"++-- | Add a blob into the store. The result is a 'BlobId' that can be used+-- later with 'fetch' to retrieve the blob content.+--+-- * This operation is idempotent. That is, adding the same content again+--   gives the same 'BlobId'.+--+add :: BlobStorage -> BSL.ByteString -> IO BlobId+add store content =+  withIncoming store content $ \_ blobId -> return (blobId, True)++-- | Like 'add' but we get another chance to make another pass over the input+-- 'ByteString'.+--+-- What happens is that we stream the input into a temp file in an incoming+-- area. Then we can make a second pass over it to do some validation or+-- processing. If the validator decides to reject then we rollback and the+-- blob is not entered into the store. If it accepts then the blob is added+-- and the 'BlobId' is returned.+--+addWith :: BlobStorage -> BSL.ByteString+        -> (BSL.ByteString -> IO (Either error result))+        -> IO (Either error (result, BlobId))+addWith store content check =+  withIncoming store content $ \file blobId -> do+    content' <- BSL.readFile file+    result <- check content'+    case result of+      Left  err -> return (Left  err,          False)+      Right res -> return (Right (res, blobId), True)++-- | Similar to 'add' but by /moving/ a file into the blob store. So this+-- is a destructive operation. Since it works by renaming the file, the input+-- file must live in the same file system as the blob store.+--+consumeFile :: BlobStorage -> FilePath -> IO BlobId+consumeFile store filePath =+  withIncomingFile store filePath $ \_ blobId -> return (blobId, True)++consumeFileWith :: BlobStorage -> FilePath+                -> (BSL.ByteString -> IO (Either error result))+                -> IO (Either error (result, BlobId))+consumeFileWith store filePath check =+  withIncomingFile store filePath $ \file blobId -> do+    content' <- BSL.readFile file+    result <- check content'+    case result of+      Left  err -> return (Left  err,          False)+      Right res -> return (Right (res, blobId), True)++hBlobId :: Handle -> IO BlobId+hBlobId hnd = evaluate . BlobId . MD5.md5 =<< BSL.hGetContents hnd++fileBlobId :: FilePath -> IO BlobId+fileBlobId file = bracket (openBinaryFile file ReadMode) hClose hBlobId++withIncoming :: BlobStorage -> BSL.ByteString+              -> (FilePath -> BlobId -> IO (a, Bool))+              -> IO a+withIncoming store content action = do+    (file, hnd) <- openBinaryTempFile (incomingDir store) "new"+    handleExceptions file hnd $ do+        md5 <- hPutGetMd5 hnd content+        let blobId = BlobId md5+        fd <- handleToFd hnd -- This closes the handle, see docs for handleToFd+        fsync fd+        closeFd fd+        withIncoming' store file blobId action+  where+    hPutGetMd5 hnd = go . lazyMD5+      where+        go (BsChunk bs cs) = BSS.hPut hnd bs >> go cs+        go (BsEndMd5 md5)  = return md5++    handleExceptions tmpFile tmpHandle =+      handle $ \err -> do+        hClose tmpHandle+        removeFile tmpFile+        throwIO (err :: IOError)++withIncomingFile :: BlobStorage+                 -> FilePath+                 -> (FilePath -> BlobId -> IO (a, Bool))+                 -> IO a+withIncomingFile store file action =+    do blobId <- fileBlobId file+       withIncoming' store file blobId action++withIncoming' :: BlobStorage -> FilePath -> BlobId -> (FilePath -> BlobId -> IO (a, Bool)) -> IO a+withIncoming' store file blobId action = do+        (res, commit) <- action file blobId+        if commit+            then do+#ifndef mingw32_HOST_OS+              fd <- openFd (directory store blobId) ReadOnly Nothing defaultFileFlags+#endif+              -- TODO: if the target already exists then there is no need to overwrite+              -- it since it will have the same content. Checking and then renaming+              -- would give a race condition but that's ok since they have the same+              -- content.+              renameFile file (filepath store blobId)+#ifndef mingw32_HOST_OS+              -- fsync the directory so that the new directory entry becomes 'durable'+              fsync fd+              closeFd fd+#endif+            else removeFile file+        return res+++-- | Retrieve a blob from the store given its 'BlobId'.+--+-- * The content corresponding to a given 'BlobId' never changes.+--+-- * The blob must exist in the store or it is an error.+--+fetch :: BlobStorage -> BlobId -> IO BSL.ByteString+fetch store blobid = BSL.readFile (filepath store blobid)++-- | Opens an existing or new blob storage area.+--+open :: FilePath -> IO BlobStorage+open storeDir = do+    let store   = BlobStorage storeDir+        chars   = ['0' .. '9'] ++ ['a' .. 'f']+        subdirs = incomingDir store+                : [storeDir </> [x, y] | x <- chars, y <- chars]++    exists <- doesDirectoryExist storeDir+    if not exists+      then do+        createDirectory storeDir+        forM_ subdirs createDirectory+      else+        forM_ subdirs $ \d -> do+          subdirExists <- doesDirectoryExist d+          unless subdirExists $+            fail $ "Store directory \""+                ++ storeDir+                ++ "\" exists but \""+                ++ d+                ++ "\" does not"+    return store++{------------------------------------------------------------------------------+  Lazy MD5 computation+------------------------------------------------------------------------------}++-- | Adapted from crypto-api+--+-- This function is defined in crypto-api but not exported, and moreover+-- not lazy enough.+--+-- Guaranteed not to return an empty list+makeBlocks :: ByteLength -> BSL.ByteString -> [BSS.ByteString]+makeBlocks len = go . BSL.toChunks+  where+    go :: [BSS.ByteString] -> [BSS.ByteString]+    go [] = [BSS.empty]+    go (bs:bss)+      | BSS.length bs >= len =+          let l = BSS.length bs - BSS.length bs `rem` len+              (blocks, leftover) = BSS.splitAt l bs+          in blocks : go (leftover : bss)+      | otherwise =+          case bss of+            []           -> [bs]+            (bs' : bss') -> go (BSS.append bs bs' : bss')++-- | Compute the MD5 checksum of a lazy bytestring without reading the entire+-- thing into memory+--+-- Example usage:+--+-- > do bs <- BSL.readFile srcPath+-- >   md5 <- writeFileGetMd5 destPath bs'+-- >   putStrLn $ "MD5 is " ++ show md5+-- > where+-- >   writeFileGetMd5 file content =+-- >       withFile file WriteMode $ \hnd ->+-- >         go hnd (lazyMD5 content)+-- >     where+-- >       go hnd (BsChunk bs cs) = BSS.hPut hnd bs >> go hnd cs+-- >       go _   (BsEndMd5 md5)  = return md5+--+-- Note that this lazily reads the file, then lazily writes it again, and+-- finally we get the MD5 checksum of the whole file. This example program+-- will run in constant memory.+--+lazyMD5 :: BSL.ByteString -> ByteStringWithMd5+lazyMD5 = go initialCtx . makeBlocks blockLen+  where+    blockLen = (blockLength `Crypto.Util.for` (undefined :: MD5Digest)) `div` 8++    go :: MD5Context+       -> [BSS.ByteString]+       -> ByteStringWithMd5+    go !md5ctx [lastBlock] =+      BsChunk lastBlock $! (BsEndMd5 (finalize md5ctx lastBlock))+    go !md5ctx (block : blocks') =+      BsChunk block (go (updateCtx md5ctx block) blocks')+    go _ [] = error "impossible"++data ByteStringWithMd5 = BsChunk  !BSS.ByteString ByteStringWithMd5+                       | BsEndMd5 !MD5Digest++{------------------------------------------------------------------------------+  Lazy MD5 computation+------------------------------------------------------------------------------}++-- | Binding to the C @fsync@ function+fsync :: Fd -> IO ()+fsync (Fd fd) =+#ifdef mingw32_HOST_OS+  return ()+#else+ throwErrnoIfMinus1_ "fsync" $ c_fsync fd++foreign import ccall "fsync" c_fsync :: CInt -> IO CInt+#endif
+ Distribution/Server/Framework/Cache.hs view
@@ -0,0 +1,140 @@+module Distribution.Server.Framework.Cache (+    AsyncCache,+    newAsyncCacheNF,+    newAsyncCacheWHNF,+    AsyncCachePolicy(..),+    defaultAsyncCachePolicy,+    readAsyncCache,+    prodAsyncCache,+    syncAsyncCache,+  ) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import Control.Monad.Trans (MonadIO(liftIO))+import Control.DeepSeq (NFData, rnf)++import Distribution.Server.Framework.Logging+import qualified Distribution.Verbosity as Verbosity+++-- | An in-memory cache with asynchronous updates.+--+-- Cache reads never block but may get stale results. So it is suitable for+-- cases where updates may be expensive, but where having slightly out of+-- date results is ok.+--+-- The cache is made with the action that calculates the new value.+-- So cache updates just prod the cache to recalculate.+--+-- * Note: this action is executed synchronously, it is the evaluation of+--   the result of this action that is performed asynchronously. The cache+--   is only actually updated when the evaluation of this result is complete.+--+data AsyncCache a = AsyncCache !(AsyncVar a) (IO a)++data AsyncCachePolicy = AsyncCachePolicy {+       -- | To reduce the cost of updating caches when there are lots of+       -- updates going on, we simply wait, that way more updates queue up+       -- and since we only take the last update, then we save computation.+       asyncCacheUpdateDelay :: !Int,++       -- | Usually we want to force the initial value synchronously but some+       -- apps may prefer to let that happen asynchronously (and in parallel)+       -- to speed up app initialisation. But in that case the app has to use+       -- 'syncAsyncCache' to be sure the cache is ready.+       asyncCacheSyncInit    :: !Bool,++       asyncCacheLogVerbosity:: !Verbosity,+       asyncCacheName        :: String+     }++defaultAsyncCachePolicy :: AsyncCachePolicy+defaultAsyncCachePolicy = AsyncCachePolicy 0 True Verbosity.normal "(unnamed)"++newAsyncCacheWHNF :: IO a -> AsyncCachePolicy -> IO (AsyncCache a)+newAsyncCacheWHNF = newAsyncCache (\x -> seq x ())++newAsyncCacheNF :: NFData a => IO a -> AsyncCachePolicy -> IO (AsyncCache a)+newAsyncCacheNF = newAsyncCache rnf++newAsyncCache :: (a -> ()) -> IO a -> AsyncCachePolicy -> IO (AsyncCache a)+newAsyncCache eval update (AsyncCachePolicy delay syncForce verbosity logname) = do+  x <- update+  avar <- newAsyncVar delay syncForce verbosity logname eval x+  return (AsyncCache avar update)++readAsyncCache :: MonadIO m => AsyncCache a -> m a+readAsyncCache (AsyncCache avar _) = liftIO $ readAsyncVar avar++prodAsyncCache :: MonadIO m => AsyncCache a -> m ()+prodAsyncCache (AsyncCache avar update) = liftIO $ update >>= writeAsyncVar avar++-- | Only needed if you use asynchronous initialisation+-- (i.e. ''asyncCacheSyncInit' = False@). Waits until the value in the cache+-- has been evaluated. It has no effect later on since the async cache always+-- has a value available (albeit perhaps a stale one).+syncAsyncCache :: NFData a => AsyncCache a -> IO ()+syncAsyncCache c = readAsyncCache c >>= evaluate . rnf >> return ()+++-------------------------------------------------+-- A mutable variable with asynchronous updates+--++data AsyncVar state = AsyncVar !(TChan state)+                               !(TVar (Either SomeException state))++newAsyncVar :: Int -> Bool -> Verbosity -> String+            -> (state -> ()) -> state -> IO (AsyncVar state)+newAsyncVar delay syncForce verbosity logname force initial = do++    inChan <- atomically newTChan+    outVar <- atomically (newTVar (Right initial))++    if syncForce+      then logTiming verbosity ("Cache '" ++ logname ++ "' initialised") $+             evaluate (force initial)+      else atomically (writeTChan inChan initial)++    let loop = do++          when (delay > 0) (threadDelay delay)++          avail   <- readAllAvailable inChan+          -- We have a series of new values.+          -- We want the last one, skipping all intermediate updates.+          let value = last avail++          logTiming verbosity ("Cache '" ++ logname ++ "' updated") $ do+            res <- try $ evaluate (force value `seq` value)+            atomically (writeTVar outVar res)++          loop++    void $ forkIO loop+    return (AsyncVar inChan outVar)+  where+    -- get a list of all the input states currently queued+    readAllAvailable chan =+      atomically $ do+        x <- readTChan chan -- will block if queue is empty+        readAll [x]         -- will never block, just gets what's available+      where+        readAll xs = do+          empty <- isEmptyTChan chan+          if empty+            then return (reverse xs)+            else do x <- readTChan chan+                    readAll (x:xs)++readAsyncVar :: AsyncVar state -> IO state+readAsyncVar (AsyncVar _ outVar) =+    atomically (readTVar outVar) >>= either throw return++writeAsyncVar :: AsyncVar state -> state -> IO ()+writeAsyncVar (AsyncVar inChan _) value =+    atomically (writeTChan inChan value)+
+ Distribution/Server/Framework/Error.hs view
@@ -0,0 +1,134 @@+-- | Error handling style for the hackage server.+--+-- The point is to be able to abort and return appropriate HTTP errors, plus+-- human readable messages.+--+-- We use a standard error monad / exception style so that we can hide some of+-- the error checking plumbing.+--+-- We use a custom error type that enables us to render the error in an+-- appropriate way, ie themed html or plain text, depending on the context.+--+module Distribution.Server.Framework.Error (++    -- * Server error monad+    ServerPartE,++    -- * Generating errors+    MessageSpan(..),+    errBadRequest,+    errForbidden,+    errNotFound,+    errBadMediaType,+    errInternalError,+    throwError,++    -- * Handling errors+    ErrorResponse(..),+    runServerPartE,+    handleErrorResponse,+    messageToText,++    -- * Handy error message operator+    (?!)+  ) where++import Happstack.Server+import Control.Monad.Error++import qualified Data.Text.Lazy          as Text+import qualified Data.Text.Lazy.Encoding as Text++-- | The \"oh noes?!\" operator+--+(?!) :: Maybe a -> e -> Either e a+ma ?! e = maybe (Left e) Right ma+++-- | A derivative of the 'ServerPartT' monad with an extra error monad layer.+--+-- So we can use the standard 'MonadError' methods like 'throwError'.+--+type ServerPartE a = ServerPartT (ErrorT ErrorResponse IO) a++-- | A type for generic error reporting that should be sufficient for+-- most purposes.+--+data ErrorResponse = ErrorResponse {+    errorCode   :: Int,+    errorHeaders:: [(String, String)],+    errorTitle  :: String,+    errorDetail :: [MessageSpan]+} deriving (Eq, Show)++instance ToMessage ErrorResponse where+  toResponse (ErrorResponse code hdrs title detail) =+    let rspbody = title ++ ": " ++ messageToText detail ++ "\n"+     in Response {+          rsCode      = code,+          rsHeaders   = mkHeaders (("Content-Type",  "text/plain") : reverse hdrs),+          rsFlags     = nullRsFlags { rsfLength = ContentLength },+          rsBody      = Text.encodeUtf8 (Text.pack rspbody),+          rsValidator = Nothing+        }++-- | A message possibly including hypertext links.+--+-- The point is to be able to render error messages either as text or as html.+--+data MessageSpan = MLink String String | MText String+  deriving (Eq, Show)++-- | Format a message as simple text.+--+-- For html or other formats you'll have to write your own function!+--+messageToText :: [MessageSpan] -> String+messageToText []             = ""+messageToText (MLink x _:xs) = x ++ messageToText xs+messageToText (MText x  :xs) = x ++ messageToText xs++-- We don't want to use these methods directly anyway.+instance Error ErrorResponse where+    noMsg      = ErrorResponse 500 [] "Internal server error" []+    strMsg str = ErrorResponse 500 [] "Internal server error" [MText str]+++errBadRequest    :: String -> [MessageSpan] -> ServerPartE a+errBadRequest    title message = throwError (ErrorResponse 400 [] title message)++-- note: errUnauthorized is deliberately not provided because exceptions thrown+-- in this way bypass the FilterMonad stuff and so setHeaderM etc are ignored+-- but setHeaderM are usually needed for responding to auth errors.++errForbidden     :: String -> [MessageSpan] -> ServerPartE a+errForbidden     title message = throwError (ErrorResponse 403 [] title message)++errNotFound      :: String -> [MessageSpan] -> ServerPartE a+errNotFound      title message = throwError (ErrorResponse 404 [] title message)++errBadMediaType  :: String -> [MessageSpan] -> ServerPartE a+errBadMediaType  title message = throwError (ErrorResponse 415 [] title message)++errInternalError :: [MessageSpan] -> ServerPartE a+errInternalError       message = throwError (ErrorResponse 500 [] title message)+  where+    title = "Internal server error"++-- | Run a 'ServerPartE', including a top-level fallback error handler.+--+-- Any 'ErrorResponse' exceptions are turned into a simple error response with+-- a \"text/plain\" formated body.+--+-- To use a nicer custom formatted error response, use 'handleErrorResponse'.+--+runServerPartE :: ServerPartE a -> ServerPart a+runServerPartE = mapServerPartT' (spUnwrapErrorT fallbackHandler)+  where+    fallbackHandler :: ErrorResponse -> ServerPart a+    fallbackHandler err = finishWith (toResponse err)++handleErrorResponse :: (ErrorResponse -> ServerPartE Response)+                    -> ServerPartE a -> ServerPartE a+handleErrorResponse handler action =+    catchError action (\errResp -> handler errResp >>= finishWith)
+ Distribution/Server/Framework/Feature.hs view
@@ -0,0 +1,224 @@+-- | This module defines a plugin interface for hackage features.+--+{-# LANGUAGE ExistentialQuantification, RankNTypes, NoMonomorphismRestriction, RecordWildCards #-}+module Distribution.Server.Framework.Feature+  ( -- * Main datatypes+    HackageFeature(..)+  , IsHackageFeature(..)+  , emptyHackageFeature+    -- * State components+  , StateComponent(..)+  , OnDiskState(..)+  , AbstractStateComponent(..)+  , abstractAcidStateComponent+  , abstractAcidStateComponent'+  , abstractOnDiskStateComponent+  , queryState+  , updateState+  , compareState+    -- * Cache components+  , CacheComponent(..)+    -- * Re-exports+  , BlobStorage+  ) where++import Distribution.Server.Framework.BackupRestore (RestoreBackup(..), AbstractRestoreBackup(..), BackupEntry, abstractRestoreBackup)+import Distribution.Server.Framework.Resource      (Resource, ServerErrorResponse)+import Distribution.Server.Framework.BlobStorage   (BlobStorage)+import Distribution.Server.Framework.MemSize++import Data.Monoid+import Control.Monad (liftM, liftM2)+import Control.Monad.Trans (MonadIO)+import Data.Acid+import Data.Acid.Advanced++-- | We compose the overall hackage server featureset from a bunch of these+-- features. The intention is to make the hackage server reasonably modular+-- by allowing distinct features to be designed independently.+--+-- Features can hold their own canonical state and caches, and can provide a+-- set of resources.+--+data HackageFeature = HackageFeature {+    featureName        :: String+  , featureDesc        :: String+  , featureResources   :: [Resource]+  , featureErrHandlers :: [(String, ServerErrorResponse)]++  , featurePostInit    :: IO ()++  , featureState       :: [AbstractStateComponent]+  , featureCaches      :: [CacheComponent]+  }++-- | A feature with no state and no resources, just a name.+--+-- Define your new feature by extending this one, e.g.+--+-- > myHackageFeature = emptyHackageFeature "wizzo" {+-- >     featureResources = [wizzo]+-- >   }+--+emptyHackageFeature :: String -> HackageFeature+emptyHackageFeature name = HackageFeature {+    featureName      = name,+    featureDesc      = "",+    featureResources = [],+    featureErrHandlers= [],++    featurePostInit  = return (),++    featureState     = error $ "'featureState' not defined for feature '" ++ name ++ "'",+    featureCaches    = []+  }++class IsHackageFeature feature where+  getFeatureInterface :: feature -> HackageFeature++--------------------------------------------------------------------------------+-- State components                                                           --+--------------------------------------------------------------------------------++-- | A state component encapsulates (part of) a feature's state+data StateComponent f st = StateComponent {+    -- | Human readable description of the state component+    stateDesc    :: String+    -- | Handle required to access the state+  , stateHandle  :: f st+    -- | Return the entire state+  , getState     :: IO st+    -- | Overwrite the state+  , putState     :: st -> IO ()+    -- | (Pure) backup function+  , backupState  :: st -> [BackupEntry]+    -- | (Pure) backup restore+  , restoreState :: RestoreBackup st+    -- | Clone the state component in the given state directory+  , resetState   :: FilePath -> IO (StateComponent f st)+  }++data OnDiskState a = OnDiskState++-- | 'AbstractStateComponent' abstracts away from a particular type of+-- 'StateComponent'+data AbstractStateComponent = AbstractStateComponent {+    abstractStateDesc       :: String+  , abstractStateCheckpoint :: IO ()+  , abstractStateClose      :: IO ()+  , abstractStateBackup     :: IO [BackupEntry]+  , abstractStateRestore    :: AbstractRestoreBackup+  , abstractStateNewEmpty   :: FilePath -> IO (AbstractStateComponent, IO [String])+  , abstractStateSize       :: IO Int+  }++compareState :: (Eq st, Show st) => st -> st -> [String]+compareState old new =+    if old /= new+     then ["Internal state mismatch:\n" ++ difference (show old) (show new)]+     else []+  where+    difference old_str new_str+        -- = indent 2 old_str ++ "Versus:\n" ++ indent 2 new_str+        = "After " ++ show (length common)   ++ " chars, in context:\n" +++            indent 2 (trunc_last 80 common)  ++ "\nOld data was:\n" +++            indent 2 (trunc 80 old_str_tail) ++ "\nVersus new data:\n" +++            indent 2 (trunc 80 new_str_tail)+      where (common, old_str_tail, new_str_tail) = dropCommonPrefix [] old_str new_str++    indent n = unlines . map (replicate n ' ' ++) . lines++    trunc n xs | null zs   = ys+               | otherwise = ys ++ "..."+      where (ys, zs) = splitAt n xs++    trunc_last n xs | null ys_rev = reverse zs_rev+                    | otherwise   = "..." ++ reverse zs_rev+      where (zs_rev, ys_rev) = splitAt n (reverse xs)++    dropCommonPrefix common (x:xs) (y:ys) | x == y = dropCommonPrefix (x:common) xs ys+    dropCommonPrefix common xs ys = (reverse common, xs, ys)++abstractAcidStateComponent :: (Eq st, Show st, MemSize st)+                           => StateComponent AcidState st -> AbstractStateComponent+abstractAcidStateComponent = abstractAcidStateComponent' compareState++abstractAcidStateComponent' :: MemSize st+                            => (st -> st -> [String])+                            -> StateComponent AcidState st -> AbstractStateComponent+abstractAcidStateComponent' cmp st = AbstractStateComponent {+    abstractStateDesc       = stateDesc st+  , abstractStateCheckpoint = createCheckpoint (stateHandle st)+  , abstractStateClose      = closeAcidState (stateHandle st)+  , abstractStateBackup     = liftM (backupState st) (getState st)+  , abstractStateRestore    = abstractRestoreBackup (putState st) (restoreState st)+  , abstractStateNewEmpty   = \stateDir -> do+                                st' <- resetState st stateDir+                                let cmpSt = liftM2 cmp (getState st) (getState st')+                                return (abstractAcidStateComponent' cmp st', cmpSt)+  , abstractStateSize       = liftM memSize (getState st)+  }++abstractOnDiskStateComponent :: (Eq st, Show st) => StateComponent OnDiskState st -> AbstractStateComponent+abstractOnDiskStateComponent st = AbstractStateComponent {+    abstractStateDesc       = stateDesc st+  , abstractStateCheckpoint = return ()+  , abstractStateClose      = return ()+  , abstractStateBackup     = liftM (backupState st) (getState st)+  , abstractStateRestore    = abstractRestoreBackup (putState st) (restoreState st)+  , abstractStateNewEmpty   = \stateDir -> do+                                st' <- resetState st stateDir+                                let cmpSt = liftM2 compareState (getState st) (getState st')+                                return (abstractOnDiskStateComponent st', cmpSt)+  , abstractStateSize       = return 0+  }++instance Monoid AbstractStateComponent where+  mempty = AbstractStateComponent {+      abstractStateDesc       = ""+    , abstractStateCheckpoint = return ()+    , abstractStateClose      = return ()+    , abstractStateBackup     = return []+    , abstractStateRestore    = mempty+    , abstractStateNewEmpty   = \_stateDir -> return (mempty, return [])+    , abstractStateSize       = return 0+    }+  a `mappend` b = AbstractStateComponent {+      abstractStateDesc       = abstractStateDesc a ++ "\n" ++ abstractStateDesc b+    , abstractStateCheckpoint = abstractStateCheckpoint a >> abstractStateCheckpoint b+    , abstractStateClose      = abstractStateClose a >> abstractStateClose b+    , abstractStateBackup     = liftM2 (++) (abstractStateBackup a) (abstractStateBackup b)+    , abstractStateRestore    = abstractStateRestore a `mappend` abstractStateRestore b+    , abstractStateNewEmpty   = \stateDir -> do+                                 (a', cmpA) <- abstractStateNewEmpty a stateDir+                                 (b', cmpB) <- abstractStateNewEmpty b stateDir+                                 return (a' `mappend` b', liftM2 (++) cmpA cmpB)+    , abstractStateSize       = liftM2 (+) (abstractStateSize a)+                                           (abstractStateSize b)+    }++queryState :: (MonadIO m, QueryEvent event)+           => StateComponent AcidState (EventState event)+           -> event+           -> m (EventResult event)+queryState = query' . stateHandle++updateState :: (MonadIO m, UpdateEvent event)+            => StateComponent AcidState (EventState event)+            -> event+            -> m (EventResult event)+updateState = update' . stateHandle+++--------------------------------------------------------------------------------+-- Cache components                                                           --+--------------------------------------------------------------------------------++-- | A cache component encapsulates a cache, managed by a feature+data CacheComponent = CacheComponent {+    -- | Human readable description of the state component+    cacheDesc :: String++    -- | Get the current memory residency of the cache+  , getCacheMemSize :: IO Int+  }
+ Distribution/Server/Framework/Hook.hs view
@@ -0,0 +1,43 @@+module Distribution.Server.Framework.Hook (+    Hook,+    newHook,+    registerHook,+    registerHookJust,++    runHook,+    runHook_,+  ) where++import Data.IORef+import Control.Monad.Trans (MonadIO, liftIO)++-- | A list of actions accociated with an event.+--+newtype Hook a b = Hook (IORef [a -> IO b])++newHook :: IO (Hook a b)+newHook = fmap Hook $ newIORef []++-- registers a hook to be run *before* all of the previously registered hooks.+-- is this the best strategy? relying on ordering rules of any kind can introduce+-- nasty bugs.+registerHook :: Hook a b -> (a -> IO b) -> IO ()+registerHook (Hook ref) action =+  atomicModifyIORef ref (\actions -> (action:actions, ())) ++registerHookJust :: Hook a () -> (a -> Maybe b) -> (b -> IO ()) -> IO ()+registerHookJust (Hook ref) predicate action =+    atomicModifyIORef ref (\actions -> (action':actions, ())) +  where+    action' x = maybe (return ()) action (predicate x)++runHook :: MonadIO m => Hook a b -> a -> m [b]+runHook (Hook ref) x = liftIO $ do+  actions <- readIORef ref+  sequence [ action x | action <- actions ]++runHook_ :: MonadIO m => Hook a () -> a -> m ()+runHook_ (Hook ref) x = liftIO $ do+  actions <- readIORef ref+  sequence_ [ action x | action <- actions ]+
+ Distribution/Server/Framework/Instances.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, FlexibleContexts, CPP #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | 'Typeable', 'Binary', 'Serialize', 'Text', and 'NFData' instances for various+-- types from Cabal, and other standard libraries.+--+-- Major version changes may break this module.+--++module Distribution.Server.Framework.Instances () where++import Distribution.Text+import Distribution.Server.Framework.MemSize++import Distribution.Package (PackageIdentifier(..), PackageName(..))+import Distribution.PackageDescription+         (GenericPackageDescription(..))+import Distribution.Version (Version(..), VersionRange(..))++import Data.Typeable+import Data.Time.Clock (UTCTime(..))+import Data.Time.Calendar (Day(..))++import Control.DeepSeq++import qualified Data.Serialize as Serialize+import Data.Serialize (Serialize)+import Data.SafeCopy (SafeCopy(getCopy, putCopy), contain)++import Happstack.Server++import Data.Maybe (fromJust)++import qualified Text.PrettyPrint as PP (text)+import Distribution.Compat.ReadP (readS_to_P)+#if !(MIN_VERSION_bytestring(0,10,0))+import qualified Data.ByteString as SBS+import qualified Data.ByteString.Lazy as LBS+#endif+++deriving instance Typeable PackageIdentifier+deriving instance Typeable GenericPackageDescription+deriving instance Typeable PackageName+deriving instance Typeable VersionRange++instance Serialize PackageIdentifier where+  put = Serialize.put . show+  get = fmap read Serialize.get++instance SafeCopy PackageIdentifier where+  putCopy = contain . Serialize.put . show+  getCopy = contain $ fmap read Serialize.get++instance SafeCopy PackageName where+    getCopy = contain textGet+    putCopy = contain . textPut++instance SafeCopy Version where+    getCopy = contain textGet+    putCopy = contain . textPut++instance SafeCopy VersionRange where+    getCopy = contain textGet+    putCopy = contain . textPut++instance FromReqURI PackageIdentifier where+  fromReqURI = simpleParse++instance FromReqURI PackageName where+  fromReqURI = simpleParse++instance FromReqURI Version where+  fromReqURI = simpleParse++-- These assume that the text representations+-- for Cabal types will be stable over time+textGet :: Text a => Serialize.Get a+textGet = (fromJust . simpleParse)  `fmap` Serialize.get++textPut :: Text a => a -> Serialize.Put+textPut = Serialize.put . display++instance Serialize UTCTime where+  put time = do+    Serialize.put (toModifiedJulianDay $ utctDay time)+    Serialize.put (toRational $ utctDayTime time)+  get = do+    day  <- Serialize.get+    secs <- Serialize.get+    return (UTCTime (ModifiedJulianDay day) (fromRational secs))++-- rough versions of RNF for these+#if !(MIN_VERSION_bytestring(0,10,0))+instance NFData LBS.ByteString where+    rnf bs = LBS.length bs `seq` ()++instance NFData SBS.ByteString where+    rnf bs = bs `seq` ()+#endif++instance NFData Response where+    rnf res@(Response{}) = rnf (rsBody res) `seq` rnf (rsHeaders res)+    rnf _ = ()++instance NFData HeaderPair where+    rnf (HeaderPair a b) = rnf a `seq` rnf b++instance NFData PackageName where+    rnf (PackageName pkg) = rnf pkg++instance NFData PackageIdentifier where+    rnf (PackageIdentifier name version) = rnf name `seq` rnf version++#if !(MIN_VERSION_deepseq(1,3,0))+instance NFData Version where+    rnf (Version branch tags) = rnf branch `seq` rnf tags+#endif++#if !(MIN_VERSION_time(1,4,0))+instance NFData Day where+    rnf (ModifiedJulianDay a) = rnf a+#endif++instance MemSize Response where+    memSize (Response a b c d e) = memSize5 a b c d e+    memSize (SendFile{})         = 42++instance MemSize HeaderPair where+    memSize (HeaderPair a b) = memSize2 a b++instance MemSize RsFlags where+    memSize (RsFlags a) = memSize1 a++instance MemSize Length where+    memSize _ = memSize0++instance Text Day where+  disp  = PP.text . show +  parse = readS_to_P (reads :: ReadS Day)+
+ Distribution/Server/Framework/Logging.hs view
@@ -0,0 +1,43 @@+module Distribution.Server.Framework.Logging (+    Verbosity,+    lognotice,+    loginfo,+    logdebug,+    logTiming,+  ) where++import Distribution.Verbosity+import System.IO+import qualified Data.ByteString.Char8 as BS -- No UTF8 in log messages+import System.Environment+import Control.Monad (when)+import Data.Time.Clock (getCurrentTime, diffUTCTime)+++lognotice :: Verbosity -> String -> IO ()+lognotice verbosity msg =+  when (verbosity >= normal) $ do+    pname <- getProgName+    BS.hPutStrLn stdout (BS.pack $ pname ++ ": " ++ msg)+    hFlush stdout++loginfo :: Verbosity -> String -> IO ()+loginfo verboisty msg =+  when (verboisty >= verbose) $ do+    BS.hPutStrLn stderr (BS.pack msg)+    hFlush stderr++logdebug :: Verbosity -> String -> IO ()+logdebug verbosity msg =+  when (verbosity >= deafening) $ do+    BS.hPutStrLn stderr (BS.pack msg)+    hFlush stderr++logTiming :: Verbosity -> String -> IO a -> IO a+logTiming verbosity msg action = do+    t   <- getCurrentTime+    res <- action+    t'  <- getCurrentTime+    loginfo verbosity (msg ++ ". time: " ++ show (diffUTCTime t' t))+    return res+
+ Distribution/Server/Framework/MemSize.hs view
@@ -0,0 +1,193 @@+module Distribution.Server.Framework.MemSize (+  MemSize(..),+  memSizeMb, memSizeKb,+  memSize0, memSize1, memSize2, memSize3, memSize4,+  memSize5, memSize6, memSize7, memSize10,+  memSizeUArray, memSizeUVector+  ) where++import Data.Word+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.IntSet as IntSet+import Data.IntSet (IntSet)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T+import Data.Time (UTCTime, Day)+import Data.Ix+import qualified Data.Array.Unboxed as A+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as V.U++import Distribution.Package  (PackageIdentifier(..), PackageName(..))+import Distribution.PackageDescription (FlagName(..))+import Distribution.Version  (Version(..), VersionRange(..))+import Distribution.System   (Arch(..), OS(..))+import Distribution.Compiler (CompilerFlavor(..), CompilerId(..))++-------------------------------------------------------------------------------+-- Mem size class and instances+--++memSizeMb, memSizeKb :: Int -> Int+memSizeMb w = wordSize * w `div` (1024 * 1024)+memSizeKb w = wordSize * w `div` 1024++wordSize :: Int+wordSize = 8++-- | Size in the heap of values, in words (so multiply by 4 or 8)+class MemSize a where+  memSize :: a -> Int++memSize0 :: Int+memSize1 :: MemSize a => a -> Int+memSize2 :: (MemSize a1, MemSize a) => a -> a1 -> Int+memSize3 :: (MemSize a2, MemSize a1, MemSize a) => a -> a1 -> a2 -> Int+memSize4 :: (MemSize a3, MemSize a2, MemSize a1, MemSize a) => a -> a1 -> a2 -> a3 -> Int+memSize5 :: (MemSize a4, MemSize a3, MemSize a2, MemSize a1, MemSize a) => a -> a1 -> a2 -> a3 -> a4 -> Int+memSize6 :: (MemSize a5, MemSize a4, MemSize a3, MemSize a2, MemSize a1, MemSize a) => a -> a1 -> a2 -> a3 -> a4 -> a5 -> Int+memSize7 :: (MemSize a6, MemSize a5, MemSize a4, MemSize a3, MemSize a2, MemSize a1, MemSize a) => a -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> Int+memSize10 :: (MemSize a9, MemSize a8, MemSize a7, MemSize a6, MemSize a5, MemSize a4, MemSize a3, MemSize a2, MemSize a1, MemSize a) => a -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> Int++                           +memSize0             = 0+memSize1 a           = 2 + memSize a+memSize2 a b         = 3 + memSize a + memSize b+memSize3 a b c       = 4 + memSize a + memSize b + memSize c+memSize4 a b c d     = 5 + memSize a + memSize b + memSize c+                         + memSize d+memSize5 a b c d e   = 6 + memSize a + memSize b + memSize c+                         + memSize d + memSize e+memSize6 a b c d e f = 7 + memSize a + memSize b + memSize c+                         + memSize d + memSize e + memSize f+memSize7 a b c d e+         f g         = 8 + memSize a + memSize b + memSize c+                         + memSize d + memSize e + memSize f+                         + memSize g++memSize10 a b c d e+          f g h i j  = 11 + memSize a + memSize b + memSize c+                          + memSize d + memSize e + memSize f+                          + memSize g + memSize h + memSize i+                          + memSize j++instance MemSize (a -> b) where+  memSize _ = 0++instance MemSize Int where+  memSize _ = 2++instance MemSize Word where+  memSize _ = 2++instance MemSize Word32 where+  memSize _ = 2++instance MemSize Char where+  memSize _ = 0++instance MemSize Bool where+  memSize _ = 0++instance MemSize Integer where+  memSize _ = 2++instance MemSize UTCTime where+  memSize _ = 7++instance MemSize Day where+  memSize _ = 2++instance MemSize a => MemSize [a] where+  memSize []     = memSize0+  memSize (x:xs) = memSize2 x xs+--   memSize xs = 2 + length xs + sum (map memSize xs)++instance (MemSize a, MemSize b) => MemSize (a,b) where+  memSize (a,b) = memSize2 a b++instance (MemSize a, MemSize b, MemSize c) => MemSize (a,b,c) where+  memSize (a,b,c) = memSize3 a b c++instance MemSize a => MemSize (Maybe a) where+  memSize Nothing  = memSize0+  memSize (Just a) = memSize1 a++instance (MemSize a, MemSize b) => MemSize (Either a b) where+  memSize (Left  a) = memSize1 a+  memSize (Right b) = memSize1 b++instance (MemSize a, MemSize b) => MemSize (Map a b) where+  memSize m = sum [ 6 + memSize k + memSize v | (k,v) <- Map.toList m ]++instance MemSize a => MemSize (IntMap a) where+  memSize m = sum [ 8 + memSize v | v <- IntMap.elems m ]++instance MemSize a => MemSize (Set a) where+  memSize m = sum [ 5 + memSize v | v <- Set.elems m ]++instance MemSize IntSet where+  memSize s = 4 * IntSet.size s --estimate++instance MemSize BS.ByteString where+  memSize s = let (w,t) = divMod (BS.length s) wordSize+               in 5 + w + signum t++instance MemSize LBS.ByteString where+  memSize s = sum [ 1 + memSize c | c <- LBS.toChunks s ]++instance MemSize T.Text where+  memSize s = let (w,t) = divMod (T.length s) (wordSize `div` 2)+               in 5 + w + signum t++memSizeUArray :: (Ix i, A.IArray a e) => Int -> a i e -> Int+memSizeUArray sz a = 13 + (rangeSize (A.bounds a) * sz) `div` wordSize++instance MemSize e => MemSize (V.Vector e) where+  memSize a = 5 + V.length a + V.foldl' (\s e -> s + memSize e) 0 a++memSizeUVector :: V.U.Unbox e => Int -> V.U.Vector e -> Int+memSizeUVector sz a = 5 + (V.U.length a * sz) `div` wordSize+++----++instance MemSize PackageName where+    memSize (PackageName n) = memSize n++instance MemSize Version where+    memSize (Version a b) = memSize2 a b++instance MemSize VersionRange where+    memSize (AnyVersion)                   = memSize0+    memSize (ThisVersion v)                = memSize1 v+    memSize (LaterVersion v)               = memSize1 v+    memSize (EarlierVersion v)             = memSize1 v+    memSize (WildcardVersion v)            = memSize1 v+    memSize (UnionVersionRanges v1 v2)     = memSize2 v1 v2+    memSize (IntersectVersionRanges v1 v2) = memSize2 v1 v2+    memSize (VersionRangeParens v)         = memSize1 v++instance MemSize PackageIdentifier where+    memSize (PackageIdentifier a b) = memSize2 a b++instance MemSize Arch where+    memSize _ = memSize0++instance MemSize OS where+    memSize _ = memSize0++instance MemSize FlagName where+    memSize (FlagName n) = memSize n++instance MemSize CompilerFlavor where+    memSize _ = memSize0++instance MemSize CompilerId where+    memSize (CompilerId a b) = memSize2 a b
+ Distribution/Server/Framework/MemState.hs view
@@ -0,0 +1,43 @@+module Distribution.Server.Framework.MemState (+    MemState,+    newMemStateNF,+    newMemStateWHNF,+    readMemState,+    writeMemState,+    modifyMemState,+  ) where++import Control.Concurrent.MVar+import Control.Exception (evaluate)+import Control.Monad.Trans (MonadIO(liftIO))+import Control.DeepSeq (NFData, rnf)++-- | General-purpose in-memory ephemeral state.+data MemState a = MemState !(MVar a) (a -> ())++newMemStateWHNF :: a -> IO (MemState a)+newMemStateWHNF state = do+  var <- newMVar state+  return (MemState var (\x -> seq x ()))++newMemStateNF :: NFData a => a -> IO (MemState a)+newMemStateNF state = do+  var <- newMVar state+  return (MemState var rnf)++readMemState :: MonadIO m => MemState a -> m a+readMemState (MemState var _) = liftIO $ readMVar var++writeMemState :: MonadIO m => MemState a -> a -> m ()+writeMemState (MemState var force) x =+  liftIO $ modifyMVar_ var $ \_ -> do+    evaluate (force x)+    return x++modifyMemState :: MonadIO m => MemState a -> (a -> a) -> m ()+modifyMemState (MemState var force) f =+  liftIO $ modifyMVar_ var $ \x -> do+    let x' = f x+    evaluate (force x')+    return x'+
+ Distribution/Server/Framework/RequestContentTypes.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE OverloadedStrings, PatternGuards #-}+-- |+--+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Server.Framework.RequestContentTypes+-- Copyright   :  (c) Duncan Coutts 2012-2013+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Utilities for validating and consuming the body of requests for various+-- content types like plain text, tarballs, JSON etc.+-----------------------------------------------------------------------------+module Distribution.Server.Framework.RequestContentTypes (++    -- * checking mime types+    expectContentType,++    -- * various specific content types+    expectTextPlain,+    expectUncompressedTarball,+    expectCompressedTarball,+    expectAesonContent,+    expectCSV,++  ) where++import Happstack.Server+import Distribution.Server.Util.Happstack+import Distribution.Server.Framework.Error+import qualified Data.ByteString.Char8 as BS (ByteString, unpack) -- Used for content-type headers only+import qualified Data.ByteString.Lazy as LBS (ByteString)+import qualified Codec.Compression.Zlib.Internal as GZip+import qualified Data.Aeson as Aeson++-- | Expect the request body to have the given mime type (exact match),+-- and to have either no content-encoding, or gzip encoding+-- (which is transparently decoded).+--+expectContentType :: BS.ByteString -> ServerPartE LBS.ByteString+expectContentType expected = do+    req <- askRq+    let contentType     = getHeader "Content-Type" req+        contentEncoding = getHeader "Content-Encoding" req+    case contentType of+      Just actual+        | actual == expected -> case contentEncoding of+           Nothing           -> consumeRequestBody+           Just enc+             | enc == "gzip" -> consumeRequestBody >>= gzipDecompress+           _                 -> wrongContentEncoding+        | otherwise          -> wrongContentType actual+      Nothing                -> missingContentType+  where+    missingContentType =+      errBadMediaType "Missing content-type"+        [MText "An HTTP content-type header was expected."]+    wrongContentType actual =+      errBadMediaType "Unexpected content-type"+        [MText $ "For this resource the content-type was expected to be "+              ++ BS.unpack expected ++ ", rather than " ++ BS.unpack actual]+    wrongContentEncoding =+      errBadMediaType "Unexpected content-encoding"+        [MText $ "The only content-encodings supported are gzip, or none at all."]++gzipDecompress :: LBS.ByteString -> ServerPartE LBS.ByteString+gzipDecompress content =+    case GZip.decompressWithErrors+           GZip.gzipFormat GZip.defaultDecompressParams content of+      GZip.StreamError errkind _ -> errDecompress errkind+      stream                     -> return (GZip.fromDecompressStream stream)+  where+    errDecompress GZip.TruncatedInput =+      errBadRequest "Truncated data upload"+        [MText $ "The uploaded data (gzip-compressed) is truncated. Check "+              ++ "your gzip data is complete, and try again."]+    errDecompress _ =+      errBadRequest "Corrupted upload"+        [MText $ "There is an error in the gzip encoding of the uploaded "+              ++ "data. Check that the uploaded data is compressed using "+              ++ "the gzip format."]++-- | Expect the request body to have mime type @text/plain@ and no+-- content-encoding.+--+expectTextPlain :: ServerPartE LBS.ByteString+expectTextPlain = expectContentType "text/plain"++-- | Expect an uncompressed @.tar@ file.+--+-- The tar file is not validated.+--+-- A content-encoding of \"gzip\" is handled transparently.+--+expectUncompressedTarball :: ServerPartE LBS.ByteString+expectUncompressedTarball = expectContentType "application/x-tar"++-- | Expect a compressed @.tar.gz@ file.+--+-- Neither the gzip encoding nor the tar format are validated.+--+-- Compressed tarballs are a little odd in that some clients send them+-- as mime type @application/x-gzip@ with no content-encoding, while others+-- use @application/x-tar@ with a @gzip@ content-encoding. We allow either.+--+expectCompressedTarball :: ServerPartE LBS.ByteString+expectCompressedTarball = do+    req <- askRq+    let contentType     = getHeader "Content-Type" req+        contentEncoding = getHeader "Content-Encoding" req+    case contentType of+      Just actual+        | actual == "application/x-tar"+        , contentEncoding == Just "gzip" -> consumeRequestBody+        | actual == "application/x-gzip"+        , contentEncoding == Nothing     -> consumeRequestBody+      _                                  -> errExpectedTarball+  where+    errExpectedTarball =+      errBadMediaType "Expected a compressed tarball"+        [MText $ "Expected either content-type application/x-tar "+              ++ " (with a content-encoding of gzip) or application/x-gzip."]++expectAesonContent :: Aeson.FromJSON a => ServerPartE a+expectAesonContent = do+  content <- expectContentType "application/json"+  case Aeson.eitherDecode' content of+    Right a  -> return a+    Left msg -> errBadRequest "Malformed request"+                   [MText $ "The JSON data is not in the expected form: " ++ msg]++expectCSV :: ServerPartE LBS.ByteString+expectCSV = expectContentType "text/csv"
+ Distribution/Server/Framework/Resource.hs view
@@ -0,0 +1,595 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving,+             FlexibleContexts, FlexibleInstances, NamedFieldPuns #-}++module Distribution.Server.Framework.Resource (+    -- | Paths+    DynamicPath,+    BranchComponent(..),+    BranchPath,+    trunkAt,++    -- | Resources+    Resource(..),+    ResourceFormat(..),+    BranchFormat(..),+    BranchEnd(..),+    Content,+    resourceAt,+    extendResource,+    extendResourcePath,+    serveResource,+    resourceMethods,++    -- | URI generation+    renderURI,+    renderResource,+    renderResource',++    -- | ServerTree+    ServerTree(..),+    serverTreeEmpty,+    addServerNode,+    renderServerTree,+    drawServerTree,++    -- | Error page serving+    serveErrorResponse,+    ServerErrorResponse,+  ) where++import Happstack.Server+import Distribution.Server.Util.Happstack (remainingPathString, uriEscape)+import Distribution.Server.Util.ContentType (parseContentAccept)+import Distribution.Server.Framework.Error++import Data.List (isSuffixOf)+import Data.Monoid+import Data.Map (Map)+import qualified Data.Map as Map+import Control.Monad+import Data.Maybe+import Data.Function (on)+import Data.List (intercalate, unionBy, findIndices, find)+import qualified Text.ParserCombinators.Parsec as Parse++import System.FilePath.Posix ((</>), (<.>))+import qualified Data.Tree as Tree (Tree(..), drawTree)+import qualified Data.ByteString.Char8 as BS -- Used for accept header only++type Content = String++type DynamicPath = [(String, String)]++type ServerResponse = DynamicPath -> ServerPartE Response+type ServerErrorResponse = ErrorResponse -> ServerPartE Response++-- | A resource is an object that handles requests at a given URI. Best practice+-- is to construct it by calling resourceAt and then setting the method fields+-- using record update syntax. You can also extend an existing resource with+-- extendResource, which can be mappended to the original to combine their+-- functionality, or with extendResourcePath.+data Resource = Resource {+    -- | The location in a form which can be added to a ServerTree.+    resourceLocation :: BranchPath,+    -- | Handlers for GET requests for different content-types+    resourceGet      :: [(Content, ServerResponse)],+    -- | Handlers for PUT requests+    resourcePut      :: [(Content, ServerResponse)],+    -- | Handlers for POST requests+    resourcePost     :: [(Content, ServerResponse)],+    -- | Handlers for DELETE requests+    resourceDelete   :: [(Content, ServerResponse)],+    -- | The format conventions held by the resource.+    resourceFormat   :: ResourceFormat,+    -- | The trailing slash conventions held by the resource.+    resourcePathEnd  :: BranchEnd,+    -- | Human readable description of the resource+    resourceDesc     :: [(Method, String)]+  }++-- favors first+instance Monoid Resource where+    mempty = Resource [] [] [] [] [] noFormat NoSlash []+    mappend (Resource bpath rget rput rpost rdelete rformat rend desc)+            (Resource bpath' rget' rput' rpost' rdelete' rformat' rend' desc') =+        Resource (simpleCombine bpath bpath') (ccombine rget rget') (ccombine rput rput')+                   (ccombine rpost rpost') (ccombine rdelete rdelete')+                   (simpleCombine rformat rformat') (simpleCombine rend rend') (desc ++ desc')+      where ccombine = unionBy ((==) `on` fst)+            simpleCombine xs ys = if null bpath then ys else xs++-- | A path element of a URI.+--+-- * StaticBranch dirName - \/dirName+-- * DynamicBranch dynamicName - \/anyName (mapping created dynamicName -> anyName)+-- * TrailingBranch - doesn't consume any path; it's here to prevent e.g. conflict between \/.:format and \/...+--+-- trunkAt yields a simple list of BranchComponents.+-- resourceAt yields the same, and some complex metadata for processing formats and the like.+data BranchComponent = StaticBranch String | DynamicBranch String | TrailingBranch deriving (Show, Eq, Ord)+type BranchPath = [BranchComponent]++-- | This type dictates the preprocessing we must do on extensions (foo.json) when serving Resources+-- For BranchFormat, we need to do:+-- 1. for NoFormat - don't do any preprocessing. The second field is ignored here.+-- 1. for StaticFormat  - look for a specific format, and guard against that+-- 2. for DynamicFormat - strip off any extension (starting from the right end, so no periods allowed)+-- Under either of the above cases, the component might need to be preprocessed as well.+-- 1. for Nothing - this means a standalone format, like \/.json (as in \/distro\/arch\/.json)+--                  either accept \/distro\/arch\/ or read \/distro\/arch\/.format and pass it along+-- 2. for Just (StaticBranch sdir) - strip off the pre-format part and make sure it equals sdir+-- 3. for Just (DynamicBranch sdir) - strip off the pre-format part and pass it with the DynamicPath as sdir+-- DynamicFormat also has the property that it is optional, and defaulting is allowed.+data ResourceFormat = ResourceFormat BranchFormat (Maybe BranchComponent) deriving (Show, Eq, Ord)++noFormat :: ResourceFormat+noFormat = ResourceFormat NoFormat Nothing++data BranchFormat = NoFormat | DynamicFormat | StaticFormat String deriving (Show, Eq, Ord)+data BranchEnd  = Slash | NoSlash | Trailing deriving (Show, Eq, Ord)++-- | Creates an empty resource from a string specifying its location and format conventions.+--+-- (Explain path literal syntax.)+resourceAt :: String -> Resource+resourceAt arg = mempty+  { resourceLocation = reverse loc+  , resourceFormat  = format+  , resourcePathEnd = slash+  }+  where+    branch = either trunkError id $ Parse.parse parseFormatTrunkAt "Distribution.Server.Resource.parseFormatTrunkAt" arg+    trunkError pe = error $ "Distribution.Server.Resource.resourceAt: Could not parse trunk literal " ++ show arg ++ ". Parsec error: " ++ show pe+    (loc, slash, format) = trunkToResource branch++-- | Creates a new resource at the same location, but without any of the request+-- handlers of the original. When mappend'd to the original, its methods and content-types+-- will be combined. This can be useful for extending an existing resource with new representations and new+-- functionality.+extendResource :: Resource -> Resource+extendResource resource = resource {+    resourceDesc   = []+  , resourceGet    = []+  , resourcePut    = []+  , resourcePost   = []+  , resourceDelete = []+  }++-- | Creates a new resource that is at a subdirectory of an existing resource. This function takes care of formats+-- as best as it can.+--+-- extendResourcePath "\/bar\/.:format" (resourceAt "\/data\/:foo.:format") == resourceAt "\/data\/:foo\/bar\/:.format"+--+-- Extending static formats with this method is not recommended. (extending "\/:tarball.tar.gz"+-- with "\/data" will give "\/:tarball\/data", with the format stripped, and extending+-- "\/help\/.json" with "\/tree" will give "\/help\/.json\/tree")+extendResourcePath :: String -> Resource -> Resource+extendResourcePath arg resource =+  let endLoc = case resourceFormat resource of+        ResourceFormat (StaticFormat _) Nothing -> case loc of+            (DynamicBranch "format":rest) -> rest+            _ -> funcError "Static ending format must have dynamic 'format' branch"+        ResourceFormat (StaticFormat _) (Just (StaticBranch sdir)) -> case loc of+            (DynamicBranch sdir':rest) | sdir == sdir' -> rest+            _ -> funcError "Static branch and format must match stated location"+        ResourceFormat (StaticFormat _) (Just (DynamicBranch sdir)) -> case loc of+            (DynamicBranch sdir':_) | sdir == sdir' -> loc+            _ -> funcError "Dynamic branch with static format must match stated location"+        ResourceFormat DynamicFormat Nothing -> loc+        ResourceFormat DynamicFormat (Just (StaticBranch sdir)) -> case loc of+            (DynamicBranch sdir':rest) | sdir == sdir' -> StaticBranch sdir:rest+            _ -> funcError "Dynamic format with static branch must match stated location"+        ResourceFormat DynamicFormat (Just (DynamicBranch sdir)) -> case loc of+            (DynamicBranch sdir':_) | sdir == sdir' -> loc+            _ -> funcError "Dynamic branch and format must match stated location"+        -- For a URI like /resource/.format: since it is encoded as NoFormat in trunkToResource,+        -- this branch will incorrectly be taken. this isn't too big a handicap though+        ResourceFormat NoFormat Nothing -> case loc of+            (TrailingBranch:rest) -> rest+            _ -> loc+        _ -> funcError $ "invalid resource format in argument 2"+  in+    extendResource resource { resourceLocation = reverse loc' ++ endLoc, resourceFormat = format', resourcePathEnd = slash' }+  where+    branch = either trunkError id $ Parse.parse parseFormatTrunkAt "Distribution.Server.Resource.parseFormatTrunkAt" arg+    trunkError pe = funcError $ "Could not parse trunk literal " ++ show arg ++ ". Parsec error: " ++ show pe+    funcError reason = error $ "Distribution.Server.Resource.extendResourcePath :" ++ reason+    loc = resourceLocation resource+    (loc', slash', format') = trunkToResource branch++-- Allows the formation of a URI from a URI specification (BranchPath).+-- URIs may obey additional constraints and have special rules (e.g., formats).+-- To accomodate these, insteaduse renderResource to get a URI.+--+-- ".." is a special argument that fills in a TrailingBranch. Make sure it's+-- properly escaped (see Happstack.Server.SURI)+--+-- renderURI (trunkAt "/home/:user/..")+--    [("user", "mgruen"), ("..", "docs/todo.txt")]+--    == "/home/mgruen/docs/todo.txt"+renderURI :: BranchPath -> DynamicPath -> String+renderURI bpath dpath = renderGenURI bpath (flip lookup dpath)++-- Render a URI generally using a function of one's choosing (usually flip lookup dpath)+-- Stops when a requested field is not found, yielding an incomplete URI. I think+-- this is better than having a function that doesn't return *some* result.+renderGenURI :: BranchPath -> (String -> Maybe String) -> String+renderGenURI bpath pathFunc = "/" </> go (reverse bpath)+  where go (StaticBranch  sdir:rest) = uriEscape sdir </> go rest+        go (DynamicBranch sdir:rest)+          | (ddir, sformat@('.':_)) <- break (=='.') sdir+          = case pathFunc ddir of+            Nothing  -> ""+            Just str -> uriEscape str <.> uriEscape sformat </> go rest+        go (DynamicBranch sdir:rest) = case pathFunc sdir of+            Nothing  -> ""+            Just str -> uriEscape str </> go rest+        go (TrailingBranch:_) = fromMaybe "" $ pathFunc ".."+        go [] = ""++-- Doesn't use a DynamicPath - rather, munches path components from a list+-- it stops if there aren't enough, and returns the extras if there's more than enough.+--+-- Trailing branches currently are assumed to be complete escaped URI paths.+renderListURI :: BranchPath -> [String] -> (String, [String])+renderListURI bpath list = let (res, extra) = go (reverse bpath) list in ("/" </> res, extra)+    where go (StaticBranch  sdir:rest) xs  = let (res, extra) = go rest xs in (uriEscape sdir </> res, extra)+          go (DynamicBranch _:rest) (x:xs) = let (res, extra) = go rest xs in (uriEscape x </> res, extra)+          go (TrailingBranch:_) xs = case xs of [] -> ("", []); (x:rest) -> (x, rest)+          go _ rest = ("", rest)++-- Given a Resource, construct a URI generator. If the Resource uses a dynamic format, it can+-- be passed in the DynamicPath as "format". Trailing slash conventions are obeyed.+--+-- See documentation for the Resource to see the conventions in interpreting the DynamicPath.+-- As in renderURI, ".." is interpreted as the trailing branch. It should be the case that+--+-- > fix $ \r -> (resourceAt uri) { resourceGet = [("txt", ok . toResponse . renderResource' r)] }+--+-- will print the URI that was used to request the page.+--+-- renderURI (resourceAt "/home/:user/docs/:doc.:format")+--     [("user", "mgruen"), ("doc", "todo"), ("format", "txt")]+--     == "/home/mgruen/docs/todo.txt"+renderResource' :: Resource -> DynamicPath -> String+renderResource' resource dpath = renderResourceFormat resource (lookup "format" dpath)+               $ renderGenURI (normalizeResourceLocation resource) (flip lookup dpath)++-- A more convenient form of renderResource'. Used when you know the path structure.+-- The first argument unused in the path, if any, will be used as a dynamic format,+-- if any.+--+-- renderResource (resourceAt "/home/:user/docs/:doc.:format")+--     ["mgruen", "todo", "txt"]+--     == "/home/mgruen/docs/todo.txt"+renderResource :: Resource -> [String] -> String+renderResource resource list = case renderListURI (normalizeResourceLocation resource) list of+    (str, format:_) -> renderResourceFormat resource (Just format) str+    (str, []) -> renderResourceFormat resource Nothing str++-- in some cases, DynamicBranches are used to accomodate formats for StaticBranches.+-- this returns them to their pre-format state so renderGenURI can handle them+normalizeResourceLocation :: Resource -> BranchPath+normalizeResourceLocation resource = case (resourceFormat resource, resourceLocation resource) of+    (ResourceFormat _ (Just (StaticBranch sdir)), DynamicBranch sdir':xs) | sdir == sdir' -> StaticBranch sdir:xs+    (_, loc) -> loc++renderResourceFormat :: Resource -> Maybe String -> String -> String+renderResourceFormat resource dformat str = case (resourcePathEnd resource, resourceFormat resource) of+    (NoSlash, ResourceFormat NoFormat _) -> str+    (Slash, ResourceFormat NoFormat _) -> case str of "/" -> "/"; _ -> str ++ "/"+    (NoSlash, ResourceFormat (StaticFormat format) branch) -> case branch of+        Just {} -> str ++ "." ++ format+        Nothing -> str ++ "/." ++ format+    (Slash, ResourceFormat DynamicFormat Nothing) -> case dformat of+        Just format@(_:_) -> str ++ "/." ++ format+        _ -> str ++ "/"+    (NoSlash, ResourceFormat DynamicFormat _) -> case dformat of+        Just format@(_:_) -> str ++ "." ++ format+        _ -> str+    -- This case might be taken by TrailingBranch+    _ -> str++-----------------------+-- Converts the output of parseTrunkFormatAt to something consumable by a Resource+-- It forbids many things that parse correctly, most notably using formats in the middle of a path.+-- It's possible in theory to allow such things, but complicated.+-- Directories are really format-less things.+--+-- trunkToResource is a top-level call to weed out cases that don't make sense recursively in trunkToResource'+trunkToResource  :: [(BranchComponent, BranchFormat)] -> ([BranchComponent], BranchEnd, ResourceFormat)+trunkToResource [] = ([], Slash, noFormat) -- ""+trunkToResource [(StaticBranch "", format)] = ([], Slash, ResourceFormat format Nothing) -- "/" or "/.format"+trunkToResource anythingElse = trunkToResource' anythingElse++trunkToResource' :: [(BranchComponent, BranchFormat)] -> ([BranchComponent], BranchEnd, ResourceFormat)+trunkToResource' [] = ([], NoSlash, noFormat)+-- /...+trunkToResource' ((TrailingBranch, _):xs) | null xs = ([TrailingBranch], Trailing, noFormat)+                                          | otherwise = error "Trailing path only allowed at very end"+-- /foo/, /foo/.format, or /foo/.:format+trunkToResource' [(branch, NoFormat), (StaticBranch "", format)] = pathFormatSep format+  where pathFormatSep (StaticFormat form) = ([branch, StaticBranch ("." ++ form)], NoSlash, noFormat) -- /foo/.json, format is not optional here!+        pathFormatSep DynamicFormat = ([branch], Slash, ResourceFormat DynamicFormat Nothing) -- /foo/.format+        pathFormatSep NoFormat = ([branch], Slash, noFormat) -- /foo/+-- /foo.format/[...] (rewrite into next case)+trunkToResource' ((StaticBranch sdir, StaticFormat format):xs) = trunkToResource' ((StaticBranch (sdir ++ "." ++ format), NoFormat):xs)+trunkToResource' ((DynamicBranch ddir, StaticFormat format):xs) = trunkToResource' ((DynamicBranch (ddir ++ "." ++ format), NoFormat):xs)+-- /foo/[...]+trunkToResource' ((branch, NoFormat):xs) = case trunkToResource' xs of (xs', slash, res) -> (branch:xs', slash, res)+-- /foo.format+trunkToResource' [(branch, format)] = pathFormat branch format+  where pathFormat (StaticBranch sdir) (StaticFormat form) = ([StaticBranch (sdir ++ "." ++ form)], NoSlash, noFormat) -- foo.json+        pathFormat (StaticBranch sdir) DynamicFormat = ([DynamicBranch sdir], NoSlash, ResourceFormat DynamicFormat (Just branch)) -- foo.:json+        pathFormat (DynamicBranch {}) (StaticFormat {}) = ([branch], NoSlash, ResourceFormat format (Just branch)) -- :foo.json+        pathFormat (DynamicBranch {}) DynamicFormat = ([branch], NoSlash, ResourceFormat DynamicFormat (Just branch)) -- :foo.:json+        pathFormat _ NoFormat = ([branch], NoSlash, noFormat) -- foo or :foo+        pathFormat _ _ = error "Trailing path can't have a format"+-- /foo.format/[...]+trunkToResource' _ = error "Format only allowed at end of path"++trunkAt :: String -> BranchPath+trunkAt arg = either trunkError reverse $ Parse.parse parseTrunkAt "Distribution.Server.Resource.parseTrunkAt" arg+    where trunkError pe = error $ "Distribution.Server.Resource.trunkAt: Could not parse trunk literal " ++ show arg ++ ". Parsec error: " ++ show pe++parseTrunkAt :: Parse.Parser [BranchComponent]+parseTrunkAt = do+    components <- Parse.many (Parse.try parseComponent)+    Parse.optional (Parse.char '/')+    Parse.eof+    return components+  where+    parseComponent = do+        void $ Parse.char '/'+        fmap DynamicBranch (Parse.char ':' >> Parse.many1 (Parse.noneOf "/"))+          Parse.<|> fmap StaticBranch (Parse.many1 (Parse.noneOf "/"))++parseFormatTrunkAt :: Parse.Parser [(BranchComponent, BranchFormat)]+parseFormatTrunkAt = do+    components <- Parse.many (Parse.try parseComponent)+    rest <- Parse.option [] (Parse.char '/' >> return [(StaticBranch "", NoFormat)])+    Parse.eof+    return (components ++ rest)+  where+    parseComponent :: Parse.Parser (BranchComponent, BranchFormat)+    parseComponent = do+        void $ Parse.char '/'+        Parse.choice $ map Parse.try+          [ Parse.char '.' >> Parse.many1 (Parse.char '.') >>+            ((Parse.lookAhead (Parse.char '/') >> return ()) Parse.<|> Parse.eof) >> return (TrailingBranch, NoFormat)+          , Parse.char ':' >> parseMaybeFormat DynamicBranch+          , do Parse.lookAhead (void $ Parse.satisfy (/=':'))+               Parse.choice $ map Parse.try+                 [ parseMaybeFormat StaticBranch+                 , fmap ((,) (StaticBranch "")) parseFormat+                 , fmap (flip (,) NoFormat . StaticBranch) untilNext+                 ]+          ]+    parseMaybeFormat :: (String -> BranchComponent) -> Parse.Parser (BranchComponent, BranchFormat)+    parseMaybeFormat control = do+        sdir <- Parse.many1 (Parse.noneOf "/.")+        format <- Parse.option NoFormat parseFormat+        return (control sdir, format)+    parseFormat :: Parse.Parser BranchFormat+    parseFormat = Parse.char '.' >> Parse.choice+        [ Parse.char ':' >> untilNext >> return DynamicFormat+        , fmap StaticFormat untilNext+        ]+    untilNext :: Parse.Parser String+    untilNext = Parse.many1 (Parse.noneOf "/")++-- serveResource does all the path format and HTTP method preprocessing for a Resource+--+-- For a small curl-based testing mini-suite of [Resource]:+-- [res "/foo" ["json"], res "/foo/:bar.:format" ["html", "json"], res "/baz/test/.:format" ["html", "text", "json"], res "/package/:package/:tarball.tar.gz" ["tarball"], res "/a/:a/:b/" ["html", "json"], res "/mon/..." [""], res "/wiki/path.:format" [], res "/hi.:format" ["yaml", "blah"]]+--     where res field formats = (resourceAt field) { resourceGet = map (\format -> (format, \_ -> return . toResponse . (++"\n") . ((show format++" - ")++) . show)) formats }+serveResource :: [(Content, ServerErrorResponse)] -> Resource -> ServerResponse+serveResource errRes (Resource _ rget rput rpost rdelete rformat rend _) = \dpath -> msum $+    map (\func -> func dpath) $ methodPart ++ [optionPart]+  where+    optionPart = makeOptions $ concat [ met | ((_:_), met) <- zip methods methodsList]+    methodPart = [ serveResources met res | (res@(_:_), met) <- zip methods methodsList]+    methods = [rget, rput, rpost, rdelete]+    methodsList = [[GET, HEAD], [PUT], [POST], [DELETE]]+    makeOptions :: [Method] -> ServerResponse+    makeOptions methodList = \_ -> method OPTIONS >> nullDir >> do+        setHeaderM "Allow" (intercalate ", " . map show $ methodList)+        return $ toResponse ()+    -- some of the dpath lookup calls can be replaced by pattern matching the head/replacing+    -- at the moment, duplicate entries tend to be inserted in dpath, because old ones are not replaced+    -- Procedure:+    -- > Guard against method+    -- > Extract format/whatnot+    -- > Potentially redirect to canonical slash form+    -- > Go from format/content-type to ServerResponse to serve-}+    serveResources :: [Method] -> [(Content, ServerResponse)] -> ServerResponse+    serveResources met res dpath = case rend of+        Trailing -> method met >> (remainingPathString >>= \str ->+                                   serveContent res (("..", str):dpath))+        _ -> serveFormat res met dpath+    serveFormat :: [(Content, ServerResponse)] -> [Method] -> ServerResponse+    serveFormat res met = case rformat of+        ResourceFormat NoFormat Nothing -> \dpath -> method met >> nullDir >> serveContent res dpath+        ResourceFormat (StaticFormat format) Nothing -> \dpath -> path $ \format' -> method met >> nullDir >> do+            -- this branch shouldn't happen - /foo/.json would instead be stored as two static dirs+            guard (format' == ('.':format))+            serveContent res dpath+        ResourceFormat (StaticFormat format) (Just (StaticBranch sdir)) -> \dpath -> method met >> nullDir >>+            -- likewise, foo.json should be stored as a single static dir+            if lookup sdir dpath == Just (sdir ++ "." ++ format) then mzero+                                                                 else serveContent res dpath+        ResourceFormat (StaticFormat format) (Just (DynamicBranch sdir)) -> \dpath -> method met >> nullDir >>+            case matchExt format =<< lookup sdir dpath of+                Just pname -> serveContent res ((sdir, pname):dpath)+                Nothing -> mzero+        ResourceFormat DynamicFormat Nothing -> \dpath ->+            msum [ method met >> nullDir >> serveContent res dpath+                 , path $ \pname -> case pname of+                       ('.':format) -> method met >> nullDir >> serveContent res (("format", format):dpath)+                       _ -> mzero+                 ]+        ResourceFormat DynamicFormat (Just (StaticBranch sdir)) -> \dpath -> method met >> nullDir >>+            case fmap extractExt (lookup sdir dpath) of+                Just (pname, format) | pname == sdir -> serveContent res (("format", format):dpath)+                _ -> mzero+        ResourceFormat DynamicFormat (Just (DynamicBranch sdir)) -> \dpath -> method met >> nullDir >>+            -- this is somewhat complicated. consider /pkg-0.1 and /pkg-0.1.html. If the format is optional, where to split?+            -- the solution is to manually check the available formats to see if something matches+            -- if this situation comes up in practice, try to require a trailing slash, e.g. /pkg-0.1/.html+            case fmap (\sd -> (,) sd $ extractExt sd) (lookup sdir dpath) of+                Just (full, (pname, format)) -> do+                    let splitOption = serveContent res (("format", format):(sdir, pname):dpath)+                        fullOption  = serveContent res ((sdir, full):dpath)+                    case guard (not $ null format) >> lookup format res of+                        Nothing -> fullOption+                        Just {} -> splitOption+                _ -> mzero+        -- some invalid combination+        _ -> \dpath -> method met >> nullDir >> serveContent res dpath+    serveContent :: [(Content, ServerResponse)] -> ServerResponse+    serveContent res dpath = do+        -- there should be no remaining path segments at this point, now check page redirection+        met <- fmap rqMethod askRq+        -- we don't check if the page exists before redirecting!+        -- just send them to the canonical place the document may or may not be+        (if met == HEAD || met == GET+            then redirCanonicalSlash dpath+            else id) $ do+          -- "Find " ++ show (lookup "format" dpath) ++ " in " ++ show (map fst res)+          case lookup "format" dpath of+            Just format@(_:_) -> case lookup format res of+                               -- return a specific format if it is found+                Just answer -> handleErrors (Just format) $ answer dpath+                Nothing -> mzero -- return 404 if the specific format is not found+                  -- return default response when format is empty or non-existent+            _ -> do (format,answer) <- negotiateContent (head res) res+                    handleErrors (Just format) $ answer dpath++    handleErrors format =+      handleErrorResponse (serveErrorResponse errRes format)++    redirCanonicalSlash :: DynamicPath -> ServerPartE Response -> ServerPartE Response+    redirCanonicalSlash dpath trueRes = case rformat of+        ResourceFormat format Nothing | format /= NoFormat -> case lookup "format" dpath of+            Just {} -> requireNoSlash `mplus` trueRes+            Nothing -> requireSlash `mplus` trueRes+        _ -> case rend of+            Slash    -> requireSlash `mplus` trueRes+            NoSlash  -> requireNoSlash `mplus` trueRes+            Trailing -> mplus (nullDir >> requireSlash) trueRes++    requireSlash = do+        theUri <- fmap rqUri askRq+        guard $ last theUri /= '/'+        movedPermanently (theUri ++ "/") (toResponse ())+    requireNoSlash = do+        theUri <- fmap rqUri askRq+        guard $ last theUri == '/'+        movedPermanently (reverse . dropWhile (=='/') . reverse $ theUri) (toResponse ())+    -- matchExt and extractExt could also use manual string-chomping recursion if wanted+    matchExt format pname = let fsize = length format+                                (pname', format') = splitAt (length pname - fsize - 1) pname+                            in if '.':format == format' then Just pname'+                                                        else Nothing+    extractExt pname = case findIndices (=='.') pname of+        [] -> (pname, "")+        xs -> case splitAt (last xs) pname of (pname', _:format) -> (pname', format)+                                              _ -> (pname, "") -- this shouldn't happen++resourceMethods :: Resource -> [Method]+resourceMethods (Resource _ rget rput rpost rdelete _ _ _) = [ met | ((_:_), met) <- zip methods methodsList]+  where methods = [rget, rput, rpost, rdelete]+        methodsList = [GET, PUT, POST, DELETE]++serveErrorResponse :: [(Content, ServerErrorResponse)] -> Maybe Content -> ServerErrorResponse+serveErrorResponse errRes mformat err = do+    -- So our strategy is to give priority to a content type requested by+    -- the client, then secondly any format implied by the requested url+    -- e.g. requesting a .html file, or html being default for the resource+    -- and finally just fall through to using text/plain+    (_, errHandler) <- negotiateContent ("", defHandler) errRes+    errHandler err+  where+    defHandler = fromMaybe throwError $ do+      format <- mformat+      lookup format errRes++negotiateContent :: ServerMonad m => (Content, a) -> [(Content, a)] -> m (Content, a)+negotiateContent def available = do+    maccept <- getHeaderM "Accept"+    case maccept of+      Nothing -> return def+      Just accept ->+        return $ fromMaybe def $ listToMaybe $ catMaybes+                   [ simpleContentTypeMapping ct+                       >>= \f -> find (\x -> fst x == f) available+                   | let acceptable = parseContentAccept (BS.unpack accept)+                   , ct <- acceptable ]+  where+    -- This is rather a non-extensible hack+    simpleContentTypeMapping ContentType {ctType, ctSubtype, ctParameters = []} =+      case (ctType, ctSubtype) of+        ("text",        "html")  -> Just "html"+        ("text",        "plain") -> Just "txt"+        ("application", "json")  -> Just "json"+        _                        -> Nothing+    simpleContentTypeMapping _    = Nothing++----------------------------------------------------------------------------++data ServerTree a = ServerTree {+    nodeResponse :: Maybe a,+    nodeForest :: Map BranchComponent (ServerTree a)+} deriving (Show)++instance Functor ServerTree where+    fmap func (ServerTree value forest) = ServerTree (fmap func value) (Map.map (fmap func) forest)++drawServerTree :: ServerTree a -> Maybe (a -> String) -> String+drawServerTree tree func = Tree.drawTree (transformTree tree Nothing)+  where transformTree (ServerTree res for) mlink = Tree.Node (drawLink mlink res) (map transformForest $ Map.toList for)+        drawLink mlink res = maybe "" ((++": ") . show) mlink ++ maybe "(nothing)" (fromMaybe (const "node") func) res+        transformForest (link, tree') = transformTree tree' (Just link)++serverTreeEmpty :: ServerTree a+serverTreeEmpty = ServerTree Nothing Map.empty++-- essentially a ReaderT DynamicPath ServerPart Response+-- this always renders parent URIs, but usually we guard against remaining path segments, so it's fine+renderServerTree :: DynamicPath -> ServerTree ServerResponse -> ServerPartE Response+renderServerTree dpath (ServerTree func forest) =+    msum $ maybeToList (fmap (\fun -> fun dpath) func)+        ++ map (uncurry renderBranch) (Map.toList forest)+  where+    renderBranch :: BranchComponent -> ServerTree ServerResponse -> ServerPartE Response+    renderBranch (StaticBranch  sdir) tree = dir sdir $ renderServerTree dpath tree+    renderBranch (DynamicBranch sdir) tree+      | (ddir, sformat@('.':_)) <- break (=='.') sdir+                   = path $ \pname -> do guard (sformat `isSuffixOf` pname)+                                         let pname' = take (length pname - length sformat) pname+                                         renderServerTree ((ddir, pname'):dpath) tree+      | otherwise  = path $ \pname -> renderServerTree ((sdir, pname):dpath) tree+    renderBranch TrailingBranch tree = renderServerTree dpath tree++reinsert :: Monoid a => BranchComponent -> ServerTree a -> Map BranchComponent (ServerTree a) -> Map BranchComponent (ServerTree a)+-- combine will only be called if branchMap already contains the key+reinsert key newTree branchMap = Map.insertWith combine key newTree branchMap++combine :: Monoid a => ServerTree a -> ServerTree a -> ServerTree a+combine (ServerTree newResponse newForest) (ServerTree oldResponse oldForest) =+    -- replace old resource with new resource, combine old and new responses+    ServerTree (mappend newResponse oldResponse) (Map.foldWithKey reinsert oldForest newForest)++addServerNode :: Monoid a => BranchPath -> a -> ServerTree a -> ServerTree a+addServerNode trunk response tree = treeFold trunk (ServerTree (Just response) Map.empty) tree++--this function takes a list whose head is the resource and traverses leftwards in the URI+--this is due to the original design of specifying URI branches: if the resources are+--themselves encoded in the branch, then subresources should share the same parent+--resource, sharing list tails.+--+--This version is greatly simplified compared to what was previously here.+treeFold :: Monoid a => BranchPath -> ServerTree a -> ServerTree a -> ServerTree a+treeFold [] newChild topLevel = combine newChild topLevel+treeFold (sdir:otherTree) newChild topLevel = treeFold otherTree (ServerTree Nothing $ Map.singleton sdir newChild) topLevel+
+ Distribution/Server/Framework/ResponseContentTypes.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, StandaloneDeriving, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Server.Framework.ResponseContentTypes+-- Copyright   :  (c) David Himmelstrup 2008+--                    Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Types for various kinds of resources we serve, xml, package tarballs etc.+-----------------------------------------------------------------------------+module Distribution.Server.Framework.ResponseContentTypes where++import Distribution.Server.Framework.BlobStorage+         ( BlobId, blobMd5 )+import Distribution.Server.Util.Parse (packUTF8)++import Happstack.Server+         ( ToMessage(..), Response(..), RsFlags(..), Length(NoContentLength), nullRsFlags, mkHeaders+         , noContentLength )++import qualified Data.ByteString.Lazy as BS.Lazy+import Text.RSS (RSS)+import qualified Text.RSS as RSS (rssToXML, showXML)+import qualified Text.XHtml.Strict as XHtml (Html, showHtml)+import qualified Data.Aeson as Aeson (Value, encode)+import Data.Time.Clock (UTCTime)+import qualified Data.Time.Format as Time (formatTime)+import System.Locale (defaultTimeLocale)+import Text.CSV (printCSV, CSV)++newtype ETag = ETag String+  deriving (Eq, Ord, Show)++blobETag :: BlobId -> ETag+blobETag = ETag . blobMd5++formatETag :: ETag -> String+formatETag (ETag etag) = '"' : etag ++ ['"']++data IndexTarball = IndexTarball BS.Lazy.ByteString++instance ToMessage IndexTarball where+  toContentType _ = "application/x-gzip"+  toMessage (IndexTarball bs) = bs+++data PackageTarball = PackageTarball BS.Lazy.ByteString BlobId UTCTime++instance ToMessage PackageTarball where+  toResponse (PackageTarball bs blobid time) = mkResponse bs+    [ ("Content-Type",  "application/x-gzip")+    , ("Content-MD5",   md5sum)+    , ("ETag",          formatETag (ETag md5sum))+    , ("Last-modified", formatTime time)+    ]+    where md5sum = blobMd5 blobid++data DocTarball = DocTarball BS.Lazy.ByteString BlobId++instance ToMessage DocTarball where+  toResponse (DocTarball bs blobid) = mkResponse bs+    [ ("Content-Type",  "application/x-tar")+    , ("Content-MD5",   md5sum)+    , ("ETag",          formatETag (ETag md5sum))+    ]+    where md5sum = blobMd5 blobid++formatTime :: UTCTime -> String+formatTime = Time.formatTime defaultTimeLocale rfc822DateFormat+  where+    -- HACK! we're using UTC but http requires GMT+    -- hopefully it's ok to just say it's GMT+    rfc822DateFormat = "%a, %d %b %Y %H:%M:%S GMT"++newtype OpenSearchXml = OpenSearchXml BS.Lazy.ByteString++instance ToMessage OpenSearchXml where+    toContentType _ = "application/opensearchdescription+xml"+    toMessage (OpenSearchXml bs) = bs++instance ToMessage Aeson.Value where+    toContentType _ = "application/json; charset=utf-8"+    toMessage val = Aeson.encode val++newtype CabalFile = CabalFile BS.Lazy.ByteString++instance ToMessage CabalFile where+    toContentType _ = "text/plain; charset=utf-8"+    toMessage (CabalFile bs) = bs++newtype BuildLog = BuildLog BS.Lazy.ByteString++instance ToMessage BuildLog where+    toContentType _ = "text/plain"+    toMessage (BuildLog bs) = bs++instance ToMessage RSS where+    toContentType _ = "application/rss+xml"+    toMessage = packUTF8 . RSS.showXML . RSS.rssToXML++newtype XHtml = XHtml XHtml.Html++instance ToMessage XHtml where+    toContentType _ = "text/html; charset=utf-8"+    toMessage (XHtml xhtml) = packUTF8 (XHtml.showHtml xhtml)++-- Like XHtml, but don't bother calculating length+newtype LongXHtml = LongXHtml XHtml.Html++instance ToMessage LongXHtml where+    toResponse (LongXHtml xhtml) = noContentLength $ mkResponse+        (packUTF8 (XHtml.showHtml xhtml))+        [("Content-Type", "text/html")]++newtype ExportTarball = ExportTarball BS.Lazy.ByteString++instance ToMessage ExportTarball where+    toResponse (ExportTarball bs)+        = noContentLength $ mkResponse bs+          [("Content-Type",  "application/gzip")]++newtype CSVFile = CSVFile CSV++instance ToMessage CSVFile where+    toContentType _ = "text/csv"+    toMessage (CSVFile csv) = packUTF8 (printCSV csv)++mkResponse :: BS.Lazy.ByteString -> [(String, String)] -> Response+mkResponse bs headers = Response {+    rsCode    = 200,+    rsHeaders = mkHeaders headers,+    rsFlags   = nullRsFlags,+    rsBody    = bs,+    rsValidator = Nothing+  }++mkResponseLen :: BS.Lazy.ByteString -> Int -> [(String, String)] -> Response+mkResponseLen bs len headers = Response {+    rsCode    = 200,+    rsHeaders = mkHeaders (("Content-Length", show len) : headers),+    rsFlags   = nullRsFlags { rsfLength = NoContentLength },+    rsBody    = bs,+    rsValidator = Nothing+  }
+ Distribution/Server/Framework/ServerEnv.hs view
@@ -0,0 +1,56 @@+module Distribution.Server.Framework.ServerEnv where++import Distribution.Server.Framework.BlobStorage (BlobStorage)+import Distribution.Server.Framework.Logging (Verbosity)+import Distribution.Server.Framework.Templating (TemplatesMode)++import qualified Network.URI as URI++-- | The internal server environment as used by 'HackageFeature's.+--+-- It contains various bits of static information (and handles of+-- server-global objects) that are needed by the implementations of+-- some 'HackageFeature's.+--+data ServerEnv = ServerEnv {++    -- | The location of the server's static files+    serverStaticDir :: FilePath,++    -- | The location of the server's template files+    serverTemplatesDir :: FilePath,++    -- | Default templates mode+    serverTemplatesMode :: TemplatesMode,++    -- | The location of the server's state directory. This is where the+    -- server's persistent state is kept, e.g. using ACID state.+    serverStateDir  :: FilePath,++    -- | The blob store is a specialised provider of persistent state for+    -- larger relatively-static blobs of data (e.g. uploaded tarballs).+    serverBlobStore :: BlobStorage,++    -- | The temporary directory the server has been configured to use.+    -- Use it for temp files such as when validating uploads.+    serverTmpDir    :: FilePath,++    -- | The base URI of the server, just the hostname (and perhaps port).+    -- Use this if you need to construct absolute URIs pointing to the+    -- current server (e.g. as required in RSS feeds).+    serverBaseURI   :: URI.URI,++    -- | A tunable parameter for cache policy. Setting this parameter high+    -- during bulk imports can very significantly improve performance. During+    -- normal operation it probably doesn't help much.++    -- By delaying cache updates we can sometimes save some effort: caches are+    -- based on a bit of changing state and if that state is updated more+    -- frequently than the time taken to update the cache, then we don't have+    -- to do as many cache updates as we do state updates. By artificially+    -- increasing the time taken to update the cache we can push this further.+    serverCacheDelay :: Int,++    serverVerbosity  :: Verbosity+}+
+ Distribution/Server/Packages/ChangeLog.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE NamedFieldPuns #-}+module Distribution.Server.Packages.ChangeLog (+    findChangeLog+  ) where++import Control.Monad (msum)+import System.FilePath ((</>))+import qualified Text.PrettyPrint.HughesPJ as Pretty (render)++import Data.TarIndex (TarIndex, TarEntryOffset)+import qualified Data.TarIndex as TarIndex+import Distribution.Text (disp)+import Distribution.Server.Packages.Types (PkgInfo(..))++findChangeLog :: PkgInfo -> TarIndex -> Either String (TarEntryOffset, String)+findChangeLog PkgInfo{pkgInfoId} index =+  case msum $ map lookupFile candidates of+    Just (offset, name) ->+      Right (offset, name)+    Nothing -> do+      Left $ "No changelog found, considered: " ++ show candidates+  where+    lookupFile fname = do+      entry <- TarIndex.lookup index fname+      case entry of+        TarIndex.TarFileEntry offset -> return (offset, fname)+        _ -> fail "is a directory"++    candidates = let pkgId = Pretty.render $ disp pkgInfoId+                 in map (pkgId </>) $ filenames ++ map (++ ".html") filenames++    filenames = [ "ChangeLog"+                , "CHANGELOG"+                , "CHANGE_LOG"+                , "Changelog"+                , "changelog"+                ]
+ Distribution/Server/Packages/Index.hs view
@@ -0,0 +1,62 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Server.Packages.Index+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Create the package index.+--+-----------------------------------------------------------------------------+module Distribution.Server.Packages.Index (+    write,+  ) where++import qualified Codec.Archive.Tar.Entry as Tar+import qualified Distribution.Server.Util.Index as PackageIndex++import Distribution.Server.Packages.Types+         ( CabalFileText(..), PkgInfo(..) )+import Distribution.Server.Users.Users+         ( Users, userIdToName )++import Distribution.Text+         ( display )+import Distribution.Server.Packages.PackageIndex (PackageIndex)+import Data.Time.Clock+         ( UTCTime )+import Data.Time.Clock.POSIX+         ( utcTimeToPOSIXSeconds )+import Data.Int (Int64)++import Data.Map (Map)+import qualified Data.Map as Map+import Data.ByteString.Lazy (ByteString)+import Prelude hiding (read)++-- Construct, with the specified user database, extra top-level files, and+-- a package index, an index tarball. This tarball has the modification times+-- and uploading users built-in.+write :: Users -> Map String (ByteString, UTCTime) -> PackageIndex PkgInfo -> ByteString+write users = PackageIndex.write (cabalFileByteString . pkgData) setModTime . extraEntries+  where+    setModTime pkgInfo entry = let (utime, uuser) = pkgUploadData pkgInfo in entry {+      Tar.entryTime      = utcToUnixTime utime,+      Tar.entryOwnership = Tar.Ownership {+        Tar.ownerName = userName uuser,+        Tar.groupName = "Hackage",+        Tar.ownerId = 0,+        Tar.groupId = 0+      }+    }+    utcToUnixTime :: UTCTime -> Int64+    utcToUnixTime = truncate . utcTimeToPOSIXSeconds+    userName = display . userIdToName users+    extraEntries emap = do+        (path, (entry, mtime)) <- Map.toList emap+        Right tarPath <- return $ Tar.toTarPath False path+        return $ (Tar.fileEntry tarPath entry) { Tar.entryTime = utcToUnixTime mtime }+
+ Distribution/Server/Packages/ModuleForest.hs view
@@ -0,0 +1,36 @@+-- (C) Copyright by Bas van Dijk, v.dijk.bas@gmail.com, 2008+-- Inspiration (read: copied, renamed and simplified) from:+-- http://code.haskell.org/haddock/src/Haddock/ModuleTree.hs++module Distribution.Server.Packages.ModuleForest ( ModuleForest, ModuleTree(..), moduleForest ) where++import Distribution.ModuleName ( ModuleName, components )++--------------------------------------------------------------------------------++type ModuleForest = [ModuleTree]++data ModuleTree = Node String       -- Part of module name+                       Bool         -- Is this an existing module?+                       ModuleForest -- Sub modules+    deriving (Show, Eq)++--------------------------------------------------------------------------------++moduleForest :: [ModuleName] -> ModuleForest+moduleForest = foldr (addToForest . components) []++addToForest :: [String] -> ModuleForest -> ModuleForest+addToForest [] ts = ts+addToForest ss [] = mkSubTree ss+addToForest s1ss@(s1:ss) (t@(Node s2 isModule subs) : ts)+  | s1 >  s2  = t : addToForest s1ss ts+  | s1 == s2  = Node s2 (isModule || null ss) (addToForest ss subs) : ts+  | otherwise = mkSubTree s1ss ++ t : ts++mkSubTree :: [String] -> ModuleForest+mkSubTree []     = []+mkSubTree (s:ss) = [Node s (null ss) (mkSubTree ss)]++--------------------------------------------------------------------------------+
+ Distribution/Server/Packages/PackageIndex.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Server.Packages.PackageIndex+-- Copyright   :  (c) David Himmelstrup 2005,+--                    Bjorn Bringert 2007,+--                    Duncan Coutts 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- An index of packages.+--+module Distribution.Server.Packages.PackageIndex (+    -- * Package index data type+    PackageIndex,++    -- * Creating an index+    fromList,++    -- * Updates+    merge,+    insert,+    insertWith,+    deletePackageName,+    deletePackageId,++    -- * Queries+    indexSize,+    packageNames,++    -- ** Precise lookups+    lookupPackageName,+    lookupPackageId,+    lookupPackageForId,+    lookupDependency,++    -- ** Case-insensitive searches+    searchByName,+    SearchResult(..),+    searchByNameSubstring,++    -- ** Bulk queries+    allPackages,+    allPackagesByName+  ) where++import Distribution.Server.Framework.MemSize+import Distribution.Server.Util.Merge++import Prelude hiding (lookup)+import Control.Exception (assert)+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Foldable as Foldable+import Data.List (groupBy, sortBy, find, isInfixOf)+import Data.Monoid (Monoid(..))+import Data.Maybe (fromMaybe)+import Data.SafeCopy+import Data.Typeable++import Distribution.Package+         ( PackageName(..), PackageIdentifier(..)+         , Package(..), packageName, packageVersion+         , Dependency(Dependency) )+import Distribution.Version ( withinRange )+import Distribution.Simple.Utils (lowercase, comparing)++-- | The collection of information about packages from one or more 'PackageDB's.+--+-- It can be searched effeciently by package name and version.+--+newtype PackageIndex pkg = PackageIndex+  -- A mapping from package names to a non-empty list of  versions of that+  -- package, in ascending order (most recent package last)+  -- TODO: Wouldn't it make more sense to store the most recent package first?+  --+  -- This allows us to find all versions satisfying a dependency.+  -- Most queries are a map lookup followed by a linear scan of the bucket.+  --+  (Map PackageName [pkg])++  deriving (Show, Read, Typeable, MemSize)++instance Eq pkg => Eq (PackageIndex pkg) where+  PackageIndex m1 == PackageIndex m2 = flip Foldable.all (mergeMaps m1 m2) $ \mr -> case mr of+      InBoth pkgs1 pkgs2 -> bagsEq pkgs1 pkgs2+      OnlyInLeft _       -> False+      OnlyInRight _      -> False+    where+      bagsEq []     [] = True+      bagsEq []     _  = False+      bagsEq (x:xs) ys = case suitable_ys of+        []                -> False+        (_y:suitable_ys') -> bagsEq xs (unsuitable_ys ++ suitable_ys')+        where (unsuitable_ys, suitable_ys) = break (==x) ys+++instance Package pkg => Monoid (PackageIndex pkg) where+  mempty  = PackageIndex (Map.empty)+  mappend = merge+  --save one mappend with empty in the common case:+  mconcat [] = mempty+  mconcat xs = foldr1 mappend xs++invariant :: Package pkg => PackageIndex pkg -> Bool+invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)+  where+    goodBucket _    [] = False+    goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0+      where+        check pkgid []          = packageName pkgid == name+        check pkgid (pkg':pkgs) = packageName pkgid == name+                               && pkgid < pkgid'+                               && check pkgid' pkgs+          where pkgid' = packageId pkg'++--+-- * Internal helpers+--++mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg+mkPackageIndex index = assert (invariant (PackageIndex index)) (PackageIndex index)++internalError :: String -> a+internalError name = error ("PackageIndex." ++ name ++ ": internal error")++-- | Lookup a name in the index to get all packages that match that name+-- case-sensitively.+--+lookup :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]+lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m++--+-- * Construction+--++-- | Build an index out of a bunch of packages.+--+-- If there are duplicates, later ones mask earlier ones.+--+fromList :: Package pkg => [pkg] -> PackageIndex pkg+fromList pkgs = mkPackageIndex+              . Map.map fixBucket+              . Map.fromListWith (++)+              $ [ (packageName pkg, [pkg])+                | pkg <- pkgs ]+  where+    fixBucket = -- out of groups of duplicates, later ones mask earlier ones+                -- but Map.fromListWith (++) constructs groups in reverse order+                map head+                -- Eq instance for PackageIdentifier is wrong, so use Ord:+              . groupBy (\a b -> EQ == comparing packageId a b)+                -- relies on sortBy being a stable sort so we+                -- can pick consistently among duplicates+              . sortBy (comparing packageId)++--+-- * Updates+--++-- | Merge two indexes.+--+-- Packages from the second mask packages of the same exact name+-- (case-sensitively) from the first.+--+merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg+merge i1@(PackageIndex m1) i2@(PackageIndex m2) =+  assert (invariant i1 && invariant i2) $+    mkPackageIndex (Map.unionWith mergeBuckets m1 m2)++-- | Elements in the second list mask those in the first.+mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg]+mergeBuckets []     ys     = ys+mergeBuckets xs     []     = xs+mergeBuckets xs@(x:xs') ys@(y:ys') =+      case packageId x `compare` packageId y of+        GT -> y : mergeBuckets xs  ys'+        EQ -> y : mergeBuckets xs' ys'+        LT -> x : mergeBuckets xs' ys++-- | Inserts a single package into the index.+--+-- This is equivalent to (but slightly quicker than) using 'mappend' or+-- 'merge' with a singleton index.+--+insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg+insert pkg (PackageIndex index) = mkPackageIndex $ -- or insertWith const+  Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index+  where+    pkgid = packageId pkg+    insertNoDup []                = [pkg]+    insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of+      LT -> pkg  : pkgs+      EQ -> pkg  : pkgs'  -- this replaces the package+      GT -> pkg' : insertNoDup pkgs'++-- | Inserts a single package into the index, combining an old and new value with a function.+-- This isn't in cabal's version of PackageIndex.+--+-- The merge function is called as (f newPkg oldPkg). Ensure that the result has the same+-- package id as the two arguments; otherwise newPkg is used.+--+insertWith :: Package pkg => (pkg -> pkg -> pkg) -> pkg -> PackageIndex pkg -> PackageIndex pkg+insertWith mergeFunc pkg (PackageIndex index) = mkPackageIndex $+    Map.insertWith (\_ -> insertMerge) (packageName pkg) [pkg] index+  where+    pkgid = packageId pkg+    insertMerge [] = [pkg]+    insertMerge pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of+        LT -> pkg : pkgs+        EQ -> let merged = mergeFunc pkg pkg' in+              if packageId merged == pkgid then merged : pkgs'+                                           else pkg : pkgs'+        GT -> pkg' : insertMerge pkgs'++-- | Internal delete helper.+--+delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg+delete name p (PackageIndex index) = mkPackageIndex $+  Map.update filterBucket name index+  where+    filterBucket = deleteEmptyBucket+                 . filter (not . p)+    deleteEmptyBucket []        = Nothing+    deleteEmptyBucket remaining = Just remaining++-- | Removes a single package from the index.+--+deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg+deletePackageId pkgid =+  delete (packageName pkgid) (\pkg -> packageId pkg == pkgid)++-- | Removes all packages with this (case-sensitive) name from the index.+--+deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg+deletePackageName name =+  delete name (\pkg -> packageName pkg == name)++--+-- * Bulk queries+--++-- | Get all the packages from the index.+--+allPackages :: Package pkg => PackageIndex pkg -> [pkg]+allPackages (PackageIndex m) = concat (Map.elems m)++-- | Get all the packages from the index.+--+-- They are grouped by package name, case-sensitively.+--+allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]]+allPackagesByName (PackageIndex m) = Map.elems m++--+-- * Lookups+--++-- | Does a lookup by package id (name & version).+--+-- Since multiple package DBs mask each other case-sensitively by package name,+-- then we get back at most one package.+--+lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg+lookupPackageId index pkgid =+  case [ pkg | pkg <- lookup index (packageName pkgid)+             , packageId pkg == pkgid ] of+    []    -> Nothing+    [pkg] -> Just pkg+    _     -> internalError "lookupPackageIdentifier"++-- | Does a case-sensitive search by package name.+-- The returned list should be ordered (strictly ascending) by version number.+--+lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]+lookupPackageName index name = lookup index name++-- | Search by name of a package identifier, and further select a version if possible.+--+lookupPackageForId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> ([pkg], Maybe pkg)+lookupPackageForId index pkgid =+  let pkgs = lookupPackageName index (packageName pkgid)+  in (,) pkgs $ find ((==pkgid) . packageId) pkgs++-- | Does a case-sensitive search by package name and a range of versions.+--+-- We get back any number of versions of the specified package name, all+-- satisfying the version range constraint.+--+lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg]+lookupDependency index (Dependency name versionRange) =+  [ pkg | pkg <- lookup index name+        , packageName pkg == name+        , packageVersion pkg `withinRange` versionRange ]++--+-- * Case insensitive name lookups+--++-- | Does a case-insensitive search by package name.+--+-- If there is only one package that compares case-insentiviely to this name+-- then the search is unambiguous and we get back all versions of that package.+-- If several match case-insentiviely but one matches exactly then it is also+-- unambiguous.+--+-- If however several match case-insentiviely and none match exactly then we+-- have an ambiguous result, and we get back all the versions of all the+-- packages. The list of ambiguous results is split by exact package name. So+-- it is a non-empty list of non-empty lists.+--+searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg]+searchByName (PackageIndex m) name =+  case [ pkgs | pkgs@(PackageName name',_) <- Map.toList m+              , lowercase name' == lname ] of+    []              -> None+    [(_,pkgs)]      -> Unambiguous pkgs+    pkgss           -> case find ((PackageName name==) . fst) pkgss of+      Just (_,pkgs) -> Unambiguous pkgs+      Nothing       -> Ambiguous (map snd pkgss)+  where lname = lowercase name++data SearchResult a = None | Unambiguous a | Ambiguous [a] deriving (Show)++-- | Does a case-insensitive substring search by package name.+--+-- That is, all packages that contain the given string in their name.+--+searchByNameSubstring :: Package pkg => PackageIndex pkg -> String -> [pkg]+searchByNameSubstring (PackageIndex m) searchterm =+  [ pkg+  | (PackageName name, pkgs) <- Map.toList m+  , lsearchterm `isInfixOf` lowercase name+  , pkg <- pkgs ]+  where lsearchterm = lowercase searchterm++-- | Gets the number of packages in the index (number of names).+indexSize :: Package pkg => PackageIndex pkg -> Int+indexSize (PackageIndex m) = Map.size m++-- | Get an ascending list of package names in the index.+packageNames :: Package pkg => PackageIndex pkg -> [PackageName]+packageNames (PackageIndex m) = Map.keys m++---------------------------------- State for PackageIndex+instance (Package pkg, SafeCopy pkg) => SafeCopy (PackageIndex pkg) where+  putCopy index = contain $ do+    safePut $ allPackages index+  getCopy = contain $ do+    packages <- safeGet+    return $ fromList packages+
+ Distribution/Server/Packages/Render.hs view
@@ -0,0 +1,244 @@+-- TODO: Review and possibly move elsewhere. This code was part of the+-- RecentPackages (formerly "Check") feature, but that caused some cyclic+-- dependencies.+module Distribution.Server.Packages.Render (+    -- * Package render+    PackageRender(..)+  , doPackageRender++    -- * Utils+  , categorySplit,+  ) where++import Data.Maybe (catMaybes)+import Control.Monad (guard, liftM2)+import Data.Char (toLower, isSpace)+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Foldable as Foldable+import qualified Data.Traversable as Traversable+import Data.Ord (comparing)+import Data.List (sort, sortBy, partition)+import Data.Time.Clock (UTCTime)++-- Cabal+import Distribution.PackageDescription+import Distribution.PackageDescription.Configuration+import Distribution.Package+import Distribution.Text+import Distribution.Version++-- hackage-server+import Distribution.Server.Packages.Types+import Distribution.Server.Packages.ModuleForest+import qualified Distribution.Server.Users.Users as Users+import Distribution.Server.Users.Types++-- This should provide the caller enough information to encode the package information+-- in its particular format (text, html, json) with minimal effort on its part.+-- This is why some fields of PackageDescription are preprocessed, and others aren't.+data PackageRender = PackageRender {+    rendPkgId        :: PackageIdentifier,+    rendDepends      :: [[Dependency]],+    rendExecNames    :: [String],+    rendLicenseName  :: String,+    rendMaintainer   :: Maybe String,+    rendCategory     :: [String],+    rendRepoHeads    :: [(RepoType, String, SourceRepo)],+    rendModules      :: Maybe ModuleForest,+    rendHasTarball   :: Bool,+    rendHasChangeLog :: Bool,+    rendUploadInfo   :: (UTCTime, Maybe UserInfo),+    rendPkgUri       :: String,+    -- rendOther contains other useful fields which are merely strings, possibly empty+    --     for example: description, home page, copyright, author, stability+    -- If PackageRender is the One True Resource Representation, should they+    -- instead be fields of PackageRender?+    rendOther        :: PackageDescription+} deriving (Show)++doPackageRender :: Users.Users -> PkgInfo -> Bool -> IO PackageRender+doPackageRender users info hasChangeLog = return $ PackageRender+    { rendPkgId        = pkgInfoId info+    , rendDepends      = flatDependencies genDesc+    , rendExecNames    = map exeName (executables flatDesc)+    , rendLicenseName  = display (license desc) -- maybe make this a bit more human-readable+    , rendMaintainer   = case maintainer desc of+                           "None" -> Nothing+                           "none" -> Nothing+                           ""     -> Nothing+                           person -> Just person+    , rendCategory     = case category desc of+                           []  -> []+                           str -> categorySplit str+    , rendRepoHeads    = catMaybes (map rendRepo $ sourceRepos desc)+    , rendModules      = fmap (moduleForest . exposedModules) (library flatDesc)+    , rendHasTarball   = not . null $ pkgTarball info+    , rendHasChangeLog = hasChangeLog+    , rendUploadInfo   = let (utime, uid) = pkgUploadData info+                         in (utime, Users.lookupUserId uid users)+    , rendPkgUri       = pkgUri+    , rendOther        = desc+    }+  where+    genDesc  = pkgDesc info+    flatDesc = flattenPackageDescription genDesc+    desc     = packageDescription genDesc+    pkgUri   = "/package/" ++ display (pkgInfoId info)++    rendRepo r = do+        guard $ repoKind r == RepoHead+        ty <- repoType r+        loc <- repoLocation r+        return (ty, loc, r)++{-------------------------------------------------------------------------------+  Util+-------------------------------------------------------------------------------}++categorySplit :: String -> [String]+categorySplit xs | all isSpace xs = []+categorySplit xs = map (dropWhile isSpace) $ splitOn ',' xs+  where+    splitOn x ys = front : case back of+                           [] -> []+                           (_:ys') -> splitOn x ys'+      where (front, back) = break (== x) ys++-----------------------------------------------------------------------+--+-- Flatten the dependencies of a GenericPackageDescription into+-- disjunctive normal form.+--+-- This could be in its own module.+--+flatDependencies :: GenericPackageDescription -> [[Dependency]]+flatDependencies pkg =+    map (map asDependency . sortOn (map toLower . display . fst)) $ sort $+    map get_deps $+    foldr reduceDisjunct [] $+    foldr intersectDisjunct head_deps $+        maybe id ((:) . fromCondTree) (condLibrary pkg) $+        map (fromCondTree . snd) (condExecutables pkg)+  where+    -- put the constrained ones first, for sorting purposes+    get_deps m = ranges ++ others+      where (others, ranges) = partition (simple . snd) (Map.toList m)++    asDependency (pkgname, interval) = Dependency pkgname $ intervalToRange interval++    intervalToRange :: VersionInterval -> VersionRange+    intervalToRange (lower, upper) = simplifyVersionRange $+        intersectVersionRanges (rangeLower lower) (rangeUpper upper)+      where rangeLower (LowerBound v bound) = case bound of+                InclusiveBound -> orLaterVersion v+                ExclusiveBound -> laterVersion v+            rangeUpper (UpperBound v bound) = case bound of+                InclusiveBound -> orEarlierVersion v+                ExclusiveBound -> earlierVersion v+            rangeUpper NoUpperBound = anyVersion++    simple :: VersionInterval -> Bool+    simple (l, NoUpperBound) = isMinLowerBound l+    simple _ = False++    head_deps = fromDependencies (buildDepends (packageDescription pkg))++    fromDependencies :: [Dependency] -> Disjunct+    fromDependencies = foldr addDep unitDisjunct+      where addDep (Dependency p vr) = liftM2 (\ x y -> Map.alter (add x) p y)+                (asVersionIntervals vr)+            add x Nothing = Just x+            add x (Just y) = intersectInterval x y++    fromCondTree :: CondTree v [Dependency] a -> Disjunct+    fromCondTree (CondNode _ ds comps) =+        foldr intersectDisjunct (fromDependencies ds) $+            map fromComponent comps++    fromComponent (_, _, Nothing) = unitDisjunct+    fromComponent (_, then_part, Just else_part) =+        unionDisjunct (fromCondTree then_part)+            (fromCondTree else_part)++    reduceDisjunct :: Conjunct -> [Conjunct] -> [Conjunct]+    reduceDisjunct c cs+      | any (c `subConjunct`) cs = cs+      | otherwise = c : filter (not . (`subConjunct` c)) cs++-- Same as @sortBy (comparing f)@, but without recomputing @f@.+sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn f xs = map snd (sortBy (comparing fst) [(f x, x) | x <- xs])++isMinLowerBound :: LowerBound -> Bool+isMinLowerBound (LowerBound (Version [0] _) InclusiveBound) = True+isMinLowerBound _ = False++{-+isWildcardRange :: Version -> Version -> Bool+isWildcardRange (Version branch1 _) (Version branch2 _) = check branch1 branch2+  where check (n:[]) (m:[]) | n+1 == m = True+        check (n:ns) (m:ms) | n   == m = check ns ms+        check _      _                 = False++withinInterval :: Version -> VersionInterval -> Bool+withinInterval v (lowerBound, upperBound)    = withinLower lowerBound+                                              && withinUpper upperBound+  where+    withinLower (LowerBound v' ExclusiveBound) = v' <  v+    withinLower (LowerBound v' InclusiveBound) = v' <= v++    withinUpper NoUpperBound                   = True+    withinUpper (UpperBound v' ExclusiveBound) = v' >  v+    withinUpper (UpperBound v' InclusiveBound) = v' >= v+-}++intersectInterval :: VersionInterval -> VersionInterval -> Maybe VersionInterval+intersectInterval (l1, u1) (l2, u2)+  | below u1 l2 || below u2 l1 = Nothing+  | otherwise = Just (max l1 l2, min u1 u2)++below :: UpperBound -> LowerBound -> Bool+below NoUpperBound _ = False+below (UpperBound v1 InclusiveBound) (LowerBound v2 InclusiveBound) = v1 < v2+below (UpperBound v1 _) (LowerBound v2 _) = v1 <= v2++subInterval :: VersionInterval -> VersionInterval -> Bool+subInterval (l1, u1) (l2, u2) = l2 <= l1 && u1 <= u2++-- Constraints in disjunctive normal form++type Conjunct = Map PackageName VersionInterval++unitConjunct :: Conjunct+unitConjunct = Map.empty++intersectConjunct :: Conjunct -> Conjunct -> Maybe Conjunct+intersectConjunct m1 m2 =+    Traversable.sequence $+        Map.unionWith inters (fmap Just m1) (fmap Just m2)+  where+    inters mx my = do+      x <- mx+      y <- my+      intersectInterval x y++subConjunct :: Conjunct -> Conjunct -> Bool+subConjunct m1 m2 =+    Map.null (Map.difference m2 m1) &&+    Foldable.and (Map.intersectionWith subInterval m1 m2)++type Disjunct = [Conjunct]++unitDisjunct :: Disjunct+unitDisjunct = [unitConjunct]++intersectDisjunct :: Disjunct -> Disjunct -> Disjunct+intersectDisjunct xs ys = catMaybes (liftM2 intersectConjunct xs ys)++-- eliminate any Conjunct list that is more restrictive than another+unionDisjunct :: Disjunct -> Disjunct -> Disjunct+unionDisjunct xs ys = xs' ++ ys'+  where ys' = [y | y <- ys, not (or [subConjunct y x | x <- xs])]+        xs' = [x | x <- xs, not (or [subConjunct x y | y <- ys'])]+
+ Distribution/Server/Packages/Types.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, StandaloneDeriving, TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Server.Packages.Types+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- All data types for the entire cabal-install system gathered here to avoid some .hs-boot files.+-----------------------------------------------------------------------------+module Distribution.Server.Packages.Types where++import Distribution.Server.Users.Types (UserId)+import Distribution.Server.Framework.BlobStorage (BlobId)+import Distribution.Server.Framework.Instances ()+import Distribution.Server.Framework.MemSize+import Distribution.Server.Util.Parse (unpackUTF8)++import Distribution.Package+         ( PackageIdentifier(..), Package(..) )+import Distribution.PackageDescription+         ( GenericPackageDescription(..))+import Distribution.PackageDescription.Parse+         ( parsePackageDescription, ParseResult(..) )++import qualified Data.Serialize as Serialize+import Data.Serialize (Serialize)+import Data.ByteString.Lazy (ByteString)+import Data.Time.Clock (UTCTime)+import Data.Typeable (Typeable)+import Data.List (sortBy)+import Data.Ord (comparing)+import Data.SafeCopy++newtype CabalFileText = CabalFileText { cabalFileByteString :: ByteString }+  deriving (Eq, Serialize, MemSize)++cabalFileString :: CabalFileText -> String+cabalFileString = unpackUTF8 . cabalFileByteString++instance SafeCopy CabalFileText where+  putCopy = contain . Serialize.put+  getCopy = contain Serialize.get++instance Show CabalFileText where+    show cft = "CabalFileText (Data.ByteString.Lazy.Char8.pack (Distribution.Simple.Utils.toUTF8 " ++ show (cabalFileString cft) ++ "))"++-- | The information we keep about a particular version of a package.+--+-- Previous versions of this package name and version may exist as well.+-- We normally disallow re-uploading but may make occasional exceptions.+data PkgInfo = PkgInfo {+    pkgInfoId :: !PackageIdentifier,+    -- | The .cabal file text.+    pkgData   :: !CabalFileText,+    -- | The actual package .tar.gz file. It is optional for making an incomplete+    -- mirror, e.g. using archives of just the latest packages, or perhaps for a+    -- multipart upload process.+    --+    -- The canonical tarball URL points to the most recently uploaded package.+    pkgTarball :: ![(PkgTarball, UploadInfo)],+    -- | Previous data. The UploadInfo does *not* indicate when the ByteString was+    -- uploaded, but rather when it was replaced. This way, pkgUploadData won't change+    -- even if a cabal file is changed.+    -- Should be updated whenever a tarball is uploaded (see mergePkg state function)+    pkgDataOld :: ![(CabalFileText, UploadInfo)],+    -- | When the package was created. Imports will override this with time in their logs.+    pkgUploadData :: !UploadInfo+} deriving (Eq, Typeable, Show)++instance SafeCopy PkgInfo where+  putCopy = contain . Serialize.put+  getCopy = contain Serialize.get++-- | The information held in a parsed .cabal file (used by cabal-install)+pkgDesc :: PkgInfo -> GenericPackageDescription+pkgDesc pkgInfo+     = case parsePackageDescription $ cabalFileString $ pkgData pkgInfo of+       -- We only make PkgInfos with parsable pkgDatas, so if it+       -- doesn't parse then something has gone wrong.+       ParseFailed e -> error ("Internal error: " ++ show e)+       ParseOk _ x   -> x++data PkgTarball = PkgTarball {+   pkgTarballGz   :: !BlobId,+   pkgTarballNoGz :: !BlobId+} deriving (Eq, Typeable, Show)++type UploadInfo = (UTCTime, UserId)++pkgUploadTime :: PkgInfo -> UTCTime+pkgUploadTime = fst . pkgUploadData++pkgUploadUser :: PkgInfo -> UserId+pkgUploadUser = snd . pkgUploadData++-- a small utility+descendUploadTimes :: [(a, UploadInfo)] -> [(a, UploadInfo)]+descendUploadTimes = sortBy (flip $ comparing (fst . snd))++instance Package PkgInfo where packageId = pkgInfoId++instance Serialize PkgInfo where+  put pkgInfo = do+    Serialize.put (pkgInfoId pkgInfo)+    Serialize.put (pkgData pkgInfo)+    Serialize.put (pkgTarball pkgInfo)+    Serialize.put (pkgDataOld pkgInfo)+    Serialize.put (pkgUploadData pkgInfo)++  get = do+    infoId  <- Serialize.get+    cabal   <- Serialize.get+    tarball <- Serialize.get+    old     <- Serialize.get+    updata  <- Serialize.get+    return PkgInfo {+        pkgInfoId = infoId,+        pkgUploadData = updata,+        pkgDataOld    = old,+        pkgTarball    = tarball,+        pkgData       = cabal+    }++instance Serialize PkgTarball where+    put tb = do+      Serialize.put (pkgTarballGz tb)+      Serialize.put (pkgTarballNoGz tb)+    get = do+      gz <- Serialize.get+      noGz <- Serialize.get+      return PkgTarball {+          pkgTarballGz = gz,+          pkgTarballNoGz = noGz+      }++instance SafeCopy PkgTarball where+  putCopy = contain . Serialize.put+  getCopy = contain Serialize.get++instance MemSize PkgInfo where+    memSize (PkgInfo a b c d e) = memSize5 a b c d e++instance MemSize PkgTarball where+    memSize (PkgTarball a b) = memSize2 a b
+ Distribution/Server/Packages/Unpack.hs view
@@ -0,0 +1,256 @@+-- Unpack a tarball containing a Cabal package+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Distribution.Server.Packages.Unpack (+    unpackPackage,+    unpackPackageRaw,+  ) where++import qualified Codec.Archive.Tar as Tar++import Distribution.Version+         ( Version(..) )+import Distribution.Package+         ( PackageIdentifier, packageVersion, packageName, PackageName(..) )+import Distribution.PackageDescription+         ( GenericPackageDescription(..), PackageDescription(..)+         , exposedModules )+import Distribution.PackageDescription.Parse+         ( parsePackageDescription )+import Distribution.PackageDescription.Configuration+         ( flattenPackageDescription )+import Distribution.PackageDescription.Check+         ( PackageCheck(..), checkPackage )+import Distribution.ParseUtils+         ( ParseResult(..), locatedErrorMsg, showPWarning )+import Distribution.Text+         ( display, simpleParse )+import Distribution.ModuleName+         ( components )+import Distribution.Server.Util.Parse+         ( unpackUTF8 )++import Data.List+         ( nub, (\\), partition, intercalate )+import Control.Monad+         ( unless, when )+import Control.Monad.Error+         ( ErrorT(..) )+import Control.Monad.Writer+         ( WriterT(..), MonadWriter, tell )+import Control.Monad.Identity+         ( Identity(..) )+import qualified Distribution.Server.Util.GZip as GZip+import Data.ByteString.Lazy+         ( ByteString )+import qualified Data.ByteString.Lazy as LBS+import System.FilePath+         ( (</>), (<.>), splitExtension, splitDirectories, normalise )+import qualified System.FilePath.Windows+         ( takeFileName )++-- | Upload or check a tarball containing a Cabal package.+-- Returns either an fatal error or a package description and a list+-- of warnings.+unpackPackage :: FilePath -> ByteString+              -> Either String+                        ((GenericPackageDescription, ByteString), [String])+unpackPackage tarGzFile contents =+  runUploadMonad $ do+    (entries, pkgDesc, warnings, cabalEntry) <- basicChecks False tarGzFile contents+    mapM_ fail warnings+    extraChecks entries pkgDesc+    return (pkgDesc, cabalEntry)++unpackPackageRaw :: FilePath -> ByteString+                 -> Either String+                           ((GenericPackageDescription, ByteString), [String])+unpackPackageRaw tarGzFile contents =+  runUploadMonad $ do+    (_entries, pkgDesc, _warnings, cabalEntry) <- basicChecks True tarGzFile contents+    return (pkgDesc, cabalEntry)++basicChecks :: Bool -> FilePath -> ByteString+            -> UploadMonad (Tar.Entries Tar.FormatError, GenericPackageDescription, [String], ByteString)+basicChecks lax tarGzFile contents = do+  let (pkgidStr, ext) = (base, tar ++ gz)+        where (tarFile, gz) = splitExtension (portableTakeFileName tarGzFile)+              (base,   tar) = splitExtension tarFile+  unless (ext == ".tar.gz") $+    fail $ tarGzFile ++ " is not a gzipped tar file, it must have the .tar.gz extension"++  pkgid <- case simpleParse pkgidStr of+    Just pkgid+      | display pkgid == pkgidStr -> return (pkgid :: PackageIdentifier)++      | not . null . versionTags . packageVersion $ pkgid+      -> fail $ "Hackage no longer accepts packages with version tags: "+             ++ intercalate ", " (versionTags (packageVersion pkgid))+    _ -> fail $ "Invalid package id " ++ show pkgidStr+             ++ ". The tarball must use the name of the package."++  -- Extract the .cabal file from the tarball+  let selectEntry entry = case Tar.entryContent entry of+        Tar.NormalFile bs _ | cabalFileName == normalise (Tar.entryPath entry)+                           -> Just bs+        _                  -> Nothing+      PackageName name  = packageName pkgid+      cabalFileName     = display pkgid </> name <.> "cabal"+      entries           = Tar.read (GZip.decompressNamed tarGzFile contents)+  cabalEntries <- selectEntries lax selectEntry entries+  cabalEntry   <- case cabalEntries of+    -- NB: tar files *can* contain more than one entry for the same filename.+    -- (This was observed in practice with the package CoreErlang-0.0.1).+    -- In this case, after extracting the tar the *last* file in the archive+    -- wins. Since selectEntries returns results in reverse order we use the head:+    cabalEntry:_ -> -- We tend to keep hold of the .cabal file, but+                    -- cabalEntry itself is part of a much larger+                    -- ByteString (the whole tar file), so we make a+                    -- copy of it+                    return $ LBS.copy cabalEntry+    [] -> fail $ "The " ++ quote cabalFileName+              ++ " file is missing from the package tarball."++  -- Parse the Cabal file+  let cabalFileContent = unpackUTF8 cabalEntry+  (pkgDesc, warnings) <- case parsePackageDescription cabalFileContent of+    ParseFailed err -> fail $ showError (locatedErrorMsg err)+    ParseOk warnings pkgDesc ->+      return (pkgDesc, map (showPWarning cabalFileName) warnings)++  -- Check that the name and version in Cabal file match+  when (packageName pkgDesc /= packageName pkgid) $+    fail "Package name in the cabal file does not match the file name."+  when (packageVersion pkgDesc /= packageVersion pkgid) $+    fail "Package version in the cabal file does not match the file name."++  return (entries, pkgDesc, warnings, cabalEntry)++  where+    showError (Nothing, msg) = msg+    showError (Just n, msg) = "line " ++ show n ++ ": " ++ msg++-- | The issue is that browsers can upload the file name using either unix+-- or windows convention, so we need to take the basename using either+-- convention. Since windows allows the unix '/' as a separator then we can+-- use the Windows.takeFileName as a portable solution.+--+portableTakeFileName :: FilePath -> String+portableTakeFileName = System.FilePath.Windows.takeFileName++-- Miscellaneous checks on package description+extraChecks :: Tar.Entries Tar.FormatError -> GenericPackageDescription -> UploadMonad ()+extraChecks entries genPkgDesc = do+  let pkgDesc = flattenPackageDescription genPkgDesc+  -- various checks++  --FIXME: do the content checks. The dev version of Cabal generalises+  -- checkPackageContent to work in any monad, we just need to provide+  -- a record of ops that will do checks inside the tarball. We should+  -- gather a map of files and dirs and have these just to map lookups:+  --+  -- > checkTarballContents = CheckPackageContentOps {+  -- >   doesFileExist      = Set.member fileMap,+  -- >   doesDirectoryExist = Set.member dirsMap+  -- > }+  -- > fileChecks <- checkPackageContent checkTarballContents pkgDesc++  let pureChecks = checkPackage genPkgDesc (Just pkgDesc)+      checks = pureChecks -- ++ fileChecks+      isDistError (PackageDistSuspicious {}) = False+      isDistError _                          = True+      (errors, warnings) = partition isDistError checks+  mapM_ (fail . explanation) errors+  mapM_ (warn . explanation) warnings++  -- Check sanity of the tarball. Some of the tarballs we import from+  -- old Hackage fail this check because e.g. they contain files+  -- using the ././@LongLink hack for long file names+  let checkEntries f = Tar.foldEntries (\x mr -> case f x of Nothing -> mr; Just s -> fail (show s)) (return ()) (fail . show) entries+  checkEntries (checkTarFilePath (package (packageDescription genPkgDesc)))+  checkEntries checkTarFileType++  -- Check reasonableness of names of exposed modules+  let topLevel = case library pkgDesc of+                 Nothing -> []+                 Just l ->+                     nub $ map head $ filter (not . null) $ map components $ exposedModules l+      badTopLevel = topLevel \\ allocatedTopLevelNodes++  unless (null badTopLevel) $+          warn $ "Exposed modules use unallocated top-level names: " +++                          unwords badTopLevel++-- Monad for uploading packages:+--      WriterT for warning messages+--      Either for fatal errors+newtype UploadMonad a = UploadMonad (WriterT [String] (ErrorT String Identity) a)+  deriving (Monad, MonadWriter [String])++warn :: String -> UploadMonad ()+warn msg = tell [msg]++runUploadMonad :: UploadMonad a -> Either String (a, [String])+runUploadMonad (UploadMonad m) = runIdentity . runErrorT . runWriterT $ m++-- | Registered top-level nodes in the class hierarchy.+allocatedTopLevelNodes :: [String]+allocatedTopLevelNodes = [+        "Algebra", "Codec", "Control", "Data", "Database", "Debug",+        "Distribution", "DotNet", "Foreign", "Graphics", "Language",+        "Network", "Numeric", "Prelude", "Sound", "System", "Test", "Text"]++selectEntries :: Bool -> (Tar.Entry -> Maybe a)+              -> Tar.Entries Tar.FormatError+              -> UploadMonad [a]+selectEntries lax select = extract []+  where+    -- We ignore those errors that are present in the historical hackage+    -- DB in lax mode (used when mirroring hackage)+    extract selected (Tar.Fail Tar.ShortTrailer)+     | lax                                    = return selected+    extract _        (Tar.Fail err)           = fail (show err)+    extract selected  Tar.Done                = return selected+    extract selected (Tar.Next entry entries) =+      case select entry of+        Nothing    -> extract          selected  entries+        Just saved -> extract (saved : selected) entries++checkTarFileType :: Tar.Entry -> Maybe String+checkTarFileType entry+  | case Tar.entryContent entry of+      Tar.NormalFile _ _ -> True+      Tar.Directory      -> True+      Tar.SymbolicLink _ -> True+      Tar.HardLink     _ -> True+      _                  -> False+  = Nothing++  | otherwise+  = Just $ "Bad file type in package tarball: " ++ Tar.entryPath entry+        ++ "\nFor portability, package tarballs should use the 'ustar' format "+        ++ "and only contain normal files, directories and file links. "+        ++ "Your tar program may be using non-standard extensions. For "+        ++ "example with GNU tar, use --format=ustar to get the portable "+        ++ "format."++checkTarFilePath :: PackageIdentifier -> Tar.Entry -> Maybe String+checkTarFilePath pkgid entry+  | not (all (/= "..") dirs)+  = Just $ "Bad file name in package tarball: " ++ quote (Tar.entryPath entry)+        ++ "\nFor security reasons, files in package tarballs may not use"+        ++ " \"..\" components in their path."+  | not (inPkgSubdir dirs)+  = Just $ "Bad file name in package tarball: " ++ quote (Tar.entryPath entry)+        ++ "\nAll the file in the package tarball must be in the subdirectory "+        ++ quote pkgstr ++ "."+  | otherwise+  = Nothing+  where+    dirs = splitDirectories (Tar.entryPath entry)+    pkgstr = display pkgid+    inPkgSubdir (".":pkgstr':_) = pkgstr == pkgstr'+    inPkgSubdir (    pkgstr':_) = pkgstr == pkgstr'+    inPkgSubdir _               = False++quote :: String -> String+quote s = "'" ++ s ++ "'"
+ Distribution/Server/Pages/BuildReports.hs view
@@ -0,0 +1,96 @@+-- Generate an HTML page listing all build reports for a package++module Distribution.Server.Pages.BuildReports (+  buildReportSummary,+  buildReportDetail,+  ) where++import qualified Distribution.Server.Features.BuildReports.BuildReport as BuildReport+import Distribution.Server.Features.BuildReports.BuildReport (BuildReport)+import Distribution.Server.Features.BuildReports.BuildReports+import Distribution.Server.Pages.Template ( hackagePage )++import Distribution.Package+         ( PackageIdentifier )+import Distribution.PackageDescription+         ( FlagName(FlagName) )+import Distribution.Text+         ( Text, display )++import qualified Text.XHtml.Strict as XHtml+import Text.XHtml.Strict+         ( Html, (<<), (!), tr, th, td, p, h2, ulist, li+         , toHtml, table, theclass, concatHtml, isNoHtml )+import Data.List (intersperse)++buildReportSummary :: PackageIdentifier+                   -> [(BuildReportId, BuildReport)] -> XHtml.Html+buildReportSummary pkgid reports = hackagePage title body+  where+    title = display pkgid ++ ": build reports"+    body  = [h2 << title, summaryTable]++    summaryTable = XHtml.table ! [theclass "properties"] <<+                    (headerRow : dataRows)+    headerRow = tr << [ th ! [XHtml.theclass "horizontal"] <<+                          columnName+                      | columnName <- columnNames ]+    columnNames = ["Platform", "Compiler", "Build outcome"]+    dataRows =+      [ tr ! [theclass (if odd n then "odd" else "even")] <<+          [ td << (display (BuildReport.arch report)+                ++ " / "+                ++ display (BuildReport.os report))+          , td << display (BuildReport.compiler report)+          , td << detailLink reportId <<+                    display (BuildReport.installOutcome report) ]+      | (n, (reportId, report)) <- zip [(1::Int)..] reports ]+    detailLink reportId =+      XHtml.anchor ! [XHtml.href $ "/buildreports/" ++ display reportId ]++buildReportDetail :: BuildReport -> BuildReportId -> Maybe BuildLog -> XHtml.Html+buildReportDetail report reportId buildLog = hackagePage title body+  where+    title = display pkgid ++ ": build report"+    pkgid = BuildReport.package report+    body  = [h2 << title, details, buildLogPara]+    details = tabulate+            [ (name, value)+            | (name, field) <- showFields+            , let value = field report+            , not (isNoHtml value) ]++    buildLogPara = p << [ ulist << [li << buildLogLink]]+    buildLogLink = case buildLog of+      Nothing -> toHtml "No build log available"+      _       -> XHtml.anchor ! [XHtml.href buildLogURL ] << "Build log"+    buildLogURL  = "/buildreports/" ++ display reportId ++ "/buildlog"++    showFields :: [(String, BuildReport -> Html)]+    showFields =+      [ ("Package",             displayHtml      . BuildReport.package)+      , ("Platform",            toHtml           . platform)+      , ("Compiler",            displayHtml      . BuildReport.compiler)+      , ("Build client",        displayHtml      . BuildReport.client)+      , ("Configuration flags", displayHtmlFlags . BuildReport.flagAssignment)+      , ("Exact dependencies",  displayHtmlList  . BuildReport.dependencies)+      , ("Install outcome",     displayHtml      . BuildReport.installOutcome)+      , ("Docs outcome",        displayHtml      . BuildReport.docsOutcome)+      ]+    platform report' = display (BuildReport.arch report')+                    ++ " / "+                    ++ display (BuildReport.os report')+    displayHtml     :: Text a => a -> Html+    displayHtml     = toHtml . display+    displayHtmlList :: Text a => [a] -> Html+    displayHtmlList  = concatHtml . intersperse (toHtml ", ") . map displayHtml+    displayHtmlFlags = concatHtml . intersperse (toHtml ", ") . map displayFlag+    displayFlag (FlagName fname, False) = toHtml $ '-':fname+    displayFlag (FlagName fname, True)  = toHtml $     fname++tabulate :: [(String, Html)] -> Html+tabulate items = table ! [theclass "properties"] <<+	[tr ! [theclass (if odd n then "odd" else "even")] <<+		[th ! [theclass "horizontal"] << t, td << d] |+		(n, (t, d)) <- zip [(1::Int)..] items]+
+ Distribution/Server/Pages/Distributions.hs view
@@ -0,0 +1,153 @@++module Distribution.Server.Pages.Distributions+    ( homePage+    , adminHomePage+    , distroListing+    , distroPage+    , adminDistroPage+    )+    where++import Distribution.Server.Pages.Template (hackagePage)+import Distribution.Server.Features.Distro.Distributions+import Distribution.Server.Users.Types+import Distribution.Text++import Distribution.Package+import qualified Happstack.Server.SURI as SURI++import System.FilePath.Posix+import Text.XHtml.Strict++-- | List of known distributions+homePage :: [DistroName] -> Html+homePage = hackagePage "Distributions" . listing "/distro"++-- | List of known distributions. Includes a form+-- to add a new distribution.+adminHomePage :: [DistroName] -> Html+adminHomePage distros+    = hackagePage "Distributions" $ concat+      [ listing "/admin/distro" distros+      , addDistroForm+      ]++-- | Display the packages in a distribution. The passed-in URL is the+-- link to the admin page.+distroListing :: DistroName -> [(PackageName, DistroPackageInfo)] -> URL -> Html+distroListing distro packages adminLink+    = hackagePage (display distro) $ concat+      [ packageListing+      , adminLinkHtml+      ]++ where+   packageListing :: [Html]+   packageListing+       = [ h3 << ("Packages in " ++ display distro)+         , ulist << map (uncurry packageHtml) packages+         ]++   packageHtml pName pInfo+       = li << (display pName ++ " " ++ display (distroVersion pInfo))++   adminLinkHtml+       = [ h3 << "Admin Tasks"+         , anchor ! [href adminLink] << "Administrative tasks"+         ]++-- | Admin page for a distribution. Includes a list+-- of the maintainers and a form to add maintainers.+distroPage :: DistroName -> [UserName] -> Html+distroPage distro users+    = hackagePage (display distro) $ concat+      [ addPackageForm distro+      , userList distro users+      , addUserForm distro+      ]++addPackageForm :: DistroName -> [Html]+addPackageForm distro  =+    let actionUri =+            "/distro" </> SURI.escape distro </> "admin" </> "addPackage"+    in [ h3 << "Add a package"+       , gui actionUri ! [theclass "box"] <<+         [ p << [stringToHtml "Package: ", textfield "packageName"]+         , p << [stringToHtml "Version: ", textfield "version"]+         , p << [stringToHtml "URL: ", textfield "uri"]+         , submit "submit" "Add package"+         ]+       ]++addDistroForm :: [Html]+addDistroForm =+    [ h3 << "Add Distribution"+    , gui "/admin/createDistro" ! [theclass "box"] <<+        [ p << [stringToHtml "Name: ", textfield "distroName"]+        , submit "submit" "Add distribution"+        ]+    ]++{-+This should be updated to match the current URI scheme in the Distro feature.++displayDir :: Text a => a -> String+displayDir = escapeString f . display+ where f c = okInPath c && c /= '/'++-- | Admin form for a distribution. Includes a list+-- of the maintainers, a form to add maintainers and+-- a button to destroy this distribution.+adminDistroPage :: DistroName -> [UserName] -> Html+adminDistroPage distro users+    = hackagePage (display distro) $ concat+      [ userList distro users+      , addUserForm distro+      , deleteDistro distro+      ]++addUserForm :: DistroName -> [Html]+addUserForm distro =+    [ h3 << "Add a maintainer"+    , gui ("/distro" </> displayDir distro </> "admin" </> "addMember") ! [theclass "box"]+      << [ p << [stringToHtml "User: ", textfield "userName"]+         , submit "submit" "Add user"+         ]+    ]++deleteDistro :: DistroName -> [Html]+deleteDistro distro+    = [ h3 << "Delete distribution"+      , gui ("/admin/distro" </> displayDir distro </> "delete") <<+        submit "submit" "Delete Distribution"+      ]++userList :: DistroName -> [UserName] -> [Html]+userList distro users+    = [ h3 << "Maintainers"+      , ulist << map (userHtml distro) users+      ]++userHtml :: DistroName -> UserName -> Html+userHtml distro user+    = li << [ stringToHtml $ display user+            , removeUser user distro+            ]++removeUser :: UserName -> DistroName -> Html+removeUser user distro+    = gui ("/distro" </> displayDir distro </> "admin" </> "removeMember")+      << [ hidden "userName" $ display user+         , submit "submit" "Remove"+         ]-}++listing :: FilePath -> [DistroName] -> [Html]+listing rootPath distros+    = [ h3 << "Distributions"+      , ulist << map (distroHtml rootPath) distros+      ]++distroHtml :: FilePath -> DistroName -> Html+distroHtml rootPath distro+    = li << anchor ! [href $ rootPath </> SURI.escape distro ]+      << display distro
+ Distribution/Server/Pages/Group.hs view
@@ -0,0 +1,69 @@+-- Body of the HTML page for a package+module Distribution.Server.Pages.Group (+    groupPage,+    renderGroupName+  ) where++import Text.XHtml.Strict+import System.FilePath.Posix ((</>))+import Distribution.Server.Pages.Template (hackagePage)+import qualified Distribution.Server.Users.Types as Users+import Distribution.Server.Users.Group (GroupDescription(..))+import qualified Distribution.Server.Users.Group as Group+import Distribution.Text+import Data.Maybe++renderGroupName :: GroupDescription -> Maybe String -> Html+renderGroupName desc murl =+    maybeUrl (groupTitle desc) murl+      ++++    maybe noHtml (\(for, mfor) -> " for " +++ maybeUrl for mfor) (groupEntity desc)+  where maybeUrl text = maybe (toHtml text) (\url -> anchor ! [href url] << text)++-- Primitive access control: the URI to post a new user request to, or the the URI/user/<username> to DELETE+-- if neither adding or removing is enabled, a link to a URI/edit page is provided+groupPage :: [Users.UserName] -> String -> (Bool, Bool) -> GroupDescription -> Html+groupPage users baseUri controls desc = hackagePage (Group.groupName desc) (groupBody users baseUri controls desc)++-- | Body of the page+-- If either addUri or removeUri are true, it can be assumed that we are one the+-- \/edit subpage of the group.+groupBody :: [Users.UserName] -> String -> (Bool, Bool) -> GroupDescription -> [Html]+groupBody users baseUri (addUri, removeUri) desc =+  [ h2 << renderGroupName desc (if addUri || removeUri then Just baseUri else Nothing)+  , paragraph <<+      [ toHtml $ groupPrologue desc+      , if addUri || removeUri then noHtml else thespan ! [thestyle "color: gray"] <<+          [ toHtml " ["+          , anchor ! [href $ baseUri </> "edit"] << "edit"+          , toHtml "]"+          ]+      ]+  , listGroup users (if removeUri then Just baseUri else Nothing)+  , if addUri then concatHtml $ addUser baseUri else noHtml+  ]++addUser :: String -> [Html]+addUser uri =+    [ h3 << "Add user"+    , gui uri ! [theclass "box"] <<+        [ p << [stringToHtml "User: ", textfield "user"]+        , submit "submit" "Add member"+        ]+    ]++removeUser :: Users.UserName -> String -> [Html]+removeUser uname uri =+    [ toHtml " ",+      gui (uri </> "user" </> display uname) <<+       [ hidden "_method" "DELETE"+       , submit "submit" "Remove"+       ]+    ]++listGroup :: [Users.UserName] -> Maybe String -> Html+listGroup [] _ = p << "No member exist presently"+listGroup users muri = unordList (map displayName users)+  where displayName uname = (anchor ! [href $ "/user/" ++ display uname] << display uname) ++++                            fromMaybe [] (fmap (removeUser uname) muri)+
+ Distribution/Server/Pages/Index.hs view
@@ -0,0 +1,148 @@+-- Generate an HTML page listing all available packages++module Distribution.Server.Pages.Index (packageIndex) where++import Distribution.Server.Pages.Template       ( hackagePage )++import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Configuration+                                ( flattenPackageDescription )+import qualified Distribution.Server.Packages.PackageIndex as PackageIndex+import Distribution.Server.Packages.Types+import Distribution.Simple.Utils (comparing, equating)+import Distribution.ModuleName (toFilePath)++import Text.XHtml.Strict hiding ( p, name )+import qualified Text.XHtml.Strict as XHtml ( name )++import Data.Char (toLower, toUpper, isSpace)+import Data.List (intersperse, sortBy, groupBy, nub, maximumBy)+++packageIndex :: PackageIndex.PackageIndex PkgInfo -> Html+packageIndex = formatPkgGroups+                 . map (mkPackageIndexInfo+                      . flattenPackageDescription+                      . pkgDesc+                      . maximumBy (comparing packageVersion))+                 . PackageIndex.allPackagesByName++data PackageIndexInfo = PackageIndexInfo {+                            pii_pkgName :: !PackageName,+                            pii_categories :: ![Category],+                            pii_hasLibrary :: !Bool,+                            pii_numExecutables :: !Int,+                            pii_synopsis :: !String+                        }++mkPackageIndexInfo :: PackageDescription -> PackageIndexInfo+mkPackageIndexInfo pd = PackageIndexInfo {+                            pii_pkgName = pkgName $ package pd,+                            pii_categories = categories pd,+                            pii_hasLibrary = hasLibs pd,+                            pii_numExecutables = length (executables pd),+                            pii_synopsis = synopsis pd+                        }++data Category = Category String | NoCategory+        deriving (Eq, Ord, Show)++-- Packages, grouped by category and ordered by name with each category.+formatPkgGroups :: [PackageIndexInfo] -> Html+formatPkgGroups pkgs = hackagePage "packages by category" docBody+  where docBody =+                (h2 << "Packages by category") :+                -- table of contents+                paragraph ! [theclass "toc"] <<+                        (bold << "Categories:" : toHtml " " :+                         intersperse (toHtml ", ") (map catLink cat_pkgs) +++                         [toHtml "."]) :+                -- packages grouped by category+                [formatCategory cat ++++                        formatPkgList (sortBy (comparing sortKey) sub_pkgs) |+                        (cat, sub_pkgs) <- cat_pkgs]+        catLink (cat, sub_pkgs) =+                (anchor ! [href ("#" ++ catLabel catName)] << catName) ++++                spaceHtml ++++                toHtml ("(" ++ show (length sub_pkgs) ++ ")")+          where catName = categoryName cat+        cat_pkgs = groupOnFstBy normalizeCategory $ [(capitalize cat, pkg) |+                        pkg <- pkgs, cat <- pii_categories pkg]+        sortKey pkg = map toLower $ unPackageName $ pii_pkgName pkg+        formatCategory cat =+                h3 ! [theclass "category"] <<+                        anchor ! [XHtml.name (catLabel catName)] << catName+          where catName = categoryName cat+        catLabel cat = "cat:" ++ cat+        categoryName (Category cat) = cat+        categoryName NoCategory = "Unclassified"+        capitalize (Category s) =+                Category (unwords [toUpper c : cs | (c:cs) <- words s])+        capitalize NoCategory = NoCategory++formatPkgList :: [PackageIndexInfo] -> Html+formatPkgList pkgs = ulist ! [theclass "packages"] << map formatPkg pkgs++formatPkg :: PackageIndexInfo -> Html+formatPkg pkg = li << (pkgLink : toHtml (" " ++ ptype) : defn)+  where pname = pii_pkgName pkg+        pkgLink = anchor ! [href (packageNameURL pname)] << unPackageName pname+        defn+          | null (pii_synopsis pkg) = []+          | otherwise = [toHtml (": " ++ trim (pii_synopsis pkg))]+        ptype+          | pii_numExecutables pkg == 0 = "library"+          | pii_hasLibrary pkg = "library and " ++ programs+          | otherwise = programs+          where programs+                  | pii_numExecutables pkg > 1 = "programs"+                  | otherwise = "program"+        trim s+          | length s < 90 = s+          | otherwise = reverse (dropWhile (/= ',') (reverse (take 76 s))) ++ " ..."++categories :: PackageDescription -> [Category]+categories pkg+  | not (null cats) && (cats `notElem` blacklist) = split cats+  | not (null top_level_nodes) && length top_level_nodes < 3 &&+        all (`elem` allocatedTopLevelNodes) top_level_nodes =+        map Category top_level_nodes+  | otherwise = [NoCategory]+  where cats = trim (category pkg)+        -- trim will not be necessary with future releases of cabal+        trim = reverse . dropWhile isSpace . reverse+        split cs = case break (== ',') cs of+                (front, _:back) ->+                        Category front : split (dropWhile isSpace back)+                (front, []) -> [Category front]+        -- if no category specified, use top-level of module hierarchy+        top_level_nodes =+                maybe [] (nub . map (takeWhile (/= '.') . toFilePath) . exposedModules)+                (library pkg)++-- categories we ignore+blacklist :: [String]+blacklist = ["Application", "Foreign binding", "Tool", "Type", "Various",+        "Unclassified"]++groupOnFstBy :: (Ord a, Ord c) => (a -> c) -> [(a, b)] -> [(a, [b])]+groupOnFstBy f xys = [(x, y : map snd xys') |+        (x, y) : xys' <- groupBy (equating (f . fst)) (sortBy (comparing sortKey) xys)]+  where sortKey (x, _) = (f x, x)++normalizeCategory :: Category -> Category+normalizeCategory (Category n) = Category (map toLower n)+normalizeCategory NoCategory = NoCategory++allocatedTopLevelNodes :: [String]+allocatedTopLevelNodes = [+        "Algebra", "Codec", "Control", "Data", "Database", "Debug",+        "Distribution", "DotNet", "Foreign", "Graphics", "Language",+        "Network", "Numeric", "Prelude", "Sound", "System", "Test", "Text"]++packageNameURL :: PackageName -> URL+packageNameURL pkg = "/package/" ++ unPackageName pkg++unPackageName :: PackageName -> String+unPackageName (PackageName name) = name
+ Distribution/Server/Pages/Package.hs view
@@ -0,0 +1,354 @@+-- Body of the HTML page for a package+{-# LANGUAGE PatternGuards, RecordWildCards #-}+module Distribution.Server.Pages.Package (+    packagePage,+    renderDependencies,+    renderVersion,+    renderFields,+    renderDownloads+  ) where++import Distribution.Server.Features.PreferredVersions++import Distribution.Server.Pages.Template (hackagePageWith)+import Distribution.Server.Pages.Package.HaddockParse (parseHaddockParagraphs)+import Distribution.Server.Pages.Package.HaddockLex  (tokenise)+import Distribution.Server.Pages.Package.HaddockHtml+import Distribution.Server.Packages.ModuleForest+import Distribution.Server.Packages.Render+import Distribution.Server.Users.Types (userStatus, userName, isActiveAccount)++import Distribution.Package+import Distribution.PackageDescription as P+import Distribution.Simple.Utils ( cabalVersion )+import Distribution.Version+import Distribution.Text        (display)+import Text.XHtml.Strict hiding (p, name, title, content)++import Data.Maybe               (maybeToList)+import Data.List                (intersperse, intercalate)+import System.FilePath.Posix    ((</>), (<.>))+import System.Locale            (defaultTimeLocale)+import Data.Time.Format         (formatTime)++packagePage :: PackageRender -> [Html] -> [Html] -> [(String, Html)] -> [(String, Html)] -> Maybe URL -> Html+packagePage render headLinks top sections bottom docURL =+    hackagePageWith [] docTitle docSubtitle docBody [docFooter]+  where+    pkgid = rendPkgId render++    docTitle = display (packageName pkgid)+            ++ case synopsis (rendOther render) of+                 ""    -> ""+                 short -> ": " ++ short+    docSubtitle = toHtml docTitle++    docBody =+        h1 <<+           bodyTitle :+            concat [+             renderHeads,+             top,+             pkgBody render sections,+             moduleSection render docURL,+             downloadSection render,+             maintainerSection pkgid,+             map pair bottom+           ]+    bodyTitle = "The " ++ display (pkgName pkgid) ++ " package"++    renderHeads = case headLinks of+        [] -> []+        items -> [thediv ! [thestyle "font-size: small"] <<+            (map (\item -> "[" +++ item +++ "] ") items)]++    docFooter = thediv ! [identifier "footer"]+                  << paragraph+                       << [ toHtml "Produced by "+                          , anchor ! [href "/"] << "hackage"+                          , toHtml " and "+                          , anchor ! [href cabalHomeURL] << "Cabal"+                          , toHtml (" " ++ display cabalVersion) ]++    pair (title, content) =+        toHtml [ h2 << title, content ]++-- | Body of the package page+pkgBody :: PackageRender -> [(String, Html)] -> [Html]+pkgBody render sections =+    prologue (description $ rendOther render) +++    propertySection sections++prologue :: String -> [Html]+prologue [] = []+prologue desc = case tokenise desc >>= parseHaddockParagraphs of+    Left _ -> [paragraph << p | p <- paragraphs desc]+    Right doc -> [markup htmlMarkup doc]++-- Break text into paragraphs (separated by blank lines)+paragraphs :: String -> [String]+paragraphs = map unlines . paras . lines+  where paras xs = case dropWhile null xs of+                [] -> []+                xs' -> case break null xs' of+                        (para, xs'') -> para : paras xs''++downloadSection :: PackageRender -> [Html]+downloadSection PackageRender{..} =+    [ h2 << "Downloads"+    , ulist << map (li <<) downloadItems+    ]+  where+    downloadItems =+      [ if rendHasTarball+          then [ anchor ! [href downloadURL] << tarGzFileName+               , toHtml << " ["+               , anchor ! [href srcURL] << "browse"+               , toHtml << "]"+               , toHtml << " (Cabal source package)"+               ]+          else [ toHtml << "Package tarball not uploaded" ]+      , [ anchor ! [href cabalURL] << "Package description"+        , toHtml $ if rendHasTarball then " (included in the package)" else ""+        ]+      , case (rendHasTarball, rendHasChangeLog) of+         (True, True)  -> [ anchor ! [href changeLogURL] << "Changelog"+                          , toHtml << " (included in the package)"+                          ]+         (True, False) -> [ toHtml << "No changelog available" ]+         _             -> [ toHtml << "Package tarball not uploaded" ]+      ]++    downloadURL   = rendPkgUri </> display rendPkgId <.> "tar.gz"+    cabalURL      = rendPkgUri </> display (packageName rendPkgId) <.> "cabal"+    changeLogURL  = rendPkgUri </> "changelog"+    srcURL        = rendPkgUri </> "src/"+    tarGzFileName = display rendPkgId ++ ".tar.gz"++maintainerSection :: PackageId -> [Html]+maintainerSection pkgid =+    [ h4 << "Maintainers' corner"+    , paragraph << "For package maintainers and hackage trustees"+    , ulist << li << anchor ! [href maintainURL]+                  << "edit package information"+    ]+  where+    maintainURL = display (packageName pkgid) </> "maintain"++moduleSection :: PackageRender -> Maybe URL -> [Html]+moduleSection render docURL = maybeToList $ fmap msect (rendModules render)+  where msect lib = toHtml+            [ h2 << "Modules"+            , renderModuleForest docURL lib+            ]++propertySection :: [(String, Html)] -> [Html]+propertySection sections =+    [ h2 << "Properties"+    , tabulate $ filter (not . isNoHtml . snd) sections+    ]++tabulate :: [(String, Html)] -> Html+tabulate items = table <<+        [tr << [th ! [align "left", valign "top"] << t, td << d] | (t, d) <- items]+++renderDependencies :: PackageRender -> (String, Html)+renderDependencies render = ("Dependencies", case htmlDepsList of+    [] -> toHtml "None"+    _  -> foldr (+++) noHtml htmlDepsList)+  where htmlDepsList =+            intersperse (toHtml " " +++ bold (toHtml "or") +++ br) $+            map showDependencies (rendDepends render)++showDependencies :: [Dependency] -> Html+showDependencies deps = commaList (map showDependency deps)++showDependency ::  Dependency -> Html+showDependency (Dependency (PackageName pname) vs) = showPkg +++ vsHtml+  where vsHtml = if vs == anyVersion then noHtml+                                     else toHtml (" (" ++ display vs ++ ")")+        -- mb_vers links to latest version in range. This is a bit computationally+        -- expensive, not cache-friendly, and perhaps unexpected in some cases+        {-mb_vers = maybeLast $ filter (`withinRange` vs) $ map packageVersion $+                    PackageIndex.lookupPackageName vmap (PackageName pname)-}+        -- nonetheless, we should ensure that the package exists /before/+        -- passing along the PackageRender, which is not the case here+        showPkg = anchor ! [href . packageURL $ PackageIdentifier (PackageName pname) (Version [] [])] << pname++renderVersion :: PackageId -> [(Version, VersionStatus)] -> Maybe String -> (String, Html)+renderVersion (PackageIdentifier pname pversion) allVersions info =+    (if null earlierVersions && null laterVersions then "Version" else "Versions", versionList +++ infoHtml)+  where (earlierVersions, laterVersionsInc) = span ((<pversion) . fst) allVersions+        (mThisVersion, laterVersions) = case laterVersionsInc of+            (v:later) | fst v == pversion -> (Just v, later)+            later -> (Nothing, later)+        versionList = commaList $ map versionedLink earlierVersions+                               ++ (case pversion of+                                      Version [] [] -> []+                                      _ -> [strong ! (maybe [] (status . snd) mThisVersion) << display pversion]+                                  )+                               ++ map versionedLink laterVersions+        versionedLink (v, s) = anchor ! (status s ++ [href $ packageURL $ PackageIdentifier pname v]) << display v+        status st = case st of+            NormalVersion -> []+            DeprecatedVersion  -> [theclass "deprecated"]+            UnpreferredVersion -> [theclass "unpreferred"]+        infoHtml = case info of Nothing -> noHtml; Just str -> " (" +++ (anchor ! [href str] << "info") +++ ")"++-- We don't keep currently per-version downloads in memory; if we decide that+-- it is important to show this all the time, we can reenable+renderDownloads :: Int -> {- Int -> Version -> -} (String, Html)+renderDownloads totalDown {- versionDown version -} =+    ("Downloads", toHtml $ {- show versionDown ++ " for " ++ display version +++                      " and " ++ -} show totalDown ++ " total")++renderFields :: PackageRender -> [(String, Html)]+renderFields render = [+        -- Cabal-Version+        ("License",     toHtml $ rendLicenseName render),+        ("Copyright",   toHtml $ P.copyright desc),+        ("Author",      toHtml $ author desc),+        ("Maintainer",  maintainField $ rendMaintainer render),+        ("Stability",   toHtml $ stability desc),+        ("Category",    commaList . map categoryField $ rendCategory render),+        ("Home page",   linkField $ homepage desc),+        ("Bug tracker", linkField $ bugReports desc),+        ("Source repository", vList $ map sourceRepositoryField $ sourceRepos desc),+        ("Executables", commaList . map toHtml $ rendExecNames render),+        ("Upload date", toHtml $ showTime utime),+        ("Uploaded by", userField)+      ]+  where desc = rendOther render+        (utime, uinfo) = rendUploadInfo render+        uname = maybe "Unknown" (display . userName) uinfo+        uactive = maybe False (isActiveAccount . userStatus) uinfo+        userField | uactive   = anchor ! [href $ "/user/" ++ uname] << uname+                  | otherwise = toHtml uname+        linkField url = case url of+            [] -> noHtml+            _  -> anchor ! [href url] << url+        categoryField cat = anchor ! [href $ "/packages/#cat:" ++ cat] << cat+        maintainField mnt = case mnt of+            Nothing -> strong ! [theclass "warning"] << toHtml "none"+            Just n  -> toHtml n+        showTime = formatTime defaultTimeLocale "%c"+        sourceRepositoryField sr = sourceRepositoryToHtml sr++sourceRepositoryToHtml :: SourceRepo -> Html+sourceRepositoryToHtml sr+    = toHtml (display (repoKind sr) ++ ": ")+  +++ case repoType sr of+      Just Darcs+       | (Just url, Nothing, Nothing) <-+         (repoLocation sr, repoModule sr, repoBranch sr) ->+          concatHtml [toHtml "darcs get ",+                      anchor ! [href url] << toHtml url,+                      case repoTag sr of+                          Just tag' -> toHtml (" --tag " ++ tag')+                          Nothing   -> noHtml,+                      case repoSubdir sr of+                          Just sd -> toHtml " ("+                                 +++ (anchor ! [href (url </> sd)]+                                      << toHtml sd)+                                 +++ toHtml ")"+                          Nothing   -> noHtml]+      Just Git+       | (Just url, Nothing) <-+         (repoLocation sr, repoModule sr) ->+          concatHtml [toHtml "git clone ",+                      anchor ! [href url] << toHtml url,+                      case repoBranch sr of+                          Just branch -> toHtml (" -b " ++ branch)+                          Nothing     -> noHtml,+                      case repoTag sr of+                          Just tag' -> toHtml ("(tag " ++ tag' ++ ")")+                          Nothing   -> noHtml,+                      case repoSubdir sr of+                          Just sd -> toHtml ("(" ++ sd ++ ")")+                          Nothing -> noHtml]+      Just SVN+       | (Just url, Nothing, Nothing, Nothing) <-+         (repoLocation sr, repoModule sr, repoBranch sr, repoTag sr) ->+          concatHtml [toHtml "svn checkout ",+                      anchor ! [href url] << toHtml url,+                      case repoSubdir sr of+                          Just sd -> toHtml ("(" ++ sd ++ ")")+                          Nothing   -> noHtml]+      Just CVS+       | (Just url, Just m, Nothing, Nothing) <-+         (repoLocation sr, repoModule sr, repoBranch sr, repoTag sr) ->+          concatHtml [toHtml "cvs -d ",+                      anchor ! [href url] << toHtml url,+                      toHtml (" " ++ m),+                      case repoSubdir sr of+                          Just sd -> toHtml ("(" ++ sd ++ ")")+                          Nothing   -> noHtml]+      Just Mercurial+       | (Just url, Nothing, Nothing, Nothing) <-+         (repoLocation sr, repoModule sr, repoBranch sr, repoTag sr) ->+          concatHtml [toHtml "hg clone ",+                      anchor ! [href url] << toHtml url,+                      case repoSubdir sr of+                          Just sd -> toHtml ("(" ++ sd ++ ")")+                          Nothing   -> noHtml]+      Just Bazaar+       | (Just url, Nothing, Nothing) <-+         (repoLocation sr, repoModule sr, repoBranch sr) ->+          concatHtml [toHtml "bzr branch ",+                      anchor ! [href url] << toHtml url,+                      case repoTag sr of+                          Just tag' -> toHtml (" -r " ++ tag')+                          Nothing -> noHtml,+                      case repoSubdir sr of+                          Just sd -> toHtml ("(" ++ sd ++ ")")+                          Nothing   -> noHtml]+      _ ->+          -- We don't know how to show this SourceRepo.+          -- This is a kludge so that we at least show all the info.+          toHtml (show sr)++commaList :: [Html] -> Html+commaList = concatHtml . intersperse (toHtml ", ")++vList :: [Html] -> Html+vList = concatHtml . intersperse br+-----------------------------------------------------------------------------++renderModuleForest :: Maybe URL -> ModuleForest -> Html+renderModuleForest mb_url forest =+    thediv ! [identifier "module-list"] << renderForest [] forest+    where+      renderForest _       [] = noHtml+      renderForest pathRev ts = myUnordList $ map renderTree ts+          where+            renderTree (Node s isModule subs) =+                    ( if isModule then moduleEntry newPath else italics << s )+                +++ renderForest newPathRev subs+                where+                  newPathRev = s:pathRev+                  newPath = reverse newPathRev++      moduleEntry path =+          thespan ! [theclass "module"] << maybe modName linkedName mb_url path+      modName path = toHtml (intercalate "." path)+      linkedName url path = anchor ! [href modUrl] << modName path+          where+            modUrl = url ++ "/" ++ intercalate "-" path ++ ".html"+      myUnordList :: HTML a => [a] -> Html+      myUnordList = unordList ! [theclass "modules"]++------------------------------------------------------------------------------+-- TODO: most of these should be available from the CoreFeature+-- so pass it in to this module++-- | URL describing a package.+packageURL :: PackageIdentifier -> URL+packageURL pkgId = "/package" </> display pkgId++--cabalLogoURL :: URL+--cabalLogoURL = "/built-with-cabal.png"++-- global URLs+cabalHomeURL :: URL+cabalHomeURL = "http://haskell.org/cabal/"
+ Distribution/Server/Pages/Package/HaddockHtml.hs view
@@ -0,0 +1,154 @@+-- stolen from Haddock's HsSyn.lhs and HaddockHtml.hs+module Distribution.Server.Pages.Package.HaddockHtml where++import Data.Char                (isSpace)+import Text.XHtml.Strict        hiding (p)+import Network.URI              (escapeURIString, isUnreserved)++data GenDoc id+  = DocEmpty+  | DocAppend (GenDoc id) (GenDoc id)+  | DocString String+  | DocParagraph (GenDoc id)+  | DocIdentifier id+  | DocModule String+  | DocEmphasis (GenDoc id)+  | DocMonospaced (GenDoc id)+  | DocUnorderedList [GenDoc id]+  | DocOrderedList [GenDoc id]+  | DocDefList [(GenDoc id, GenDoc id)]+  | DocCodeBlock (GenDoc id)+  | DocURL String+  | DocPic String+  | DocAName String+  deriving (Eq, Show)++type Doc = GenDoc String++-- | DocMarkup is a set of instructions for marking up documentation.+-- In fact, it's really just a mapping from 'GenDoc' to some other+-- type [a], where [a] is usually the type of the output (HTML, say).++data DocMarkup id a = Markup {+  markupEmpty         :: a,+  markupString        :: String -> a,+  markupParagraph     :: a -> a,+  markupAppend        :: a -> a -> a,+  markupIdentifier    :: id -> a,+  markupModule        :: String -> a,+  markupEmphasis      :: a -> a,+  markupMonospaced    :: a -> a,+  markupUnorderedList :: [a] -> a,+  markupOrderedList   :: [a] -> a,+  markupDefList       :: [(a,a)] -> a,+  markupCodeBlock     :: a -> a,+  markupURL           :: String -> a,+  markupPic           :: String -> a,+  markupAName         :: String -> a+  }++markup :: DocMarkup id a -> GenDoc id -> a+markup m DocEmpty               = markupEmpty m+markup m (DocAppend d1 d2)      = markupAppend m (markup m d1) (markup m d2)+markup m (DocString s)          = markupString m s+markup m (DocParagraph d)       = markupParagraph m (markup m d)+markup m (DocIdentifier i)      = markupIdentifier m i+markup m (DocModule mod0)       = markupModule m mod0+markup m (DocEmphasis d)        = markupEmphasis m (markup m d)+markup m (DocMonospaced d)      = markupMonospaced m (markup m d)+markup m (DocUnorderedList ds)  = markupUnorderedList m (map (markup m) ds)+markup m (DocOrderedList ds)    = markupOrderedList m (map (markup m) ds)+markup m (DocDefList ds)        = markupDefList m (map (markupPair m) ds)+markup m (DocCodeBlock d)       = markupCodeBlock m (markup m d)+markup m (DocURL url)           = markupURL m url+markup m (DocPic url)           = markupPic m url+markup m (DocAName ref)         = markupAName m ref++markupPair :: DocMarkup id a -> (GenDoc id, GenDoc id) -> (a, a)+markupPair m (a,b) = (markup m a, markup m b)++-- | The identity markup+idMarkup :: DocMarkup a (GenDoc a)+idMarkup = Markup {+  markupEmpty         = DocEmpty,+  markupString        = DocString,+  markupParagraph     = DocParagraph,+  markupAppend        = DocAppend,+  markupIdentifier    = DocIdentifier,+  markupModule        = DocModule,+  markupEmphasis      = DocEmphasis,+  markupMonospaced    = DocMonospaced,+  markupUnorderedList = DocUnorderedList,+  markupOrderedList   = DocOrderedList,+  markupDefList       = DocDefList,+  markupCodeBlock     = DocCodeBlock,+  markupURL           = DocURL,+  markupPic           = DocPic,+  markupAName         = DocAName+  }++htmlMarkup :: DocMarkup String Html+htmlMarkup = Markup {+  markupParagraph     = paragraph,+  markupEmpty         = toHtml "",+  markupString        = toHtml,+  markupAppend        = (+++),+  markupIdentifier    = tt . toHtml . init . tail,+  markupModule        = tt . toHtml,+  markupEmphasis      = emphasize . toHtml,+  markupMonospaced    = tt . toHtml,+  markupUnorderedList = ulist . concatHtml . map (li <<),+  markupOrderedList   = olist . concatHtml . map (li <<),+  markupDefList       = dlist . concatHtml . map markupDef,+  markupCodeBlock     = pre,+  markupURL           = \url -> anchor ! [href url] << toHtml url,+  markupPic           = \url -> image ! [src url],+  markupAName         = \aname -> namedAnchor aname << toHtml ""+  }+  where markupDef (a,b) = dterm << a +++ ddef << b++namedAnchor :: String -> Html -> Html+namedAnchor n = anchor ! [name (escapeStr n)]++escapeStr :: String -> String+escapeStr = escapeURIString isUnreserved++-- -----------------------------------------------------------------------------+-- ** Smart constructors++-- used to make parsing easier; we group the list items later+docAppend :: Doc -> Doc -> Doc+docAppend (DocUnorderedList ds1) (DocUnorderedList ds2)+  = DocUnorderedList (ds1++ds2)+docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)+  = DocAppend (DocUnorderedList (ds1++ds2)) d+docAppend (DocOrderedList ds1) (DocOrderedList ds2)+  = DocOrderedList (ds1++ds2)+docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)+  = DocAppend (DocOrderedList (ds1++ds2)) d+docAppend (DocDefList ds1) (DocDefList ds2)+  = DocDefList (ds1++ds2)+docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d)+  = DocAppend (DocDefList (ds1++ds2)) d+docAppend DocEmpty d = d+docAppend d DocEmpty = d+docAppend d1 d2+  = DocAppend d1 d2++-- again to make parsing easier - we spot a paragraph whose only item+-- is a DocMonospaced and make it into a DocCodeBlock+docParagraph :: Doc -> Doc+docParagraph (DocMonospaced p)+  = DocCodeBlock p+docParagraph (DocAppend (DocString s1) (DocMonospaced p))+  | all isSpace s1+  = DocCodeBlock p+docParagraph (DocAppend (DocString s1)+                (DocAppend (DocMonospaced p) (DocString s2)))+  | all isSpace s1 && all isSpace s2+  = DocCodeBlock p+docParagraph (DocAppend (DocMonospaced p) (DocString s2))+  | all isSpace s2+  = DocCodeBlock p+docParagraph p+  = DocParagraph p
+ Distribution/Server/Pages/Package/HaddockLex.x view
@@ -0,0 +1,159 @@+--+-- Haddock - A Haskell Documentation Tool+--+-- (c) Simon Marlow 2002+--++{+{-# LANGUAGE BangPatterns #-}+-- Disable warnings that the generated code causes+{-# OPTIONS_GHC -fno-warn-deprecated-flags+                -fno-warn-unused-binds+                -fno-warn-unused-imports+                -fno-warn-unused-matches+                -fno-warn-missing-signatures+                -fno-warn-tabs #-}+module Distribution.Server.Pages.Package.HaddockLex (+        Token(..),+        tokenise+ ) where++import Data.Char+import Data.Word (Word8)+import Numeric+import Control.Monad (liftM)+}++$ws    = $white # \n+$digit = [0-9]+$hexdigit = [0-9a-fA-F]+$special =  [\"\@]+$alphanum = [A-Za-z0-9]+$ident    = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]++:-++-- beginning of a paragraph+<0,para> {+ $ws* \n                ;+ $ws* \>                { begin birdtrack }+ $ws* [\*\-]            { token TokBullet `andBegin` string }+ $ws* \[                { token TokDefStart `andBegin` def }+ $ws* \( $digit+ \)     { token TokNumber `andBegin` string }+ $ws*                   { begin string }+}++-- beginning of a line+<line> {+  $ws* \>               { begin birdtrack }+  $ws* \n               { token TokPara `andBegin` para }+  -- Here, we really want to be able to say+  -- $ws* (\n | <eof>)  { token TokPara `andBegin` para}+  -- because otherwise a trailing line of whitespace will result in+  -- a spurious TokString at the end of a docstring.  We don't have <eof>,+  -- though (NOW I realise what it was for :-).  To get around this, we always+  -- append \n to the end of a docstring.+  ()                    { begin string }+}++<birdtrack> .*  \n?     { strtoken TokBirdTrack `andBegin` line }++<string,def> {+  $special                      { strtoken $ \s -> TokSpecial (head s) }+  \<\<.*\>\>                    { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) }+  \<.*\>                        { strtoken $ \s -> TokURL (init (tail s)) }+  \#.*\#                        { strtoken $ \s -> TokAName (init (tail s)) }+  \/ [^\/]* \/                  { strtoken $ \s -> TokEmphasis (init (tail s)) }+  [\'\`] $ident+ [\'\`]         { ident }+  \\ .                          { strtoken (TokString . tail) }+  "&#" $digit+ \;               { strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] }+  "&#" [xX] $hexdigit+ \;       { strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n]; _ -> error "hexParser: Can't happen" }+  -- allow special characters through if they don't fit one of the previous+  -- patterns.+  [\/\'\`\<\#\&\\]                      { strtoken TokString }+  [^ $special \/ \< \# \n \'\` \& \\ \]]* \n { strtoken TokString `andBegin` line }+  [^ $special \/ \< \# \n \'\` \& \\ \]]+    { strtoken TokString }+}++<def> {+  \]                            { token TokDefEnd `andBegin` string }+}++-- ']' doesn't have any special meaning outside of the [...] at the beginning+-- of a definition paragraph.+<string> {+  \]                            { strtoken TokString }+}++{+data Token+  = TokPara+  | TokNumber+  | TokBullet+  | TokDefStart+  | TokDefEnd+  | TokSpecial Char+  | TokIdent String+  | TokString String+  | TokURL String+  | TokPic String+  | TokEmphasis String+  | TokAName String+  | TokBirdTrack String+  deriving Show++-- -----------------------------------------------------------------------------+-- Alex support stuff++type StartCode = Int+type Action = String -> StartCode -> (StartCode -> Either String [Token]) -> Either String [Token]++type AlexInput = (Char,String)++-- | For alex >= 3+--+-- See also alexGetChar+alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)+alexGetByte (_, [])   = Nothing+alexGetByte (_, c:cs) = Just (fromIntegral (ord c), (c,cs))++-- | For alex < 3+--+-- See also alexGetByte+alexGetChar :: AlexInput -> Maybe (Char, AlexInput)+alexGetChar (_, [])   = Nothing+alexGetChar (_, c:cs) = Just (c, (c,cs))++alexInputPrevChar (c,_) = c++tokenise :: String -> Either String [Token]+tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks+  where go inp@(_,str') sc =+          case alexScan inp sc of+                AlexEOF -> Right []+                AlexError _ -> Left "lexical error"+                AlexSkip  inp' _       -> go inp' sc+                AlexToken inp' len act -> act (take len str') sc (\sc' -> go inp' sc')++-- NB. we add a final \n to the string, (see comment in the beginning of line+-- production above).+eofHack str = str++"\n"++andBegin  :: Action -> StartCode -> Action+andBegin act new_sc = \str _ cont -> act str new_sc cont++token :: Token -> Action+token t = \_ sc cont -> liftM (t :) (cont sc)++strtoken :: (String -> Token) -> Action+strtoken t = \str sc cont -> liftM (t str :) (cont sc)++begin :: StartCode -> Action+begin sc = \_ _ cont -> cont sc++-- -----------------------------------------------------------------------------+-- Lex a string as a Haskell identifier++ident :: Action+ident str sc cont = liftM (TokIdent str :) (cont sc)+}
+ Distribution/Server/Pages/Package/HaddockParse.y view
@@ -0,0 +1,101 @@+{+-- Disable warnings that the generated code causes+{-# OPTIONS_GHC -fno-warn-deprecated-flags+                -fno-warn-missing-signatures+                -fno-warn-unused-binds+                -fno-warn-unused-matches+                -fno-warn-lazy-unlifted-bindings+                -fno-warn-name-shadowing+                -fno-warn-incomplete-patterns+                -fno-warn-tabs #-}+module Distribution.Server.Pages.Package.HaddockParse (parseHaddockParagraphs) where++import Distribution.Server.Pages.Package.HaddockLex+import Distribution.Server.Pages.Package.HaddockHtml+}++%tokentype { Token }++%token+        '@'     { TokSpecial '@' }+        '['     { TokDefStart }+        ']'     { TokDefEnd }+        DQUO    { TokSpecial '\"' }+        URL     { TokURL $$ }+        PIC     { TokPic $$ }+        ANAME   { TokAName $$ }+        '/../'  { TokEmphasis $$ }+        '-'     { TokBullet }+        '(n)'   { TokNumber }+        '>..'   { TokBirdTrack $$ }+        IDENT   { TokIdent $$ }+        PARA    { TokPara }+        STRING  { TokString $$ }++%monad { Either String }++%name parseHaddockParagraphs  doc+%name parseHaddockString seq++%%++doc     :: { Doc }+        : apara PARA doc        { docAppend $1 $3 }+        | PARA doc              { $2 }+        | apara                 { $1 }+        | {- empty -}           { DocEmpty }++apara   :: { Doc }+        : ulpara                { DocUnorderedList [$1] }+        | olpara                { DocOrderedList [$1] }+        | defpara               { DocDefList [$1] }+        | para                  { $1 }++ulpara  :: { Doc }+        : '-' para              { $2 }++olpara  :: { Doc }+        : '(n)' para            { $2 }++defpara :: { (Doc,Doc) }+        : '[' seq ']' seq       { ($2, $4) }++para    :: { Doc }+        : seq                   { docParagraph $1 }+        | codepara              { DocCodeBlock $1 }++codepara :: { Doc }+        : '>..' codepara        { docAppend (DocString $1) $2 }+        | '>..'                 { DocString $1 }++seq     :: { Doc }+        : elem seq              { docAppend $1 $2 }+        | elem                  { $1 }++elem    :: { Doc }+        : elem1                 { $1 }+        | '@' seq1 '@'          { DocMonospaced $2 }++seq1    :: { Doc }+        : PARA seq1             { docAppend (DocString "\n") $2 }+        | elem1 seq1            { docAppend $1 $2 }+        | elem1                 { $1 }++elem1   :: { Doc }+        : STRING                { DocString $1 }+        | '/../'                { DocEmphasis (DocString $1) }+        | URL                   { DocURL $1 }+        | PIC                   { DocPic $1 }+        | ANAME                 { DocAName $1 }+        | IDENT                 { DocIdentifier $1 }+        | DQUO strings DQUO     { DocModule $2 }++strings  :: { String }+        : STRING                { $1 }+        | STRING strings        { $1 ++ $2 }++{+happyError :: [Token] -> Either String a+happyError toks =+  Left ("parse error in doc string: "  ++ show (take 3 toks))+}
+ Distribution/Server/Pages/Recent.hs view
@@ -0,0 +1,121 @@+-- Takes a reversed log file on the standard input and outputs web page.++module Distribution.Server.Pages.Recent (+    recentPage,+    recentFeed,+  ) where++import Distribution.Server.Packages.Types+import qualified Distribution.Server.Users.Users as Users+import Distribution.Server.Users.Users (Users)+import Distribution.Server.Pages.Template+         ( hackagePageWithHead )++import Distribution.Package+         ( PackageIdentifier, packageName, packageVersion, PackageName(..) )+import Distribution.PackageDescription+         ( GenericPackageDescription(packageDescription)+         , PackageDescription(synopsis)  )+import Distribution.Text+         ( display )++import qualified Text.XHtml.Strict as XHtml+import Text.XHtml+         ( Html, URL, (<<), (!) )+import qualified Text.RSS as RSS+import Text.RSS+         ( RSS(RSS) )+import Network.URI+         ( URI(..), uriToString )+import Data.Time.Clock+         ( UTCTime )+import Data.Time.Format+         ( formatTime )+import System.Locale+         ( defaultTimeLocale )+++-- | Takes a list of package info, in reverse order by timestamp.+--+recentPage :: Users -> [PkgInfo] -> Html+recentPage users pkgs =+  let log_rows = map (makeRow users) (take 20 pkgs)+      docBody = [XHtml.h2 << "Recent additions",+          XHtml.table ! [XHtml.align "center"] << log_rows]+      rss_link = XHtml.thelink ! [XHtml.rel "alternate",+                                  XHtml.thetype "application/rss+xml",+                                  XHtml.title "Hackage RSS Feed",+                                  XHtml.href rssFeedURL] << XHtml.noHtml+   in hackagePageWithHead [rss_link] "recent additions" docBody++makeRow :: Users -> PkgInfo -> Html+makeRow users PkgInfo {+      pkgInfoId = pkgid+    , pkgUploadData = (time, userId)+  } =+  XHtml.tr <<+    [XHtml.td ! [XHtml.align "right"] <<+            [XHtml.toHtml (showTime time), nbsp, nbsp],+     XHtml.td ! [XHtml.align "left"] << display user,+     XHtml.td ! [XHtml.align "left"] <<+            [nbsp, nbsp, XHtml.anchor !+                           [XHtml.href (packageURL pkgid)] << display pkgid]]+  where nbsp = XHtml.primHtmlChar "nbsp"+        user = Users.userIdToName users userId++showTime :: UTCTime -> String+showTime = formatTime defaultTimeLocale "%c"++-- | URL describing a package.+packageURL :: PackageIdentifier -> URL+packageURL pkgid = "/package/" ++ display pkgid++rssFeedURL :: URL+rssFeedURL = "/recent.rss"++recentAdditionsURL :: URL+recentAdditionsURL = "/recent.html"++recentFeed :: Users -> URI -> UTCTime -> [PkgInfo] -> RSS+recentFeed users hostURI now pkgs = RSS+  "Recent additions"+  (hostURI { uriPath = recentAdditionsURL})+  desc+  (channel now)+  [ releaseItem users hostURI pkg | pkg <- take 20 pkgs ]+  where+    desc = "The 20 most recent additions to Hackage, the Haskell package database."++channel :: UTCTime -> [RSS.ChannelElem]+channel now =+  [ RSS.Language "en"+  , RSS.ManagingEditor email+  , RSS.WebMaster email+  , RSS.ChannelPubDate now+  , RSS.LastBuildDate   now+  , RSS.Generator "rss-feed"+  ]+  where+    email = "duncan@haskell.org (Duncan Coutts)"++releaseItem :: Users -> URI -> PkgInfo -> [RSS.ItemElem]+releaseItem users hostURI pkgInfo@(PkgInfo {+      pkgInfoId = pkgId+    , pkgUploadData = (time, userId)+  }) =+  [ RSS.Title title+  , RSS.Link uri+  , RSS.Guid True (uriToString id uri "")+  , RSS.PubDate time+  , RSS.Description desc+  ]+  where+    uri   = hostURI { uriPath = packageURL pkgId }+    title = unPackageName (packageName pkgId) ++ " " ++ display (packageVersion pkgId)+    body  = synopsis (packageDescription (pkgDesc pkgInfo))+    desc  = "<i>Added by " ++ display user ++ ", " ++ showTime time ++ ".</i>"+         ++ if null body then "" else "<p>" ++ body+    user = Users.userIdToName users userId++unPackageName :: PackageName -> String+unPackageName (PackageName name) = name
+ Distribution/Server/Pages/Template.hs view
@@ -0,0 +1,82 @@+-- Common wrapper for HTML pages+module Distribution.Server.Pages.Template+    ( hackagePage+    , hackagePageWith+    , hackagePageWithHead+    ) where++import Text.XHtml.Strict++--TODO: replace all this with external templates++-- | Create top-level HTML document by wrapping the Html with boilerplate.+hackagePage :: String -> [Html] -> Html+hackagePage = hackagePageWithHead []++hackagePageWithHead :: [Html] -> String -> [Html] -> Html+hackagePageWithHead headExtra docTitle docContent =+    hackagePageWith headExtra docTitle docSubtitle docContent bodyExtra+  where+    docSubtitle = anchor ! [href introductionURL] << "Hackage :: [Package]"+    bodyExtra   = []++hackagePageWith :: [Html] -> String -> Html -> [Html] -> [Html] -> Html+hackagePageWith headExtra docTitle docSubtitle docContent bodyExtra =+    toHtml [ header << (docHead ++ headExtra)+           , body   << (docBody ++ bodyExtra) ]+  where+    docHead   = [ thetitle << ("Hackage: " ++ docTitle)+                , thelink ! [ rel "stylesheet"+                            , href stylesheetURL+                            , thetype "text/css"] << noHtml+                -- if Search is enabled+                , thelink ! [ rel "search", href "/packages/opensearch.xml"+                            , thetype "application/opensearchdescription+xml"+                            , title "Hackage" ] << noHtml+                ]+    docBody   = [ thediv ! [identifier "page-header"] << docHeader+                , thediv ! [identifier "content"] << docContent ]+    docHeader = [ navigationBar+                , paragraph ! [theclass "caption"] << docSubtitle ]++navigationBar :: Html+navigationBar =+    ulist ! [theclass "links", identifier "page-menu"]+      <<  map (li <<)+          [ anchor ! [href introductionURL] << "Home"+          , form   ! [action "/packages/search", theclass "search", method "get"]+                  << [ button ! [thetype "submit"] << "Search", spaceHtml+                     , input  ! [thetype "text", name "terms" ] ]+          , anchor ! [href pkgListURL] << "Browse"+          , anchor ! [href recentAdditionsURL] << "What's new"+          , anchor ! [href uploadURL]   << "Upload"+          , anchor ! [href accountsURL] << "User accounts"+          ]++stylesheetURL :: URL+stylesheetURL = "/static/hackage.css"++-- URL of the package list+pkgListURL :: URL+pkgListURL = "/packages/"++-- URL of the upload form+introductionURL :: URL+introductionURL = "/"++-- URL of the upload form+uploadURL :: URL+uploadURL = "/upload"++-- URL about user accounts, including the form to change passwords+accountsURL :: URL+accountsURL = "/accounts"++-- URL of the admin front end+adminURL :: URL+adminURL = "/admin"++-- URL of the list of recent additions to the database+recentAdditionsURL :: URL+recentAdditionsURL = "/recent"+
+ Distribution/Server/Pages/Util.hs view
@@ -0,0 +1,30 @@++module Distribution.Server.Pages.Util+    ( hackageNotFound+    , hackageError++    , makeInput+    , makeCheckbox+    ) where++import Distribution.Server.Pages.Template (hackagePage)++import Text.XHtml.Strict++hackageNotFound :: HTML a => a -> Html+hackageNotFound contents+    = hackagePage "Not Found" [toHtml contents]++hackageError :: HTML a => a -> Html+hackageError contents+    = hackagePage "Error" [toHtml contents]++makeInput :: [HtmlAttr] -> String -> String -> [Html]+makeInput attrs fname labelName = [label ! [thefor fname] << labelName,+                                   input ! (attrs ++ [name fname, identifier fname])]++makeCheckbox :: Bool -> String -> String -> String -> [Html]+makeCheckbox isChecked fname fvalue labelName = [input ! ([thetype "checkbox", name fname, identifier fname, value fvalue]+                                                 ++ if isChecked then [checked] else []),+                                        toHtml " ",+                                        label ! [thefor fname] << labelName]
+ Distribution/Server/Users/Backup.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}+module Distribution.Server.Users.Backup (+    -- Importing user data+    userBackup,+    importGroup,+    groupBackup,+    -- Exporting user data+    usersToCSV,+    groupToCSV+  ) where++import qualified Distribution.Server.Users.Users as Users+import Distribution.Server.Users.Users (Users)+import Distribution.Server.Users.Group (UserList(..))+import qualified Distribution.Server.Users.Group as Group+import Distribution.Server.Users.Types++import Distribution.Server.Framework.BackupRestore+import Distribution.Text (display)+import Data.Version+import Text.CSV (CSV, Record)+import qualified Data.IntSet as IntSet++-- Import for the user database+userBackup :: RestoreBackup Users+userBackup = updateUserBackup Users.emptyUsers++updateUserBackup :: Users -> RestoreBackup Users+updateUserBackup users = RestoreBackup {+    restoreEntry = \entry -> case entry of+      BackupByteString ["users.csv"] bs -> do+        csv <- importCSV "users.csv" bs+        users' <- importAuth csv users+        return (updateUserBackup users')+      _ ->+        return (updateUserBackup users)+  , restoreFinalize =+     return users+  }++importAuth :: CSV -> Users -> Restore Users+importAuth = concatM . map fromRecord . drop 2+  where+    fromRecord :: Record -> Users -> Restore Users+    fromRecord [idStr, nameStr, "enabled", auth] users = do+        uid   <- parseText "user id"   idStr+        uname <- parseText "user name" nameStr+        let uauth = UserAuth (PasswdHash auth)+        insertUser users uid $ UserInfo uname (AccountEnabled uauth)+    fromRecord [idStr, nameStr, "disabled", auth] users = do+        uid   <- parseText "user id"   idStr+        uname <- parseText "user name" nameStr+        let uauth | null auth = Nothing+                  | otherwise = Just (UserAuth (PasswdHash auth))+        insertUser users uid $ UserInfo uname (AccountDisabled uauth)+    fromRecord [idStr, nameStr, "deleted", ""] users = do+        uid   <- parseText "user id"   idStr+        uname <- parseText "user name" nameStr+        insertUser users uid $ UserInfo uname AccountDeleted++    fromRecord x _ = fail $ "Error processing auth record: " ++ show x++insertUser :: Users -> UserId -> UserInfo -> Restore Users+insertUser users uid uinfo =+    case Users.insertUserAccount uid uinfo users of+        Left (Left Users.ErrUserIdClash)    -> fail $ "duplicate user id " ++ display uid+        Left (Right Users.ErrUserNameClash) -> fail $ "duplicate user name " ++ display (userName uinfo)+        Right users'                        -> return users'++-- Import for a single group+groupBackup :: [FilePath] -> RestoreBackup UserList+groupBackup csvPath = updateGroupBackup Group.empty+  where+    updateGroupBackup group = RestoreBackup {+        restoreEntry = \entry -> case entry of+          BackupByteString path bs | path == csvPath -> do+            csv    <- importCSV (last path) bs+            group' <- importGroup csv+            -- TODO: we just discard "group" here. Is that right?+            return (updateGroupBackup group')+          _ ->+            return (updateGroupBackup group)+      , restoreFinalize =+          return group+      }++-- parses a rather lax format. Any layout of integer ids separated by commas.+importGroup :: CSV -> Restore UserList+importGroup csv = do+    parsed <- mapM parseUserId (concat $ clean csv)+    return . UserList . IntSet.fromList $ parsed+  where+    clean xs = if all null xs then [] else xs+    parseUserId uid = case reads uid of+        [(num, "")] -> return num+        _ -> fail $ "Unable to parse user id : " ++ show uid++-------------------------------------------------- Exporting+-- group.csv+groupToCSV :: UserList -> CSV+groupToCSV (UserList list) = [map show (IntSet.toList list)]++-- auth.csv+{- | Produces a CSV file for the users DB.+   .+   Format:+   .+   User Id,User name,(enabled|disabled|deleted),pwd-hash+ -}+-- have a "safe" argument to this function that doesn't export password hashes?+usersToCSV :: Users -> CSV+usersToCSV users+    = ([showVersion userCSVVer]:) $+      (usersCSVKey:) $++      flip map (Users.enumerateAllUsers users) $ \(uid, uinfo) ->+      [ display uid+      , display (userName uinfo)+      , infoToStatus uinfo+      , infoToAuth uinfo+      ]++ where+    usersCSVKey =+       [ "uid"+       , "name"+       , "status"+       , "auth-info"+       ]+    userCSVVer = Version [0,2] []++    -- one of "enabled" "disabled" or "deleted"+    infoToStatus :: UserInfo -> String+    infoToStatus userInfo = case userStatus userInfo of+        AccountEnabled  _ -> "enabled"+        AccountDisabled _ -> "disabled"+        AccountDeleted    -> "deleted"++    -- may be null+    infoToAuth :: UserInfo -> String+    infoToAuth userInfo = case userStatus userInfo of+        AccountEnabled        (UserAuth (PasswdHash hash))  -> hash+        AccountDisabled (Just (UserAuth (PasswdHash hash))) -> hash+        _                                                   -> ""+
+ Distribution/Server/Users/Group.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ExistentialQuantification #-}+module Distribution.Server.Users.Group (+    UserList(..),+    UserGroup(..),+    GroupDescription(..),+    nullDescription,+    groupName,+    empty,+    add,+    remove,+    member,+    enumerate,+    fromList,+    unions,+    queryGroups+  ) where++import Distribution.Server.Users.Types+import Distribution.Server.Framework.MemSize++import qualified Data.IntSet as IntSet+import Data.Monoid (Monoid)+import Data.SafeCopy (SafeCopy(..), contain)+import Data.Serialize (Serialize)+import qualified Data.Serialize as Serialize+import Data.Typeable (Typeable)+import Control.DeepSeq++import Prelude hiding (id)++-- | Some subset of users, eg those allowed to perform some action.+--+newtype UserList = UserList IntSet.IntSet+  deriving (Eq, Monoid, Serialize, Typeable, Show, MemSize)++instance SafeCopy UserList where+  putCopy = contain . Serialize.put+  getCopy = contain Serialize.get++empty :: UserList+empty = UserList IntSet.empty++add :: UserId -> UserList -> UserList+add (UserId id) (UserList group) = UserList (IntSet.insert id group)++remove :: UserId -> UserList -> UserList+remove (UserId id) (UserList group) = UserList (IntSet.delete id group)++member :: UserId -> UserList -> Bool+member (UserId id) (UserList group) = IntSet.member id group++enumerate :: UserList -> [UserId]+enumerate (UserList group) = map UserId (IntSet.toList group)++fromList :: [UserId] -> UserList+fromList ids = UserList $ IntSet.fromList (map (\(UserId uid) -> uid) ids)++unions :: [UserList] -> UserList+unions groups = UserList (IntSet.unions [ group | UserList group <- groups ])++-- | An abstraction over a UserList for dynamically querying and modifying+-- a user group.+--+-- This structure is not only meant for singleton user groups, but also collections+-- of groups. Some features may provide a UserGroup parametrized by an argument.+--+data UserGroup = UserGroup {+    -- a description of the group for display+    groupDesc :: GroupDescription,+    -- dynamic querying for its members+    queryUserList :: IO UserList,+    -- dynamically add a member (does nothing if already exists)+    -- creates the group if it didn't exist previously+    addUserList :: UserId -> IO (),+    -- dynamically remove a member (does nothing if not present)+    -- creates the group if it didn't exist previously+    removeUserList :: UserId -> IO (),+    -- user groups which can remove from one+    canRemoveGroup :: [UserGroup],+    -- user groups which can add to this one  (use 'fix' to add to self)+    canAddGroup :: [UserGroup]+}++-- | A displayable description for a user group.+--+-- Given a groupTitle of A and a group entity of Nothing, the group will be+-- called "A"; given a groupTitle  of "A" and a groupEntity of Just ("B",+-- Just "C"), the title will be displayed as "A for <a href=C>B</a>".+data GroupDescription = GroupDescription {+    groupTitle :: String,+    groupEntity :: Maybe (String, Maybe String),+    groupPrologue  :: String+}++nullDescription :: GroupDescription+nullDescription = GroupDescription { groupTitle = "", groupEntity = Nothing, groupPrologue = "" }++groupName :: GroupDescription -> String+groupName desc = groupTitle desc ++ maybe "" (\(for, _) -> " for " ++ for) (groupEntity desc)++queryGroups :: [UserGroup] -> IO UserList+queryGroups = fmap unions . mapM queryUserList++-- for use in Caches, really...+instance NFData GroupDescription where+    rnf (GroupDescription a b c) = rnf a `seq` rnf b `seq` rnf c++instance MemSize GroupDescription where+    memSize (GroupDescription a b c) = memSize3 a b c
+ Distribution/Server/Users/State.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell,+             FlexibleInstances, FlexibleContexts, MultiParamTypeClasses,+             TypeOperators, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Distribution.Server.Users.State where++import Distribution.Server.Framework.Instances ()+import Distribution.Server.Framework.MemSize++import Distribution.Server.Users.Types+import Distribution.Server.Users.Group as Group (UserList(..), add, remove, empty)+import Distribution.Server.Users.Users as Users++import Data.Acid     (Query, Update, makeAcidic)+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Typeable (Typeable)++import Control.Monad.Reader+import qualified Control.Monad.State as State++initialUsers :: Users+initialUsers = Users.emptyUsers++--------------------------------------------++-- Returns 'Nothing' if the user name is in use+addUserEnabled :: UserName -> UserAuth -> Update Users (Either Users.ErrUserNameClash UserId)+addUserEnabled uname auth =+  updateUsers $ Users.addUserEnabled uname auth++addUserDisabled :: UserName -> Update Users (Either Users.ErrUserNameClash UserId)+addUserDisabled uname =+  updateUsers $ Users.addUserDisabled uname++-- Enables or disables the indicated user's account+setUserEnabledStatus :: UserId -> Bool -> Update Users (Maybe (Either ErrNoSuchUserId ErrDeletedUser))+setUserEnabledStatus uid en =+  updateUsers_ $ Users.setUserEnabledStatus uid en++-- Deletes the indicated user. Cannot be re-enabled. The associated+-- user name is available for re-use+deleteUser :: UserId -> Update Users (Maybe ErrNoSuchUserId)+deleteUser uid =+  updateUsers_ $ Users.deleteUser uid++-- Set the user autenication info+setUserAuth :: UserId -> UserAuth -> Update Users (Maybe (Either ErrNoSuchUserId ErrDeletedUser))+setUserAuth userId auth =+  updateUsers_ $ Users.setUserAuth userId auth++setUserName :: UserId -> UserName -> Update Users (Maybe (Either ErrNoSuchUserId ErrUserNameClash))+setUserName uid uname =+  updateUsers_ $ Users.setUserName uid uname++-- updates the user db with a simpler function+updateUsers_ :: (Users -> Either err Users) -> Update Users (Maybe err)+updateUsers_ upd = do+  users <- State.get+  case upd users of+    Left err     -> return (Just err)+    Right users' -> do State.put users'+                       return Nothing++-- Helper function for updating the users db+updateUsers :: (Users -> Either err (Users, a)) -> Update Users (Either err a)+updateUsers upd = do+  users <- State.get+  case upd users of+    Left err         -> return (Left err)+    Right (users',a) -> do State.put users'+                           return (Right a)++getUserDb :: Query Users Users+getUserDb = ask++replaceUserDb :: Users -> Update Users ()+replaceUserDb = State.put++$(makeAcidic ''Users ['addUserEnabled+                     ,'addUserDisabled+                     ,'setUserEnabledStatus+                     ,'setUserAuth+                     ,'setUserName+                     ,'deleteUser+                     ,'getUserDb+                     ,'replaceUserDb+                     ])++-----------------------------------------------------++data HackageAdmins = HackageAdmins {+    adminList :: !Group.UserList+} deriving (Typeable, Eq, Show)++$(deriveSafeCopy 0 'base ''HackageAdmins)++instance MemSize HackageAdmins where+    memSize (HackageAdmins a) = memSize1 a++getHackageAdmins :: Query HackageAdmins HackageAdmins+getHackageAdmins = ask++getAdminList :: Query HackageAdmins UserList+getAdminList = asks adminList++modifyHackageAdmins :: (UserList -> UserList) -> Update HackageAdmins ()+modifyHackageAdmins func = State.modify (\users -> users { adminList = func (adminList users) })++addHackageAdmin :: UserId -> Update HackageAdmins ()+addHackageAdmin uid = modifyHackageAdmins (Group.add uid)++removeHackageAdmin :: UserId -> Update HackageAdmins ()+removeHackageAdmin uid = modifyHackageAdmins (Group.remove uid)++replaceHackageAdmins :: UserList -> Update HackageAdmins ()+replaceHackageAdmins ulist = modifyHackageAdmins (const ulist)++initialHackageAdmins :: HackageAdmins+initialHackageAdmins = HackageAdmins Group.empty++$(makeAcidic ''HackageAdmins+                 ['getHackageAdmins+                 ,'getAdminList+                 ,'addHackageAdmin+                 ,'removeHackageAdmin+                 ,'replaceHackageAdmins])++--------------------------------------------------------------------------+data MirrorClients = MirrorClients {+    mirrorClients :: !Group.UserList+} deriving (Eq, Typeable, Show)++$(deriveSafeCopy 0 'base ''MirrorClients)++instance MemSize MirrorClients where+    memSize (MirrorClients a) = memSize1 a++getMirrorClients :: Query MirrorClients MirrorClients+getMirrorClients = ask++getMirrorClientsList :: Query MirrorClients UserList+getMirrorClientsList = asks mirrorClients++modifyMirrorClients :: (UserList -> UserList) -> Update MirrorClients ()+modifyMirrorClients func = State.modify (\users -> users { mirrorClients = func (mirrorClients users) })++addMirrorClient :: UserId -> Update MirrorClients ()+addMirrorClient uid = modifyMirrorClients (Group.add uid)++removeMirrorClient :: UserId -> Update MirrorClients ()+removeMirrorClient uid = modifyMirrorClients (Group.remove uid)++replaceMirrorClients :: UserList -> Update MirrorClients ()+replaceMirrorClients ulist = modifyMirrorClients (const ulist)++initialMirrorClients :: MirrorClients+initialMirrorClients = MirrorClients Group.empty++$(makeAcidic ''MirrorClients+                    ['getMirrorClients+                    ,'getMirrorClientsList+                    ,'addMirrorClient+                    ,'removeMirrorClient+                    ,'replaceMirrorClients])+
+ Distribution/Server/Users/Types.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-}+module Distribution.Server.Users.Types (+    module Distribution.Server.Users.Types,+    module Distribution.Server.Framework.AuthTypes+  ) where++import Distribution.Server.Framework.AuthTypes+import Distribution.Server.Framework.MemSize++import Distribution.Text+         ( Text(..) )+import qualified Distribution.Server.Util.Parse as Parse+import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint          as Disp+import qualified Data.Char as Char++import Data.Serialize (Serialize)+import Control.Applicative ((<$>))++import Data.SafeCopy (base, deriveSafeCopy)+import Data.Typeable (Typeable)++newtype UserId = UserId Int+  deriving (Eq, Ord, Show, Serialize, Typeable, MemSize)++newtype UserName  = UserName String+  deriving (Eq, Ord, Show, Serialize, Typeable, MemSize)++data UserInfo = UserInfo {+                  userName   :: !UserName,+                  userStatus :: !UserStatus+                } deriving (Eq, Show, Typeable)++data UserStatus = AccountEnabled  UserAuth+                | AccountDisabled (Maybe UserAuth)+                | AccountDeleted+    deriving (Eq, Show, Typeable)++newtype UserAuth = UserAuth PasswdHash+    deriving (Show, Eq, Typeable)++isActiveAccount :: UserStatus -> Bool+isActiveAccount (AccountEnabled  _) = True+isActiveAccount (AccountDisabled _) = True+isActiveAccount  AccountDeleted     = False++instance MemSize UserInfo where+    memSize (UserInfo a b) = memSize2 a b++instance MemSize UserStatus where+    memSize (AccountEnabled  a) = memSize1 a+    memSize (AccountDisabled a) = memSize1 a+    memSize (AccountDeleted)    = memSize0++instance MemSize UserAuth where+    memSize (UserAuth a) = memSize1 a+++instance Text UserId where+    disp (UserId uid) = Disp.int uid+    parse = UserId <$> Parse.int++instance Text UserName where+    disp (UserName name) = Disp.text name+    parse = UserName <$> Parse.munch1 Char.isAlphaNum+++$(deriveSafeCopy 0 'base ''UserId)+$(deriveSafeCopy 0 'base ''UserName)+$(deriveSafeCopy 1 'base ''UserAuth)+$(deriveSafeCopy 0 'base ''UserStatus)+$(deriveSafeCopy 0 'base ''UserInfo)
+ Distribution/Server/Users/Users.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell, NamedFieldPuns #-}+module Distribution.Server.Users.Users (+    -- * Users type+    Users,++    -- * Construction+    emptyUsers,+    addUserEnabled,+    addUserDisabled,+    addUser,+    insertUserAccount,++    -- * Modification+    deleteUser,+    setUserEnabledStatus,+    setUserAuth,+    setUserName,++    -- * Lookup+    lookupUserId,+    lookupUserName,++    -- ** Lookup utils+    userIdToName,++    -- * Enumeration+    enumerateAllUsers,+    enumerateActiveUsers,++    -- * Error codes+    ErrUserNameClash(..),+    ErrUserIdClash(..),+    ErrNoSuchUserId(..),+    ErrDeletedUser(..),+  ) where++import Distribution.Server.Users.Types++import Distribution.Server.Framework.Instances ()+import Distribution.Server.Framework.MemSize++import Control.Monad (guard)+import Control.Monad.Error (Error(..))+import Data.Maybe (fromMaybe)+import Data.List  (sort, group)+import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import Data.SafeCopy (base, deriveSafeCopy)+import Data.Typeable (Typeable)+import Control.Exception (assert)+++-- | The entrie collection of users. Manages the mapping between 'UserName'+-- and 'UserId'.+--+data Users = Users {+    -- | A map from UserId to UserInfo+    userIdMap   :: !(IntMap.IntMap UserInfo),+    -- | A map from active UserNames to the UserId for that name+    userNameMap :: !(Map.Map UserName UserId),+    -- | The next available UserId+    nextId      :: !UserId+  }+  deriving (Eq, Typeable, Show)++instance MemSize Users where+  memSize (Users a b c) = memSize3 a b c++$(deriveSafeCopy 0 'base ''Users)++checkinvariant :: Users -> Users+checkinvariant users = assert (invariant users) users ++invariant :: Users -> Bool+invariant Users{userIdMap, userNameMap, nextId} =+      nextIdIsRight+   && noUserNameOverlap+   && userNameMapComplete+   && userNameMapConsistent+  where+    nextIdIsRight =+      --  1) the next id should be 0 if the userIdMap is empty+      --     or one bigger than the maximum allocated id+      let UserId nextid = nextId+       in nextid == case IntMap.maxViewWithKey userIdMap of+                      Nothing                     -> 0+                      Just ((maxAllocatedId,_),_) -> maxAllocatedId + 1++    noUserNameOverlap =+      --  2) there must be no overlap in the user names of active accounts+      --     (active are enabled or disabled but not deleted)+          all (\g -> length g == 1)+        . group . sort+        . map userName . filter (isActiveAccount . userStatus)+        . IntMap.elems+        $ userIdMap++    userNameMapComplete =+      -- 3) the userNameMap must map every active user name to the id of the+      --    corresponding user info+          Map.keys userNameMap+       == sort [ userName uinfo+               | uinfo <- IntMap.elems userIdMap+               , isActiveAccount (userStatus uinfo)]++    userNameMapConsistent =+      and [ case IntMap.lookup uid userIdMap of+              Nothing    -> False+              Just uinfo -> userName uinfo == uname+          | (uname, UserId uid) <- Map.toList userNameMap ]++  -- the point is, user names can be recycled but user ids never are+  -- this simplifies things because other user groups in the system do not+  -- need to be adjusted when an account is enabled/disabled/deleted+  -- it also allows us to track historical info, like name of uploader+  -- even if that user name has been recycled, the user ids will be distinct.+++emptyUsers :: Users+emptyUsers = Users {+    userIdMap   = IntMap.empty,+    userNameMap = Map.empty,+    nextId      = UserId 0+  }++-- error codes+data ErrUserNameClash = ErrUserNameClash deriving Typeable+data ErrUserIdClash   = ErrUserIdClash   deriving Typeable+data ErrNoSuchUserId  = ErrNoSuchUserId  deriving Typeable+data ErrDeletedUser   = ErrDeletedUser   deriving Typeable++instance Error ErrUserNameClash+instance Error ErrUserIdClash+instance Error ErrNoSuchUserId+instance Error ErrDeletedUser++$(deriveSafeCopy 0 'base ''ErrUserNameClash)+$(deriveSafeCopy 0 'base ''ErrUserIdClash)+$(deriveSafeCopy 0 'base ''ErrNoSuchUserId)+$(deriveSafeCopy 0 'base ''ErrDeletedUser)++(?!) :: Maybe a -> e -> Either e a+ma ?! e = maybe (Left e) Right ma++++lookupUserId :: UserId -> Users -> Maybe UserInfo+lookupUserId (UserId userId) users = IntMap.lookup userId (userIdMap users)++lookupUserName :: UserName -> Users -> Maybe (UserId, UserInfo)+lookupUserName uname users = do+    case Map.lookup uname (userNameMap users) of+      Nothing  -> Nothing+      Just uid -> Just (uid, fromMaybe impossible (lookupUserId uid users))+  where+    impossible = error "lookupUserName: invariant violation"++-- | Convert a 'UserId' to a 'UserName'. If the user id doesn't exist,+-- an ugly placeholder is used instead.+--+userIdToName :: Users -> UserId -> UserName+userIdToName users userId@(UserId idNum) =+    case lookupUserId userId users of+      Just user -> userName user+      Nothing   -> UserName $ "~id#" ++ show idNum+++-- | Add a new user account, in the enabled state.+--+addUserEnabled :: UserName -> UserAuth -> Users+               -> Either ErrUserNameClash (Users, UserId)+addUserEnabled name auth = addUser name (AccountEnabled auth)++-- | Add a new user account, in the disabled state and with no password.+--+addUserDisabled :: UserName -> Users+                -> Either ErrUserNameClash (Users, UserId)+addUserDisabled name = addUser name (AccountDisabled Nothing)++-- | Add a new user account with the given user status.+--+addUser :: UserName -> UserStatus -> Users -> Either ErrUserNameClash (Users, UserId)+addUser name status users =+  case Map.lookup name (userNameMap users) of+    Just _  -> Left ErrUserNameClash+    Nothing -> users' `seq` Right (users', userid)+      where+        userid@(UserId uid) = nextId users+        uinfo = UserInfo {+          userName   = name,+          userStatus = status+        }+        users' = checkinvariant users {+          userIdMap   = IntMap.insert uid uinfo (userIdMap users),+          userNameMap = Map.insert name userid (userNameMap users),+          nextId      = UserId (uid + 1)+        }++-- | Insert pre-existing user info. This should only be used for constructing+-- a user db manually or from a backup.+--+insertUserAccount :: UserId -> UserInfo -> Users+                  -> Either (Either ErrUserIdClash ErrUserNameClash) Users+insertUserAccount userId@(UserId uid) uinfo users = do+    guard (not userIdInUse)                     ?! Left  ErrUserIdClash+    guard (not userNameInUse || isUserDeleted)  ?! Right ErrUserNameClash+    return $! checkinvariant users {+          userIdMap   = IntMap.insert uid uinfo (userIdMap users),+          userNameMap = if isUserDeleted+                          then userNameMap users+                          else Map.insert (userName uinfo) userId (userNameMap users),+          nextId      = let UserId nextid = nextId users+                        in UserId (max nextid (uid + 1))+        }+  where+    userIdInUse   = IntMap.member uid (userIdMap users)+    userNameInUse = Map.member (userName uinfo) (userNameMap users)+    isUserDeleted = case userStatus uinfo of+                      AccountDeleted -> True+                      _              -> False+++-- | Delete a user account.+--+-- Prevents the given user from performing authenticated operations.+-- This operation is idempotent but not reversible. Deleting an account forgets+-- any authentication credentials and the user name becomes available for+-- re-use in a new account.+--+-- Unlike 'UserName's, 'UserId's are never actually deleted or re-used. This is+-- what distinguishes disabling and deleting an account; a disabled account can+-- be enabled again and a disabled account does not release the user name for+-- re-use.+--+deleteUser :: UserId -> Users -> Either ErrNoSuchUserId Users+deleteUser (UserId userId) users = do+  userInfo     <- lookupUserId (UserId userId) users ?! ErrNoSuchUserId+  let userInfo' = userInfo { userStatus = AccountDeleted }+  return $! checkinvariant users {+    userIdMap   = IntMap.insert userId userInfo' (userIdMap users),+    userNameMap = Map.delete (userName userInfo) (userNameMap users)+  }++-- | Change the status of a user account to enabled or disabled.+--+-- Prevents the given user from performing any authenticated operations.+-- This operation is idempotent and reversable. Use 'enable' to re-enable a+-- disabled account.+--+-- The disabled state is intended to be temporary. Use 'delete' to permanently+-- delete the account and release the user name to be re-used.+--+setUserEnabledStatus :: UserId -> Bool -> Users -> Either (Either ErrNoSuchUserId ErrDeletedUser) Users+setUserEnabledStatus (UserId uid) enable users = do+    userInfo  <- lookupUserId (UserId uid) users ?! Left  ErrNoSuchUserId+    userInfo' <- changeStatus userInfo           ?! Right ErrDeletedUser+    return $! checkinvariant users {+        userIdMap = IntMap.insert uid userInfo' (userIdMap users)+    }+  where+    changeStatus userInfo | enable = case userStatus userInfo of+        AccountEnabled  _           -> Just userInfo+        AccountDisabled (Just auth) -> Just userInfo { userStatus = AccountEnabled auth }+        AccountDisabled Nothing     -> Nothing+        AccountDeleted              -> Nothing++    changeStatus userInfo          = case userStatus userInfo of+        AccountEnabled  auth       -> Just userInfo { userStatus = AccountDisabled (Just auth) }+        AccountDisabled _          -> Just userInfo+        AccountDeleted             -> Nothing++-- | Replace the user authentication for the given user.+--+setUserAuth :: UserId -> UserAuth -> Users -> Either (Either ErrNoSuchUserId ErrDeletedUser) Users+setUserAuth (UserId uid) newauth users = do+    userInfo  <- lookupUserId (UserId uid) users ?! Left  ErrNoSuchUserId+    userInfo' <- changeAuth userInfo             ?! Right ErrDeletedUser+    return $! checkinvariant users {+      userIdMap = IntMap.insert uid userInfo' (userIdMap users)+    }+  where+    changeAuth userInfo = case userStatus userInfo of+        AccountEnabled  _oldauth -> Just $ userInfo { userStatus = AccountEnabled newauth }+        AccountDisabled _oldauth -> Just $ userInfo { userStatus = AccountDisabled (Just newauth) }+        AccountDeleted           -> Nothing++-- | Change the username for a user account. The new name must not be in use.+--+setUserName :: UserId -> UserName -> Users+            -> Either (Either ErrNoSuchUserId ErrUserNameClash) Users+setUserName (UserId uid) newname users = do+    userinfo  <- lookupUserId (UserId uid) users ?! Left  ErrNoSuchUserId+    guard (not (userNameInUse newname))          ?! Right ErrUserNameClash+    let oldname   = userName userinfo+        userinfo' = userinfo { userName = newname }+    return $! checkinvariant users {+      userIdMap   = IntMap.insert uid userinfo' (userIdMap users),+      userNameMap = Map.insert newname (UserId uid) . Map.delete oldname $ userNameMap users+    }+  where+    userNameInUse uname = Map.member uname (userNameMap users)++enumerateAllUsers :: Users -> [(UserId, UserInfo)]+enumerateAllUsers users =+    [ (UserId uid, uinfo) | (uid, uinfo) <- IntMap.assocs (userIdMap users) ]++enumerateActiveUsers :: Users -> [(UserId, UserInfo)]+enumerateActiveUsers users =+    [ (UserId uid, uinfo) | (uid, uinfo) <- IntMap.assocs (userIdMap users)+                          , isActiveAccount (userStatus uinfo) ]+
+ Distribution/Server/Util/CountingMap.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, DeriveDataTypeable, ScopedTypeVariables #-}+module Distribution.Server.Util.CountingMap (+    NestedCountingMap(..)+  , SimpleCountingMap(..)+  , CountingMap(..)+  , cmFromCSV+  ) where++import Prelude hiding (rem)++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Typeable (Typeable)+import Text.CSV (CSV, Record)+import Control.Applicative ((<$>), (<*>))++import Data.SafeCopy (SafeCopy(..), safeGet, safePut, contain)++import Distribution.Text (Text(..), display)++import Distribution.Server.Framework.Instances ()+import Distribution.Server.Framework.MemSize+import Distribution.Server.Framework.BackupRestore (parseRead, parseText)++{------------------------------------------------------------------------------+  We define some generic machinery to give us functions for arbitrarily+  nested "counting maps".++  We define SimpleCountingMap as a separate type from NestedCountingMap as+  a hint to the type checker (we get into trouble with the functional+  dependencies otherwise).+------------------------------------------------------------------------------}++data NestedCountingMap a b = NCM {+    nestedTotalCount  :: Int+  , nestedCountingMap :: Map a b+  }+  deriving (Show, Eq, Typeable)++newtype SimpleCountingMap a = SCM {+    simpleCountingMap :: NestedCountingMap a Int+  }+  deriving (Show, Eq, Typeable)++class CountingMap k a | a -> k where+  cmEmpty  :: a+  cmTotal  :: a -> Int+  cmInsert :: k -> Int -> a -> a+  cmFind   :: k -> a -> Int+  cmToList :: a -> [(k, Int)]++  cmToCSV        :: a -> CSV+  cmInsertRecord :: Monad m => Record -> a -> m (a, Int)++instance (Ord k, Text k) => CountingMap k (SimpleCountingMap k) where+  cmEmpty = SCM (NCM 0 Map.empty)++  cmTotal (SCM (NCM total _)) = total++  cmInsert k n (SCM (NCM total m)) =+    SCM (NCM (total + n) (adjustFrom (+ n) k 0 m))++  cmFind k (SCM (NCM _ m)) = Map.findWithDefault 0 k m++  cmToList (SCM (NCM _ m)) = Map.toList m++  cmToCSV (SCM (NCM _ m)) = map aux (Map.toList m)+    where+      aux :: (k, Int) -> Record+      aux (k, n) = [display k, show n]++  cmInsertRecord [k, n] m = do+     key   <- parseText "key"   k+     count <- parseRead "count" n+     return (cmInsert key count m, count)+  cmInsertRecord _ _ =+    fail "cmInsertRecord: Invalid record"++instance (Text k, Ord k, Eq l, CountingMap l a) => CountingMap (k, l) (NestedCountingMap k a) where+  cmEmpty = NCM 0 Map.empty++  cmTotal (NCM total _m) = total++  cmInsert (k, l) n (NCM total m) =+    NCM (total + n) (adjustFrom (cmInsert l n) k cmEmpty m)++  cmFind (k, l) (NCM _ m) = cmFind l (Map.findWithDefault cmEmpty k m)++  cmToList (NCM _ m) = concatMap aux (Map.toList m)+    where+      aux :: (k, a) -> [((k, l), Int)]+      aux (k, m') = map (\(l, c) -> ((k, l), c)) (cmToList m')++  cmToCSV (NCM _ m) = concatMap aux (Map.toList m)+    where+      aux :: (k, a) -> CSV+      aux (k, m') = map (display k:) (cmToCSV m')++  cmInsertRecord (k : record) (NCM total m) = do+    key <- parseText "key" k+    let submap = Map.findWithDefault cmEmpty key m+    (submap', added) <- cmInsertRecord record submap+    return (NCM (total + added) (Map.insert key submap' m), added)+  cmInsertRecord [] _ =+    fail "cmInsertRecord: Invalid record"++cmFromCSV :: (Monad m, CountingMap k a) => CSV -> m a+cmFromCSV = go cmEmpty+  where+    go acc []     = return acc+    go acc (r:rs) = do+      (acc', _) <- cmInsertRecord r acc+      go acc' rs++{------------------------------------------------------------------------------+  Auxiliary+------------------------------------------------------------------------------}++adjustFrom :: Ord k => (a -> a) -> k -> a -> Map k a -> Map k a+adjustFrom func key value = Map.alter (Just . func . fromMaybe value) key++{------------------------------------------------------------------------------+  Type classes instances+------------------------------------------------------------------------------}++instance MemSize a => MemSize (SimpleCountingMap a) where+  memSize (SCM m) = memSize m++instance (MemSize a, MemSize b) => MemSize (NestedCountingMap a b) where+  memSize (NCM a b) = memSize2 a b++instance (Ord a, SafeCopy a, SafeCopy b) => SafeCopy (NestedCountingMap a b) where+  putCopy (NCM total m) = contain $ do safePut total ; safePut m+  getCopy = contain $ NCM <$> safeGet <*> safeGet++instance (Ord a, SafeCopy a) => SafeCopy (SimpleCountingMap a) where+  putCopy (SCM m) = contain $ safePut m+  getCopy = contain $ SCM <$> safeGet
+ Distribution/Server/Util/Happstack.hs view
@@ -0,0 +1,95 @@++{-|++Functions and combinators to expose functioanlity buiding+on happstack bit is not really specific to any one area+of Hackage.++-}++module Distribution.Server.Util.Happstack (+    rqRealMethod,+    methodOverrideHack,++    remainingPath,+    remainingPathString,+    mime,+    consumeRequestBody,++    uriEscape+  ) where++import Happstack.Server+import Happstack.Server.Internal.Monads+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Control.Monad.Reader (runReaderT)+import Control.Monad.Trans (MonadIO(..))+import System.FilePath.Posix (takeExtension, (</>))+import Control.Monad (liftM)+import qualified Data.ByteString.Lazy as BS+import qualified Network.URI as URI++import System.IO.Unsafe (unsafePerformIO)+++-- | Allows a hidden '_method' field on a form to override the apparent+-- method of a request. Useful until we can standardise on HTML 5.+methodOverrideHack :: MonadIO m => ServerPartT m a -> ServerPartT m a+methodOverrideHack rest+  = withDataFn (look "_method") $ \mthdStr ->+      let mthd = read mthdStr+      in localRq (\req -> req { rqMethod = mthd }) rest++-- | For use with 'methodOverrideHack': tries to report the original method+-- of a request before the hack was applied.+rqRealMethod :: Request -> Method+rqRealMethod rq = fromMaybe (rqMethod rq) $ unsafePerformIO $ runServerPartT_hack rq $+    withDataFn (liftM (not . null) $ lookInputs "_method") $ \mthd_exists ->+      return $ if mthd_exists then POST else rqMethod rq++runServerPartT_hack :: Monad m => Request -> ServerPartT m a -> m (Maybe a)+runServerPartT_hack rq mx+  = liftM (\res -> case res of+                     Nothing           -> Nothing+                     Just (Left _,  _) -> Nothing+                     Just (Right x, _) -> Just x)+          (ununWebT (runReaderT (unServerPartT mx) rq))+++-- |Passes a list of remaining path segments in the URL. Does not+-- include the query string. This call only fails if the passed in+-- handler fails.+remainingPath :: Monad m => ([String] -> ServerPartT m a) -> ServerPartT m a+remainingPath handle = do+    rq <- askRq+    localRq (\newRq -> newRq{rqPaths=[]}) $ handle (rqPaths rq)++-- | Gets the string without altering the request.+remainingPathString :: Monad m => ServerPartT m String+remainingPathString = do+    strs <- liftM rqPaths askRq+    return $ if null strs then "" else foldr1 (</>) . map uriEscape $ strs++-- This disappeared from happstack in 7.1.7+uriEscape :: String -> String+uriEscape = URI.escapeURIString URI.isAllowedInURI++-- |Returns a mime-type string based on the extension of the passed in+-- file.+mime :: FilePath -> String+mime x  = Map.findWithDefault "text/plain" (drop 1 (takeExtension x)) mimeTypes+++-- | Get the raw body of a PUT or POST request.+--+-- Note that for performance reasons, this consumes the data and it cannot be+-- called twice.+--+consumeRequestBody :: Happstack m => m BS.ByteString+consumeRequestBody = do+    mRq <- takeRequestBody =<< askRq+    case mRq of+      Nothing -> escape $ internalServerError $ toResponse+                   "consumeRequestBody cannot be called more than once."+      Just (Body b) -> return b
+ Distribution/Server/Util/Histogram.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Distribution.Server.Util.Histogram where++import Data.Map (Map)+import qualified Data.Map as Map+import Data.List (delete, sortBy)+import Data.Ord (comparing)+import Control.DeepSeq++import Distribution.Server.Framework.MemSize+++-- | Histograms are intended to keep track of an integer attribute related+-- to a collection of objects.+data Histogram a = Histogram {+    histogram        :: !(Map a Int),+    reverseHistogram :: !(Map Count [a])+}+emptyHistogram :: Histogram a+emptyHistogram = Histogram Map.empty Map.empty++newtype Count = Count Int deriving (Eq, Show, NFData, MemSize)+instance Ord Count where+    compare (Count a) (Count b) = compare b a++instance NFData a => NFData (Histogram a) where+    rnf (Histogram a b) = rnf a `seq` rnf b++instance MemSize a => MemSize (Histogram a) where+    memSize (Histogram a b) = memSize2 a b++topCounts :: Ord a => Histogram a -> [(a, Int)]+topCounts = concatMap (\(Count c, es) -> map (flip (,) c) es) . Map.toList . reverseHistogram++topEntries :: Ord a => Histogram a -> [a]+topEntries = concat . Map.elems . reverseHistogram++getCount :: Ord a => Histogram a -> a -> Int+getCount (Histogram hist _) entry = Map.findWithDefault 0 entry hist++updateHistogram :: Ord a => a -> Int -> Histogram a -> Histogram a+updateHistogram entry new (Histogram hist rev) =+    let old = Map.findWithDefault 0 entry hist+    in Histogram+        (Map.insert entry new hist)+        (Map.alter putInEntry (Count new) . Map.alter takeOutEntry (Count old) $ rev)+  where+    takeOutEntry Nothing = Nothing+    takeOutEntry (Just l) = case delete entry l of+        [] -> Nothing+        l' -> Just l'+    putInEntry Nothing  = Just [entry]+    putInEntry (Just l) = Just (entry:l)++constructHistogram :: Ord a => [(a, Int)] -> Histogram a+constructHistogram assoc = Histogram+    (Map.fromList assoc)+    (Map.fromListWith (++) . map toSingle $ assoc)+  where toSingle (entry, c) = (Count c, [entry])++sortByCounts :: Ord a => (b -> a) -> Histogram a -> [b] -> [(b, Int)]+sortByCounts entryFunc (Histogram hist _) items =+    let modEntry item = (item, Map.findWithDefault 0 (entryFunc item) hist)+    in sortBy (comparing snd) $ map modEntry items+
+ Distribution/Server/Util/Index.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE PatternGuards #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Server.Util.Index+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Extra utils related to the package indexes.+-----------------------------------------------------------------------------+module Distribution.Server.Util.Index (+    read,+    write,+  ) where++import qualified Codec.Archive.Tar       as Tar+         ( read, write, Entries(..) )+import qualified Codec.Archive.Tar.Entry as Tar+         ( Entry(..), entryPath, fileEntry, toTarPath )++import Distribution.Package+import Distribution.Version+import Distribution.Server.Packages.PackageIndex (PackageIndex)+import qualified Distribution.Server.Packages.PackageIndex as PackageIndex+import Distribution.Text+         ( display, simpleParse )++import Data.ByteString.Lazy (ByteString)+import System.FilePath.Posix+         ( (</>), (<.>), splitDirectories, normalise )+import Prelude hiding (read)++-- | Parse an uncompressed tar repository index file from a 'ByteString'.+--+-- Takes a function to turn a tar entry into a package+--+-- This fails only if the tar is corrupted. Any entries not recognized as+-- belonging to a package are ignored.+--+read :: (PackageIdentifier -> Tar.Entry -> pkg)+     -> ByteString+     -> Either String [pkg]+read mkPackage indexFileContent = collect [] entries+  where+    entries = Tar.read indexFileContent+    collect es' Tar.Done        = Right es'+    collect es' (Tar.Next e es) = case entry e of+                       Just e' -> collect (e':es') es+                       Nothing -> collect     es'  es+    collect _   (Tar.Fail err)  = Left (show err)++    entry e+      | [pkgname,versionStr,_] <- splitDirectories (normalise (Tar.entryPath e))+      , Just version <- simpleParse versionStr+      , [] <- versionTags version+      = let pkgid = PackageIdentifier (PackageName pkgname) version+         in Just (mkPackage pkgid e)+    entry _ = Nothing++-- | Create an uncompressed tar repository index file as a 'ByteString'.+--+-- Takes a couple functions to turn a package into a tar entry. Extra+-- entries are also accepted.+--+write :: Package pkg+      => (pkg -> ByteString)+      -> (pkg -> Tar.Entry -> Tar.Entry)+      -> [Tar.Entry]+      -> PackageIndex pkg+      -> ByteString+write externalPackageRep updateEntry extras =+  Tar.write . (extras++) . map entry . PackageIndex.allPackages+  where+    entry pkg = updateEntry pkg+              . Tar.fileEntry tarPath+              $ externalPackageRep pkg+      where+        Right tarPath = Tar.toTarPath False fileName+        PackageName name = packageName pkg+        fileName = name </> display (packageVersion pkg)+                        </> name <.> "cabal"+
+ Distribution/Server/Util/Merge.hs view
@@ -0,0 +1,20 @@+module Distribution.Server.Util.Merge where++import Data.Map+++data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b++mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]+mergeBy cmp = merge+  where+    merge []     ys     = [ OnlyInRight y | y <- ys]+    merge xs     []     = [ OnlyInLeft  x | x <- xs]+    merge (x:xs) (y:ys) =+      case x `cmp` y of+        GT -> OnlyInRight   y : merge (x:xs) ys+        EQ -> InBoth      x y : merge xs     ys+        LT -> OnlyInLeft  x   : merge xs  (y:ys)++mergeMaps :: Ord k => Map k a -> Map k b -> Map k (MergeResult a b)+mergeMaps m1 m2 = unionWith (\(OnlyInLeft a) (OnlyInRight b) -> InBoth a b) (fmap OnlyInLeft m1) (fmap OnlyInRight m2)
+ Distribution/Server/Util/NameIndex.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell,+             FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}+-- TypeOperators, TypeSynonymInstances, TypeFamilies++module Distribution.Server.Util.NameIndex where++import Data.Map (Map)+import Data.Typeable (Typeable)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Char (toLower)+import Data.List (unfoldr, foldl')+import Data.Maybe (maybeToList)+import Control.DeepSeq+import Data.SafeCopy++import Distribution.Server.Framework.MemSize++-- | Case-insensitive name search. This is meant to be an enhanced set of+-- names, not a full text search. It's also meant to be a sort of a short-term+-- solution for name suggestion searches; e.g., package searches should also+-- consider the tagline of a package.+data NameIndex = NameIndex {+    -- | This is the mapping from case-insensitive search term -> name.+    nameIndex :: Map String (Set String),+    -- | This is the set of names.+    storedNamesIndex :: Set String,+    -- | This is the specification of the type of generator, mainly here because+    -- functions can't be serialized. Just str means to break on any char in+    -- str (breakGenerator); Nothing is defaultGenerator.+    nameGenType :: Maybe [Char],+    -- | This is the generator of search terms from names.+    nameSearchGenerator :: String -> [String]+} deriving (Typeable)++emptyNameIndex :: Maybe [Char] -> NameIndex+emptyNameIndex gen = NameIndex Map.empty Set.empty gen $ case gen of+    Nothing -> defaultGenerator+    Just st -> breakGenerator st++defaultGenerator :: String -> [String]+defaultGenerator name = [name]++breakGenerator :: [Char] -> String -> [String]+breakGenerator breakStr name = name:unfoldr unfoldName name+  where unfoldName str = case break (`elem` breakStr) str of+            ([], _) -> Nothing+            (_, []) -> Nothing+            (_, _:str') -> Just (str', str')++constructIndex :: [String] -> Maybe [Char] -> NameIndex+constructIndex strs gen = foldl' (flip addName) (emptyNameIndex gen) strs++addName :: String -> NameIndex -> NameIndex+addName caseName (NameIndex index stored gen' gen) =+    let name = map toLower caseName+        nameSet = Set.singleton caseName+        forName = Map.fromList $ map (\term -> (term, nameSet)) (gen name)+    in NameIndex (Map.unionWith Set.union index forName)+                 (Set.insert caseName stored) gen' gen++deleteName :: String -> NameIndex -> NameIndex+deleteName caseName (NameIndex index stored gen' gen) =+    let name = map toLower caseName+        nameSet = Set.singleton caseName+        forName = Map.fromList $ map (\term -> (term, nameSet)) (gen name)+    in NameIndex (Map.differenceWith (\a b -> keepSet $ Set.difference a b) index forName)+                 (Set.delete caseName stored) gen' gen+  where keepSet s = if Set.null s then Nothing else Just s++lookupName :: String -> NameIndex -> Set String+lookupName caseName (NameIndex index _ _ _) =+    Map.findWithDefault Set.empty (map toLower caseName) index++lookupPrefix :: String -> NameIndex -> Set String+lookupPrefix caseName (NameIndex index _ _ _) =+    let name = map toLower caseName+        (_, mentry, startTree) = Map.splitLookup name index+        -- the idea is, select all names in the range [name, mapLast succ name)+        -- an alternate idea would just be to takeWhile (`isPrefixOf` name)+        (totalTree, _, _) = Map.splitLookup (mapLast succ name) startTree+        nameSets = maybeToList mentry ++ Map.elems totalTree+    in Set.unions nameSets++takeSetPrefix :: String -> Set String -> Set String+takeSetPrefix name strs =+    let (_, present, startSet) = Set.splitMember name strs+        (totalSet, _, _) = Set.splitMember (mapLast succ name) startSet+    in (if present then Set.insert name else id) totalSet++-- | Map only the last element of a list+mapLast :: (a -> a) -> [a] -> [a]+mapLast f (x:[]) = f x:[]+mapLast f (x:xs) = x:mapLast f xs+mapLast _ [] = []++-- store arguments which can be sent to constructIndex :: [String] -> Maybe [Char] -> NameIndex+instance SafeCopy NameIndex where+    putCopy index = contain $ safePut (nameGenType index) >> safePut (storedNamesIndex index)+    getCopy = contain $ do+        gen <- safeGet+        index <- safeGet+        return $ constructIndex (Set.toList index) gen++instance NFData NameIndex where+    rnf (NameIndex a b _ _) = rnf a `seq` rnf b++instance MemSize NameIndex where+    memSize (NameIndex a b c d) = memSize4 a b c d
+ Distribution/Server/Util/Parse.hs view
@@ -0,0 +1,35 @@+-- | Parsing and UTF8 utilities+module Distribution.Server.Util.Parse (+    int, unpackUTF8, packUTF8+  ) where++import qualified Distribution.Compat.ReadP as Parse++import qualified Data.Char as Char+import Data.ByteString.Lazy (ByteString)+import qualified Data.Text.Lazy           as Text+import qualified Data.Text.Lazy.Encoding  as Text+import qualified Data.Text.Encoding.Error as Text++-- | Parse a positive integer. No leading @0@'s allowed.+--+int :: Parse.ReadP r Int+int = do+  first <- Parse.satisfy Char.isDigit+  if first == '0'+    then return 0+    else do rest <- Parse.munch Char.isDigit+            return (read (first : rest))++-- | Ignore a Unicode byte order mark (BOM) at the beginning of the input        +--                                                                               +-- (Also in Distribution.Simple.Utils, but not exported)                         +ignoreBOM :: String -> String                                                    +ignoreBOM ('\xFEFF':string) = string   +ignoreBOM string            = string                                             ++unpackUTF8 :: ByteString -> String+unpackUTF8 = ignoreBOM . Text.unpack . Text.decodeUtf8With Text.lenientDecode++packUTF8 :: String -> ByteString+packUTF8 = Text.encodeUtf8 . Text.pack
+ Distribution/Server/Util/ServeTarball.hs view
@@ -0,0 +1,151 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Server.Util.ServeTarball+-- Copyright   :  (c) 2008 David Himmelstrup+--                (c) 2009 Antoine Latter+-- License     :  BSD-like+--+-- Maintainer  :  duncan@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+--+-----------------------------------------------------------------------------+module Distribution.Server.Util.ServeTarball+    ( serveTarball+    , serveTarEntry+    , constructTarIndexFromFile+    , constructTarIndex+    ) where++import Happstack.Server.Types+import Happstack.Server.Monads+import Happstack.Server.Routing (method)+import Happstack.Server.Response+import Happstack.Server.FileServe as Happstack (mimeTypes)+import Distribution.Server.Util.Happstack (remainingPath)+import Distribution.Server.Pages.Template (hackagePage)+import Distribution.Server.Framework.ResponseContentTypes as Resource++import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Data.TarIndex as TarIndex+import Data.TarIndex (TarIndex)++import qualified Text.XHtml.Strict as XHtml+import qualified Data.ByteString.Lazy as BS+import qualified Data.Map as Map+import System.FilePath+import Control.Monad.Trans (MonadIO, liftIO)+import Control.Monad (msum, mzero)+import System.IO++-- | Serve the contents of a tar file+-- file. TODO: This is not a sustainable implementation,+-- but it gives us something to test with.+serveTarball :: MonadIO m+             => [FilePath] -- dir index file names (e.g. ["index.html"])+             -> FilePath   -- root dir in tar to serve+             -> FilePath   -- the tarball+             -> TarIndex   -- index for tarball+             -> ETag       -- the etag+             -> ServerPartT m Response+serveTarball indices tarRoot tarball tarIndex etag = do+    rq <- askRq+    action GET $ remainingPath $ \paths -> do++      -- first we come up with the set of paths in the tarball that+      -- would match our request+      let validPaths :: [FilePath]+          validPaths = (joinPath $ tarRoot:paths)+                     : [joinPath $ tarRoot:paths ++ [index] | index <- indices]++      msum $ concat+       [ serveFiles validPaths+       , serveDirs (rqUri rq) validPaths+       ]+  where+    serveFiles paths+           = flip map paths $ \path ->+             case TarIndex.lookup tarIndex path of+               Just (TarIndex.TarFileEntry off)+                   -> do+                 tfe <- liftIO $ serveTarEntry tarball off path etag+                 ok (toResponse tfe)+               _ -> mzero++    action act m = method act >> m++    serveDirs fullPath paths+           = flip map paths $ \path ->+             case TarIndex.lookup tarIndex path of+               Just (TarIndex.TarDir fs)+                 | not (hasTrailingPathSeparator fullPath)+                 -> seeOther (addTrailingPathSeparator fullPath) (toResponse ())++                 | otherwise+                 -> ok $ setHeader "ETag" (formatETag etag) $+                         toResponse $ Resource.XHtml $ renderDirIndex fs+               _ -> mzero++renderDirIndex :: [FilePath] -> XHtml.Html+renderDirIndex entries = hackagePage "Directory Listing"+    [ (XHtml.anchor XHtml.! [XHtml.href e] XHtml.<< e)+      XHtml.+++ XHtml.br+    | e <- entries ]++serveTarEntry :: FilePath -> Int -> FilePath -> ETag -> IO Response+serveTarEntry tarfile off fname etag = do+  htar <- openFile tarfile ReadMode+  hSeek htar AbsoluteSeek (fromIntegral (off * 512))+  header <- BS.hGet htar 512+  case Tar.read header of+    (Tar.Next Tar.Entry{Tar.entryContent = Tar.NormalFile _ size} _) -> do+         body <- BS.hGet htar (fromIntegral size)+         let extension = case takeExtension fname of+                           ('.':ext) -> ext+                           ext       -> ext+             mimeType = Map.findWithDefault "text/plain" extension mimeTypes'+             response = ((setHeader "Content-Length" (show size)) .+                         (setHeader "Content-Type" mimeType) .+                         (setHeader "ETag" (formatETag etag))) $+                         resultBS 200 body+         return response+    _ -> fail "oh noes!!"++-- | Extended mapping from file extension to mime type+mimeTypes' :: Map.Map String String+mimeTypes' = Happstack.mimeTypes `Map.union` Map.fromList+  [("xhtml", "application/xhtml+xml")]++constructTarIndexFromFile :: FilePath -> IO TarIndex+constructTarIndexFromFile file = do+  tar <- BS.readFile file+  case constructTarIndex tar of+    Left err       -> fail err+    Right tarIndex -> return tarIndex++-- | Forcing the Either will force the tar index+constructTarIndex :: BS.ByteString -> Either String TarIndex+constructTarIndex tar =+  case extractInfo (Tar.read tar) of+    Just info -> let tarIndex = TarIndex.construct info+                 in tarIndex `seq` Right tarIndex+    Nothing   -> Left "bad tar file"++type Block = Int++extractInfo :: Tar.Entries e -> Maybe [(FilePath, Block)]+extractInfo = go 0 []+  where+    go _ es' (Tar.Done)      = Just es'+    go _ _   (Tar.Fail _)    = Nothing+    go n es' (Tar.Next e es) = go n' ((Tar.entryPath e, n) : es') es+      where+        n' = n + 1+               + case Tar.entryContent e of+                   Tar.NormalFile     _   size -> blocks size+                   Tar.OtherEntryType _ _ size -> blocks size+                   _                           -> 0+        blocks s = 1 + ((fromIntegral s - 1) `div` 512)+
+ Distribution/Server/Util/TarIndex.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, TypeFamilies, TemplateHaskell,+      MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}++-- This is presently unused: features provide their own BlobId-to-TarIndex+-- mappings.++module Distribution.Server.Util.TarIndex+    where++import Control.Applicative ((<$>))+import Control.Monad.Reader.Class (asks)+import Control.Monad.State.Class (put, modify)+import qualified Data.Map as Map++import Data.Acid     (makeAcidic)+import Data.SafeCopy (base, deriveSafeCopy)+import Data.TarIndex (TarIndex)++import Distribution.Server.Framework.BlobStorage (BlobId)++data TarIndexMap = M {indexMap :: Map.Map BlobId TarIndex}+ deriving (Typeable, Show)++addIndex :: BlobId -> TarIndex -> Update TarIndexMap ()+addIndex blob index = modify $ insertTarIndex blob index++insertTarIndex :: BlobId -> TarIndex -> TarIndexMap -> TarIndexMap+insertTarIndex blob index (M state) = M (Map.insert blob index state)++dropIndex :: BlobId -> Update TarIndexMap ()+dropIndex blob = modify $ \(M state) -> M (Map.delete blob state)++lookupIndex :: BlobId -> Query TarIndexMap (Maybe TarIndex)+lookupIndex blob =  Map.lookup blob <$> asks indexMap++replaceTarIndexMap :: TarIndexMap -> Update TarIndexMap ()+replaceTarIndexMap = put++$(deriveSafeCopy 0 'base ''TarIndexMap)++initialTarIndexMap :: TarIndexMap+initialTarIndexMap = emptyTarIndex++emptyTarIndex :: TarIndexMap+emptyTarIndex = M Map.empty+++$(makeAcidic ''TarIndexMap+                [ 'addIndex+                , 'dropIndex+                , 'lookupIndex+                , 'replaceTarIndexMap+                ]+ )
+ Distribution/Server/Util/TextSearch.hs view
@@ -0,0 +1,63 @@+module Distribution.Server.Util.TextSearch (+    TextSearch(..),+    constructTextIndex,+    searchText+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS -- TODO: Deal with UTF8+import Data.ByteString.Search+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Char+import Data.Maybe (catMaybes)+import Control.DeepSeq++import Distribution.Server.Framework.MemSize+++-- Basic full text search. This works best when there are plenty of entries+-- and all of them are short. I'd use something like Hayoo here, but there's+-- no easy way to integrate it into the site.+--+-- At present this uses Bayer-Moore. Something with multiple search keys+-- might be more flexible. Or, even better, a Lucene-like engine.+data TextSearch = TextSearch {+    fullText  :: !ByteString,+    textIndex :: !(Map Int (String, String))+} deriving Show++instance NFData TextSearch++constructTextIndex :: [(String, String)] -> TextSearch+constructTextIndex strs = case go strs 0 of+    (bs, texts) -> TextSearch (BS.concat bs) (Map.fromList texts)+  where+    go :: [(String, String)] -> Int -> ([ByteString], [(Int, (String, String))])+    go [] _ = ([], [])+    go (pair@(_, text):xs) pos =+        let text' = BS.pack $ "\0" ++ stripText text+        in case go xs (BS.length text' + pos) of+            ~(bs, texts) -> (text':bs, (pos, pair):texts)++stripText :: String -> String+stripText = map toLower . filter (\c -> isSpace c || isAlphaNum c)++searchText :: TextSearch -> String -> [(String, String)]+searchText (TextSearch theText theIndex) str =+    Map.toList . Map.fromAscListWith const+  . catMaybes . map (\i -> getIndexEntry (fromIntegral i) theIndex)+  $ nonOverlappingIndices (BS.pack $ stripText str) theText++-- TODO: offset might be useful for determining whether the match was whole-word+-- or no+getIndexEntry :: Int -> Map Int a -> Maybe a+getIndexEntry index theIndex = case Map.splitLookup index theIndex of+    (_, Just entry, _) -> Just entry+    (beforeMap, _, afterMap) -> case (Map.null beforeMap, Map.null afterMap) of+        (True, True)  -> Nothing+        (True, False) -> Just $ snd $ Map.findMin afterMap+        (False, _) -> Just $ snd $ Map.findMax beforeMap++instance MemSize TextSearch where+    memSize (TextSearch a b) = memSize2 a b
+ ImportClient.hs view
@@ -0,0 +1,1023 @@+{-# LANGUAGE PatternGuards, ScopedTypeVariables, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module Main where++import Network.HTTP+import Network.Browser hiding (err)+import Network.URI+         ( URI(..), URIAuth(..), parseURI, escapeURIString, isUnescapedInURI )++import qualified Distribution.Client.HtPasswdDb as HtPasswdDb+import qualified Distribution.Client.UserAddressesDb as UserAddressesDb+import qualified Distribution.Client.UploadLog  as UploadLog+import qualified Distribution.Client.TagsFile   as TagsFile+import qualified Distribution.Client.DistroMap  as DistroMap+import qualified Distribution.Client.PkgIndex   as PkgIndex++import Distribution.Server.Users.Types (UserName(..))+import Distribution.Server.Util.Parse (packUTF8, unpackUTF8)++import Distribution.Package+         ( PackageId, PackageName, packageName, packageVersion )+import Distribution.Version+         ( Version, versionTags )+import Distribution.Text+         ( display, simpleParse )+import Distribution.Simple.Utils+         ( topHandler, die, {-warn, debug,-} wrapText )+import Distribution.Verbosity+         ( Verbosity, normal )++import Distribution.Simple.Command+import Distribution.Simple.Setup+         ( Flag(..), fromFlag, flagToList )++import Distribution.Client.ParseApacheLogs+import qualified Distribution.Server.Util.GZip as GZip++import System.Environment+         ( getArgs, getProgName )+import System.Locale+         ( defaultTimeLocale )+import System.Exit+         ( exitWith, ExitCode(..) )+import System.IO+import System.FilePath+         ( (</>), (<.>), takeFileName, dropExtension, takeExtension )+import qualified System.FilePath.Posix as Posix+import Data.List+import Data.Maybe+import Data.Ord (comparing)+import Data.Time (UTCTime, formatTime, getCurrentTime)+import Control.Monad+import Control.Monad.Trans+import Control.Applicative ((<$>))+import Data.ByteString.Lazy (ByteString)+import Data.Aeson (Value(..), toJSON, encode)+import Data.Text (Text)+import qualified Data.HashMap.Strict  as HashMap+import qualified Data.Text            as Text+import qualified Data.Vector          as Vector+import qualified Data.ByteString.Lazy as LBS++import qualified Text.CSV as CSV++import Control.Exception+import Control.Concurrent.Chan+import Control.Concurrent.Async++import qualified Paths_hackage_server as Paths (version)++--+-- The following data can be imported:+--+--  * User accounts+--    - user names+--    - htpasswd-style passwords+--    - email addresses+--+--  * Package metadata+--    - cabal files+--    - upload user+--    - upload times+--    - maintainer group+--+--  * Package tarballs+--+--  * Package deprecations+--+--  * Distribution information+--+--  * Documentation tarballs+--++-------------------------------------------------------------------------------+-- Top level command handling+--++main :: IO ()+main = topHandler $ do+    hSetBuffering stdout LineBuffering+    args <- getArgs+    case commandsRun globalCommand commands args of+      CommandHelp   help  -> printHelp help+      CommandList   opts  -> printOptionsList opts+      CommandErrors errs  -> printErrors errs+      CommandReadyToGo (globalflags, commandParse) ->+        case commandParse of+          _ | fromFlag (globalVersion globalflags) -> printVersion+          CommandHelp      help    -> printHelp help+          CommandList      opts    -> printOptionsList opts+          CommandErrors    errs    -> printErrors errs+          CommandReadyToGo action  -> action globalflags++  where+    printHelp help = getProgName >>= putStr . help+    printOptionsList = putStr . unlines+    printErrors errs = do+      putStr (concat (intersperse "\n" errs))+      exitWith (ExitFailure 1)+    printVersion = putStrLn $ "hackage-import " ++ display Paths.version++    commands =+      [ usersCommand         `commandAddAction` usersAction+      , metadataCommand      `commandAddAction` metadataAction+      , tarballCommand       `commandAddAction` tarballAction+      , distroCommand        `commandAddAction` distroAction+      , deprecationCommand   `commandAddAction` deprecationAction+      , docsCommand          `commandAddAction` docsAction+      , downloadCountCommand `commandAddAction` downloadCountAction+      ]+++-------------------------------------------------------------------------------+-- Global command+--++data GlobalFlags = GlobalFlags {+    globalVersion :: Flag Bool+  }++defaultGlobalFlags :: GlobalFlags+defaultGlobalFlags = GlobalFlags {+    globalVersion = Flag False+  }++globalCommand :: CommandUI GlobalFlags+globalCommand = CommandUI {+    commandName         = "",+    commandSynopsis     = "",+    commandUsage        = \_ ->+         "Data import client for the hackage server:\n"+      ++ "utility for importing old data into a new hackage-server\n",+    commandDescription  = Just $ \pname ->+         "For more information about a command use\n"+      ++ "  " ++ pname ++ " COMMAND --help\n\n"+      ++ "Main steps for populating a new empty server instance:\n"+      ++ concat [ "  " ++ x ++ "\n"+                | x <- ["users", "metadata", "tarballs"]],+    commandDefaultFlags = defaultGlobalFlags,+    commandOptions      = \_ ->+      [option ['V'] ["version"]+         "Print version information"+         globalVersion (\v flags -> flags { globalVersion = v })+         (noArg (Flag True))+      ]+  }+++-------------------------------------------------------------------------------+-- Users command+--++data UsersFlags = UsersFlags {+    usersHtPasswd  :: Flag FilePath,+    usersUploaders :: Flag Bool,+    usersAddresses :: Flag FilePath,+    usersJobs      :: Flag String+  }++defaultUsersFlags :: UsersFlags+defaultUsersFlags = UsersFlags {+    usersHtPasswd  = NoFlag,+    usersUploaders = Flag False,+    usersAddresses = NoFlag,+    usersJobs      = NoFlag+  }++usersCommand :: CommandUI UsersFlags+usersCommand =+    (makeCommand name shortDesc longDesc defaultUsersFlags options) {+      commandUsage = \pname ->+           "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS] [URI]\n\n"+        ++ "Flags for " ++ name ++ ":"+    }+  where+    name       = "users"+    shortDesc  = "Import user accounts and other user data"+    longDesc   = Just $ \_ ->+                  "User account names and passwords can be imported from a "+               ++ "file in the\napache 'htpasswd' format.\n"+    options _  =+      [ option [] ["htpasswd"]+          "Import an apache 'htpasswd' user account database file"+          usersHtPasswd (\v flags -> flags { usersHtPasswd = v })+          (reqArgFlag "HTPASSWD")+      , option [] ["all-uploaders"]+          "Add all new accounts to the uploaders group (use with --htpasswd)"+          usersUploaders (\v flags -> flags { usersUploaders = v })+          (noArg (Flag True))+      , option [] ["addresses"]+          "Import user email addresses"+          usersAddresses (\v flags -> flags { usersAddresses = v })+          (reqArgFlag "ADDRESSES")+      , option [] ["jobs"]+          "The level of concurrency to use when uploading"+          usersJobs (\v flags -> flags { usersJobs = v })+          (reqArgFlag "N")+      ]++usersAction :: UsersFlags -> [String] -> GlobalFlags -> IO ()+usersAction flags args _ = do+    jobs    <- validateOptsJobs (usersJobs flags)+    baseURI <- validateOptsServerURI args++    when (usersHtPasswd flags == NoFlag+       && usersAddresses flags == NoFlag) $+      die $ "specify what to import using one or more of the flags:\n"+         ++ "  --htpasswd=  --addresses="++    let makeUploader = fromFlag (usersUploaders flags)++    case usersHtPasswd flags of+      NoFlag    -> return ()+      Flag file -> importAccounts jobs file makeUploader baseURI++    case usersAddresses flags of+      NoFlag    -> return ()+      Flag file -> importAddresses jobs file baseURI++importAccounts :: Int -> FilePath -> Bool -> URI -> IO ()+importAccounts jobs htpasswdFile makeUploader baseURI = do++  htpasswdDb <- either die return . HtPasswdDb.parse+            =<< readFile htpasswdFile++  concForM_ jobs htpasswdDb $ \tasks ->+    httpSession $ do+      setAuthorityFromURI baseURI+      tasks $ \(username, mPasswdhash) ->+        putUserAccount baseURI username mPasswdhash makeUploader+++putUserAccount :: URI -> UserName+               -> Maybe HtPasswdDb.HtPasswdHash -> Bool+               -> HttpSession ()+putUserAccount baseURI username mPasswdHash makeUploader = do++    do rsp <- requestPUT userURI "" LBS.empty+       case rsp of+        Nothing  -> return ()+        Just err -> fail (formatErrorResponse err)++    case mPasswdHash of+      Nothing -> return ()+      Just (HtPasswdDb.HtPasswdHash passwdHash) -> do+        rsp <- requestPUT passwdURI "text/plain" (packUTF8 passwdHash)+        case rsp of+          Nothing  -> return ()+          Just err -> fail (formatErrorResponse err)++    when makeUploader $ do+      rsp <- requestPUT userUploaderURI "" LBS.empty+      case rsp of+        Nothing  -> return ()+        Just err -> fail (formatErrorResponse err)++  where+    userURI   = baseURI <//> "user" </> display username+    passwdURI = userURI <//> "htpasswd"+    userUploaderURI = baseURI <//> "packages/uploaders/user" </> display username++importAddresses :: Int -> FilePath -> URI -> IO ()+importAddresses jobs addressesFile baseURI = do++    addressesDb <- either die return =<< UserAddressesDb.parseFile addressesFile++    concForM_ jobs addressesDb $ \tasks ->+      httpSession $ do+        setAuthorityFromURI baseURI+        tasks $ \(username, realname, email, timestamp, adminname) ->+          putUserDetails baseURI username realname email timestamp adminname++putUserDetails :: URI -> UserName -> Text -> Text+               -> UTCTime -> UserName -> HttpSession ()+putUserDetails baseURI username realname email timestamp adminname = do++    do rsp <- requestPUT userNameAddressURI "application/json" (encode nameAddressInfo)+       case rsp of+         Nothing  -> return ()+         Just err | isErrNotFound err+                  -> liftIO $ info $ "Ignoring address info for user "+                                  ++ display username+         Just err -> fail (formatErrorResponse err)++    do now <- liftIO getCurrentTime+       rsp <- requestPUT userAdminInfoURI "application/json" (encode (adminInfo now))+       case rsp of+         Nothing  -> return ()+         Just err | isErrNotFound err+                  -> liftIO $ info $ "Ignoring address info for user "+                                  ++ display username+         Just err -> fail (formatErrorResponse err)++  where+    userURI            = baseURI <//> "user" </> display username+    userNameAddressURI = userURI <//> "name-contact.json"+    userAdminInfoURI   = userURI <//> "admin-info.json"++    nameAddressInfo =+      object+          [ ("name",                String realname)+          , ("contactEmailAddress", String email)+          ]+    adminInfo now =+      object+          [ ("accountKind", object [("AccountKindRealUser", array [])])+          , ("notes",       toJSON (notes now))+          ]+    notes now = "Original hackage account created by "+             ++ display adminname ++ " on " ++ showUTCTime timestamp ++ "\n"+             ++ "Account created on this server by the hackage-import client on "+             ++ showUTCTime now+++-------------------------------------------------------------------------------+-- Metadata command+--++data MetadataFlags = MetadataFlags {+    metadataIndex     :: Flag FilePath,+    metadataUploadLog :: Flag FilePath,+    metadataJobs      :: Flag String+  }++defaultMetadataFlags :: MetadataFlags+defaultMetadataFlags = MetadataFlags {+    metadataIndex     = NoFlag,+    metadataUploadLog = NoFlag,+    metadataJobs      = NoFlag+  }++metadataCommand :: CommandUI MetadataFlags+metadataCommand =+    (makeCommand name shortDesc longDesc defaultMetadataFlags options) {+      commandUsage = \pname ->+           "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS] [URI]\n\n"+        ++ "Flags for " ++ name ++ ":"+    }+  where+    name       = "metadata"+    shortDesc  = "Import package metadata: cabal files and upload log"+    longDesc   = Just $ \_ ->+                  "The cabal files can be imported from hackage index file,"+               ++ "while upload details\ncan be got from the hackage log.\n"+    options _  =+      [ option [] ["index"]+          "Import all the packages from a hackage '00-index.tar' file"+          metadataIndex (\v flags -> flags { metadataIndex = v })+          (reqArgFlag "INDEX")+      , option [] ["upload-log"]+          "Import who uploaded what when, and set maintainer groups"+          metadataUploadLog (\v flags -> flags { metadataUploadLog = v })+          (reqArgFlag "LOG")+      , option [] ["jobs"]+          "The level of concurrency to use when uploading"+          metadataJobs (\v flags -> flags { metadataJobs = v })+          (reqArgFlag "N")+      ]++metadataAction :: MetadataFlags -> [String] -> GlobalFlags -> IO ()+metadataAction flags args _ = do++    jobs    <- validateOptsJobs (metadataJobs flags)+    baseURI <- validateOptsServerURI args++    when (metadataIndex flags == NoFlag+       && metadataUploadLog flags == NoFlag) $+      die $ "specify what to import using one or more of the flags:\n"+         ++ "  --index=  --upload-log="++    case metadataIndex flags of+      NoFlag    -> return ()+      Flag file -> importIndex jobs file baseURI++    case metadataUploadLog flags of+      NoFlag    -> return ()+      Flag file -> importUploadLog jobs file baseURI++importIndex :: Int -> FilePath -> URI -> IO ()+importIndex jobs indexFile baseURI = do+    info $ "Reading index file " ++ indexFile+    pkgs  <- either fail return+           . PkgIndex.readPkgIndex+         =<< LBS.readFile indexFile++    pkgs' <- evaluate (sortBy (comparing fst) pkgs)+    info $ "Uploading..."++    concForM_ jobs pkgs' $ \tasks ->+      httpSession $ do+        setAuthorityFromURI baseURI+        tasks $ \ (pkgid, cabalFile) ->+          putCabalFile baseURI pkgid cabalFile+++putCabalFile :: URI -> PackageId -> ByteString -> HttpSession ()+putCabalFile baseURI pkgid cabalFile = do++    rsp <- requestPUT pkgURI "text/plain" cabalFile+    case rsp of+      Nothing  -> return ()+      Just err -> fail (formatErrorResponse err)++  where+    pkgURI = baseURI <//> "package" </> display pkgid+                      </> display (packageName pkgid) <.> "cabal"+++importUploadLog :: Int -> FilePath -> URI -> IO ()+importUploadLog jobs uploadLogFile baseURI = do+    info $ "Reading log file " ++ uploadLogFile+    uploadLog <- either fail return+               . UploadLog.read+             =<< readFile uploadLogFile++    let uploadInfo     = UploadLog.collectUploadInfo uploadLog+        maintainerInfo = UploadLog.collectMaintainerInfo uploadLog++    concForM_ jobs uploadInfo $ \tasks ->+      httpSession $ do+        setAuthorityFromURI baseURI+        tasks $ \(pkgid, time, uname) ->+          putUploadInfo baseURI pkgid time uname++    concForM_ jobs maintainerInfo $ \tasks ->+      httpSession $ do+        setAuthorityFromURI baseURI+        tasks $ \(pkgname, maintainers) ->+          putMaintainersInfo baseURI pkgname maintainers+++putUploadInfo :: URI -> PackageId -> UTCTime -> UserName -> HttpSession ()+putUploadInfo baseURI pkgid time uname = do++    liftIO $ info $ "setting upload info for " ++ display pkgid++    do let timeStr = showUTCTime time+       rsp <- requestPUT (pkgURI <//> "upload-time") "text/plain" (packUTF8 timeStr)+       case rsp of+         Nothing  -> return ()+         Just err | isErrNotFound err -> liftIO $ info $ "Ignoring upload log entry for package " ++ display pkgid+         Just err -> fail (formatErrorResponse err)++    do let nameStr = display uname+       rsp <- requestPUT (pkgURI <//> "uploader") "text/plain" (packUTF8 nameStr)+       case rsp of+         Nothing  -> return ()+         Just err | isErrNotFound err  -> liftIO $ info $ "Ignoring upload log entry for package " ++ display pkgid+         Just err -> fail (formatErrorResponse err)++  where+    pkgURI = baseURI <//> "package" </> display pkgid++putMaintainersInfo :: URI -> PackageName -> [UserName] -> HttpSession ()+putMaintainersInfo baseURI pkgname maintainers =++    -- Add to the package's maintainers group+    forM_ maintainers $ \uname -> do+      rsp <- requestPUT (pkgURI <//> "maintainers" </> "user" </> display uname) "" LBS.empty+      case rsp of+        Nothing  -> return ()+        Just err | isErrNotFound err -> liftIO $ info $ "Cannot make " ++ display uname ++ " a maintainer for package " ++ display pkgname+        Just err -> fail (formatErrorResponse err)++  where+    pkgURI = baseURI <//> "package" </> display pkgname+++-------------------------------------------------------------------------------+-- Tarballs command+--++data TarballFlags = TarballFlags {+    tarballJobs :: Flag String+  }++defaultTarballFlags :: TarballFlags+defaultTarballFlags = TarballFlags {+    tarballJobs = NoFlag+  }++tarballCommand :: CommandUI TarballFlags+tarballCommand =+    (makeCommand name shortDesc longDesc defaultTarballFlags options) {+      commandUsage = \pname ->+           "Usage: " ++ pname ++ " " ++ name ++ " [URI] [TARBALL]... \n\n"+        ++ "Flags for " ++ name ++ ":"+    }+  where+    name       = "tarball"+    shortDesc  = "Import package tarballs"+    longDesc   = Just $ \_ ->+                     "The package tarballs can be imported directly from\n"+                  ++ " local .tar.gz files.\n"+    options _  = [ option [] ["jobs"]+                   "The level of concurrency to use when uploading tarballs"+                   tarballJobs (\v flags -> flags { tarballJobs = v })+                   (reqArgFlag "N")+                 ]++tarballAction :: TarballFlags -> [String] -> GlobalFlags -> IO ()+tarballAction flags args _ = do++    jobs <- validateOptsJobs (tarballJobs flags)++    (baseURI, tarballFiles) <- validateOptsServerURI' args++    let pkgidAndTarball =+          [ (mpkgid, file)+          | file <- tarballFiles+          , let pkgidstr = (dropExtension . dropExtension . takeFileName) file+                ext      = takeExtension (dropExtension file)+                             <.> takeExtension file+                mpkgid | ext == ".tar.gz"+                       , Just pkgid <- simpleParse pkgidstr+                       , null (versionTags (packageVersion pkgid))+                       = Just pkgid+                       | otherwise+                       = Nothing+          ]++    case [ file | (Nothing, file) <- pkgidAndTarball] of+      []    -> return ()+      files -> warn normal $ "the following files will be ignored because they "+                          ++ "do not match the expected naming convention of "+                          ++ "foo-1.0.tar.gz:\n" ++ unlines files++    let pkgidAndTarball' = [ (pkgid, tarballFilePath)+                           | (Just pkgid, tarballFilePath) <- pkgidAndTarball ]++    concForM_ jobs pkgidAndTarball' $ \tasks ->+      httpSession $ do+        setAuthorityFromURI baseURI+        tasks $ \(pkgid, tarballFilePath) ->+          putPackageTarball baseURI pkgid tarballFilePath+++putPackageTarball :: URI -> PackageId -> FilePath -> HttpSession ()+putPackageTarball baseURI pkgid tarballFilePath = do++    pkgContent <- liftIO $ LBS.readFile tarballFilePath+    rsp <- requestPUT pkgURI "application/x-gzip" pkgContent+    case rsp of+      Nothing  -> return ()+      Just err -> out (formatErrorResponse err)++  where+    pkgURI = baseURI <//> "package" </> display pkgid </> display pkgid <.> "tar.gz"+++-------------------------------------------------------------------------------+-- Deprecations command+--++data DeprecationFlags = DeprecationFlags++defaultDeprecationFlags :: DeprecationFlags+defaultDeprecationFlags = DeprecationFlags++deprecationCommand :: CommandUI DeprecationFlags+deprecationCommand =+    (makeCommand name shortDesc longDesc defaultDeprecationFlags options) {+      commandUsage = \pname ->+           "Usage: " ++ pname ++ " " ++ name ++ " [URI] [TAGS]... \n\n"+        ++ "Flags for " ++ name ++ ":"+    }+  where+    name       = "deprecation"+    shortDesc  = "Import package deprecation info from old hackage files"+    longDesc   = Just $ \_ ->+                     "The old hackage server has files like alsa/0.4/tags\n"+                  ++ "and some of these tags files contain info about the \n"+                  ++ "package being deprecated, and sometimes what it is\n"+                  ++ "superceded by. The files must follow this file name\n"+                  ++ "convention so we know which package the tags apply to.\n"+    options _  = []++deprecationAction :: DeprecationFlags -> [String] -> GlobalFlags -> IO ()+deprecationAction _flags args _ = do++    (baseURI, tagFiles) <- validateOptsServerURI' args++    entries <- forM tagFiles $ \tagFile -> do+      content <- readFile tagFile+      either die return (TagsFile.read tagFile content)++    httpSession $ do+      setAuthorityFromURI baseURI+      sequence_+        [ putDeprecatedInfo baseURI pkgname replacement+        | (pkgname, replacement) <- TagsFile.collectDeprecated entries ]+++putDeprecatedInfo :: URI -> PackageName -> Maybe PackageName -> HttpSession ()+putDeprecatedInfo baseURI pkgname replacement = do++    rsp <- requestPUT (pkgURI <//> "deprecated.json") "application/json" (encode deprecatedInfo)+    case rsp of+      Nothing  -> return ()+      Just err -> fail (formatErrorResponse err)++  where+    pkgURI = baseURI <//> "package" </> display pkgname++    deprecatedInfo =+      object+          [ ("is-deprecated", Bool True)+          , ("in-favour-of", array [ string $ display pkg+                                   | pkg <- maybeToList replacement ])+          ]+++-------------------------------------------------------------------------------+-- Distro command+--++data DistroFlags = DistroFlags++defaultDistroFlags :: DistroFlags+defaultDistroFlags = DistroFlags++distroCommand :: CommandUI DistroFlags+distroCommand =+    (makeCommand name shortDesc longDesc defaultDistroFlags options) {+      commandUsage = \pname ->+           "Usage: " ++ pname ++ " " ++ name ++ " [URI] [TAGS]... \n\n"+        ++ "Flags for " ++ name ++ ":"+    }+  where+    name       = "distro"+    shortDesc  = "Import distro info from old hackage files"+    longDesc   = Just $ \_ ->+                     "The old hackage server has files like archive/00-distromap/Debian\n"+                  ++ "which contain info about what versions of the packages \n"+                  ++ "are available in the respective distributions.\n"+                  ++ "The file name must be the distro name."+    options _  = []++distroAction :: DistroFlags -> [String] -> GlobalFlags -> IO ()+distroAction _flags args _ = do++    (baseURI, distroFiles) <- validateOptsServerURI' args++    distros <- forM distroFiles $ \distroFile -> do+      content <- readFile distroFile+      let (errs, entries) = DistroMap.read content+      mapM_ info errs+      return (takeFileName distroFile, entries)++    httpSession $ do+      setAuthorityFromURI baseURI+      sequence_+        [ putDistroInfo baseURI distroname entries+        | (distroname, entries) <- distros, not (null entries) ]+++putDistroInfo :: URI -> String -> [DistroMap.Entry] -> HttpSession ()+putDistroInfo baseURI distroname entries = do++    do rsp <- requestPUT distroURI "" LBS.empty+       case rsp of+         Nothing  -> return ()+         Just err -> fail (formatErrorResponse err)++    do rsp <- requestPUT (distroURI <//> "packages.csv") "text/csv" (toBS entries)+       case rsp of+         Nothing  -> return ()+         Just err -> fail (formatErrorResponse err)++  where+    distroURI = baseURI <//> "distro" </> distroname+    toBS      = packUTF8 . CSV.printCSV . DistroMap.toCSV++-------------------------------------------------------------------------------+-- Documentation tarballs command+--++data DocsFlags = DocsFlags {+    docsJobs :: Flag String+  }++defaultDocsFlags :: DocsFlags+defaultDocsFlags = DocsFlags {+    docsJobs = NoFlag+  }++docsCommand :: CommandUI DocsFlags+docsCommand =+    (makeCommand name shortDesc longDesc defaultDocsFlags options) {+      commandUsage = \pname ->+           "Usage: " ++ pname ++ " " ++ name ++ " [URI] [TARBALL]... \n\n"+        ++ "Flags for " ++ name ++ ":"+    }+  where+    name       = "docs"+    shortDesc  = "Import package documentation tarballs"+    longDesc   = Just $ \_ ->+                     "The package documentation can be imported directly from\n"+                  ++ " local .tar or .tar.gz files of the html bundle."+    options _  = [ option [] ["jobs"]+                   "The level of concurrency to use when uploading documentation"+                   docsJobs (\v flags -> flags { docsJobs = v })+                   (reqArgFlag "N")+                 ]++docsAction :: DocsFlags -> [String] -> GlobalFlags -> IO ()+docsAction flags args _ = do++    jobs <- validateOptsJobs (docsJobs flags)++    (baseURI, docTarballFiles) <- validateOptsServerURI' args++    let pkgidAndTarball =+          [ (mpkgid, file)+          | file <- docTarballFiles+          , let pkgidstr = (dropExtension . dropExtension. takeFileName) file+                ext      = takeExtension (dropExtension file)+                             <.> takeExtension file+                mpkgid | ext == ".tar" || ext == ".tar.gz"+                       , Just pkgid <- simpleParse pkgidstr+                       , versionTags (packageVersion pkgid) == ["docs"]+                       = Just pkgid+                       | otherwise+                       = Nothing+          ]++    case [ file | (Nothing, file) <- pkgidAndTarball ] of+      []    -> return ()+      files -> warn normal $ "the following files don't match the expected naming "+                          ++ "convention of foo-1.0-docs.tar[.gz]:\n" ++ unlines files++    let pkgidAndTarball' = [ (pkgid, tarballFilePath)+                           | (Just pkgid, tarballFilePath) <- pkgidAndTarball ]++    concForM_ jobs pkgidAndTarball' $ \tasks ->+      httpSession $ do+        setAuthorityFromURI baseURI+        tasks $ \(pkgid, tarballFilePath) ->+          putPackageDocsTarball baseURI pkgid tarballFilePath++putPackageDocsTarball :: URI -> PackageId -> FilePath -> HttpSession ()+putPackageDocsTarball baseURI pkgid tarballFilePath = do++    tarballContent <- liftIO $ LBS.readFile tarballFilePath+    let extraHeaders+          | takeExtension tarballFilePath == ".gz"+                      = [Header HdrContentEncoding "gzip"]+          | otherwise = []++    rsp <- requestPUTWithHeaders pkgDocURI "application/x-tar" extraHeaders+                                 tarballContent+    case rsp of+      Nothing  -> return ()+      Just err | isErrNotFound err+               -> liftIO $ info $ "Ignoring documentation for package "+                               ++ display pkgid+      Just err -> fail (formatErrorResponse err)++  where+    pkgDocURI = baseURI <//> "package" </> display pkgid </> "docs.tar"++-------------------------------------------------------------------------------+-- Download count command+--++data DownloadCountFlags = DownloadCountFlags++defaultDownloadCountFlags :: DownloadCountFlags+defaultDownloadCountFlags = DownloadCountFlags++downloadCountCommand :: CommandUI DownloadCountFlags+downloadCountCommand =+    (makeCommand name shortDesc longDesc defaultDownloadCountFlags options) {+      commandUsage = \pname ->+           "Usage: " ++ pname ++ " " ++ name ++ " URI [LOG.GZ]... \n\n"+        ++ "Flags for " ++ name ++ ":"+      }+  where+    name = "downloads"+    shortDesc = "Import download counts"+    longDesc  = Just $ \_ -> unlines $ [+        "Replace the on-disk download statistics with the download statistics"+      , "extracted from Apache log files (in .gz format)"+      ]+    options _ = []++downloadCountAction :: DownloadCountFlags -> [String] -> GlobalFlags -> IO ()+downloadCountAction _ args _ = do+    (baseURI, logFiles) <- validateOptsServerURI' args+    csv <- logToDownloadCounts <$> readLogs logFiles++    -- Compute before we open the connection to the server+    evaluate $ LBS.length csv++    httpSession $ do+      setAuthorityFromURI baseURI+      void $ requestPUT (baseURI <//> "packages" </> "downloads.csv") "text/csv" csv+  where+    readLogs :: [FilePath] -> IO LBS.ByteString+    readLogs paths = LBS.concat <$> mapM decompress paths++    decompress :: FilePath -> IO LBS.ByteString+    decompress path = GZip.decompressNamed path <$> LBS.readFile path++-------------------------+-- HTTP utilities+-------------------------++infixr 5 <//>++(<//>) :: URI -> FilePath -> URI+uri <//> path = uri { uriPath = Posix.addTrailingPathSeparator (uriPath uri)+                                Posix.</> escapeURIString isUnescapedInURI path }++validateHttpURI :: String -> Either String URI+validateHttpURI str = case parseURI str of+  Nothing                          -> Left ("invalid URL " ++ str)+  Just uri+    | uriScheme uri /= "http:"     -> Left ("only http URLs are supported " ++ str)+    | isNothing (uriAuthority uri) -> Left ("server name required in URL " ++ str)+    | otherwise                    -> Right uri+++type HttpSession a = BrowserAction (HandleStream ByteString) a++httpSession :: HttpSession a -> IO a+httpSession action =+    browse $ do+      setUserAgent  ("hackage-import/" ++ display Paths.version)+      setErrHandler (warn  verbosity)+      setOutHandler (debug verbosity)+      setAllowBasicAuth True+      setCheckForProxy True+      action+  where+    verbosity = normal++data ErrorResponse = ErrorResponse URI ResponseCode String (Maybe String)+  deriving Show++isErrNotFound :: ErrorResponse -> Bool+isErrNotFound (ErrorResponse _ (4,0,4) _ _) = True+isErrNotFound _                             = False++-- | We can do http digest auth, however currently the Network.Browser module+-- does not cache the auth info so it has to re-auth for every single request.+-- So instead here we just make it pre-emptively supply basic auth info.+-- We assume this is fine since we're probably working with localhost anyway.+--+setAuthorityFromURI :: URI -> HttpSession ()+setAuthorityFromURI uri+    | Just (username, passwd) <- extractCredentials uri+    = addAuthority AuthBasic {+        auRealm    = "Hackage",+        auUsername = username,+        auPassword = passwd,+        auSite     = uri+      }+    | otherwise = return ()++extractCredentials :: URI -> Maybe (String, String)+extractCredentials uri+  | Just authority <- uriAuthority uri+  , (username, ':':passwd0) <- break (==':') (uriUserInfo authority)+  , let passwd = takeWhile (/='@') passwd0+  , not (null username)+  , not (null passwd)+  = Just (username, passwd)+extractCredentials _ = Nothing+++requestGET :: URI -> HttpSession (Either ErrorResponse ByteString)+requestGET uri = do+    (_, rsp) <- request (Request uri GET headers LBS.empty)+    case rspCode rsp of+      (2,0,0) -> return (Right (rspBody rsp))+      _       -> return (Left  (mkErrorResponse uri rsp))+  where+    headers = []++requestPUT :: URI -> String -> ByteString -> HttpSession (Maybe ErrorResponse)+requestPUT uri mimetype body =+    let extraHeaders = [] in+    requestPUTWithHeaders uri mimetype extraHeaders body++requestPUTWithHeaders :: URI -> String -> [Header] -> ByteString+                      -> HttpSession (Maybe ErrorResponse)+requestPUTWithHeaders uri mimetype extraHeaders body = do+    (_, rsp) <- request (Request uri PUT headers body)+    case rspCode rsp of+      (2,_,_) -> return Nothing+      _       -> return (Just (mkErrorResponse uri rsp))+  where+    headers =   Header HdrContentLength (show (LBS.length body))+              : Header HdrContentType mimetype+              : extraHeaders++mkErrorResponse :: URI -> Response ByteString -> ErrorResponse+mkErrorResponse uri rsp =+    ErrorResponse uri (rspCode rsp) (rspReason rsp) mBody+  where+    mBody = case lookupHeader HdrContentType (rspHeaders rsp) of+      Just mimetype | "text/plain" `isPrefixOf` mimetype+                   -> Just (unpackUTF8 (rspBody rsp))+      _            -> Nothing++formatErrorResponse :: ErrorResponse -> String+formatErrorResponse (ErrorResponse uri (a,b,c) reason mBody) =+    "HTTP error code " ++ show a ++ show b ++ show c+ ++ ", " ++ reason ++ "\n  " ++  show uri+ ++ maybe "" (('\n':) . unlines . map ("  "++) . lines . wrapText) mBody+++-------------------------------------------------------------------------------+-- Utils+--++showUTCTime :: UTCTime -> String+showUTCTime = formatTime defaultTimeLocale "%c"++-- option utility+reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description+           -> (a -> Flag String) -> (Flag String -> a -> a)+           -> OptDescr a+reqArgFlag ad = reqArg' ad Flag flagToList++warn :: Verbosity -> String -> IO ()+warn verbosity msg =+  when (verbosity >= normal) $+    putStrLn ("Warning: " ++ msg)++debug :: Verbosity -> String -> IO ()+debug verbosity msg =+  when (verbosity > normal) $+    putStrLn ("Debug: " ++ msg)++info :: String -> IO ()+info msg = do+  pname <- getProgName+  putStrLn (pname ++ ": " ++ msg)+  hFlush stdout++validateOptsServerURI :: [String] -> IO URI+validateOptsServerURI [server] = either die return $ validateHttpURI server+validateOptsServerURI _        = die $ "The command expects the target server "+                            ++ "URI e.g. http://admin:admin@localhost:8080/"++validateOptsServerURI' :: [String] -> IO (URI, [String])+validateOptsServerURI' (server:opts) = do uri <- either die return $ validateHttpURI server+                                          return (uri,opts)+validateOptsServerURI' _             = die $ "The command expects the target server "+                                          ++ "URI e.g. http://admin:admin@localhost:8080/"++validateOptsJobs :: Flag String -> IO Int+validateOptsJobs  NoFlag       = return 1+validateOptsJobs (Flag s)+  | [(n,"")] <- reads s+ , n >= 1 && n <= 16           = return n+validateOptsJobs (Flag s)+  | [(_ :: Int,"")] <- reads s = die "not a sensible number for --jobs"+  | otherwise                  = die "expected a number for --jobs"+++-------------------------------------------------------------------------------+-- Concurrency Utils+--++concForM_ :: MonadIO m => Int -> [a] -> (((a -> m ()) -> m ()) -> IO ()) -> IO ()+concForM_ n = flip (concMapM_ n)++concMapM_ :: forall m a. MonadIO m => Int -> (((a -> m ()) -> m ()) -> IO ()) -> [a] -> IO ()+concMapM_ n action xs = do+    chan <- newChan+    writeList2Chan chan (map Just xs ++ replicate n Nothing)+    bracket+      (replicateM n (async (worker chan)))+      (mapM_ cancel)+      (\as -> waitAny as >> mapM_ wait as)+  where+    worker :: Chan (Maybe a) -> IO ()+    worker chan = action mapMTasks+      where+        mapMTasks :: MonadIO m => (a -> m ()) -> m ()+        mapMTasks process = go+          where+            go = do mx <- liftIO $ readChan chan+                    case mx of+                      Nothing -> return ()+                      Just x  -> process x >> go++{------------------------------------------------------------------------------+  Auxiliary+------------------------------------------------------------------------------}++array :: [Value] -> Value+array = Array . Vector.fromList++object :: [(Text.Text, Value)] -> Value+object = Object . HashMap.fromList++string :: String -> Value+string = String . Text.pack
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright 2008, Duncan Coutts and David Himmelstrup.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++- The names of the contributors may not be used to endorse or promote+products derived from this software without specific prior written+permission.++THIS SOFTWARE IS PROVIDED BY "AS IS" AND ANY EXPRESS OR IMPLIED+WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN+NO EVENT SHALL THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF+USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,862 @@+{-# LANGUAGE PatternGuards #-}++module Main where++import qualified Distribution.Server as Server+import Distribution.Server (ListenOn(..), ServerConfig(..), Server)+import Distribution.Server.Framework.Feature+import Distribution.Server.Framework.Logging+import Distribution.Server.Framework.BackupRestore (equalTarBall, restoreServerBackup)+import Distribution.Server.Framework.BackupDump (dumpServerBackup)+import qualified Distribution.Server.Framework.BlobStorage as BlobStorage++import Distribution.Text+         ( display )+import Distribution.Simple.Utils+         ( topHandler, die )+import Distribution.Verbosity as Verbosity++import System.Environment+         ( getArgs, getProgName )+import System.Exit+         ( exitWith, ExitCode(..) )+import Control.Exception+         ( bracket )+import System.Posix.Signals as Signal+         ( Signal+         , installHandler+         , Handler(Catch)+         , userDefinedSignal1+         , userDefinedSignal2+         )+import System.IO+import System.Directory+         ( createDirectory, createDirectoryIfMissing, doesDirectoryExist+         , getDirectoryContents, Permissions(..), getPermissions )+import System.FilePath+         ( (</>), (<.>) )+import Network.URI+         ( URI(..), URIAuth(..), parseAbsoluteURI )+import Distribution.Simple.Command+import Distribution.Simple.Setup+         ( Flag(..), fromFlag, fromFlagOrDefault, flagToList, flagToMaybe )+import Data.Maybe+         ( isNothing )+import Data.List+         ( intercalate, isInfixOf )+import Data.Traversable+         ( forM )+import Control.Monad+         ( void, unless, when, filterM )+import Control.Applicative+         ( (<$>) )+import Control.Arrow+         ( second )+import qualified Data.ByteString.Lazy as BS+import qualified Distribution.Server.Util.GZip as GZip+import qualified Text.Parsec as Parse++import Paths_hackage_server as Paths (version)++-------------------------------------------------------------------------------+-- Top level command handling+--++main :: IO ()+main = topHandler $ do+    hSetBuffering stdout LineBuffering+    args <- getArgs+    case commandsRun globalCommand commands args of+      CommandHelp   help  -> printHelp help+      CommandList   opts  -> printOptionsList opts+      CommandErrors errs  -> printErrors errs+      CommandReadyToGo (flags, commandParse) ->+        case commandParse of+          _ | fromFlag (flagGlobalVersion flags) -> printVersion+          CommandHelp      help    -> printHelp help+          CommandList      opts    -> printOptionsList opts+          CommandErrors    errs    -> printErrors errs+          CommandReadyToGo action  -> action++  where+    printHelp help = getProgName >>= putStr . help+    printOptionsList = putStr . unlines+    printErrors errs = do+      putStr (intercalate "\n" errs)+      exitWith (ExitFailure 1)+    printVersion = putStrLn $ "hackage-server " ++ display version++    commands =+      [ runCommand     `commandAddActionNoArgs` runAction+      , initCommand    `commandAddActionNoArgs` initAction+      , backupCommand  `commandAddActionNoArgs` backupAction+      , restoreCommand `commandAddAction`       restoreAction+      , testBackupCommand `commandAddActionNoArgs` testBackupAction+      ]++    commandAddActionNoArgs cmd action =+      commandAddAction cmd $ \flags extraArgs -> do+        when (not (null extraArgs)) $+          die $ "'" ++ commandName cmd+             ++ "' does not take any extra arguments: " ++ unwords extraArgs+        action flags+++-------------------------------------------------------------------------------+-- Global command+--++data GlobalFlags = GlobalFlags {+    flagGlobalVersion :: Flag Bool+  }++defaultGlobalFlags :: GlobalFlags+defaultGlobalFlags = GlobalFlags {+    flagGlobalVersion = Flag False+  }++globalCommand :: CommandUI GlobalFlags+globalCommand = CommandUI {+    commandName         = "",+    commandSynopsis     = "",+    commandUsage        = \_ ->+         "Hackage server: serves a collection of Haskell Cabal packages\n",+    commandDescription  = Just $ \pname ->+         "For more information about a command use\n"+      ++ "  " ++ pname ++ " COMMAND --help\n\n"+      ++ "Steps to create a new empty server instance:\n"+      ++ concat [ "  " ++ pname ++ " " ++ x ++ "\n"+                | x <- ["init", "run"]],+    commandDefaultFlags = defaultGlobalFlags,+    commandOptions      = \_ ->+      [option ['V'] ["version"]+         "Print version information"+         flagGlobalVersion (\v flags -> flags { flagGlobalVersion = v })+         (noArg (Flag True))+      ]+  }++-- Common options+--++optionVerbosity :: (a -> Flag Verbosity)+                -> (Flag Verbosity -> a -> a)+                -> OptionField a+optionVerbosity getter setter =+  option "v" ["verbose"]+    "Control verbosity (n is 0--3, default verbosity level is 1)"+    getter setter+    (optArg "n" (fmap Flag Verbosity.flagToVerbosity)+          (Flag Verbosity.verbose)+          (fmap (Just . showForCabal) . flagToList))++optionStateDir :: (a -> Flag FilePath)+               -> (Flag FilePath -> a -> a)+               -> OptionField a+optionStateDir getter setter =+  option [] ["state-dir"]+    "Directory in which to store the persistent state of the server (default state/)"+    getter setter+    (reqArgFlag "DIR")++optionStaticDir :: (a -> Flag FilePath)+                -> (Flag FilePath -> a -> a)+                -> OptionField a+optionStaticDir getter setter =+  option [] ["static-dir"]+    "Directory in which to find the html templates and static files (default: cabal location)"+    getter setter+    (reqArgFlag "DIR")+++-------------------------------------------------------------------------------+-- Run command+--++data RunFlags = RunFlags {+    flagRunVerbosity       :: Flag Verbosity,+    flagRunPort            :: Flag String,+    flagRunIP              :: Flag String,+    flagRunHostURI         :: Flag String,+    flagRunStateDir        :: Flag FilePath,+    flagRunStaticDir       :: Flag FilePath,+    flagRunTmpDir          :: Flag FilePath,+    flagRunTemp            :: Flag Bool,+    flagRunCacheDelay      :: Flag String,+    -- Online backup flags+    flagRunBackupOutputDir :: Flag FilePath,+    flagRunBackupLinkBlobs :: Flag Bool+  }++defaultRunFlags :: RunFlags+defaultRunFlags = RunFlags {+    flagRunVerbosity       = Flag Verbosity.normal,+    flagRunPort            = NoFlag,+    flagRunIP              = NoFlag,+    flagRunHostURI         = NoFlag,+    flagRunStateDir        = NoFlag,+    flagRunStaticDir       = NoFlag,+    flagRunTmpDir          = NoFlag,+    flagRunTemp            = Flag False,+    flagRunCacheDelay      = NoFlag,+    flagRunBackupOutputDir = Flag "backups",+    flagRunBackupLinkBlobs = Flag False+  }++runCommand :: CommandUI RunFlags+runCommand = makeCommand name shortDesc longDesc defaultRunFlags options+  where+    name       = "run"+    shortDesc  = "Run an already-initialized Hackage server."+    longDesc   = Just $ \progname ->+                  "Note: the " ++ progname ++ " data lock prevents two "+               ++ "state-accessing modes from\nbeing run simultaneously.\n\n"+               ++ "On unix systems you can tell the server to checkpoint its "+               ++ "database state using:\n"+               ++ " $ kill -USR1 $the_pid\n"+               ++ "where $the_pid is the process id of the running server. "+               ++ "Similarly,\n"+               ++ " $ kill -USR2 $the_pid\n"+               ++ "starts an online backup.\n"+    options _  =+      [ optionVerbosity+          flagRunVerbosity (\v flags -> flags { flagRunVerbosity = v })+      , option [] ["port"]+          "Port number to serve on (default 8080)"+          flagRunPort (\v flags -> flags { flagRunPort = v })+          (reqArgFlag "PORT")+      , option [] ["ip"]+          "IPv4 address to listen on (default 0.0.0.0)"+          flagRunIP (\v flags -> flags { flagRunIP = v })+          (reqArgFlag "IP")+      , option [] ["base-uri"]+          "Server's public base URI (defaults to machine name)"+          flagRunHostURI (\v flags -> flags { flagRunHostURI = v })+          (reqArgFlag "NAME")+      , optionStateDir+          flagRunStateDir (\v flags -> flags { flagRunStateDir = v })+      , optionStaticDir+          flagRunStaticDir (\v flags -> flags { flagRunStaticDir = v })+      , option [] ["tmp-dir"]+          "Temporary directory in which to store file uploads (default state/tmp/)"+          flagRunTmpDir (\v flags -> flags { flagRunTmpDir = v })+          (reqArgFlag "DIR")+      , option [] ["temp-run"]+          "Set up a temporary server while initializing state for maintenance restarts"+          flagRunTemp (\v flags -> flags { flagRunTemp = v })+          (noArg (Flag True))+      , option [] ["delay-cache-updates"]+          "Save time during bulk imports by delaying cache updates."+          flagRunCacheDelay (\v flags -> flags { flagRunCacheDelay = v })+          (reqArgFlag "SECONDS")+      , option ['o'] ["output-dir"]+          "The directory in which to create the backup (default ./backups/)"+          flagRunBackupOutputDir (\v flags -> flags { flagRunBackupOutputDir = v })+          (reqArgFlag "TARBALL")+      , option [] ["hardlink-blobs"]+          ("Hard-link the blob files in the backup rather than copying them "+           ++ " (reduces disk space and I/O but is less robust to errors).")+          flagRunBackupLinkBlobs (\v flags -> flags { flagRunBackupLinkBlobs = v })+          (noArg (Flag True))+      ]++runAction :: RunFlags -> IO ()+runAction opts = do+    defaults <- Server.defaultServerConfig++    port       <- checkPortOpt defaults (flagToMaybe (flagRunPort opts))+    ip         <- checkIPOpt   defaults (flagToMaybe (flagRunIP   opts))+    hosturi    <- checkHostURI defaults (flagToMaybe (flagRunHostURI opts)) port+    cacheDelay <- checkCacheDelay defaults (flagToMaybe (flagRunCacheDelay opts))+    let stateDir  = fromFlagOrDefault (confStateDir  defaults) (flagRunStateDir  opts)+        staticDir = fromFlagOrDefault (confStaticDir defaults) (flagRunStaticDir opts)+        tmpDir    = fromFlagOrDefault (confTmpDir    defaults) (flagRunTmpDir    opts)+        listenOn  = (confListenOn defaults) {+                       loPortNum = port,+                       loIP      = ip+                    }+        config    = defaults {+                        confHostUri    = hosturi,+                        confListenOn   = listenOn,+                        confStateDir   = stateDir,+                        confStaticDir  = staticDir,+                        confTmpDir     = tmpDir,+                        confCacheDelay = cacheDelay,+                        confVerbosity  = verbosity+                    }+        outputDir = fromFlag (flagRunBackupOutputDir opts)+        linkBlobs = fromFlag (flagRunBackupLinkBlobs opts)++    checkBlankServerState =<< Server.hasSavedState config+    checkStaticDir staticDir (flagRunStaticDir opts)+    checkTmpDir    tmpDir++    let checkpointHandler server = do+          lognotice verbosity "Writing checkpoint..."+          Server.checkpoint server+          lognotice verbosity "Done"++    let backupHandler server = do+          lognotice verbosity "Starting backup..."+          startBackup verbosity outputDir linkBlobs server+          lognotice verbosity "Done"++    let useTempServer = fromFlag (flagRunTemp opts)+    withServer config useTempServer $ \server ->+      withHandler userDefinedSignal1 (checkpointHandler server) $+        withHandler userDefinedSignal2 (backupHandler server) $ do+          lognotice verbosity $ "Ready! Point your browser at " ++ show hosturi+          Server.run server++  where+    verbosity = fromFlag (flagRunVerbosity opts)++    -- Option handling:+    --+    checkPortOpt defaults Nothing    = return (loPortNum (confListenOn defaults))+    checkPortOpt _        (Just str) = case reads str of+      [(n,"")]  | n >= 1 && n <= 65535+               -> return n+      _        -> fail $ "bad port number " ++ show str++    checkHostURI defaults Nothing port = do+      let guessURI       = confHostUri defaults+          Just authority = uriAuthority guessURI+          portStr | port == 80 = ""+                  | otherwise  = ':' : show port+          guessURI' = guessURI { uriAuthority = Just authority { uriPort = portStr } }+      lognotice verbosity $ "Guessing public URI as " ++ show guessURI'+                        ++ "\n(you can override with the --base-uri= flag)"+      return guessURI'++    checkHostURI _        (Just str) _ = case parseAbsoluteURI str of+      Nothing -> fail $ "Cannot parse as a URI: " ++ str ++ "\n"+                     ++ "Make sure you include the http:// part"+      Just uri+        | uriScheme uri `notElem` ["http:", "https:"] ->+          fail $ "Sorry, the server assumes it will be served (or proxied) "+              ++ " via http or https, so cannot use uri scheme " ++ uriScheme uri+        | isNothing (uriAuthority uri) ->+          fail $ "The base-uri has to include the full host name"+        | uriPath uri `notElem` ["", "/"] ->+          fail $ "Sorry, the server assumes the base-uri to be at the root of "+              ++ " the domain, so cannot use " ++ uriPath uri+        | otherwise -> return uri { uriPath = "" }++    checkIPOpt defaults Nothing    = return (loIP (confListenOn defaults))+    checkIPOpt _        (Just str) =+      let pQuad = do ds <- Parse.many1 Parse.digit+                     let quad = read ds :: Integer+                     when (quad < 0 || quad > 255) $ fail "bad IP address"+                     return quad+          pIPv4 = do q1 <- pQuad+                     void $ Parse.char '.'+                     q2 <- pQuad+                     void $ Parse.char '.'+                     q3 <- pQuad+                     void $ Parse.char '.'+                     q4 <- pQuad+                     Parse.eof+                     return (q1, q2, q3, q4)+      in case Parse.parse pIPv4 str str of+         Left err -> fail (show err)+         Right _ -> return str++    checkCacheDelay defaults Nothing    = return (confCacheDelay defaults)+    checkCacheDelay _        (Just str) = case reads str of+      [(n,"")]  | n >= 0 && n <= 3600+               -> return n+      _        -> fail $ "bad cache delay number " ++ show str++    withHandler :: Signal -> IO () -> IO () -> IO ()+    withHandler signal signalHandler mainAction =+        bracket (setHandler $ Signal.Catch signalHandler)+                setHandler+                (const mainAction)+      where+        setHandler h = Signal.installHandler signal h Nothing++    checkBlankServerState  hasSavedState = when (not hasSavedState) . die $+            "There is no existing server state.\nYou can either import "+         ++ "existing data using the various import modes, or start with "+         ++ "an empty state using the new mode. Either way, we have to make "+         ++ "sure that there is at least one admin user account, otherwise "+         ++ "you'll not be able to administer your shiny new hackage server!\n"+         ++ "Use --help for more information."++-- Check that tmpDir exists and is readable & writable+checkTmpDir :: FilePath -> IO ()+checkTmpDir tmpDir = do+  exists <- doesDirectoryExist tmpDir+  when (not exists) $ fail $ "The temporary directory " ++ tmpDir ++ " does not exist. Create the directory or use --tmp-dir to specify an alternate location."+  perms <- getPermissions tmpDir+  when (not $ readable perms) $+    fail $ "The temporary directory " ++ tmpDir ++ " is not readable by the server. Fix the permissions or use --tmp-dir to specify an alternate location."+  when (not $ writable perms) $+    fail $ "The temporary directory " ++ tmpDir ++ " is not writable by the server. Fix the permissions or use --tmp-dir to specify an alternate location."++-- Check that staticDir exists and is readable+checkStaticDir :: FilePath -> Flag FilePath -> IO ()+checkStaticDir staticDir staticDirFlag = do+    exists <- doesDirectoryExist staticDir+    when (not exists) $+      case staticDirFlag of+        Flag _ -> die $ "The given static files directory " ++ staticDir+                     ++ " does not exist."+        -- Be helpful to people running from the build tree+        NoFlag -> die $ "It looks like you are running the server without "+                     ++ "installing it. That is fine but you will have to "+                     ++ "give the location of the static html files with the "+                     ++ "--static-dir flag."+    perms <- getPermissions staticDir+    when (not $ readable perms) $+      die $ "The static files directory " ++ staticDir+          ++ " exists but is not readable by the server."+++-------------------------------------------------------------------------------+-- Init command+--++data InitFlags = InitFlags {+    flagInitVerbosity :: Flag Verbosity,+    flagInitAdmin     :: Flag String,+    flagInitStateDir  :: Flag FilePath,+    flagInitStaticDir :: Flag FilePath+  }++defaultInitFlags :: InitFlags+defaultInitFlags = InitFlags {+    flagInitVerbosity = Flag Verbosity.normal,+    flagInitAdmin     = NoFlag,+    flagInitStateDir  = NoFlag,+    flagInitStaticDir = NoFlag+  }++initCommand :: CommandUI InitFlags+initCommand = makeCommand name shortDesc longDesc defaultInitFlags options+  where+    name       = "init"+    shortDesc  = "Initialize the server state to a useful default."+    longDesc   = Just $ \_ ->+                 "Creates an empty package collection and one admininstrator "+              ++ "account so that you\ncan log in via the web interface and "+              ++ "bootstrap from there.\n"+    options _  =+      [ optionVerbosity+          flagInitVerbosity (\v flags -> flags { flagInitVerbosity = v })+      , option [] ["admin"]+          "New server's administrator, name:password (default: admin:admin)"+          flagInitAdmin (\v flags -> flags { flagInitAdmin = v })+          (reqArgFlag "NAME:PASS")+      , optionStateDir+          flagInitStateDir (\v flags -> flags { flagInitStateDir = v })+      , optionStaticDir+          flagInitStaticDir (\v flags -> flags { flagInitStaticDir = v })+      ]++initAction :: InitFlags -> IO ()+initAction opts = do+    defaults <- Server.defaultServerConfig++    let stateDir  = fromFlagOrDefault (confStateDir defaults)  (flagInitStateDir opts)+        staticDir = fromFlagOrDefault (confStaticDir defaults) (flagInitStaticDir opts)+        verbosity = fromFlag (flagInitVerbosity opts)+        config    = defaults {+                        confVerbosity = verbosity,+                        confStateDir  = stateDir,+                        confStaticDir = staticDir+                    }+        parseAdmin adminStr = case break (==':') adminStr of+            (uname, ':':pass) -> Just (uname, pass)+            _                 -> Nothing++    admin <- case flagInitAdmin opts of+        NoFlag   -> return ("admin", "admin")+        Flag str -> case parseAdmin str of+            Just arg -> return arg+            Nothing  -> fail $ "Couldn't parse username:password in " ++ show str++    checkAccidentalDataLoss =<< Server.hasSavedState config+    checkStaticDir staticDir (flagInitStaticDir opts)++    withServer config False $ \server -> do+        lognotice verbosity "Creating initial state..."+        Server.initState server admin+        createDirectory (stateDir </> "tmp")+        when (flagInitAdmin opts == NoFlag) $+          lognotice verbosity $ "Using default administrator account "+              ++ "(user admin, passwd admin)"+        lognotice verbosity "Done"+++-------------------------------------------------------------------------------+-- Backup command+--++data BackupFlags = BackupFlags {+    flagBackupVerbosity   :: Flag Verbosity,+    flagBackupOutputDir   :: Flag FilePath,+    flagBackupStateDir    :: Flag FilePath,+    flagBackupStaticDir   :: Flag FilePath,+    flagBackupLinkBlobs   :: Flag Bool+  }++defaultBackupFlags :: BackupFlags+defaultBackupFlags = BackupFlags {+    flagBackupVerbosity   = Flag Verbosity.normal,+    flagBackupOutputDir   = Flag "backups",+    flagBackupStateDir    = NoFlag,+    flagBackupStaticDir   = NoFlag,+    flagBackupLinkBlobs   = Flag False+  }++backupCommand :: CommandUI BackupFlags+backupCommand = makeCommand name shortDesc longDesc defaultBackupFlags options+  where+    name       = "backup"+    shortDesc  = "Create a backup of the server's database."+    longDesc   = Just $ \_ ->+                 "Creates a backup containing all of the data that the server "+              ++ "manages.\nThe purpose is for backup and for data integrity "+              ++ "across server upgrades.\nThe backup consists of a per-backup "+              ++ "tarball plus a shared directory of static files. The tarball "+              ++ "contains files in standard formats or simple text formats.\n"+              ++ "The backup can be restored using the 'restore' command.\n"+    options _  =+      [ optionVerbosity+          flagBackupVerbosity (\v flags -> flags { flagBackupVerbosity = v })+      , optionStateDir+          flagBackupStateDir (\v flags -> flags { flagBackupStateDir = v })+      , optionStaticDir+          flagBackupStaticDir (\v flags -> flags { flagBackupStaticDir = v })+      , option ['o'] ["output-dir"]+          "The directory in which to create the backup (default ./backups/)"+          flagBackupOutputDir (\v flags -> flags { flagBackupOutputDir = v })+          (reqArgFlag "TARBALL")+      , option [] ["hardlink-blobs"]+          ("Hard-link the blob files in the backup rather than copying them "+           ++ " (reduces disk space and I/O but is less robust to errors).")+          flagBackupLinkBlobs (\v flags -> flags { flagBackupLinkBlobs = v })+          (noArg (Flag True))+      ]++backupAction :: BackupFlags -> IO ()+backupAction opts = do+    defaults <- Server.defaultServerConfig++    let stateDir  = fromFlagOrDefault (confStateDir defaults)  (flagBackupStateDir  opts)+        staticDir = fromFlagOrDefault (confStaticDir defaults) (flagBackupStaticDir opts)+        outputDir = fromFlag (flagBackupOutputDir opts)+        linkBlobs = fromFlag (flagBackupLinkBlobs opts)+        verbosity = fromFlag (flagBackupVerbosity opts)+        config    = defaults {+                      confVerbosity = verbosity,+                      confStateDir  = stateDir,+                      confStaticDir = staticDir+                     }++    withServer config False $ startBackup verbosity outputDir linkBlobs++startBackup :: Verbosity -> FilePath -> Bool -> Server -> IO ()+startBackup verbosity outputDir linkBlobs server = do+  let store = Server.serverBlobStore (Server.serverEnv server)+      state = Server.serverState server+  dumpServerBackup verbosity outputDir Nothing store linkBlobs+                   (map (second abstractStateBackup) state)++-------------------------------------------------------------------------------+-- Test backup command+--++data TestBackupFlags = TestBackupFlags {+    flagTestBackupVerbosity :: Flag Verbosity,+    flagTestBackupStateDir  :: Flag FilePath,+    flagTestBackupStaticDir :: Flag FilePath,+    flagTestBackupTestDir   :: Flag FilePath,+    flagTestBackupLinkBlobs :: Flag Bool,+    flagTestBackupFeatures  :: Flag String+  }++defaultTestBackupFlags :: TestBackupFlags+defaultTestBackupFlags = TestBackupFlags {+    flagTestBackupVerbosity = Flag Verbosity.normal,+    flagTestBackupStateDir  = NoFlag,+    flagTestBackupStaticDir = NoFlag,+    flagTestBackupTestDir   = Flag "test-backup",+    flagTestBackupLinkBlobs = Flag False,+    flagTestBackupFeatures  = NoFlag+  }++testBackupCommand :: CommandUI TestBackupFlags+testBackupCommand = makeCommand name shortDesc longDesc defaultTestBackupFlags options+  where+    name       = "test-backup"+    shortDesc  = "A self-test of the server's database backup/restore system."+    longDesc   = Just $ \_ ->+                 "Checks that backing up and then restoring is the identity function on the"+              ++ "server state,\n and that restoring and then backing up is the identity function"+              ++ "on the backup tarball.\n"+    options _  =+      [ optionVerbosity+          flagTestBackupVerbosity (\v flags -> flags { flagTestBackupVerbosity = v })+      , optionStateDir+          flagTestBackupStateDir (\v flags -> flags { flagTestBackupStateDir = v })+      , optionStaticDir+          flagTestBackupStaticDir (\v flags -> flags { flagTestBackupStaticDir = v })+      , option [] ["test-dir"]+          "Temporary directory in which to store temporary information generated by the test (default test-backup/)."+          flagTestBackupTestDir (\v flags -> flags { flagTestBackupTestDir = v })+          (reqArgFlag "DIR")+      , option [] ["hardlink-blobs"]+          ("Do a partial test, short-circuting the reading and writing of the "+           ++ "blob files (saves on disk I/O, but less test coverage).")+          flagTestBackupLinkBlobs (\v flags -> flags { flagTestBackupLinkBlobs = v })+          (noArg (Flag True))+      , option [] ["features"]+          ("Only test the specified features")+          flagTestBackupFeatures (\v flags -> flags { flagTestBackupFeatures = v })+          (reqArgFlag "FEATURES")+      ]++-- FIXME: the following acidic types are neither backed up nor tested:+--   PlatformPackages+--   PreferredVersions+--   CandidatePackages+--   IndexUsers+--   TarIndexMap++testBackupAction :: TestBackupFlags -> IO ()+testBackupAction opts = do+    defaults <- Server.defaultServerConfig++    let shouldTest  = fromFlagOrDefault (const True) (flip isInfixOf `fmap` flagTestBackupFeatures opts)+        shouldTestM = \(name, _) -> if shouldTest name then putStrLn ("Testing " ++ name) >> return True+                                                       else putStrLn ("Skipping " ++ name) >> return False++    let stateDir    = fromFlagOrDefault (confStateDir  defaults) (flagTestBackupStateDir  opts)+        staticDir   = fromFlagOrDefault (confStaticDir defaults) (flagTestBackupStaticDir opts)+        testDir     = fromFlag (flagTestBackupTestDir  opts)+        linkBlobs   = fromFlag (flagTestBackupLinkBlobs opts)+        verbosity   = fromFlag (flagTestBackupVerbosity opts)+        config      = defaults {+                        confStateDir  = stateDir,+                        confStaticDir = staticDir,+                        confTmpDir    = testDir,+                        confVerbosity = verbosity+                      }++    let dump1Dir    = testDir </> "dump-1"+        restoreDir  = testDir </> "restore"+        dump2Dir    = testDir </> "dump-2"+        tarDumpName = "test-dump"+        dump1Tar    = dump1Dir </> tarDumpName <.> "tar.gz"+        dump2Tar    = dump2Dir </> tarDumpName <.> "tar.gz"++    existsAlready <- doesDirectoryExist testDir+    when existsAlready $ do+      entries <- filter (`notElem` [".", ".."]) <$> getDirectoryContents testDir+      unless (null entries) $+        fail $ "The directory " ++ testDir ++ " contains files. Please remove "+            ++ "or clear it, or select a different one with the --test-dir "+            ++ "flag. (The test procedure needs a clean working area.)"+    mapM_ (createDirectoryIfMissing False) [testDir, dump1Dir, restoreDir, dump2Dir]++    withServer config False $ \server -> do+      let fullState = Server.serverState server+          store = Server.serverBlobStore (Server.serverEnv server)++      state <- filterM shouldTestM fullState++      -- We want to check that our dump/restore correctly preserves all the+      -- data. So we want to do a round trip test, and though it's nice to do+      -- QC tests on each feature's backingup, it adds a lot of confidence to+      -- be able to do a self-test using the full data of your server instance.+      --+      -- Ok, so there are two ways to do a round trip test: compare the internal+      -- representations or compare the external representations. Our strategy+      -- is to do both.+      --+      -- We start with all the data in the server in the internal+      -- representation. We start by writing it all out in the external+      -- representation.+      --+      dumpServerBackup verbosity dump1Dir (Just tarDumpName) store linkBlobs+                       (map (second abstractStateBackup) state)++      -- Now what we need to do is to keep hold of our current internal state+      -- and construct an extra internal state by restoring from the external+      -- representation that we wrote out previously.+      --+      -- And we can do just that. We've set things up so that every feature in+      -- the server has the capability to initialise a new empty copy of+      -- it's state. That's what abstractStateEmptyCopy does. In addition to+      -- that we get back a comparison action, that when executed will look at+      -- the current value of the state and compare the two, reporting any+      -- mismatches.+      --+      -- So we initialise all these new empty copies, (collecting the comparison+      -- actions)+      --+      (state', compareSts) <-+        unzip <$> sequence+                    [ do (st', cmpSt) <- abstractStateNewEmpty st restoreDir+                         let annotateErr err = featurename ++ ": " ++ err+                         return ((featurename, st'), map annotateErr <$> cmpSt)++                    | (featurename, st) <- state ]++      -- We also need a corresponding empty blob store+      store' <- BlobStorage.open (restoreDir </> "blobs")++      -- And then restore from the external representation into these new empty+      -- copies.+      loginfo verbosity "Restoring from backup tarball"+      res <- restoreServerBackup store' dump1Tar linkBlobs+                                 (map (second abstractStateRestore) state')+      case res of+        Nothing  -> return ()+        Just err -> fail $ "Error while restoring the backup:\n" ++ err++      -- Write second tarball so that if some of the comparisons go wrong,+      -- we can look at the second backup tarball and manually do some+      -- comparisons+      lognotice verbosity "Preparing second export tarball"+      dumpServerBackup verbosity dump2Dir (Just tarDumpName) store' linkBlobs+                       (map (second abstractStateBackup) state')++      -- Now we are in a position to check that the original internal state and+      -- the new internal state we get from a dump/restore do actually match up.+      lognotice verbosity "Comparing snapshots before and after dump/restore..."+      stErrs <- concat <$> sequence compareSts+      unless (null stErrs) $ do+        mapM_ (loginfo verbosity) stErrs+        let failLogfile = testDir </> "round-trip-failure.log"+        writeFile failLogfile (intercalate "\n\n" stErrs)+        fail $ "Snapshot check failed!  Log written to " ++ failLogfile+      lognotice verbosity "Snapshots match"++      -- So that was all checking the internal representations matched up after+      -- a round trip. We can also check the external representations match+      -- after a round trip.+      lognotice verbosity "Comparing export tarballs..."+      tar  <- GZip.decompressNamed dump1Tar <$> BS.readFile dump1Tar+      tar' <- GZip.decompressNamed dump2Tar <$> BS.readFile dump2Tar+      let tarErrs = tar `equalTarBall` tar'+      unless (null tarErrs) $ do+        mapM_ (loginfo verbosity) tarErrs+        let failLogfile = testDir </> "round-trip-failure.log"+        writeFile failLogfile (intercalate "\n\n" tarErrs)+        fail $ "Tarballs don't match! Tarballs written to "+            ++ dump1Tar ++ " and " ++ dump2Tar+            ++ " and log written to " ++ failLogfile+      lognotice verbosity "Tarballs match"++-------------------------------------------------------------------------------+-- Restore command+--++data RestoreFlags = RestoreFlags {+    flagRestoreVerbosity :: Flag Verbosity,+    flagRestoreStateDir  :: Flag FilePath,+    flagRestoreStaticDir :: Flag FilePath+  }++defaultRestoreFlags :: RestoreFlags+defaultRestoreFlags = RestoreFlags {+    flagRestoreVerbosity = Flag Verbosity.normal,+    flagRestoreStateDir  = NoFlag,+    flagRestoreStaticDir = NoFlag+  }++restoreCommand :: CommandUI RestoreFlags+restoreCommand = makeCommand name shortDesc longDesc defaultRestoreFlags options+  where+    name       = "restore"+    shortDesc  = "Restore server state from a backup tarball."+    longDesc   = Just $ \_ ->+                 "Note that this creates a new server state, so for safety "+              ++ "it requires that the\nserver not be initialised already.\n"+    options _  =+      [ optionVerbosity+          flagRestoreVerbosity (\v flags -> flags { flagRestoreVerbosity = v })+      , optionStateDir+          flagRestoreStateDir (\v flags -> flags { flagRestoreStateDir = v })+      , optionStaticDir+          flagRestoreStaticDir (\v flags -> flags { flagRestoreStaticDir = v })+      ]++restoreAction :: RestoreFlags -> [String] -> IO ()+restoreAction _ [] = die "No restore tarball given."+restoreAction opts [tarFile] = do+    defaults <- Server.defaultServerConfig++    let stateDir  = fromFlagOrDefault (confStateDir  defaults) (flagRestoreStateDir  opts)+        staticDir = fromFlagOrDefault (confStaticDir defaults) (flagRestoreStaticDir opts)+        verbosity = fromFlag (flagRestoreVerbosity opts)+        config    = defaults {+                      confStateDir  = stateDir,+                      confStaticDir = staticDir,+                      confVerbosity = verbosity+                    }++    checkAccidentalDataLoss =<< Server.hasSavedState config++    withServer config False $ \server -> do+        let state = Server.serverState server+            store = Server.serverBlobStore (Server.serverEnv server)++        loginfo verbosity "Parsing import tarball..."+        res <- restoreServerBackup store tarFile False+                                   (map (second abstractStateRestore) state)+        case res of+            Just err -> fail err+            _ ->+                do createDirectory (stateDir </> "tmp")+                   lognotice verbosity "Successfully imported."+restoreAction _ _ = die "There should be exactly one argument: the backup tarball."+++-------------------------------------------------------------------------------+-- common action functions+--++withServer :: ServerConfig -> Bool -> (Server -> IO a) -> IO a+withServer config doTemp = bracket initialise shutdown+  where+    initialise = do+      mtemp <- case doTemp of+          True  -> do+            loginfo verbosity "Setting up temp sever"+            fmap Just $ Server.setUpTemp config 1+          False -> return Nothing+      loginfo verbosity "Initializing happstack-state..."+      server <- Server.initialise config+      loginfo verbosity "Server data loaded into memory"+      void $ forM mtemp $ \temp -> do+        loginfo verbosity "Tearing down temp server"+        Server.tearDownTemp temp+      return server++    shutdown server = do+      -- This only shuts down happstack-state and writes a checkpoint;+      -- the HTTP part takes care of itself+      loginfo verbosity "Shutting down..."+      Server.shutdown server++    verbosity = confVerbosity config++-- Import utilities+checkAccidentalDataLoss :: Bool -> IO ()+checkAccidentalDataLoss hasSavedState =+    when hasSavedState . die $+        "The server already has an initialised database!!\n"+     ++ "If you really *really* intend to completely reset the "+     ++ "whole database you should remove the state/ directory."++-- option utility+reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description+           -> (a -> Flag String) -> (Flag String -> a -> a)+           -> OptDescr a+reqArgFlag ad = reqArg' ad Flag flagToList+
+ MirrorClient.hs view
@@ -0,0 +1,933 @@+{-# LANGUAGE PatternGuards, GeneralizedNewtypeDeriving,+             MultiParamTypeClasses, FlexibleInstances, CPP #-}+module Main where++import Network.HTTP+import Network.Browser+import Network.URI (URI(..), URIAuth(..))++import Distribution.Client (validateHackageURI, validatePackageIds, PkgIndexInfo(..))+import Distribution.Client.UploadLog as UploadLog (read, Entry(..))+import Distribution.Client.Cron (cron, rethrowSignalsAsExceptions, Signal(..))+import Distribution.Server.Util.Parse (packUTF8, unpackUTF8)++import Distribution.Server.Users.Types (UserId(..), UserName(UserName))+import Distribution.Server.Util.Index as PackageIndex (read)+import Distribution.Server.Util.Merge+import Distribution.Package+import Distribution.Version+import Distribution.Text+import Distribution.Verbosity+import Distribution.Simple.Utils hiding (warn)++import Data.List+import Data.Maybe+import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Error+import Control.Monad.State+import Control.Monad.Reader+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BS+import qualified Distribution.Server.Util.GZip as GZip+import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Data.Set as Set+import Data.Set (Set)+import Data.IORef++import Control.Exception+import Data.Time+import Data.Time.Clock.POSIX+import System.Locale+import System.Environment+import System.IO+import System.Exit+import System.FilePath+import System.Directory+import System.Console.GetOpt+import qualified System.FilePath.Posix as Posix++#if __GLASGOW_HASKELL__ >= 706+import System.IO.Error+#else+import System.IO.Error hiding (catch)+import Prelude hiding (catch)+#endif++import Paths_hackage_server (version)++data MirrorOpts = MirrorOpts {+                    srcURI       :: URI,+                    dstURI       :: URI,+                    stateDir     :: FilePath,+                    selectedPkgs :: [PackageId],+                    continuous   :: Maybe Int, -- if so, interval in minutes+                    mo_keepGoing    :: Bool+                  }++data MirrorEnv = MirrorEnv {+                   me_srcCacheDir :: FilePath,+                   me_dstCacheDir :: FilePath,+                   me_missingPkgsFile      :: FilePath,+                   me_unmirrorablePkgsFile :: FilePath+                 }+  deriving Show++data MirrorState = MirrorState {+                     ms_missingPkgs          :: Set PackageId,+                     ms_unmirrorablePkgs     :: Set PackageId+                   }+  deriving (Eq, Show)++main :: IO ()+main = toplevelHandler $ do+  rethrowSignalsAsExceptions [SIGABRT, SIGINT, SIGQUIT, SIGTERM]+  hSetBuffering stdout LineBuffering++  args <- getArgs+  (verbosity, opts) <- validateOpts args++  (env, st) <- mirrorInit verbosity opts+++  case continuous opts of+    Nothing       -> mirrorOneShot verbosity opts env st+    Just interval -> cron verbosity interval+                          (mirrorIteration verbosity opts env) st+++mirrorInit :: Verbosity -> MirrorOpts -> IO (MirrorEnv, MirrorState)+mirrorInit verbosity opts = do++    let srcName     = mkCacheFileName (srcURI opts)+        dstName     = mkCacheFileName (dstURI opts)+        srcCacheDir = stateDir opts </> srcName+        dstCacheDir = stateDir opts </> dstName++    when (srcCacheDir == dstCacheDir) $+      die "source and destination cache files clash"++    when (continuous opts == Just 0) $+      warn verbosity "A sync interval of zero is a seriously bad idea!"++    when (isOldHackageURI (srcURI opts)+       && maybe False (<30) (continuous opts)) $+       die $ "Please don't hit the central hackage.haskell.org "+          ++ "more frequently than every 30 minutes."++    createDirectoryIfMissing False (stateDir opts)+    createDirectoryIfMissing False srcCacheDir+    createDirectoryIfMissing False dstCacheDir++    let missingPkgsFile      = stateDir opts+                           </> "missing-" ++ srcName+        -- being unmirrorable is a function of the combination of the source and+        -- destination, so the cache file uses both names.+        unmirrorablePkgsFile = stateDir opts+                           </> "unmirrorable-" ++ srcName ++ "-" ++ dstName+    missingPkgs      <- readPkgProblemFile missingPkgsFile+    unmirrorablePkgs <- readPkgProblemFile unmirrorablePkgsFile++    return (MirrorEnv srcCacheDir dstCacheDir+                      missingPkgsFile unmirrorablePkgsFile+           ,MirrorState missingPkgs unmirrorablePkgs)+  where+    mkCacheFileName :: URI -> FilePath+    mkCacheFileName URI { uriAuthority = Just auth }+                        = makeValid (uriRegName auth ++ uriPort auth)+    mkCacheFileName uri = error $ "unexpected URI " ++ show uri+++readPkgProblemFile :: FilePath -> IO (Set PackageId)+readPkgProblemFile file = do+  exists <- doesFileExist file+  if exists+    then evaluate . Set.fromList+                  . catMaybes . map simpleParse . lines+                =<< readFile file+    else return Set.empty++writePkgProblemFile :: FilePath -> Set PackageId -> IO ()+writePkgProblemFile file =+  writeFile file . unlines . map display . Set.toList+++---------------------------+-- Main mirroring logic+---------------------------++mirrorOneShot :: Verbosity -> MirrorOpts -> MirrorEnv -> MirrorState -> IO ()+mirrorOneShot verbosity opts env st = do++    (merr, _) <- mirrorOnce verbosity opts env st++    case merr of+      Nothing -> return ()+      Just theError -> fail (formatMirrorError theError)+++mirrorIteration :: Verbosity -> MirrorOpts -> MirrorEnv+                -> MirrorState -> IO MirrorState+mirrorIteration verbosity opts env st = do++    (merr, st') <- mirrorOnce verbosity opts { mo_keepGoing = True } env st++    when (st' /= st) $+      savePackagesState env st'++    case merr of+      Nothing          -> return ()+      Just Interrupted -> throw UserInterrupt+      Just theError         -> do+        warn verbosity (formatMirrorError theError)+        notice verbosity "Abandoning this mirroring attempt."+    return st'+++savePackagesState :: MirrorEnv  -> MirrorState -> IO ()+savePackagesState (MirrorEnv _ _ missingPkgsFile unmirrorablePkgsFile)+                  (MirrorState missingPkgs unmirrorablePkgs) = do+  writePkgProblemFile missingPkgsFile      missingPkgs+  writePkgProblemFile unmirrorablePkgsFile unmirrorablePkgs+++mirrorOnce :: Verbosity -> MirrorOpts -> MirrorEnv+           -> MirrorState -> IO (Maybe MirrorError, MirrorState)+mirrorOnce verbosity opts+           (MirrorEnv srcCacheDir dstCacheDir missingPkgsFile unmirrorablePkgsFile)+           st@(MirrorState missingPkgs unmirrorablePkgs) =++    mirrorSession (mo_keepGoing opts) $ do++      srcIndex <- downloadIndex (srcURI opts) srcCacheDir+      dstIndex <- downloadIndex (dstURI opts) dstCacheDir++      let pkgsMissingFromDest = diffIndex srcIndex dstIndex+          pkgsToMirror+            | null (selectedPkgs opts) = pkgsMissingFromDest+            | otherwise                = subsetIndex (selectedPkgs opts)+                                                     pkgsMissingFromDest+          pkgsToMirror' = filter (\(PkgIndexInfo pkg _ _ _) ->+                                     pkg `Set.notMember` missingPkgs+                                  && pkg `Set.notMember` unmirrorablePkgs )+                                 pkgsToMirror+          mirrorCount   = length pkgsToMirror'+          ignoreCount   = length pkgsToMirror - mirrorCount++      liftIO $ notice verbosity $+          show mirrorCount ++ " packages to mirror."+       ++ if ignoreCount == 0 then ""+            else " Ignoring " ++ show ignoreCount+              ++ " package(s) that cannot be mirrored\n(for details see "+              ++ missingPkgsFile ++ " and " ++ unmirrorablePkgsFile ++ ")"++      mirrorPackages verbosity opts pkgsToMirror'++  where+    mirrorSession :: Bool+                  -> MirrorSession a -> IO (Maybe MirrorError, MirrorState)+    mirrorSession keepGoing action =+      liftM (\(eerr, st') -> (either Just (const Nothing) eerr,+                              fromErrorState st')) $+      runMirrorSession verbosity keepGoing (toErrorState st) $ do+        browserAction $ do+          setUserAgent  ("hackage-mirror/" ++ display version)+          setErrHandler (warn  verbosity)+          setOutHandler (debug verbosity)+          setAllowBasicAuth True+          setCheckForProxy True+        action+++diffIndex :: [PkgIndexInfo] -> [PkgIndexInfo] -> [PkgIndexInfo]+diffIndex as bs =+    [ pkg | OnlyInLeft pkg <- mergeBy (comparing mirrorPkgId)+                                       (sortBy (comparing mirrorPkgId) as)+                                       (sortBy (comparing mirrorPkgId) bs) ]+  where+    mirrorPkgId (PkgIndexInfo pkgid _ _ _) = pkgid++subsetIndex :: [PackageId] -> [PkgIndexInfo] -> [PkgIndexInfo]+subsetIndex pkgids =+    filter (\(PkgIndexInfo pkgid' _ _ _) -> anyMatchPackage pkgid')+  where+    anyMatchPackage :: PackageId -> Bool+    anyMatchPackage pkgid' =+      any (\pkgid -> matchPackage pkgid pkgid') pkgids++    matchPackage :: PackageId -> PackageId -> Bool+    matchPackage (PackageIdentifier name  (Version [] _))+                 (PackageIdentifier name' _             ) = name == name'+    matchPackage pkgid pkgid' = pkgid == pkgid'+++mirrorPackages :: Verbosity -> MirrorOpts -> [PkgIndexInfo] -> MirrorSession ()+mirrorPackages verbosity opts pkgsToMirror = do++    let credentials = extractCredentials (dstURI opts)+    browserAction $ setAuthorityGen (provideAuthInfo credentials)++    mapM_ mirrorPackage pkgsToMirror++  where+    provideAuthInfo :: Maybe (String, String) -> URI -> String -> IO (Maybe (String, String))+    provideAuthInfo credentials = \uri _realm -> do+      if hostName uri == hostName (dstURI opts) then return credentials+                                                else return Nothing++    hostName = fmap uriRegName . uriAuthority++    extractCredentials uri+      | Just authority <- uriAuthority uri+      , (username, ':':passwd0) <- break (==':') (uriUserInfo authority)+      , let passwd = takeWhile (/='@') passwd0+      , not (null username)+      , not (null passwd)+      = Just (username, passwd)+    extractCredentials _ = Nothing++    mirrorPackage pkginfo@(PkgIndexInfo pkgid _ _ _) = do+      let srcPackage = if isOldHackageURI (srcURI opts)+              then "packages" </> "archive"+                    </> display (packageName pkgid)+                    </> display (packageVersion pkgid)+              else "package" </> display pkgid+          srcBase = srcURI opts <//> srcPackage+          dstBase = dstURI opts+                    <//> "package"+                    </> display pkgid++          srcTgz  = srcBase <//> display pkgid <.> "tar.gz"+          srcCab  = srcBase <//> display (packageName pkgid) <.> "cabal"++          locTgz  = stateDir opts </> display pkgid <.> "tar.gz"+          locCab  = stateDir opts </> display pkgid <.> "cabal"++      liftIO $ notice verbosity $ "mirroring " ++ display pkgid+      rsp <- browserActions [+                 downloadFile' srcCab locCab+               , downloadFile' srcTgz locTgz+               ]+      case rsp of+        Just theError ->+          notifyResponse (GetPackageFailed theError pkgid)+        Nothing -> do+          notifyResponse GetPackageOk+          putPackage dstBase pkginfo locCab locTgz++putPackage :: URI -> PkgIndexInfo -> FilePath -> FilePath -> MirrorSession ()+putPackage baseURI (PkgIndexInfo pkgid mtime muname _muid) locCab locTgz = do+    cab <- liftIO $ BS.readFile locCab+    tgz <- liftIO $ BS.readFile locTgz++    rsp <- browserActions [+        requestPUT cabURI "text/plain" cab+      , requestPUT tgzURI "application/x-gzip" tgz+      , maybe (return Nothing) putPackageUploadTime mtime+      , maybe (return Nothing) putPackageUploader muname+      ]++    case rsp of+      Just theError ->+        notifyResponse (PutPackageFailed theError pkgid)+      Nothing -> do+        notifyResponse PutPackageOk+        liftIO $ removeFile locCab+        liftIO $ removeFile locTgz++      -- TODO: think about in what situations we delete the file+      -- and if we should actually cache it if we don't sucessfully upload.++      -- TODO: perhaps we shouldn't report failure for the whole package if+      -- we fail to set the upload time/uploader+  where+    cabURI = baseURI <//> display (packageName pkgid) <.> "cabal"+    tgzURI = baseURI <//> display pkgid               <.> "tar.gz"++    putPackageUploadTime time = do+      let timeStr = formatTime defaultTimeLocale "%c" time+      requestPUT (baseURI <//> "upload-time") "text/plain" (packUTF8 timeStr)++    putPackageUploader uname = do+      let nameStr = display uname+      requestPUT (baseURI <//> "uploader") "text/plain" (packUTF8 nameStr)++-----------------------------+-- Error handling strategy+-----------------------------++-- There's two general classes of errors we have to consider:+--  - systematic errors that apply to all packages+--  - errors that only apply to individual packages+--+-- For the first class we want to fail and not continue mirroring.+--+-- For the second class we want to keep going and try mirroring other packages.+-- In addition we want to remember the packages involved persistently so that+-- we don't keep trying again and again to mirror packages that simply cannot+-- be mirrored.+--+-- We want the mirroring to be robust. So we don't want to have temporary or+-- individual package errors make us fail overall.+--+-- To add further complication, it can be hard to distinguish a systematic+-- error from an individual per-package error. Our strategy may have to be+-- complex and based on counting various events to make best guesses.+--+-- Since we expect our error handling stategy we try to separate it from the+-- main mirroring logic.+--+-- We make a new monad to hold the plumbing for our strategy. We make it to+-- be a state monad so that we can accumulating info about non-fatal errors in+-- individual packages. We make it an error monad to deal with fatal errors.+--+-- We layer state and error on top of the HTTP Browser monad. The layering+-- order of the state vs error is such that errors do not roll back the changed+-- state. This is because we want (at least the option) to keep the info about+-- individual packages when we encounter a systematic error.+--++newtype MirrorSession a+      = MirrorSession {+          unMirror :: ErrorT MirrorError+                        (ReaderT (Verbosity, Bool, IORef ErrorState)+                          (BrowserAction (HandleStream ByteString)))+                        a+        }+  deriving (Functor, Monad, MonadIO,+            MonadError MirrorError)++instance MonadReader (Verbosity, Bool) MirrorSession where+  ask       = MirrorSession (fmap (\(x,y,_) -> (x,y)) ask)+  local f m = MirrorSession (local f' (unMirror m))+                where+                  f' (x,y,z) = (x',y',z) where (x',y') = f (x,y)++instance MonadState ErrorState MirrorSession where+  get   = MirrorSession (ask >>= \(_,_,stRef) -> liftIO (readIORef stRef))+  put x = MirrorSession (ask >>= \(_,_,stRef) -> liftIO (writeIORef stRef x))++browserAction :: BrowserAction (HandleStream ByteString) a -> MirrorSession a+browserAction = MirrorSession . lift . lift++browserActions :: [BrowserAction (HandleStream ByteString) (Maybe ErrorResponse)] -> MirrorSession (Maybe ErrorResponse)+browserActions = foldr1 maybeThen . map browserAction+  where+    -- Bind for the strange not-quite-monad where errors are returned as+    -- (Just err) and success is returned as Nothing+    maybeThen :: Monad m => m (Maybe err) -> m (Maybe err) -> m (Maybe err)+    maybeThen p q = do+      res <- p+      case res of+        Just theError -> return (Just theError)+        Nothing       -> q++runMirrorSession :: Verbosity -> Bool -> ErrorState -> MirrorSession a+                 -> IO (Either MirrorError a, ErrorState)+runMirrorSession verbosity keepGoing st (MirrorSession m) = do+  stRef <- newIORef st+  result <- browse (runReaderT (runErrorT m) (verbosity, keepGoing, stRef))+              `catch` (return . Left . MirrorIOError)+              `catch` \ae -> case ae of+                               UserInterrupt -> return (Left Interrupted)+                               _             -> throw ae++  st' <- readIORef stRef+  return (result, st')+++-- So that's the plumbing. The actual policy/strategy is implemented by an+-- action in the monad where we inform it of the interesting events, which is+-- basically all the gets and puts, the packages and their http response codes.+-- This policy action behaves like a state machine action, updating the monad+-- state and if it decides it has to fail hard, by making use of error monad.++data MirrorError = MirrorGeneralError String+                 | MirrorIOError IOError+                 | GetEntityError Entity ErrorResponse+                 | ParseEntityError Entity URI String+                 | PutPackageError PackageId ErrorResponse+                 | Interrupted+  deriving Show++data Entity = EntityIndex | EntityLog | EntityPackage PackageId+  deriving Show++instance Error MirrorError where+  strMsg = MirrorGeneralError++formatMirrorError :: MirrorError -> String+formatMirrorError (MirrorGeneralError msg)  = msg+formatMirrorError (MirrorIOError      ioe)  = formatIOError ioe+formatMirrorError (GetEntityError entity rsp) =+    "Failed to download " ++ formatEntity entity+ ++ ",\n  " ++ formatErrorResponse rsp+formatMirrorError (ParseEntityError entity uri theError) =+    "Error parsing " ++ formatEntity entity+ ++ " at " ++ show uri ++ ": " ++ theError+formatMirrorError (PutPackageError pkgid rsp) =+    "Failed to upload package "  ++ display pkgid+ ++ ",\n  " ++ formatErrorResponse rsp+formatMirrorError Interrupted = error "formatMirrorError: Interrupted"++formatEntity :: Entity -> String+formatEntity EntityIndex           = "the package index"+formatEntity EntityLog             = "the package upload log"+formatEntity (EntityPackage pkgid) = "package " ++ display pkgid++data ErrorState = ErrorState {+                    es_missing      :: Set PackageId,+                    es_unmirrorable :: Set PackageId+                  }+  deriving Show++toErrorState :: MirrorState -> ErrorState+toErrorState (MirrorState missing unmirrorable) =+  ErrorState missing unmirrorable++fromErrorState :: ErrorState -> MirrorState+fromErrorState (ErrorState missing unmirrorable) =+  MirrorState missing unmirrorable++data MirrorEvent = GetIndexOk+                 | GetPackageOk | GetPackageFailed ErrorResponse PackageId+                 | PutPackageOk | PutPackageFailed ErrorResponse PackageId++notifyResponse :: MirrorEvent -> MirrorSession ()+notifyResponse e = do+    st <- get+    (verbosity, keepGoing) <- ask+    st' <- handleEvent verbosity keepGoing st+    put st'+  where+    handleEvent _ False st = case e of+      GetIndexOk   -> return st+      GetPackageOk -> return st+      PutPackageOk -> return st+      GetPackageFailed rsp pkgid ->+        throwError (GetEntityError (EntityPackage pkgid) rsp)+      PutPackageFailed rsp pkgid ->+        throwError (PutPackageError pkgid rsp)++    handleEvent verbosity True st = case e of+      GetIndexOk   -> return st+      GetPackageOk -> return st+      PutPackageOk -> return st+      GetPackageFailed rsp@(ErrorResponse _ code _ _) pkgid+        | code == (4,0,4) -> do+            liftIO $ warn verbosity $+              formatMirrorError (GetEntityError (EntityPackage pkgid) rsp)+            return st {+              es_missing = Set.insert pkgid (es_missing st)+            }+        | otherwise -> throwError (GetEntityError (EntityPackage pkgid) rsp)++      PutPackageFailed rsp@(ErrorResponse _ code _ _) pkgid+        | code == (4,0,0) || code == (4,0,4) -> do+            liftIO $ warn verbosity $+              formatMirrorError (PutPackageError pkgid rsp)+            return st {+              es_unmirrorable = Set.insert pkgid (es_unmirrorable st)+            }+        | otherwise -> throwError (PutPackageError pkgid rsp)+++----------------------------------------------------+-- Fetching info from source and destination servers+----------------------------------------------------++downloadIndex :: URI -> FilePath -> MirrorSession [PkgIndexInfo]+downloadIndex uri | isOldHackageURI uri = downloadOldIndex uri+                  | otherwise           = downloadNewIndex uri+  where++isOldHackageURI :: URI -> Bool+isOldHackageURI uri+  | Just auth <- uriAuthority uri = uriRegName auth == "hackage.haskell.org"+  | otherwise                     = False+++downloadOldIndex :: URI -> FilePath -> MirrorSession [PkgIndexInfo]+downloadOldIndex uri cacheDir = do++    rsp1 <- browserAction $ downloadFile indexURI indexFile+    case rsp1 of+      Nothing       -> notifyResponse GetIndexOk+      Just theError -> throwError (GetEntityError EntityIndex theError)++    rsp2 <- browserAction $ downloadFile logURI logFile+    case rsp2 of+      Nothing       -> notifyResponse GetIndexOk+      Just theError -> throwError (GetEntityError EntityLog theError)++    res1 <- liftIO $+      withFile indexFile ReadMode $ \hnd ->+        evaluate . PackageIndex.read (\pkgid _ -> pkgid)+                 . GZip.decompressNamed indexFile+               =<< BS.hGetContents hnd+    pkgids <- case res1 of+      Left  theError -> throwError (ParseEntityError EntityIndex uri theError)+      Right pkgs     -> return pkgs++    res2 <- liftIO $+      withFile logFile ReadMode $ \hnd ->+        evaluate . UploadLog.read =<< hGetContents hnd+    theLog <- case res2 of+      Left  theError -> throwError (ParseEntityError EntityLog uri theError)+      Right theLog   -> return theLog++    return (mergeLogInfo pkgids theLog)++  where+    indexURI  = uri <//> "packages" </> "archive" </> "00-index.tar.gz"+    indexFile = cacheDir </> "00-index.tar.gz"++    logURI    = uri <//> "packages" </> "archive" </> "log"+    logFile   = cacheDir </> "log"++    mergeLogInfo pkgids theLog =+        catMaybes+      . map selectDetails+      $ mergeBy (\pkgid entry -> compare pkgid (entryPkgId entry))+                (sort pkgids)+                ( map (maximumBy (comparing entryTime))+                . groupBy (equating  entryPkgId)+                . sortBy  (comparing entryPkgId)+                $ theLog )++    selectDetails (OnlyInRight _)     = Nothing+    selectDetails (OnlyInLeft  pkgid) =+      Just $ PkgIndexInfo pkgid Nothing Nothing Nothing+    selectDetails (InBoth pkgid (UploadLog.Entry time uname _)) =+      Just $ PkgIndexInfo pkgid (Just time) (Just uname) Nothing++    entryPkgId (Entry _ _ pkgid) = pkgid+    entryTime  (Entry time _ _)  = time+++downloadNewIndex :: URI -> FilePath -> MirrorSession [PkgIndexInfo]+downloadNewIndex uri cacheDir = do+    rsp <- browserAction $ downloadFile indexURI indexFile+    case rsp of+      Just theError -> throwError (GetEntityError EntityIndex theError)+      Nothing -> do+        notifyResponse GetIndexOk+        res <- liftIO $ withFile indexFile ReadMode $ \hnd ->+                 evaluate . PackageIndex.read selectDetails+                          . GZip.decompressNamed indexFile+                        =<< BS.hGetContents hnd+        case res of+          Left  theError -> throwError (ParseEntityError EntityIndex uri theError)+          Right pkgs     -> return pkgs++  where+    indexURI  = uri <//> "packages/00-index.tar.gz"+    indexFile = cacheDir </> "00-index.tar.gz"++    selectDetails :: PackageId -> Tar.Entry -> PkgIndexInfo+    selectDetails pkgid entry =+        PkgIndexInfo+          pkgid+          (Just time)+          (if null username then Nothing else Just (UserName username))+          (if userid == 0   then Nothing else Just (UserId userid))+      where+        time     = epochTimeToUTC (Tar.entryTime entry)+        username = Tar.ownerName (Tar.entryOwnership entry)+        userid   = Tar.ownerId   (Tar.entryOwnership entry)++        epochTimeToUTC :: Tar.EpochTime -> UTCTime+        epochTimeToUTC = posixSecondsToUTCTime . realToFrac+++-------------------------+-- HTTP utilities+-------------------------++infixr 5 <//>++(<//>) :: URI -> FilePath -> URI+uri <//> path = uri { uriPath = Posix.addTrailingPathSeparator (uriPath uri)+                                Posix.</> path }+++type HttpSession a = BrowserAction (HandleStream ByteString) a++downloadFile :: URI -> FilePath -> HttpSession (Maybe ErrorResponse)+downloadFile uri file = do+  out $ "downloading " ++ show uri ++ " to " ++ file+  let etagFile = file <.> "etag"+  metag <- liftIO $ catchJustDoesNotExistError+                        (Just <$> readFile etagFile)+                        (\_ -> return Nothing)+  case metag of+    Just etag -> do+      let headers = [mkHeader HdrIfNoneMatch (quote etag)]+      (_, rsp) <- request (Request uri GET headers BS.empty)+      case rspCode rsp of+        (3,0,4) -> do out $ file ++ " unchanged with ETag " ++ etag+                      return Nothing+        (2,0,0) -> do liftIO $ writeDowloadedFileAndEtag rsp+                      return Nothing+        _       -> return (Just (mkErrorResponse uri rsp))++    Nothing -> do+      (_, rsp) <- request (Request uri GET [] BS.empty)+      case rspCode rsp of+        (2,0,0) -> do liftIO $ writeDowloadedFileAndEtag rsp+                      return Nothing+        _       -> return (Just (mkErrorResponse uri rsp))++  where+    writeDowloadedFileAndEtag rsp = do+      BS.writeFile file (rspBody rsp)+      setETag file (unquote <$> findHeader HdrETag rsp)++getETag :: FilePath -> IO (Maybe String)+getETag file =+    catchJustDoesNotExistError+      (Just <$> readFile (file </> ".etag"))+      (\_ -> return Nothing)++setETag :: FilePath -> Maybe String -> IO ()+setETag file Nothing     = catchJustDoesNotExistError+                             (removeFile (file <.> "etag"))+                             (\_ -> return ())+setETag file (Just etag) = writeFile  (file <.> "etag") etag++catchJustDoesNotExistError :: IO a -> (IOError -> IO a) -> IO a+catchJustDoesNotExistError =+  catchJust (\e -> if isDoesNotExistError e then Just e else Nothing)++quote :: String -> String+quote   s = '"' : s ++ ['"']++unquote :: String -> String+unquote ('"':s) = go s+  where+    go []       = []+    go ('"':[]) = []+    go (c:cs)   = c : go cs+unquote     s   = s+++downloadFile' :: URI -> FilePath -> HttpSession (Maybe ErrorResponse)+downloadFile' uri file = do+  out $ "downloading " ++ show uri ++ " to " ++ file+  rsp <- requestGET uri+  case rsp of+    Left  theError -> return (Just theError)+    Right content  -> do liftIO $ BS.writeFile file content+                         --TODO: check we wrote the expected length.+                         return Nothing++requestGET :: URI -> HttpSession (Either ErrorResponse ByteString)+requestGET uri = do+    (_, rsp) <- request (Request uri GET headers BS.empty)+    case rspCode rsp of+      (2,0,0) -> return (Right (rspBody rsp))+      _       -> return (Left  (mkErrorResponse uri rsp))+  where+    headers = []+++requestPUT :: URI -> String -> ByteString -> HttpSession (Maybe ErrorResponse)+requestPUT uri mimetype body = do+    (_, rsp) <- request (Request uri PUT headers body)+    case rspCode rsp of+      (2,_,_) -> return Nothing+      _       -> return (Just (mkErrorResponse uri rsp))+  where+    headers = [ Header HdrContentLength (show (BS.length body))+              , Header HdrContentType mimetype ]++data ErrorResponse = ErrorResponse URI ResponseCode String (Maybe String)+  deriving Show++mkErrorResponse :: URI -> Response ByteString -> ErrorResponse+mkErrorResponse uri rsp =+    ErrorResponse uri (rspCode rsp) (rspReason rsp) mBody+  where+    mBody = case lookupHeader HdrContentType (rspHeaders rsp) of+      Just mimetype | "text/plain" `isPrefixOf` mimetype+                   -> Just (unpackUTF8 (rspBody rsp))+      _            -> Nothing++formatErrorResponse :: ErrorResponse -> String+formatErrorResponse (ErrorResponse uri (a,b,c) reason mBody) =+    "HTTP error code " ++ show a ++ show b ++ show c+ ++ ", " ++ reason ++ "\n  " ++  show uri+ ++ maybe "" (('\n':) . unlines . map ("  "++) . lines . wrapText) mBody++-------------------------+-- Command line handling+-------------------------++data MirrorFlags = MirrorFlags {+    flagCacheDir  :: Maybe FilePath,+    flagContinuous:: Bool,+    flagInterval  :: Maybe String,+    flagKeepGoing :: Bool,+    flagVerbosity :: Verbosity,+    flagHelp      :: Bool+}++defaultMirrorFlags :: MirrorFlags+defaultMirrorFlags = MirrorFlags+                       Nothing False Nothing False normal False++mirrorFlagDescrs :: [OptDescr (MirrorFlags -> MirrorFlags)]+mirrorFlagDescrs =+  [ Option ['h'] ["help"]+      (NoArg (\opts -> opts { flagHelp = True }))+      "Show this help text"++  , Option ['v'] []+      (NoArg (\opts -> opts { flagVerbosity = moreVerbose (flagVerbosity opts) }))+      "Verbose mode (can be listed multiple times e.g. -vv)"++  , Option [] ["cache-dir"]+      (ReqArg (\dir opts -> opts { flagCacheDir = Just dir }) "DIR")+      "Where to put downloaded files (default ./mirror-cache/)"++  , Option [] ["continuous"]+      (NoArg (\opts -> opts { flagContinuous = True }))+      "Mirror continuously rather than just once."++  , Option [] ["interval"]+      (ReqArg (\int opts -> opts { flagInterval = Just int }) "MIN")+      "Set the mirroring interval in minutes (default 30)"++  , Option [] ["keep-going"]+      (NoArg (\opts -> opts { flagKeepGoing = True }))+      "Don't fail on mirroring errors, keep going."+  ]++validateOpts :: [String] -> IO (Verbosity, MirrorOpts)+validateOpts args = do+    let (flags0, args', errs) = getOpt Permute mirrorFlagDescrs args+        flags = accum flags0 defaultMirrorFlags++    when (flagHelp flags) printUsage+    when (not (null errs)) (printErrors errs)++    case args' of+      (configFile:pkgstrs) -> do+        mFromTo <- readConfigFile configFile+        case mFromTo of+          Left theError -> die theError+          Right (fromURI, toURI) -> case (mpkgs, minterval) of+            (Left theError, _) -> die theError+            (_, Left theError) -> die theError+            (Right pkgs, Right interval) ->+               return $ (,) (flagVerbosity flags) MirrorOpts {+                   srcURI       = fromURI,+                   dstURI       = toURI,+                   stateDir     = fromMaybe "mirror-cache" (flagCacheDir flags),+                   selectedPkgs = pkgs,+                   continuous   = if flagContinuous flags+                                    then Just interval+                                    else Nothing,+                   mo_keepGoing    = flagKeepGoing flags+                 }+          where+            mpkgs     = validatePackageIds pkgstrs+            minterval = validateInterval (flagInterval flags)++      _ -> die $ "Expected path to a config file.\n"+              ++ "See hackage-mirror --help for details and an example."++  where+    printUsage = do+      putStrLn $ usageInfo usageHeader mirrorFlagDescrs ++ helpExampleStr+      exitSuccess+    usageHeader = helpDescrStr+               ++ "Usage: hackage-mirror configFile [packages] [options]\n\n"+               ++ "configFile should be a path to a file containing two lines:\n\n"+               ++ "    fromURL\n"+               ++ "    toURL\n\n"+               ++ "Options:"+    printErrors errs = die $ concat errs ++ "Try --help."++    accum flags = foldr (flip (.)) id flags++    validateInterval Nothing    = return 30 --default 30 min+    validateInterval (Just str) = do+      int <- case reads str of+               [(int,"")]  -> return int+               [(int,"m")] -> return int+               [(int,"h")] -> return (int * 60)+               _           -> Left ("expected a number of minutes, not '" ++ str ++ "'")+      if int < 0+        then Left "a negative mirroring interval is meaningless"+        else return int++readConfigFile :: FilePath -> IO (Either String (URI, URI))+readConfigFile configFile = runErrorT $ do+    config   <- ErrorT $ tryIO $ readFile configFile+    [fr, to] <- case lines config of+                  [fr, to] -> return [fr, to]+                  _        -> fail "Invalid config file format"+    frURI    <- ErrorT . return $ validateHackageURI fr+    toURI    <- ErrorT . return $ validateHackageURI to+    return (frURI, toURI)+  where+    tryIO :: IO a -> IO (Either String a)+    tryIO io = catch (Right `liftM` io) (\e -> return . Left $ show (e :: IOException))++helpDescrStr :: String+helpDescrStr = unlines+  [ "The hackage-mirror client copies packages from one hackage server to another."+  , "By default it copies over all packages that exist on the source but not on"+  , "the destination server. You can also select just specific packages to mirror."+  , "It is also possible to run the mirror in a continuous mode, giving you"+  , "nearly-live mirroring.\n"+  ]++helpExampleStr :: String+helpExampleStr = unlines+  [ "\nExample:"+  , "  Suppose we have:"+  , "  - source server: hackage.haskell.org"+  , "  - dest server:   localhost:8080"+  , "  Uploading packages almost always requires authentication, so suppose we have"+  , "  a user account for our mirror client with username 'foo' and password 'bar'."+  , "  We include the authentication details into the destination URL:"+  , "    http://foo:bar@localhost:8080/"+  , "  To test that it is working without actually syncing a Gb of data from"+  , "  hackage.haskell.org, we will specify to mirror only the 'zlib' package."+  , "  So overall we run:"+  , "    hackage-mirror ./mirror.cfg zlib"+  , "  where ./mirror.cfg contains"+  , "    http://hackage.haskell.org/"+  , "    http://foo:bar@localhost:8080/"+  , "  This will synchronise all versions of the 'zlib' package and then exit."+  ]++toplevelHandler :: IO a -> IO a+toplevelHandler =+    handle $ \ioe -> do+      hFlush stdout+      pname <- getProgName+      hPutStrLn stderr (pname ++ ": " ++ formatIOError ioe)+      exitWith (ExitFailure 1)++formatIOError :: IOError -> String+formatIOError ioe+  | isUserError ioe = file ++ location ++ detail+  | otherwise       = show ioe+  where+    file         = case ioeGetFileName ioe of+                     Nothing   -> ""+                     Just path -> path ++ ": "+    location     = case ioeGetLocation ioe of+                    ""  -> ""+                    loc -> loc ++ ": "+    detail       = ioeGetErrorString ioe++warn :: Verbosity -> String -> IO ()+warn verbosity msg =+  when (verbosity >= normal) $+    putStrLn ("Warning: " ++ msg)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ datafiles/static/built-with-cabal.png view

binary file changed (absent → 2939 bytes)

+ datafiles/static/cabal-tiny.png view

binary file changed (absent → 137 bytes)

+ datafiles/static/favicon.ico view

binary file changed (absent → 1150 bytes)

+ datafiles/static/hackage.css view
@@ -0,0 +1,570 @@+/* @group Fundamentals */++* { margin: 0; padding: 0 }++/* Is this portable? */+html {+  background-color: white;+  width: 100%;+  height: 100%;+}++body {+  background: white;+  color: black;+  text-align: left;+  min-height: 100%;+  position: relative;+}++p {+  margin: 0.8em 0;+}++ul, ol {+  margin: 0.8em 0 0.8em 2em;+}++dl {+  margin: 0.8em 0;+}++dt {+  font-weight: bold;+}+dd {+  margin-left: 2em;+}++a { text-decoration: none; }+a[href]:link { color: rgb(196,69,29); }+a[href]:visited { color: rgb(171,105,84); }+a[href]:hover { text-decoration:underline; }++/* @end */++/* @group Fonts & Sizes */++/* Basic technique & IE workarounds from YUI 3+   For reasons, see:+      http://yui.yahooapis.com/3.1.1/build/cssfonts/fonts.css+ */+ +body {+	font:11pt/1.4 sans-serif;+	*font-size:small; /* for IE */+	*font:x-small; /* for IE in quirks mode */+}++h1 { font-size: 146.5%; /* 19pt */ } +h2 { font-size: 131%;   /* 17pt */ }+h3 { font-size: 116%;   /* 15pt */ }+h4 { font-size: 100%;   /* 13pt */ }+h5 { font-size: 100%;   /* 13pt */ }++select, input, button, textarea {+	font:99% sans-serif;+}++table {+	font-size:inherit;+	font:100%;+}++pre, code, kbd, samp, tt, .src {+	font-family:monospace;+	*font-size:108%;+	line-height: 124%;+}++.links, .link {+  font-size: 85%; /* 11pt */+}++#module-header .caption {+  font-size: 182%; /* 24pt */+}++.info  {+  font-size: 85%; /* 11pt */+}++#table-of-contents, #synopsis  {+  /* font-size: 85%; /* 11pt */+}+++/* @end */++/* @group Common */++.caption, h1, h2, h3, h4, h5, h6 { +  font-weight: bold;+  color: rgb(78,98,114);+  margin: 0.8em 0 0.4em;+}++* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 {+  margin-top: 2em;+}++h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 {+  margin-top: inherit;+}++ul.links {+  list-style: none;+  text-align: left;+  float: right;+  display: inline-table;+  margin: 0 0 0 1em;+}++ul.links li {+  display: inline;+  border-left: 1px solid #d5d5d5; +  white-space: nowrap;+  padding: 0;+}++ul.links li a, ul.links li form {+  padding: 0.2em 0.5em;+}++.hide { display: none; }+.show { display: inherit; }+.clear { clear: both; }++.collapser {+  background-image: url(minus.gif);+  background-repeat: no-repeat;+}+.expander {+  background-image: url(plus.gif);+  background-repeat: no-repeat;+}+p.caption.collapser,+p.caption.expander {+  background-position: 0 0.4em;+}+.collapser, .expander {+  padding-left: 14px;+  margin-left: -14px;+  cursor: pointer;+}++pre {+  padding: 0.25em;+  margin: 0.8em 0;+  background: rgb(229,237,244);+  overflow: auto;+  border-bottom: 0.25em solid white;+  /* white border adds some space below the box to compensate+     for visual extra space that paragraphs have between baseline+     and the bounding box */+}++.src {+  background: #f0f0f0;+  padding: 0.2em 0.5em;+}++.keyword { font-weight: normal; }+.def { font-weight: bold; }+++/* @end */++/* @group Page Structure */++#content {+  margin: 0 auto;+  padding: 0 2em 6em;+  max-width: 60em;+}++#page-header {+  background: rgb(41,56,69);+  border-top: 5px solid rgb(78,98,114);+  color: #ddd;+  padding: 0.2em;+  position: relative;+  text-align: left;+  font-size: 125%;+}++#page-header .caption {+  background: url(hslogo-16.png) no-repeat 0em;+  color: white;+  margin: 0 2em;+  font-weight: normal;+  font-style: normal;+  padding-left: 2em;+}++#page-header a:link, #page-header a:visited { color: white; }+#page-header li a:hover { background: rgb(78,98,114); }++#module-header .caption {+  color: rgb(78,98,114);+  font-weight: bold;+  border-bottom: 1px solid #ddd;+}++table.info {+  float: right;+  padding: 0.5em 1em;+  border: 1px solid #ddd;+  color: rgb(78,98,114);+  background-color: #fff;+  max-width: 40%;+  border-spacing: 0;+  position: relative;+  top: -0.5em;+  margin: 0 0 0 2em;+}++.info th {+	padding: 0 1em 0 0;+}++div#style-menu-holder {+  position: relative;+  z-index: 2;+  display: inline;+}++#style-menu {+  position: absolute;+  z-index: 1;+  overflow: visible;+  background: #374c5e;+  margin: 0;+  text-align: center;+  right: 0;+  padding: 0;+  top: 1.25em;+}++#style-menu li {+	display: list-item;+	border-style: none;+	margin: 0;+	padding: 0;+	color: #000;+	list-style-type: none;+}++#style-menu li + li {+	border-top: 1px solid #919191;+}++#style-menu a {+  width: 6em;+  padding: 3px;+  display: block;+}++#footer {+  background: #ddd;+  border-top: 1px solid #aaa;+  padding: 0.5em 0;+  color: #666;+  text-align: center;+  position: absolute;+  bottom: 0;+  width: 100%;+  height: 3em;+}++/* @end */++/* @search box */++ul.links li form {+  display: inline;+}+ul.links li form input {+	border:0px;+  padding:1px;+	width: 8em; +	background: rgb(235,235,235); /* url('/static/search.png') no-repeat 3px 4px; */+}++ul.links li form button {+  border:0px;+  cursor:pointer;+  color: white;+  background: rgb(41,56,69);+}+ul.links li form button:hover {+  background: rgb(78,98,114);+}++/* @end */++/* @group Front Matter */++#table-of-contents {+  float: right;+  clear: right;+  background: #faf9dc;+  border: 1px solid #d8d7ad;+  padding: 0.5em 1em;+  max-width: 20em;+  margin: 0.5em 0 1em 1em;+}++#table-of-contents .caption {+  text-align: center;+  margin: 0;+}++#table-of-contents ul {+  list-style: none;+  margin: 0;+}++#table-of-contents ul ul {+  margin-left: 2em;+}++#description .caption {+  display: none;+}++#synopsis {+  display: none;+}++.no-frame #synopsis {+  display: block;+  position: fixed;+  right: 0;+  height: 80%;+  top: 10%;+  padding: 0;+}++#synopsis .caption {+  float: left;+  width: 29px;+  color: rgba(255,255,255,0);+  height: 110px;+  margin: 0;+  font-size: 1px;+  padding: 0;+}++#synopsis p.caption.collapser {+  background: url(synopsis.png) no-repeat -64px -8px;+}++#synopsis p.caption.expander {+  background: url(synopsis.png) no-repeat 0px -8px;+}++#synopsis ul {+  height: 100%;+  overflow: auto;+  padding: 0.5em;+  margin: 0;+}++#synopsis ul ul {+  overflow: hidden;+}++#synopsis ul,+#synopsis ul li.src {+  background-color: #faf9dc;+  white-space: nowrap;+  list-style: none;+  margin-left: 0;+}++/* @end */++/* @group Main Content */++#interface div.top { margin: 2em 0; }+#interface h1 + div.top,+#interface h2 + div.top,+#interface h3 + div.top,+#interface h4 + div.top,+#interface h5 + div.top {+ 	margin-top: 1em;+}+#interface p.src .link {+  float: right;+  color: #919191;+  border-left: 1px solid #919191;+  background: #f0f0f0;+  padding: 0 0.5em 0.2em;+  margin: 0 -0.5em 0 0.5em;+}++#interface table { border-spacing: 2px; }+#interface td {+  vertical-align: top;+  padding-left: 0.5em;+}+#interface td.src {+  white-space: nowrap;+}+#interface td.doc p {+  margin: 0;+}+#interface td.doc p + p {+  margin-top: 0.8em;+}++.subs dl {+  margin: 0;+}++.subs dt {+  float: left;+  clear: left;+  display: block;+  margin: 1px 0;+}++.subs dd {+  float: right;+  width: 90%;+  display: block;+  padding-left: 0.5em;+  margin-bottom: 0.5em;+}++.subs dd.empty {+  display: none;+}++.subs dd p {+  margin: 0;+}++.top p.src {+  border-top: 1px solid #ccc;+}++.subs, .doc {+  /* use this selector for one level of indent */+  padding-left: 2em;+}++.arguments {+  margin-top: -0.4em;+}+.arguments .caption {+  display: none;+}++.fields { padding-left: 1em; }++.fields .caption { display: none; }++.fields p { margin: 0 0; }++/* this seems bulky to me+.methods, .constructors {+  background: #f8f8f8;+  border: 1px solid #eee;+}+*/++/* @end */++/* @group Auxillary Pages */++#mini {+  margin: 0 auto;+  padding: 0 1em 1em;+}++#mini > * {+  font-size: 93%; /* 12pt */  +}++#mini #module-list .caption,+#mini #module-header .caption {+  font-size: 125%; /* 15pt */+}++#mini #interface h1,+#mini #interface h2,+#mini #interface h3,+#mini #interface h4 {+  font-size: 109%; /* 13pt */+  margin: 1em 0 0;+}++#mini #interface .top,+#mini #interface .src {+  margin: 0;+}++#mini #module-list ul {+  list-style: none;+  margin: 0;+}++#alphabet ul {+	list-style: none;+	padding: 0;+	margin: 0.5em 0 0;+	text-align: center;+}++#alphabet li {+	display: inline;+	margin: 0 0.25em;+}++#alphabet a {+	font-weight: bold;+}++#index .caption,+#module-list .caption { font-size: 131%; /* 17pt */ }++#index table {+  margin-left: 2em;+}++#index .src {+  font-weight: bold;+}+#index .alt {+  font-size: 77%; /* 10pt */+  font-style: italic;+  padding-left: 2em;+}++#index td + td {+  padding-left: 1em;+}++#module-list ul {+  list-style: none;+  margin: 0 0 0 2em;+}++#module-list li {+  clear: right;+}++#module-list span.collapser,+#module-list span.expander {+  background-position: 0 0.3em;+}++#module-list .package {+  float: right;+}++strong.warning { color: red; }++/* @end */
+ datafiles/static/hslogo-16.png view

binary file changed (absent → 1684 bytes)

+ datafiles/templates/EditCabalFile/cabalFileEditPage.html.st view
@@ -0,0 +1,66 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: Edit package metadata for $pkgid$</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h1>Edit package metadata for $pkgid$ (Tech Preview)</h1>++<p><b>NOTE</b>: This is work in progress. It's not currently actually possible+to publish new revisions (see <a+href="https://github.com/haskell/hackage-server/issues/52">Issue 52</a>).</p>++<p>Package maintainers and Hackage trustees are allowed to edit certain bits+of package metadata after a release, without uploading a new tarball.++<form class="box" action="edit" method="post" enctype="multipart/form-data">+  <textarea autofocus style="font-family: monospace" name="cabalfile" rows="20" cols="80">$cabalfile$</textarea>+  <p><input type="submit" name="review" value="Review changes"/>+     <input type="submit" name="publish" value="Publish new revision" disabled="disabled"/>+     <a href="edit">Reset</a>++$if(publish)$+<p>Cannot publish new revision</p>+$endif$++$if(first(errors))$+<h2>Errors</h2>+$errors:{error|<p>$error$</p>}$+$endif$++$if(first(changes))$+<h2>Changes</h2>+<ul>+$changes:{change|<li><p>Changed $change.what$+                 from <pre>$change.from$</pre>+                 to <pre>$change.to$</pre></li>}$+</ul>+$elseif(publish)$+<h2>Errors</h2>+<p>No changes? A new revision isn't really a revision without any changes!</p>+$elseif(!first(errors))$+<h2>Changes</h2>+No changes.+$endif$+</form>++<h2>Advice on adjusting version constraints</h2>++<p>You can edit the version constraints for the dependencies,+either to restrict or relax them. The goal in editing the constraints should+always be to make them reflect reality.+<ul>+<li><p>If the package fails to build against certain versions of a dependency+then constrain the version.+<li><p>If the package builds against <em>and work correctly</em> with a newer+version of a dependency then it is ok to relax the constraint+<ul>++</div>+</body></html>+
+ datafiles/templates/EditCabalFile/cabalFilePublished.html.st view
@@ -0,0 +1,40 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: Published new revision for $pkgid$</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h1>Published new revision for <a href="/package/$pkgid$">$pkgid$</a></h1>++<p>The new revision has been published. It will be available to users as soon+as they update their package index (e.g. <tt>cabal update</tt>).++<pre rows="20" cols="80">$cabalfile$</pre>++<h2>Changes in this revision</h2>+<ul>+$changes:{change|<li><p>Changed $change.what$+                 from <pre>$change.from$</pre>+                 to <pre>$change.to$</pre></li>}$+</ul>++<h2>Advice on adjusting version constraints</h2>++<p>You can edit the version constraints for the dependencies,+either to restrict or relax them. The goal in editing the constraints should+always be to make them reflect reality.+<ul>+<li><p>If the package fails to build against certain versions of a dependency+then constrain the version.+<li><p>If the package builds against <em>and work correctly</em> with a newer+version of a dependency then it is ok to relax the constraint+<ul>++</div>+</body></html>+
+ datafiles/templates/Html/maintain.html.st view
@@ -0,0 +1,47 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: Maintainers' page for $pkgname$</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h2>Maintainers' page for $pkgname$</h2>++<p>Package maintainers (and Hackage trustees) can edit a few things about the+package after its been released.++<dl>+<dt><a href="tags/edit">Package tags</a></dt>+  <dd>Package tags are used to improve search results and related packages to+      each other.+  </dd>++<dt><a href="preferred/edit">Preferred versions</a></dt>+  <dd>If you want users to keep using an older version when you release a newer+      version then you can set a preferred version range and tools like cabal+      will take it into account.+      You can also use this mechanism to deprecate individual versions (e.g. if+      you know they are broken) without deprecating the whole package.+  </dd>++<dt><a href="deprecated/edit">Deprecation</a></dt>+  <dd>You can deprecate the whole package (optionally in favour of some other+      package).+  </dd>++<dt><a href="maintainers">Maintainer group</a></dt>+  <dd>Only these users are allowed to upload new versions of the package.+      Existing members can add other users into the maintainer group.+  </dd>++<dt>Cabal file metadata</dt>+  <dd>You can edit certain bits of package metadata after a release, without uploading a new tarball.+  <p>$versions:{pkgid|<a href="/package/$pkgid$/$pkgname$.cabal/edit">$pkgid$</a>}; separator=", "$</p>+  </dd>++</div>+</body></html>
+ datafiles/templates/LegacyPasswds/htpasswd-upgrade-success.html.st view
@@ -0,0 +1,34 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: Account upgrade successful</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h2>Account upgrade successful</h2>+<p>Your account has been re-enabled.+</p>++<h3>Technical details for the curious</h3>++<p>The old hackage implementation used <a href="http://en.wikipedia.org/wiki/Basic_access_authentication">HTTP basic authentication</a>. The new system uses <a href="http://en.wikipedia.org/wiki/Digest_access_authentication">HTTP digest authentication</a>.++<p>We could not transparently upgrade accounts to the new system because+the password hash format is different for the new system. The old+format was the+<a href="http://httpd.apache.org/docs/2.2/misc/password_encryptions.html#basic">+Apache basic auth 'CRYPT' format</a>, while the new format is+equivalent to the+<a href="http://httpd.apache.org/docs/2.2/misc/password_encryptions.html#digest">+Apache digest authentication format</a>. It is not possible to generate+the new format without access to the plaintext password &ndash; which+was never stored. So by authenticating once using the old account+information &ndash; using HTTP basic authentication &ndash; we can+generate and store password digest for the new system.++</div>+</body></html>
+ datafiles/templates/LegacyPasswds/htpasswd-upgrade.html.st view
@@ -0,0 +1,49 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: Account upgrade</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h2>Users moving from the old Hackage</h2>+<p>This new Hackage implementation uses a somewhat more secure system+for logging in. Because of this change, users who had accounts on the+old system need to do a one-time upgrade step.+</p>++<form class="box" action="/users/htpasswd-upgrade" method="post" enctype="multipart/form-data">+<p>You will be prompted to enter your existing username and password.+Your account will be re-enabled and you will then be able to use the+new site normally.+</p>+<input type="submit" value="Upgrade account">+</form>++<p><small>Note that if the upgrade is successful then the old auth+information will be deleted and trying to upgrade again will fail.+</small></p>+++<h3>Technical details for the curious</h3>++<p>The old hackage implementation used <a href="http://en.wikipedia.org/wiki/Basic_access_authentication">HTTP basic authentication</a>. The new system uses <a href="http://en.wikipedia.org/wiki/Digest_access_authentication">HTTP digest authentication</a>.++<p>We could not transparently upgrade accounts to the new system because+the password hash format is different for the new system. The old+format was the+<a href="http://httpd.apache.org/docs/2.2/misc/password_encryptions.html#basic">+Apache basic auth 'CRYPT' format</a>, while the new format is+equivalent to the+<a href="http://httpd.apache.org/docs/2.2/misc/password_encryptions.html#digest">+Apache digest authentication format</a>. It is not possible to generate+the new format without access to the plaintext password &ndash; which+was never stored. So by authenticating once using the old account+information &ndash; using HTTP basic authentication &ndash; we can+generate and store password digest for the new system.++</div>+</body></html>
+ datafiles/templates/Search/opensearch.xml.st view
@@ -0,0 +1,15 @@+<?xml version="1.0"?>+<OpenSearchDescription xmlns="http://a9.com/-/spec/opensearch/1.1/"+                       xmlns:moz="http://www.mozilla.org/2006/browser/search/">+<ShortName>Hackage</ShortName>+<Description>Search for Haskell packages on Hackage</Description>+<InputEncoding>UTF-8</InputEncoding>+<Image height="16" width="16" type="image/x-icon">$serverhost$/favicon.ico</Image>+<Url type="text/html" method="get"+     template="$serverhost$/packages/search?terms={searchTerms}" />+<!--+<Url type="application/x-suggestions+json" method="get"+     template="$serverhost$/packages/suggest.json?terms={searchTerms}" />+-->+<moz:SearchForm>$serverhost$/packages/search</moz:SearchForm>+</OpenSearchDescription>
+ datafiles/templates/UserSignupReset/ResetConfirm.st view
@@ -0,0 +1,34 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: Account recovery</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h2>Account recovery</h2>++<p>Email confirmation done!++<p>Now you can set a new password.++<form class="box" action="$posturl$" method="post" enctype="multipart/form-data">+  <table>+    <tr><td>Your name:<td>$realname$+    <tr><td>Login username:<td>$username$+    <tr><td>Contact email address:<td>$useremail$+    <tr><td><label for="password">Password</label>+        <td><input type="password" name="password" id="password">+    <tr><td><label for="repeat-password">Confirm Password</label>+        <td><input type="password" name="repeat-password" id="repeat-password">+  </table>++  <p><input type="submit" value="Set new password"/>+</form>++</div>+</body></html>+
+ datafiles/templates/UserSignupReset/ResetConfirmationEmail.st view
@@ -0,0 +1,19 @@+Dear $realname$,++We received a lost password request for your Hackage+user account. To set a new password, please follow+this link:++  $confirmlink$++If you were not expecting this email, our apologies,+please ignore it.++From,+  The Hackage website at $serverhost$+  (and on behalf of the site administrators)+______________________________________________+Please do not reply to this email. This email+address is used only for sending email so you+will not receive a response.+
+ datafiles/templates/UserSignupReset/ResetEmailSent.st view
@@ -0,0 +1,23 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: Account recovery</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h2>Account recovery email sent</h2>++<p>An email has been sent to <b>$useremail$</b>++<p>The email will contain a link to a page where+you can set a new password.++<p>Note that these activation links do eventually expire,+so don't leave it too long!++</div>+</body></html>
+ datafiles/templates/UserSignupReset/ResetRequest.st view
@@ -0,0 +1,41 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: Account recovery</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h2>Account recovery for forgotten passwords</h2>++<p>If you have forgotten the password you use to log in to Hackage, you can+recover the account and set a new password.++<p>Enter your account name and the email address that you <em>originally</em>+signed up with. The system will send you an email with a link that you can use+to set a new password.++<form class="box" action="/users/password-reset" method="post" enctype="multipart/form-data">++<table>+<tr>+<td><label for="username">Login username</label>+<td><input type="text" name="username" id="username">++<tr>+<td><label for="email">Your email address</label>+<td><input type="text" name="email" id="email">+<td>This must be the same email address that you registered with originally. +</table>++<p><input type="submit" value="Request account recovery">++<p>You will be sent an email containing a link to a page where you+can set a new password.+</form>++</div>+</body></html>
+ datafiles/templates/UserSignupReset/SignupConfirm.st view
@@ -0,0 +1,34 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: Register a new account</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h2>Register a new account</h2>++<p>Email confirmation done!++<p>Now you can set your password and create the account.++<form class="box" action="$posturl$" method="post" enctype="multipart/form-data">+  <table>+    <tr><td>Your name:<td>$realname$+    <tr><td>Login username:<td>$username$+    <tr><td>Contact email address:<td>$useremail$+    <tr><td><label for="password">Password</label>+        <td><input type="password" name="password" id="password">+    <tr><td><label for="repeat-password">Confirm Password</label>+        <td><input type="password" name="repeat-password" id="repeat-password">+  </table>++  <p><input type="submit" value="Create account"/>+</form>++</div>+</body></html>+
+ datafiles/templates/UserSignupReset/SignupConfirmationEmail.st view
@@ -0,0 +1,19 @@+Dear $realname$,++We received a request to create a Hackage account+for you. To create a Hackage account, please follow+this link:++  $confirmlink$++If you were not expecting this email, our apologies,+please ignore it.++From,+  The Hackage website at $serverhost$+  (and on behalf of the site administrators)+______________________________________________+Please do not reply to this email. This email+address is used only for sending email so you+will not receive a response.+
+ datafiles/templates/UserSignupReset/SignupEmailSent.st view
@@ -0,0 +1,23 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: Register a new account</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h2>Confirmation email sent</h2>++<p>An email has been sent to <b>$useremail$</b>++<p>The email will contain a link to a page where+you can set your password and activate your account.++<p>Note that these activation links do eventually expire,+so don't leave it too long!++</div>+</body></html>
+ datafiles/templates/UserSignupReset/SignupRequest.st view
@@ -0,0 +1,52 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: Register a new account</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h2>Register a new account</h2>++<p>Certain actions on this website require you to have an account.+In particular you need an account to be able to upload or help maintain packages.++<p>Using the form below you can register an account. Note however that getting+permission to upload packages requires an extra step from an administrator.++<form class="box" action="/users/register-request" method="post" enctype="multipart/form-data">++<table>+<tr>+<td><label for="realname">Your name</label>+<td><input type="text" name="realname" id="realname">+<td>This is what will be displayed on the site, e.g. Jan Novák++<tr>+<td><label for="username">Login username</label>+<td><input type="text" name="username" id="username">+<td>This has to be ASCII with no spaces, e.g. JanNovak++<tr>+<td><label for="email">Your email address</label>+<td><input type="text" name="email" id="email">+<td>e.g. jnovak@example.com (but do <b>not</b> use the style "Jan Novák" &lt;jnovak@example.com&gt;)+</table>++<p>Your email address will be used to confirm your account (and if you ever+need to reset your password). It will also be used if one of the site+administrators ever needs to contact you. It will not be displayed on+the website (but note that email addresses in .cabal files that you+upload are public).++<p><input type="submit" value="Request account">++<p>You will be sent an email containing a link to a page where you+can set your password and activate your account.+</form>++</div>+</body></html>
+ datafiles/templates/accounts.html.st view
@@ -0,0 +1,34 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: User accounts</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h2>User accounts</h2>+<p>Most of the functions of the Hackage web interface+(including browsing and checking packages) are available to all.+However, uploading packages requires a Hackage username and password.+</p>++<p>The current policy is that anyone can register an account but an+administrator needs to grant upload priviledges before you can upload+packages. In future this will make a bit more sense because there will+be things you can do with an account other than uploading or managing+packages, like comments and submitting build logs.</p>++<p>So, you can <a href="/users/register-request">register a new user account</a>.</p>+<p>You can also peruse the <a href="/users/">list of users</a>.</p>++<p>Passwords are <b>not</b> stored, just the digest.</p>++<p>If you forget your password you can <a href="/users/password-reset">reset it</a>+so long as you know your user login name and the email address you+originally registered with. The system will send you an email with a+link you can use to set a new password.</p>+</div>+</body></html>
+ datafiles/templates/admin.html.st view
@@ -0,0 +1,59 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: user administartion</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h2>Admin front-end</h2>++<ul>+<li><a href="/users/register">Add user</a></li>+<li>Edit groups: <a href="/users/admins/edit">admin</a>,+  <a href="/packages/mirrorers/edit">mirrorers</a>,+  <a href="/packages/trustees/edit">trustees</a>,+  <a href="/packages/uploaders/edit">uploaders</a></li>+</ul>++<!--+<H3>Change Password</H3>++<FORM CLASS="box" action="/admin/users/change-password" method="post" enctype="multipart/form-data">+<P>User name: <INPUT type="text" name="user-name"></P>+<P>Password:  <INPUT type="password" name="password"></P>+<P>Repeat password: <INPUT type="password" name="repeat-password"></P>+<INPUT type="submit" value="Change Password">+</FORM>++<H3>Disable User</H3>++<FORM CLASS="box" action="/admin/users/disable" method="post" enctype="multipart/form-data">+<P>User name: <INPUT type="text" name="user-name"></P>+<INPUT type="submit" value="Disable user">+</FORM>+++<H3>Re-Enable User</H3>++<FORM CLASS="box" action="/admin/users/enable" method="post" enctype="multipart/form-data">+<P>User name: <INPUT type="text" name="user-name"></P>+<INPUT type="submit" value="Enable user">+</FORM>++<H3>Delete User</H3>++<P>THIS IS PERMANENT</P>+<FORM CLASS="box" action="/admin/users/delete" method="post" enctype="multipart/form-data">+<P>User name: <INPUT type="text" name="user-name"></P>+<INPUT type="submit" value="Delete user">+</FORM>++  -->++</div> <!-- content -->+</body>+</html>
+ datafiles/templates/hackageCssTheme.st view
@@ -0,0 +1,2 @@+<link rel="stylesheet" href="/static/hackage.css" type="text/css" />+<link rel="search" type="application/opensearchdescription+xml" title="Hackage" href="/packages/opensearch.xml" />
+ datafiles/templates/hackageErrorPage.html.st view
@@ -0,0 +1,18 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: $errorTitle$</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h1>$errorTitle$</h1>++$errorMessage$++</div>+</body>+</html>
+ datafiles/templates/hackageErrorPage.txt.st view
@@ -0,0 +1,4 @@+Error: $errorTitle$++$errorMessage$+
+ datafiles/templates/hackagePageHeader.st view
@@ -0,0 +1,11 @@+<div id="page-header">+<ul class="links" id="page-menu">+<li><a href="/">Home</a></li+><li><form action="/packages/search" method="get" class="search"><button type="submit">Search&nbsp;</button><input type="text" name="terms" /></form></li+><li><a href="/packages/">Browse</a></li+><li><a href="/recent">What's new</a></li+><li><a href="/upload">Upload</a></li+><li><a href="/accounts">User accounts</a></li+></ul>+<a class="caption" href="/">Hackage :: [Package]</a>+</div>
+ datafiles/templates/index.html.st view
@@ -0,0 +1,86 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: introduction</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h2>About Hackage</h2>++<p>Hackage is a collection of released+<a href="http://www.haskell.org/">Haskell</a> packages.+Each package is in the <a href="http://www.haskell.org/cabal">Cabal</a> format,+a standard way of packaging Haskell source code that makes it easy to build+and install.+(Hackage and Cabal are components of a broader Haskell infrastructure effort+called <a href="http://hackage.haskell.org/trac/hackage/">Hackage</a>.)+These pages are a basic web interface to the Hackage package database.+</p>++<p>This isn't the <em>official</em> Hackage. It's an in-progress+rewrite of the server using the <a href="/package/happstack">happstack</a> web+framework. <!-- links to places to comment -->+</p>++<h3>Finding packages</h3>++<p>The <em>Packages</em> link above lists the available packages+and provides a full text search of the package pages (via Google),+while <em>What's new</em> lists recent additions (also available+<a href="/recent.rss">as an RSS feed</a>). You can also do a simple text+search of package descriptions:+</p>++<form action="/packages/search" method="get">+<p>+<input name="terms"/>+<input type="submit" value="Search"/>+</p>+</form>++<p>There are a few other package indices:</p>+<ul>+<li><a href="/packages/tags">All tags</a></li>+<li><a href="/packages/names">All packages by name</a>, with tags</li>+<li><a href="/packages/reverse">All packages with reverse dependencies</a></li>+<li><a href="/packages/top">All packages by download</a> (since old download data isn't imported, this will look somewhat barren)</li>+<li><a href="/packages/preferred">All packages with preferred versions</a></li>+<li><a href="/packages/deprecated">All deprecated packages</a></li>+<li><a href="/packages/candidates">All candidate packages</a></li>+</ul>++<p>See <a href="http://www.haskell.org/haskellwiki/Cabal/How_to_install_a_Cabal_package">How to install a Cabal package</a> for instructions on installing the packages you find here.</p>++<h3>Releasing packages through Hackage</h3>+<p>To upload your own releases, you'll first need to package them as Cabal+source packages.+See <a href="http://www.haskell.org/haskellwiki/How_to_write_a_Haskell_program">How to create a Haskell package</a>+for a tutorial.+You can check and upload your package using the <em>Upload</em> link above,+though you'll need a Hackage <a href="accounts.html">username</a> and password.+</p>++<h3>Getting the raw data</h3>+<ul>+<li><a href="/packages/index.tar.gz">tarball of package descriptions</a></li>+</ul>++<h3>Development</h3>+<p>See the+<a href="http://hackage.haskell.org/trac/hackage/wiki/HackageDB">Hackage wiki page</a>.+There is also a <a href="http://hackage.haskell.org/trac/hackage/wiki/HackageDB/2.0/Architecture">document in progress</a> summarizing the architecture of the new hackage-server. Check out the code yourself:+</p>++<pre>darcs get http://code.haskell.org/hackage-server</pre>++<p>+We'd like to make it as simple as possible for anyone to <a href="http://hackage.haskell.org/trac/hackage/wiki/HackageDB/2.0/CommandLine">set up a Hackage server</a>.+</p>+</div>+</body>+</html>+
+ datafiles/templates/new-features.html.st view
@@ -0,0 +1,107 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>New features in Hackage 2</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">++<h2>New features in Hackage 2</h2>+<p>Though our main priority has been feature parity so that we can switch over, volunteers have contributed several new features:</p+><ul+><li+  ><p+    >Package search: you can search by keywords that appear in the package name, synopsis or description. We expect this will be extend later to include tags, module names and author names.</p+    ></li+  ><li+  ><p+    >A new visual theme for the site, using the CSS borrowed from haddock.</p+    ></li+  ><li+  ><p+    >Improved security: per-package maintainer groups. Only those users may upload new versions of the package. The server also now uses HTTP digest authentication rather than basic authentication.</p+    ></li+  ><li+  ><p+    >Adjusting package dependencies after a release to match reality: some package metadata can be edited after a package tarball is uploaded. In particular the dependency version constraints can be tightened or relaxed. The original tarball is not altered.</p+    ></li+  ><li+  ><p+    >Hackage “trustees”: a privileged group of users who help to curate the collection of packages as a whole (or some subset). They can adjust package tags and metadata — including fixing dependencies. The hope is that this will significantly improve the number of packages that build “out of the box”.</p+    ></li+  ><li+  ><p+    >Package changelogs, when they are included in the package tarball.</p+    ></li+  ><li+  ><p+    >The contents of package tarballs can be browsed online.</p+    ></li+  ><li+  ><p+    >User self-registration via email, and self-service password reset. The current policy however is that before a new user can upload packages they must be added to the “uploaders” group by an administrator.</p+    ></li+  ><li+  ><p+    >Documentation can be uploaded by any suitably-authorised user, not just a single dedicated documentation build bot. In particular maintainers can upload documentation bundles if the doc build bots fail to do so.</p+    ></li+  ><li+  ><p+    >A RESTful API for getting and updating most of the data that the server holds, plus an auto-generated <a href="/api"+      >API description</a+      > / sitemap.</p+    ></li+  ></ul+><p+>There are also a number of new features that volunteers have partially implemented or that are in need of improvement.</p+><ul+><li+  ><p+    >Tags: packages can have arbitrary sets of tags, initially set from the categories in the .cabal file. This should be extended so that we can consolidate tags that should be aliases and tags should be used in the package search. See <a href="https://github.com/haskell/hackage-server/issues/24"+      >issue #24</a+      > and <a href="https://github.com/haskell/hackage-server/issues/27"+      >issue #27</a+      >.</p+    ></li+  ><li+  ><p+    >Reverse dependencies. This feature has been implemented but is currently disabled because it used to much memory. This should be investigated, the data structured adjusted and the feature re-enabled. The number of reverse dependencies should be an important component of a package popularity/quality metric. See <a href="https://github.com/haskell/hackage-server/issues/40"+      >issue #40</a+      >.</p+    ></li+  ><li+  ><p+    >Package “candidates”. You may have noticed that package versions are often uploaded in quick succession — sometimes just minutes apart — because a mistake is only noticed after the author uploaded. This feature lets you upload a “candidate”, giving it a URL that others can download from, and gives an opportunity for build bots and documentation builders to try the package out. Once the author is satisfied then they can publish to the main package index. We think this feature is about 90% complete. See <a href="https://github.com/haskell/hackage-server/issues/41"+      >issue #41</a+      >.</p+    ></li+  ><li+  ><p+    >Build reporting. There is support for build bots to upload build reports and build logs. This needs to be extended to include the anonymous build reports that cabal-install can generate. This way we can gather huge amounts of data. The goal is to inform users and maintainers about what packages work in what circumstances by digesting this data into useful information. In particular maintainers and trustees can then edit package dependencies to match reality. See <a href="https://github.com/haskell/hackage-server/issues/44"+      >issue #44</a+      >.</p+    ></li+  ><li+  ><p+    >All resources in machine readable formats. Many resources have JSON or other machine readable formats, but not yet all. See the <a href="/api"+      >api page</a+      >. This is an easy way to contribute to the development. See <a href="https://github.com/haskell/hackage-server/issues/42"+      >issue #42</a+      >.</p+    ></li+  ><li+  ><p+    >Site visual and information design. While we have at least switched to use the haddock “Ocean” theme, there’s a lot more that could be done by someone good at web design. Currently some pages use templates and other pages are generated in code. We should move towards consistently using templates to make it easier to adjust the site. It would also be possible to make more use of client-side technologies, rather than just classic html4 forms. See <a href="https://github.com/haskell/hackage-server/issues/43"+      >issue #43</a+      >.</p+    ></li+  ></ul+>++</div> <!-- content -->+</body>+</html>
+ datafiles/templates/upload.html.st view
@@ -0,0 +1,89 @@+<!DOCTYPE html>+<html>+<head>+$hackageCssTheme()$+<title>Hackage: Uploading packages and package candidates</title>+</head>++<body>+$hackagePageHeader()$++<div id="content">+<h2>Uploading packages and package candidates</h2>+<p>Uploading a package puts it in the <a href="/packages/">main package index</a>+so that anyone can download it and view information about it. You can only+upload a package version once, so try to get it right the first time!+</p>++<p>You can also upload a <a href="/packages/candidates">package <em>candidate</em></a>+to preview the package page, view any warnings or possible errors you might+encounter, and let others install it before publishing it to the main index.+(Note: you can view these warnings with 'cabal check'.) You can have multiple+candidates for each package at the same time so long as they each have different+versions. Finally, you can publish a candidate to the main index if it's not+there already.+</p>++<p>If you upload a package or package candidate and no other versions exist+in the package database, you become part of the maintainer group for that+package, and you can add other maintainers if you wish. If a maintainer group+exists for a package, only its members can upload new versions of that package.+</p>++<p>If there is no maintainer, the uploader can remove themselves from the group,+and a <a href="/packages/trustees">package trustee</a> can add anyone who wishes+to assume the responsibility. The <tt>Maintainer</tt> field of the Cabal file should be+<tt>None</tt> in this case. If a package is being maintained, any release not approved+and supported by the maintainer should use a different package name. Then use+the <tt>Maintainer</tt> field as above either to commit to supporting the fork+yourself or to mark it as unsupported.+</p>++<p>Note that all of the above is a makeshift upload policy based on the features+available in the newer hackage-server. The <tt>Maintainer</tt> field has its uses,+as does maintainer user groups. The libraries mailing list should probably+determine the best approach for this.+</p>++<h3>Upload forms</h3>+<p>Some last formalities: to upload a package, you'll need a Hackage+<a href="accounts.html">username</a> and password. (Alternatively, there's a+command-line interface via cabal-install, which also needs the same username+and password.)+</p>++<p>Packages must be in the form produced by Cabal's+<a href="http://www.haskell.org/ghc/docs/latest/html/Cabal/builders.html#setup-sdist">sdist</a> command:+a gzipped tar file <em>package</em>-<em>version</em><tt>.tar.gz</tt>+comprising a directory <em>package</em>-<em>version</em> containing a package+of that name and version, including <em>package</em><tt>.cabal</tt>.+See the notes at the bottom of the page.+</p>++<div style="font-size: large; text-align: center;"><a href="/packages/upload">Upload a package</a></div>+<div style="font-size: large; text-align: center;"><a href="/packages/candidates/upload">Upload a package candidate</a></div>++<h3>Notes</h3>+<ul>+<li>You should check that your source bundle builds,+including the haddock documentation if it's a library.</li>+<li>Categories are determined by whatever you put in the <tt>Category</tt> field+(there's no agreed list of category names yet).+You can have more than one category, separated by commas. If no other versions of+the package exist, the categories automatically become the package's tags.</li>+<li>Documentation for library packages should be generated by a maintainer.+The means of doing this is still up in the air.</li>+<li>We have moved to Haddock 2, and expect some glitches.+If you notice anything broken, please report it on the+<a href="http://trac.haskell.org/haddock">Haddock bug tracker</a>.</li>+<li>In GHC 6.8, several modules were split from the <tt>base</tt> package+into other packages.+See <a href="http://www.haskell.org/haskellwiki/Upgrading_packages">these notes</a> on making packages work with a range of versions of GHC.</li>+<li>While <a href="http://www.haskell.org/haddock/">Haddock 2</a>+accepts GHC features, it is also more picky about comment syntax than+the old version.</li>+</ul>++</div>+</body>+</html>
+ hackage-server.cabal view
@@ -0,0 +1,356 @@+name:         hackage-server+version:      0.4+category:     Distribution+synopsis:     The Hackage web server+description:  The new implementation of the Hackage web server, based on the+              Happstack architecture. This is the implementation used to power+              http://hackage.haskell.org/+              .+              It is designed to be easy to run your own instance.+              It also includes a doc builder client and a mirroring client.+author:       Duncan Coutts <duncan@community.haskell.org>,+              David Himmelstrup <lemmih@gmail.com>,+              Ross Paterson <ross@soi.city.ac.uk>,+              Matthew Gruen <wikigracenotes@gmail.com>+maintainer:   Duncan Coutts <duncan@community.haskell.org>,+              Matthew Gruen <wikigracenotes@gmail.com>+copyright:    2008-2013 Duncan Coutts,+              2012-2013 Edsko de Vries,+              2010-2011 Matthew Gruen,+              2009-2010 Antoine Latter,+              2008 David Himmelstrup,+              2007 Ross Paterson+license:      BSD3+license-file: LICENSE++build-type: Simple+cabal-version: >=1.10+data-dir: datafiles+data-files:+  templates/*.html.st+  templates/*.st+  templates/*.txt.st+  templates/EditCabalFile/*.html.st+  templates/Html/*.html.st+  templates/LegacyPasswds/*.html.st+  templates/Search/*.xml.st+  templates/UserSignupReset/*.st++  static/*.css+  static/*.ico+  static/*.png++source-repository head+  type: git +  location: https://github.com/haskell/hackage-server ++flag minimal+  default: False+  description: Include only the minimum feature set.+  manual: True++flag debug+  default: False+  description: Include debugging features+  manual: True++flag build-hackage-server+  default: True+  manual: True++flag build-hackage-mirror+  default: True+  manual: True++flag build-hackage-build+  default: True+  manual: True++executable hackage-server+  if ! flag(build-hackage-server)+    buildable: False+  main-is: Main.hs+  other-modules:+    Data.IntTrie+    Data.StringTable+    Data.TarIndex++    Distribution.Server++    Distribution.Server.Framework+    Distribution.Server.Framework.Auth+    Distribution.Server.Framework.AuthTypes+    Distribution.Server.Framework.AuthCrypt+    Distribution.Server.Framework.BlobStorage+    Distribution.Server.Framework.Cache+    Distribution.Server.Framework.Error+    Distribution.Server.Framework.Logging+    Distribution.Server.Framework.Feature+    Distribution.Server.Framework.Hook+    Distribution.Server.Framework.Instances+    Distribution.Server.Framework.MemState+    Distribution.Server.Framework.MemSize+    Distribution.Server.Framework.Resource+    Distribution.Server.Framework.RequestContentTypes+    Distribution.Server.Framework.ResponseContentTypes+    Distribution.Server.Framework.BackupDump+    Distribution.Server.Framework.BackupRestore+    Distribution.Server.Framework.ServerEnv+    +    Distribution.Server.Packages.Index+    Distribution.Server.Packages.ModuleForest+    Distribution.Server.Packages.PackageIndex+    Distribution.Server.Packages.Types+    Distribution.Server.Packages.Unpack+    Distribution.Server.Packages.Render+    Distribution.Server.Packages.ChangeLog++    Distribution.Server.Pages.BuildReports+    Distribution.Server.Pages.Distributions+    Distribution.Server.Pages.Group+    Distribution.Server.Pages.Index+    Distribution.Server.Pages.Package+    Distribution.Server.Pages.Package.HaddockHtml+    Distribution.Server.Pages.Package.HaddockLex+    Distribution.Server.Pages.Package.HaddockParse+    Distribution.Server.Pages.Recent+    -- [reverse index disabled] Distribution.Server.Pages.Reverse+    Distribution.Server.Pages.Template+    Distribution.Server.Pages.Util++    Distribution.Server.Users.Group+    Distribution.Server.Users.State+    Distribution.Server.Users.Types+    Distribution.Server.Users.Backup+    Distribution.Server.Users.Users++    Distribution.Server.Util.Happstack+    Distribution.Server.Util.Histogram+    Distribution.Server.Util.CountingMap+    Distribution.Server.Util.Index+    Distribution.Server.Util.NameIndex+    Distribution.Server.Util.Parse+    Distribution.Server.Util.ServeTarball+    Distribution.Server.Util.TarIndex+    Distribution.Server.Util.TextSearch++    Distribution.Server.Features+    Distribution.Server.Features.Core+    Distribution.Server.Features.Core.State+    Distribution.Server.Features.Core.Backup+    Distribution.Server.Features.Mirror+    Distribution.Server.Features.Upload+    Distribution.Server.Features.Upload.State+    Distribution.Server.Features.Upload.Backup+    Distribution.Server.Features.Users+++  if flag(minimal)+    cpp-options: -DMINIMAL+  else+    other-modules:+      Distribution.Server.Features.TarIndexCache+      Distribution.Server.Features.TarIndexCache.State+      Distribution.Server.Features.LegacyRedirects+      Distribution.Server.Features.LegacyPasswds+      Distribution.Server.Features.LegacyPasswds.Auth+      Distribution.Server.Features.PackageContents+      Distribution.Server.Features.BuildReports+      Distribution.Server.Features.BuildReports.BuildReport+      Distribution.Server.Features.BuildReports.BuildReports+      Distribution.Server.Features.BuildReports.Backup+      Distribution.Server.Features.BuildReports.State+      Distribution.Server.Features.PackageCandidates+      Distribution.Server.Features.PackageCandidates.Types+      Distribution.Server.Features.PackageCandidates.State+      Distribution.Server.Features.PackageCandidates.Backup+      Distribution.Server.Features.Distro+      Distribution.Server.Features.Distro.Distributions+      Distribution.Server.Features.Distro.Backup+      Distribution.Server.Features.Distro.State+      Distribution.Server.Features.Distro.Types+      Distribution.Server.Features.Documentation+      Distribution.Server.Features.Documentation.State+      Distribution.Server.Features.DownloadCount+      Distribution.Server.Features.DownloadCount.State+      Distribution.Server.Features.EditCabalFiles+      Distribution.Server.Features.Html+      Distribution.Server.Features.Search+      Distribution.Server.Features.RecentPackages+      Distribution.Server.Features.PreferredVersions+      Distribution.Server.Features.PreferredVersions.State+      Distribution.Server.Features.PreferredVersions.Backup+      -- [reverse index disabled] Distribution.Server.Features.ReverseDependencies+    -- [reverse index disabled] Distribution.Server.Features.ReverseDependencies.State+      Distribution.Server.Features.Tags+      Distribution.Server.Features.Tags.State+      Distribution.Server.Features.UserDetails+      Distribution.Server.Features.UserSignup+      Distribution.Server.Features.StaticFiles++  if flag(debug)+    cpp-options: -DDEBUG+    other-modules:+      Distribution.Server.Features.Crash++  build-depends:+    base       == 4.*,+    filepath   >= 1.1,+    directory  >= 1.0 && < 1.3,+    random     >= 1.0,+    array      >= 0.1,+    vector     >= 0.10,+    containers >= 0.4,+    pretty     >= 1.0,+    base64-bytestring ==0.1.* || == 1.0.*,+    base16-bytestring ==0.1.*,+    bytestring >= 0.9,+    --TODO: drop blaze builder in favour of bytestring-0.10 builder+    blaze-builder,+    text       >= 0.11,+    split      >= 0.2,+    time       >= 1.1 && < 1.5,+    old-locale >= 1.0,+    deepseq    == 1.1.* || == 1.3.*,+    transformers >= 0.3,+    mtl        >= 2.0,+    parsec     == 3.1.*,+    network    >= 2.1,+    unix       < 2.7,+    zlib       >= 0.5.3 && < 0.6,+    tar        == 0.4.* && >= 0.4.0.1,+    async      == 2.0.*,+    binary     == 0.5.*,+    cereal     == 0.3.*,+    safecopy   >= 0.6 && < 0.9,+    crypto-api >= 0.12 && < 0.13, +    pureMD5    >= 0.2,+    xhtml      >= 3000.1,+    -- The instances created by deriveJSON in later versions of Aeson are +    -- different from the instances created by this version; this would be ok+    -- if we only used the Aeson-created instance, but we also hand-create+    -- JSON in various places (for instance, in 'putUserDetails' in the import+    -- client). +    aeson      == 0.6.1.*,+    unordered-containers >= 0.2.3.0,+    rss        == 3000.2.*,+    Cabal      >= 1.16 && < 1.17,+    csv        == 0.1.*,+    stm        >= 2.2 && < 2.5,+    acid-state == 0.8.*,+    happstack-server == 7.0.* || ==7.1.* && >= 7.0.6,+    hslogger,+    mime-mail  ==0.4.*,+    HStringTemplate ==0.7.*,+    lifted-base >= 0.2.1 && < 0.3++  if ! flag(minimal)+    build-depends:+      snowball == 1.0.*,+      tokenize >= 0.1.3 && < 0.2++  build-tools:+    alex       >= 2.2  && < 3.2,+    happy      >= 1.17 && < 1.20++  if !os(darwin)+    extra-libraries: crypt++  default-language: Haskell2010+  ghc-options: -Wall -fwarn-tabs -fno-warn-unused-do-bind -fno-warn-deprecated-flags+               -threaded -funbox-strict-fields+  other-extensions: TemplateHaskell+  if impl(ghc >= 7.0)+    ghc-options: -rtsopts -with-rtsopts=-I0++executable hackage-mirror+  if ! flag(build-hackage-mirror)+    buildable: False+  main-is: MirrorClient.hs+  other-modules:+    Distribution.Client+    Distribution.Server.Users.Types+    Distribution.Server.Util.Index+    Distribution.Server.Util.Merge+  build-depends:+    base,+    containers, array, vector, bytestring, text, pretty,+    filepath, directory,+    time,     old-locale, random,+    tar,      zlib,+    network,  HTTP >= 4000.1.3,+    Cabal,+    safecopy, cereal, binary, mtl,+    unix+  default-language: Haskell2010+  ghc-options: -Wall -fwarn-tabs++executable hackage-build+  if ! flag(build-hackage-build)+    buildable: False+  main-is: BuildClient.hs+  other-modules:+    Distribution.Client+    Distribution.Server.Users.Types+    Distribution.Server.Util.Index+    Distribution.Server.Util.Merge+  build-depends:+    base,+    containers, array, vector, bytestring, text, pretty,+    filepath, directory, process >= 1.0,+    time,     old-locale,+    tar,      zlib,+    network,  HTTP,+    Cabal,+    safecopy, cereal, binary, mtl,+    -- See comment above why we insist on this version of Aeson+    aeson == 0.6.1.*, +    random,+    unix,+    -- Runtime dependency only:+    hscolour >= 1.8+  default-language: Haskell2010+  -- the -threaded option is necessary for correct handling+  -- of CTRL-C (not sure why :( )+  ghc-options: -Wall -fwarn-tabs -threaded++executable hackage-import+  if ! flag(build-hackage-mirror)+    buildable: False+  main-is: ImportClient.hs+  other-modules:+  build-depends:+    base,+    containers, array, vector, bytestring, text, pretty,+    filepath, directory,+    time,     old-locale, random,+    tar,      zlib,+    network,  HTTP >= 4000.1.3,+    Cabal,+    safecopy, cereal, binary, mtl,+    csv, async, attoparsec,+    -- See comment above why we insist on this version of Aeson+    aeson == 0.6.1.*,+    unordered-containers+  default-language: Haskell2010+  ghc-options: -Wall -fwarn-tabs++Test-Suite HighLevelTest+    type:           exitcode-stdio-1.0+    main-is:        HighLevelTest.hs+    hs-source-dirs: tests+    default-language: Haskell2010+    ghc-options:    -threaded+    build-depends:  base,+                    bytestring,+                    base64-bytestring,+                    Cabal,+                    directory,+                    filepath,+                    HTTP,+                    network,+                    process,+                    tar,+                    unix,+                    zlib+
+ tests/HighLevelTest.hs view
@@ -0,0 +1,463 @@++{-+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+