diff --git a/BuildClient.hs b/BuildClient.hs --- a/BuildClient.hs +++ b/BuildClient.hs @@ -1,17 +1,19 @@ {-# LANGUAGE PatternGuards #-} module Main (main) where +import Network.HTTP hiding (password) import Network.Browser -import Network.URI (URI(..), URIAuth(..)) +import Network.URI (URI(..), parseRelativeReference, relativeTo) import Distribution.Client -import Distribution.Client.Cron (cron, rethrowSignalsAsExceptions, Signal(..)) +import Distribution.Client.Cron (cron, rethrowSignalsAsExceptions, + Signal(..), ReceivedSignal(..)) import Distribution.Package import Distribution.Text import Distribution.Verbosity import Distribution.Simple.Utils hiding (intercalate) -import Distribution.Version (Version) +import Distribution.Version (Version(..)) import Data.List import Data.Maybe @@ -35,10 +37,13 @@ import System.IO import System.IO.Error +import Paths_hackage_server (version) + + import Data.Aeson (eitherDecode) data Mode = Help [String] - | Init String + | Init URI [URI] | Stats | Build [PackageId] @@ -47,22 +52,27 @@ bo_runTime :: Maybe NominalDiffTime, bo_stateDir :: FilePath, bo_continuous :: Maybe Int, - bo_keepGoing :: Bool + bo_keepGoing :: Bool, + bo_dryRun :: Bool, + bo_prune :: Bool } data BuildConfig = BuildConfig { bc_srcURI :: URI, + bc_auxURIs :: [URI], bc_username :: String, bc_password :: String } -srcName :: BuildConfig -> String -srcName config = fromMaybe (show (bc_srcURI config)) - (uriHostName (bc_srcURI config)) +srcName :: URI -> String +srcName uri = fromMaybe (show uri) (uriHostName uri) installDirectory :: BuildOpts -> FilePath -installDirectory bo = bo_stateDir bo "inst" +installDirectory bo = bo_stateDir bo "tmp-install" +resultsDirectory :: BuildOpts -> FilePath +resultsDirectory bo = bo_stateDir bo "results" + main :: IO () main = topHandler $ do rethrowSignalsAsExceptions [SIGABRT, SIGINT, SIGQUIT, SIGTERM] @@ -73,14 +83,14 @@ case mode of Help strs -> do let usageHeader = intercalate "\n" [ - "Usage: hackage-build init URL [options]", + "Usage: hackage-build init URL [auxiliary URLs] [options]", " hackage-build build [packages] [options]", " hackage-build stats", "Options:"] mapM_ putStrLn $ strs putStrLn $ usageInfo usageHeader buildFlagDescrs unless (null strs) exitFailure - Init uri -> initialise opts uri + Init uri auxUris -> initialise opts uri auxUris Stats -> do stateDir <- canonicalizePath $ bo_stateDir opts let opts' = opts { @@ -101,41 +111,81 @@ (const (buildOnce opts' pkgs)) () -initialise :: BuildOpts -> String -> IO () -initialise opts uriStr + +--------------------------------- +-- Initialisation & config file +-- + +initialise :: BuildOpts -> URI -> [URI] -> IO () +initialise opts uri auxUris = do putStrLn "Enter hackage username" username <- getLine putStrLn "Enter hackage password" password <- getLine + let config = BuildConfig { + bc_srcURI = uri, + bc_auxURIs = auxUris, + bc_username = username, + bc_password = password + } createDirectoryIfMissing False $ bo_stateDir opts - -- [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)) + createDirectoryIfMissing False $ resultsDirectory opts + writeConfig opts config + writeCabalConfig opts config +writeConfig :: BuildOpts -> BuildConfig -> IO () +writeConfig opts BuildConfig { + bc_srcURI = uri, + bc_auxURIs = auxUris, + bc_username = username, + bc_password = password + } = + -- [Note: Show/Read URI] + -- Ideally we'd just be showing a BuildConfig, but URI doesn't + -- have Show/Read, so that doesn't work. So instead, we write + -- out a tuple containing the uri as a string, and parse it + -- each time we read it. + let confStr = show (show uri, map show auxUris, username, password) in + writeFile (configFile opts) confStr + readConfig :: BuildOpts -> IO BuildConfig -readConfig opts = do xs <- readFile $ configFile opts - case reads xs of - [((uriStr, 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" +readConfig opts = do + xs <- readFile $ configFile opts + case reads xs of + [((uriStr, auxUriStrs, username, password), _)] -> + case mapM validateHackageURI (uriStr : auxUriStrs) of + -- Shouldn't happen: We check that this + -- returns Right when we create the + -- config file. See [Note: Show/Read URI]. + Left theError -> die theError + Right (uri : auxUris) -> + return $ BuildConfig { + bc_srcURI = uri, + bc_auxURIs = auxUris, + bc_username = username, + bc_password = password + } + Right _ -> error "The impossible happened" + _ -> + die "Can't parse config file (maybe re-run \"hackage-build init\")" configFile :: BuildOpts -> FilePath -configFile opts = bo_stateDir opts "hd-config" +configFile opts = bo_stateDir opts "hackage-build-config" +writeCabalConfig :: BuildOpts -> BuildConfig -> IO () +writeCabalConfig opts config = do + let tarballsDir = bo_stateDir opts "cached-tarballs" + writeFile (bo_stateDir opts "cabal-config") . unlines $ + [ "remote-repo: " ++ srcName uri ++ ":" ++ show uri + | uri <- bc_srcURI config : bc_auxURIs config ] + ++ [ "remote-repo-cache: " ++ tarballsDir ] + createDirectoryIfMissing False tarballsDir + + +---------------------- +-- Displaying status +-- + data StatResult = AllVersionsBuiltOk | AllVersionsAttempted | NoneBuilt @@ -147,25 +197,18 @@ 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 + pkgIdsHaveDocs <- getDocumentationStats verbosity config didFail + infoStats verbosity (Just statsFile) pkgIdsHaveDocs where statsFile = bo_stateDir opts "stats" -infoStats :: MonadIO m => Verbosity -> Maybe FilePath -> [DocInfo] -> m () -infoStats verbosity mDetailedStats pkgIdsHaveDocs = liftIO $ do +infoStats :: Verbosity -> Maybe FilePath -> [DocInfo] -> IO () +infoStats verbosity mDetailedStats pkgIdsHaveDocs = do nfo $ "There are " ++ show (length byPackage) ++ " packages with a total of " @@ -290,26 +333,32 @@ docInfoTarGzURI :: BuildConfig -> DocInfo -> URI docInfoTarGzURI config docInfo = docInfoBaseURI config docInfo display (docInfoPackage docInfo) <.> "tar.gz" -getDocumentationStats :: BuildConfig +docInfoReports :: BuildConfig -> DocInfo -> URI +docInfoReports config docInfo = docInfoBaseURI config docInfo "reports/" + +getDocumentationStats :: Verbosity + -> BuildConfig -> (PackageId -> IO Bool) - -> HttpSession [DocInfo] -getDocumentationStats config didFail = do - mPackages <- liftM eitherDecode `liftM` requestGET' packagesUri - mCandidates <- liftM eitherDecode `liftM` requestGET' candidatesUri + -> IO [DocInfo] +getDocumentationStats verbosity config didFail = do + notice verbosity "Downloading documentation index" + httpSession verbosity "hackage-build" version $ do + mPackages <- liftM eitherDecode `liftM` requestGET' packagesUri + mCandidates <- liftM eitherDecode `liftM` requestGET' candidatesUri - case (mPackages, mCandidates) of - -- Download failure - (Nothing, _) -> fail $ "Could not download " ++ show packagesUri - (_, Nothing) -> fail $ "Could not download " ++ show candidatesUri - -- Decoding failure - (Just (Left e), _) -> fail $ "Could not decode " ++ show packagesUri ++ ": " ++ e - (_, Just (Left e)) -> fail $ "Could not decode " ++ show candidatesUri ++ ": " ++ e - -- Success - (Just (Right packages), Just (Right candidates)) -> do - packages' <- liftIO $ mapM checkFailed packages - candidates' <- liftIO $ mapM checkFailed candidates - return $ map (setIsCandidate False) packages' - ++ map (setIsCandidate True) candidates' + 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" @@ -330,26 +379,21 @@ , docInfoIsCandidate = isCandidate } + +---------------------- +-- Building packages +-- + 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 + updatePackageIndex + pkgIdsHaveDocs <- getDocumentationStats verbosity config has_failed infoStats verbosity Nothing pkgIdsHaveDocs -- First build all of the latest versions of each package @@ -367,33 +411,33 @@ . sortBy (comparing docInfoPackageName) $ pkgIdsHaveDocs - liftIO $ notice verbosity $ show (length toBuild) ++ " package(s) to build" + 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 + startTime <- getCurrentTime let go :: [DocInfo] -> IO () go [] = return () go (docInfo : toBuild') = do - mTgz <- buildPackage verbosity opts config docInfo + (mTgz, mRpt, logfile) <- 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 + Nothing -> mark_as_failed (docInfoPackage docInfo) + Just _ -> return () + case mRpt of + Just _ | bo_dryRun opts -> return () + Just report -> uploadResults verbosity config docInfo + mTgz report logfile + _ -> return () -- We don't check the runtime until we've actually tried -- to build a doc, so as to ensure we make progress. outOfTime <- case bo_runTime opts of Nothing -> return False - Just d -> liftIO $ do + Just d -> do currentTime <- getCurrentTime return $ (currentTime `diffUTCTime` startTime) > d @@ -403,22 +447,45 @@ go toBuild where shouldBuild :: DocInfo -> Bool - shouldBuild docInfo = case docInfoHasDocs docInfo of - DocsNotBuilt -> docInfoPackage docInfo `elem` pkgs || null pkgs - _ -> docInfoPackage docInfo `elem` pkgs + shouldBuild docInfo = + case docInfoHasDocs docInfo of + DocsNotBuilt -> null pkgs || any (isSelectedPackage pkgid) pkgs + _ -> False + where + pkgid = docInfoPackage docInfo + -- do versionless matching if no version was given + isSelectedPackage pkgid pkgid'@(PackageIdentifier _ (Version [] _)) = + packageName pkgid == packageName pkgid' + isSelectedPackage pkgid pkgid' = + pkgid == pkgid' + keepGoing :: IO () -> IO () keepGoing act - | bo_keepGoing opts = catch act showExceptionAsWarning + | bo_keepGoing opts = Control.Exception.catch act showExceptionAsWarning | otherwise = act showExceptionAsWarning :: SomeException -> IO () - showExceptionAsWarning e = do - warn verbosity (show e) - notice verbosity "Abandoning this build attempt." + showExceptionAsWarning e + -- except for signals telling us to really stop + | Just (ReceivedSignal {}) <- fromException e + = throwIO e + | Just UserInterrupt <- fromException e + = throwIO e + + | otherwise + = do warn verbosity (show e) + notice verbosity "Abandoning this build attempt." + verbosity = bo_verbosity opts + updatePackageIndex = do + update_ec <- cabal opts "update" [] Nothing + unless (update_ec == ExitSuccess) $ + die "Could not 'cabal update' from specified server" + + -- Builds a little memoised function that can tell us whether a -- particular package failed to build its documentation mkPackageFailed :: BuildOpts @@ -445,157 +512,132 @@ 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 +buildPackage :: Verbosity -> BuildOpts -> BuildConfig -> DocInfo - -> m (Maybe BS.ByteString) + -> IO (Maybe FilePath, Maybe FilePath, FilePath) 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 () + let pkgid = docInfoPackage docInfo + notice verbosity ("Building " ++ display pkgid) + handleDoesNotExist (return ()) $ + removeDirectoryRecursive $ installDirectory opts + createDirectory $ installDirectory opts - -- 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" + -- Create the local package db + let packageDb = installDirectory opts "packages.db" + -- TODO: use Distribution.Simple.Program.HcPkg + ph <- runProcess "ghc-pkg" + ["init", packageDb] + Nothing Nothing Nothing Nothing Nothing + init_ec <- waitForProcess ph + unless (init_ec == ExitSuccess) $ + die $ "Could not initialise the package db " ++ packageDb -- The documentation is installed within the stateDir because we -- set a prefix while installing - let doc_root = installDirectory opts "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" + let doc_root = installDirectory opts "haddocks" + doc_dir_tmpl = doc_root "$pkgid-docs" + doc_dir_pkg = doc_root display pkgid ++ "-docs" +-- doc_dir_html = doc_dir "html" +-- deps_doc_dir = doc_dir "deps" +-- temp_doc_dir = doc_dir display (docInfoPackage docInfo) ++ "-docs" pkg_url = "/package" "$pkg-$version" + pkg_flags = + ["--enable-documentation", + "--htmldir=" ++ doc_dir_tmpl, + -- We only care about docs, so we want to build as + -- quickly as possible, and hence turn + -- optimisation off. Also explicitly pass -O0 as a + -- GHC option, in case it overrides a .cabal + -- setting or anything + "--disable-optimization", "--ghc-option", "-O0", + "--disable-library-for-ghci", + -- We don't want packages installed in the user + -- package.conf to affect things. In particular, + -- we don't want doc building to fail because + -- "packages are likely to be broken by the reinstalls" + "--package-db=clear", "--package-db=global", + "--package-db=" ++ packageDb, + -- Always build the package, even when it's been built + -- before. This lets us regenerate documentation when + -- dependencies are updated. + "--reinstall", + -- We know where this documentation will + -- eventually be hosted, bake that in. + -- The wiki claims we shouldn't include the + -- version in the hyperlinks so we don't have + -- to rehaddock some package when the dependent + -- packages get updated. However, this is NOT + -- what the Hackage v1 did, so ignore that: + "--haddock-html-location=" ++ pkg_url "docs", + -- Link "Contents" to the package page: + "--haddock-contents-location=" ++ pkg_url, + -- Link to colourised source code: + "--haddock-hyperlink-source", + "--prefix=" ++ installDirectory opts, + "--build-summary=" ++ installDirectory opts "reports" "$pkgid.report", + "--report-planning-failure", + -- We want both html documentation and hoogle database generated + "--haddock-html", + "--haddock-hoogle", + -- For candidates we need to use the full URL, because + -- otherwise cabal-install will not find the package. + -- For regular packages however we need to use just the + -- package name, otherwise cabal-install will not + -- generate a report + if docInfoIsCandidate docInfo + then show (docInfoTarGzURI config docInfo) + else display pkgid + ] - 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 + -- The installDirectory is purely temporary, while the resultsDirectory is + -- more persistent. We will grab various outputs from the tmp dir and stash + -- them for safe keeping (for later upload or manual inspection) in the + -- results dir. + let resultDir = resultsDirectory opts + resultLogFile = resultDir display pkgid <.> "log" + resultReportFile = resultDir display pkgid <.> "report" + resultDocsTarball = resultDir (display pkgid ++ "-docs") <.> "tar.gz" - -- 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) - ] + buildLogHnd <- openFile resultLogFile WriteMode - -- 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 + -- We ignore the result of calling @cabal install@ because + -- @cabal install@ succeeds even if the documentation fails to build. + void $ cabal opts "install" pkg_flags (Just buildLogHnd) - -- 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] + -- Grab the report for the package we want. Stash it for safe keeping. + report <- handleDoesNotExist (return Nothing) $ do + renameFile (installDirectory opts "reports" + display pkgid <.> "report") + resultReportFile + appendFile resultReportFile "\ndoc-builder: True" + return (Just resultReportFile) - -- 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 + docs_generated <- fmap and $ sequence [ + doesDirectoryExist doc_dir_pkg, + doesFileExist (doc_dir_pkg "doc-index.html"), + doesFileExist (doc_dir_pkg display (docInfoPackageName docInfo) <.> "haddock")] + docs <- if docs_generated + then do + when (bo_prune opts) (pruneHaddockFiles doc_dir_pkg) + BS.writeFile resultDocsTarball =<< tarGzDirectory doc_dir_pkg + return (Just resultDocsTarball) + else return Nothing - -- 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 + notice verbosity $ unlines + [ "Build results for " ++ display pkgid ++ ":" + , fromMaybe "no report" report + , fromMaybe "no docs" docs + , resultLogFile + ] - 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 + return (docs, report, resultLogFile) -cabal :: BuildOpts -> String -> [String] -> IO ExitCode -cabal opts cmd args = do - cwd' <- getCurrentDirectory + +cabal :: BuildOpts -> String -> [String] -> Maybe Handle -> IO ExitCode +cabal opts cmd args moutput = do let verbosity = bo_verbosity opts cabalConfigFile = bo_stateDir opts "cabal-config" verbosityArgs = if verbosity == silent @@ -605,11 +647,45 @@ : cmd : verbosityArgs ++ args - notice verbosity $ "In " ++ cwd' ++ ":\n" ++ unwords ("cabal":all_args) - ph <- runProcess "cabal" all_args (Just cwd') - Nothing Nothing Nothing Nothing + info verbosity $ unwords ("cabal":all_args) + ph <- runProcess "cabal" all_args Nothing + Nothing Nothing moutput moutput waitForProcess ph +pruneHaddockFiles :: FilePath -> IO () +pruneHaddockFiles dir = do + -- Hackage doesn't support the haddock frames view, so remove it + -- both visually (no frames link) and save space too. + files <- getDirectoryContents dir + sequence_ + [ removeFile (dir file) + | file <- files + , unwantedFile file ] + hackJsUtils + where + unwantedFile file + | "frames.html" == file = True + | "mini_" `isPrefixOf` file = True + -- The .haddock file is haddock-version specific + -- so it is not useful to make available for download + | ".haddock" <- takeExtension file = True + | otherwise = False + + -- The "Frames" link is added by the JS, just comment it out. + hackJsUtils = do + content <- readFile (dir "haddock-util.js") + _ <- evaluate (length content) + writeFile (dir "haddock-util.js") (munge content) + where + munge = unlines + . map removeAddMenuItem + . lines + removeAddMenuItem l | (sp, l') <- span (==' ') l + , "addMenuItem" `isPrefixOf` l' + = sp ++ "//" ++ l' + removeAddMenuItem l = l + + tarGzDirectory :: FilePath -> IO BS.ByteString tarGzDirectory dir = do res <- liftM (GZip.compress . Tar.write) $ @@ -621,15 +697,70 @@ 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) +uploadResults :: Verbosity -> BuildConfig -> DocInfo + -> Maybe FilePath -> FilePath -> FilePath -> IO () +uploadResults verbosity config docInfo + mdocsTarballFile buildReportFile buildLogFile = + httpSession verbosity "hackage-build" version $ do + -- Make sure we authenticate to Hackage + setAuthorityGen (provideAuthInfo (bc_srcURI config) + (Just (bc_username config, bc_password config))) + case mdocsTarballFile of + Nothing -> return () + Just docsTarballFile -> + putDocsTarball config docInfo docsTarballFile + buildId <- postBuildReport config docInfo buildReportFile + putBuildLog buildId buildLogFile +putDocsTarball :: BuildConfig -> DocInfo -> FilePath -> HttpSession () +putDocsTarball config docInfo docsTarballFile = + requestPUTFile (docInfoDocsURI config docInfo) + "application/x-tar" (Just "gzip") docsTarballFile + +type BuildReportId = URI + +postBuildReport :: BuildConfig -> DocInfo -> FilePath -> HttpSession BuildReportId +postBuildReport config docInfo reportFile = do + let uri = docInfoReports config docInfo + body <- liftIO $ BS.readFile reportFile + setAllowRedirects False + (_, response) <- request Request { + rqURI = uri, + rqMethod = POST, + rqHeaders = [Header HdrContentType ("text/plain"), + Header HdrContentLength (show (BS.length body)), + Header HdrAccept ("text/plain")], + rqBody = body + } + case rspCode response of + --TODO: fix server to not do give 303, 201 is more appropriate + (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location + return $ relativeTo rel uri + | Header HdrLocation location <- rspHeaders response ] + -> return buildId + _ -> do checkStatus uri response + fail "Unexpected response from server." + +putBuildLog :: BuildReportId -> FilePath -> HttpSession () +putBuildLog reportId buildLogFile = do + body <- liftIO $ BS.readFile buildLogFile + let uri = reportId "log" + setAllowRedirects False + (_, response) <- request Request { + rqURI = uri, + rqMethod = PUT, + rqHeaders = [Header HdrContentType ("text/plain"), + Header HdrContentLength (show (BS.length body)), + Header HdrAccept ("text/plain")], + rqBody = body + } + case rspCode response of + --TODO: fix server to not to give 303, 201 is more appropriate + (3,0,3) -> return () + _ -> checkStatus uri response + + ------------------------- -- Command line handling ------------------------- @@ -642,7 +773,9 @@ flagForce :: Bool, flagContinuous :: Bool, flagKeepGoing :: Bool, - flagInterval :: Maybe String + flagDryRun :: Bool, + flagInterval :: Maybe String, + flagPrune :: Bool } emptyBuildFlags :: BuildFlags @@ -654,7 +787,9 @@ , flagForce = False , flagContinuous = False , flagKeepGoing = False + , flagDryRun = False , flagInterval = Nothing + , flagPrune = False } buildFlagDescrs :: [OptDescr (BuildFlags -> BuildFlags)] @@ -689,9 +824,17 @@ (NoArg (\opts -> opts { flagKeepGoing = True })) "Keep going after errors" + , Option [] ["dry-run"] + (NoArg (\opts -> opts { flagDryRun = True })) + "Don't record results or upload" + , Option [] ["interval"] (ReqArg (\int opts -> opts { flagInterval = Just int }) "MIN") "Set the building interval in minutes (default 30)" + + , Option [] ["prune-haddock-files"] + (NoArg (\opts -> opts { flagPrune = True })) + "Remove unnecessary haddock files (frames, .haddock file)" ] validateOpts :: [String] -> IO (Mode, BuildOpts) @@ -709,20 +852,21 @@ (True, Just i) -> Just (read i) (True, Nothing) -> Just 30 -- default interval (False, _) -> Nothing, - bo_keepGoing = flagKeepGoing flags + bo_keepGoing = flagKeepGoing flags, + bo_dryRun = flagDryRun flags, + bo_prune = flagPrune flags } mode = case args' of _ | flagHelp flags -> Help [] | not (null errs) -> Help errs - ["init", uri] -> + "init" : uriStr : auxUriStrs -> -- 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)"] + case mapM validateHackageURI (uriStr : auxUriStrs) of + Left theError -> Help [theError] + Right (uri:auxUris) -> Init uri auxUris + Right _ -> error "impossible" ["stats"] -> Stats "stats" : _ -> @@ -758,17 +902,3 @@ (\() -> 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 diff --git a/Distribution/Client.hs b/Distribution/Client.hs --- a/Distribution/Client.hs +++ b/Distribution/Client.hs @@ -23,6 +23,7 @@ , requestGET , requestPUTFile , requestPOST + , checkStatus ) where import Network.HTTP @@ -35,6 +36,7 @@ import Distribution.Server.Util.Merge import Distribution.Server.Util.Parse (unpackUTF8) import Distribution.Package +import Distribution.Version import Distribution.Verbosity import Distribution.Simple.Utils import Distribution.Text @@ -58,7 +60,6 @@ import System.Directory import qualified System.FilePath.Posix as Posix -import Paths_hackage_server (version) ------------------------- -- Command line handling @@ -229,10 +230,10 @@ type HttpSession a = BrowserAction (HandleStream ByteString) a -httpSession :: Verbosity -> HttpSession a -> IO a -httpSession verbosity action = +httpSession :: Verbosity -> String -> Version -> HttpSession a -> IO a +httpSession verbosity agent version action = browse $ do - setUserAgent ("hackage-mirror/" ++ display version) + setUserAgent (agent ++ "/" ++ display version) setErrHandler die setOutHandler (debug verbosity) setAllowBasicAuth True @@ -350,6 +351,10 @@ checkStatus uri rsp = case rspCode rsp of -- 200 OK (2,0,0) -> return () + -- 201 Created + (2,0,1) -> return () + -- 201 Created + (2,0,2) -> return () -- 204 No Content (2,0,4) -> return () -- 400 Bad Request diff --git a/Distribution/Client/Cron.hs b/Distribution/Client/Cron.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Cron.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Distribution.Client.Cron + ( cron + , Signal(..) + , ReceivedSignal(..) + , rethrowSignalsAsExceptions + ) where + +import Control.Monad (forM_) +import Control.Exception (Exception) +import Control.Concurrent (myThreadId, threadDelay, throwTo) +import System.Random (randomRIO) +import System.Locale (defaultTimeLocale) +import Data.Time.Format (formatTime) +import Data.Time.Clock (UTCTime, getCurrentTime, addUTCTime) +import Data.Time.LocalTime (getCurrentTimeZone, utcToZonedTime) +import Data.Typeable (Typeable) + +import qualified System.Posix.Signals as Posix + +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils hiding (warn) + +data ReceivedSignal = ReceivedSignal Signal UTCTime + deriving (Show, Typeable) + +data Signal = SIGABRT + | SIGINT + | SIGQUIT + | SIGTERM + deriving (Show, Typeable) + +instance Exception ReceivedSignal + + +-- | "Re"throw signals as exceptions to the invoking thread +rethrowSignalsAsExceptions :: [Signal] -> IO () +rethrowSignalsAsExceptions signals = do + tid <- myThreadId + forM_ signals $ \s -> + let handler = do + time <- getCurrentTime + throwTo tid (ReceivedSignal s time) + in Posix.installHandler (toPosixSignal s) (Posix.Catch handler) Nothing + +toPosixSignal :: Signal -> Posix.Signal +toPosixSignal SIGABRT = Posix.sigABRT +toPosixSignal SIGINT = Posix.sigINT +toPosixSignal SIGQUIT = Posix.sigQUIT +toPosixSignal SIGTERM = Posix.sigTERM + +-- | @cron verbosity interval act@ runs @act@ over and over with +-- the specified interval. +cron :: Verbosity -> Int -> (a -> IO a) -> (a -> IO ()) +cron verbosity interval action x = do + x' <- action x + + interval' <- pertabate interval + logNextSyncMessage interval' + wait interval' + cron verbosity interval action x' + + where + -- to stop all mirror clients hitting the server at exactly the same time + -- we randomly adjust the wait time by +/- 10% + pertabate i = let deviation = i `div` 10 + in randomRIO (i + deviation, i - deviation) + + -- Annoyingly, threadDelay takes an Int number of microseconds, so we cannot + -- wait much longer than an hour. So have to wait repeatedly. Sigh. + wait minutes | minutes > 60 = do threadDelay (60 * 60 * 1000000) + wait (minutes - 60) + | otherwise = threadDelay (minutes * 60 * 1000000) + + logNextSyncMessage minutes = do + now <- getCurrentTime + tz <- getCurrentTimeZone + let nextSync = addUTCTime (fromIntegral (60 * minutes)) now + notice verbosity $ + "Next try will be in " ++ show minutes ++ " minutes, at " + ++ formatTime defaultTimeLocale "%R %Z" (utcToZonedTime tz nextSync) diff --git a/Distribution/Client/DistroMap.hs b/Distribution/Client/DistroMap.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/DistroMap.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.DistroMap +-- Copyright : (c) Duncan Coutts 2012 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Support for reading the distromap files of the old hackage server. +----------------------------------------------------------------------------- +module Distribution.Client.DistroMap ( + Entry(..), + read, + toCSV, + ) where + +import Distribution.Package + ( PackageName ) +import Distribution.Version + ( Version ) +import Distribution.Text + ( display, simpleParse ) + +import Text.CSV + ( CSV ) +import Network.URI + ( URI, parseURI ) +import Data.Either + ( partitionEithers ) + +import Prelude hiding (read) + +data Entry = Entry PackageName Version (Maybe URI) + deriving (Eq, Show) + +-- | Returns a list of log entries. +-- +read :: String -> ([String], [Entry]) +read = partitionEithers . map parseLine . lines + where + parseLine line + | [((pkgnamestr, pkgverstr, murlstr),_)] <- reads line + , Just pkgname <- simpleParse pkgnamestr + , Just pkgver <- simpleParse pkgverstr + , Just murl <- maybe (Just Nothing) (fmap Just . parseURI) murlstr + = Right (Entry pkgname pkgver murl) + + | otherwise + = Left err + where + err = "Failed to parse distro map line:\n" ++ show line + +toCSV :: [Entry] -> CSV +toCSV = map $ \(Entry pkgname pkgver murl) -> + [display pkgname, display pkgver, maybe "" show murl] + diff --git a/Distribution/Client/HtPasswdDb.hs b/Distribution/Client/HtPasswdDb.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/HtPasswdDb.hs @@ -0,0 +1,32 @@ +-- | Parsing @.htpasswd@ files +-- +module Distribution.Client.HtPasswdDb ( + HtPasswdDb, HtPasswdHash(..), + parse, + ) where + +import Distribution.Server.Users.Types (UserName(..)) + +type HtPasswdDb = [(UserName, Maybe HtPasswdHash)] + +newtype HtPasswdHash = HtPasswdHash String + deriving (Eq, Show) + +parse :: String -> Either String HtPasswdDb +parse = accum 0 [] . map parseLine . lines + where + accum _ pairs [] = Right (reverse pairs) + accum n pairs (Just pair:rest) = accum (n+1) (pair:pairs) rest + accum n _ (Nothing :_ ) = Left errmsg + where errmsg = "parse error in htpasswd file on line " ++ show (n :: Int) + +parseLine :: String -> Maybe (UserName, Maybe HtPasswdHash) +parseLine line = case break (==':') line of + + -- entries like "myName:$apr1$r31.....$HqJZimcKQFAMYayBlzkrA/" + -- this is a special Apache md5-based format that we do not handle + (user@(_:_), ':' :'$':_) -> Just (UserName user, Nothing) + + -- entries like "myName:rqXexS6ZhobKA" + (user@(_:_), ':' : hash) -> Just (UserName user, Just (HtPasswdHash hash)) + _ -> Nothing diff --git a/Distribution/Client/ParseApacheLogs.hs b/Distribution/Client/ParseApacheLogs.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/ParseApacheLogs.hs @@ -0,0 +1,115 @@ +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +-- Extract download counts from Apache log files +module Distribution.Client.ParseApacheLogs + ( logToDownloadCounts + ) where + +-- TODO: We assume the Apache log files are ASCII, not Unicode. + +import Distribution.Package (PackageName) +import Distribution.Version (Version) +import Distribution.Text (display, simpleParse) + +import Control.Monad ((>=>)) +import System.Locale (defaultTimeLocale) +import Data.List (intercalate) +import Data.Maybe (catMaybes) +import Data.Attoparsec.Char8 (Parser) +import Data.Map (Map) +import Data.Time.Calendar (Day) +import Data.Time.Format (parseTime) +import qualified Data.ByteString.Char8 as SBS +import qualified Data.Attoparsec.Char8 as Att +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Map as Map + +logToDownloadCounts :: LBS.ByteString -> LBS.ByteString +logToDownloadCounts = + LBS.unlines + . map formatOutput + . Map.toList + . accumHist + . catMaybes + . map ((packageGET >=> parseGET) . parseLine . SBS.concat . LBS.toChunks) + . LBS.lines + +data LogLine = LogLine { + _getIP :: !SBS.ByteString + , _getIdent :: !SBS.ByteString + , _getUser :: !SBS.ByteString + , getDate :: !SBS.ByteString + , getReq :: !SBS.ByteString + , _getStatus :: !SBS.ByteString + , _getBytes :: !SBS.ByteString + , _getRef :: !SBS.ByteString + , _getUA :: !SBS.ByteString +} deriving (Ord, Show, Eq) + +plainValue :: Parser SBS.ByteString +plainValue = Att.takeWhile1 (\c -> c /= ' ' && c /= '\n') --many1' (noneOf " \n") + +bracketedValue :: Parser SBS.ByteString +bracketedValue = do + Att.char '[' + content <- Att.takeWhile1 (\c -> c /= ']') --many' (noneOf "]") + Att.char ']' + return content + +quotedValue :: Parser SBS.ByteString +quotedValue = do + Att.char '"' + content <- Att.takeWhile1 (\c -> c /= '"') --many' (noneOf "\"") + Att.char '"' + return content + +logLine :: Parser LogLine +logLine = do + ip <- plainValue ; Att.skipSpace + ident <- plainValue ; Att.skipSpace + usr <- plainValue ; Att.skipSpace + date <- bracketedValue ; Att.skipSpace + req <- quotedValue ; Att.skipSpace + status <- plainValue ; Att.skipSpace + bytes <- plainValue ; Att.skipSpace + ref <- quotedValue ; Att.skipSpace + ua <- quotedValue + return $! LogLine ip ident usr date req status bytes ref ua + +parseLine :: SBS.ByteString -> Either SBS.ByteString LogLine +parseLine line = case Att.parseOnly logLine line of + Left _ -> Left line + Right res -> Right res + +packageGET :: Either a LogLine -> Maybe (SBS.ByteString, SBS.ByteString, SBS.ByteString) +packageGET (Right logline) + | [method, path, _] <- SBS.words (getReq logline) + , method == methodGET + , [root, dir1, dir2, name, ver, tarball] <- SBS.split '/' path + , SBS.null root, dir1 == packagesDir, dir2 == archiveDir + , SBS.isSuffixOf targzExt tarball + = Just (name, ver, getDate logline) +packageGET _ = Nothing + +parseGET :: (SBS.ByteString, SBS.ByteString, SBS.ByteString) -> Maybe (PackageName, Version, Day) +parseGET (pkgNameStr, pkgVersionStr, dayStr) = do + name <- simpleParse . SBS.unpack $ pkgNameStr + version <- simpleParse . SBS.unpack $ pkgVersionStr + day <- parseTime defaultTimeLocale "%d/%b/%Y:%T %z" . SBS.unpack $ dayStr + return (name, version, day) + +methodGET, packagesDir, archiveDir, targzExt :: SBS.ByteString +methodGET = SBS.pack "GET" +packagesDir = SBS.pack "packages" +archiveDir = SBS.pack "archive" +targzExt = SBS.pack ".tar.gz" + +accumHist :: Ord k => [k] -> Map k Int +accumHist es = Map.fromListWith (+) [ (pkgId,1) | pkgId <- es ] + +formatOutput :: ((PackageName, Version, Day), Int) -> LBS.ByteString +formatOutput ((name, version, day), numDownloads) = + LBS.pack $ intercalate "," $ map show [ display name + , show day + , display version + , show numDownloads + ] diff --git a/Distribution/Client/PkgIndex.hs b/Distribution/Client/PkgIndex.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/PkgIndex.hs @@ -0,0 +1,38 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.PkgIndex +-- Copyright : (c) Duncan Coutts 2012 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Support for importing cabal files from a 00-index.tar.gz file +----------------------------------------------------------------------------- +module Distribution.Client.PkgIndex ( + readPkgIndex + ) where + +import qualified Distribution.Server.Util.Index as PackageIndex (read) +import qualified Codec.Archive.Tar.Entry as Tar (Entry(..), EntryContent(..)) + +import Distribution.Package + +import Data.ByteString.Lazy (ByteString) +import qualified Distribution.Server.Util.GZip as GZip + +import Prelude hiding (read) + + +readPkgIndex :: ByteString -> Either String [(PackageIdentifier, ByteString)] +readPkgIndex = fmap extractCabalFiles + . PackageIndex.read (,) + . GZip.decompressNamed "<>" + where + extractCabalFiles entries = + [ (pkgid, cabalFile) + | (pkgid, Tar.Entry { + Tar.entryContent = Tar.NormalFile cabalFile _ + }) <- entries ] + diff --git a/Distribution/Client/TagsFile.hs b/Distribution/Client/TagsFile.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/TagsFile.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.TagsFile +-- Copyright : (c) Duncan Coutts 2012 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Support for reading the tags files of the old hackage server. +----------------------------------------------------------------------------- +module Distribution.Client.TagsFile ( + Entry, + read, + collectDeprecated, + ) where + +import Distribution.Package + ( PackageName, PackageId, packageName ) +import Distribution.Text + ( simpleParse ) +import Distribution.Simple.Utils + ( comparing, equating ) + +import Data.List + ( foldl', sortBy, groupBy, stripPrefix ) +import System.FilePath + ( splitDirectories ) + +import Prelude hiding (read) + +data Entry = Entry PackageId Bool (Maybe PackageName) + deriving (Eq, Ord, Show) + +-- | Returns a list of log entries, however some packages have been uploaded +-- more than once, so each entry is paired with any older entries for the same +-- package. +-- +read :: FilePath -> String -> Either String Entry +read filepath content + | ("tags":verstr:namestr:_) <- reverse (splitDirectories filepath) + , Just pkgid <- simpleParse (namestr ++ "-" ++ verstr) + = Right $! foldl' accum (Entry pkgid False Nothing) (lines content) + + | otherwise + = Left $ "cannot get a package id from the file name " ++ filepath + where + accum e@(Entry pkgid deprecated replacement) s + | Just "true" <- stripPrefix "deprecated: " s + = Entry pkgid True replacement + + | Just newnamestr <- stripPrefix "superseded by: " s + , Just newpkg <- simpleParse newnamestr + = Entry pkgid deprecated (Just newpkg) + + | otherwise + = e + +collectDeprecated :: [Entry] -> [(PackageName, Maybe PackageName)] +collectDeprecated = + map (\(Entry pkgid _ replacement) -> (packageName pkgid, replacement)) + . filter (\(Entry _ deprecated _) -> deprecated) + . map last + . groupBy (equating (\(Entry pkgid _ _) -> packageName pkgid)) + . sortBy (comparing (\(Entry pkgid _ _) -> pkgid)) + diff --git a/Distribution/Client/UploadLog.hs b/Distribution/Client/UploadLog.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/UploadLog.hs @@ -0,0 +1,108 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ImportClient.UploadLog +-- Copyright : (c) Ross Paterson 2007 +-- Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Support for reading the upload log of the old hackage server. +----------------------------------------------------------------------------- +module Distribution.Client.UploadLog ( + Entry(..), + read, + collectUploadInfo, + collectMaintainerInfo, + ) where + +import Distribution.Server.Users.Types + ( UserName ) + +import Distribution.Package + ( PackageId, PackageName, packageName, PackageIdentifier(..)) +import Distribution.Text + ( Text(..), simpleParse ) +import Distribution.ParseUtils ( parsePackageNameQ ) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint + ( (<+>) ) +import Distribution.Simple.Utils + ( comparing, equating ) + +import Data.Time.Clock + ( UTCTime ) +import Data.Time.LocalTime + ( zonedTimeToUTC ) +import Data.Time.Format + ( readsTime, formatTime ) +import System.Locale + ( defaultTimeLocale ) +import Data.List + ( sortBy, groupBy, nub ) + +import Prelude hiding (read) + +data Entry = Entry UTCTime UserName PackageIdentifier + deriving (Eq, Ord, Show) + +instance Text Entry where + disp (Entry time user pkgid) = + Disp.text (formatTime defaultTimeLocale "%c" time) + <+> disp user <+> disp pkgid + parse = do + time <- Parse.readS_to_P (readsTime defaultTimeLocale "%c") + Parse.skipSpaces + user <- parse + Parse.skipSpaces + pkg <- parsePackageNameQ + Parse.skipSpaces + ver <- parse + let pkgid = PackageIdentifier pkg ver + return (Entry (zonedTimeToUTC time) user pkgid) + +-- | Returns a list of log entries, however some packages have been uploaded +-- more than once, so each entry is paired with any older entries for the same +-- package. +-- +read :: String -> Either String [Entry] +read = check [] . map parseLine . lines + where + check es' [] = Right (reverse es') + check es' (Right e:es) = check (e:es') es + check _ (Left err:_) = Left err + parseLine line = maybe (Left err) Right (simpleParse line) + where err = "Failed to parse log line:\n" ++ show line + +collectUploadInfo :: [Entry] -> [(PackageId, UTCTime, UserName)] +collectUploadInfo = + map (uploadInfo . sortBy (comparing entryTime)) + . groupBy (equating entryPackageId) + . sortBy (comparing entryPackageId) + where + entryPackageId (Entry _ _ pkgid) = pkgid + entryTime (Entry t _ _) = t + + uploadInfo :: [Entry] -> (PackageId, UTCTime, UserName) + uploadInfo entries = + case last entries of + Entry time uname pkgid -> (pkgid, time, uname) + +collectMaintainerInfo :: [Entry] -> [(PackageName, [UserName])] +collectMaintainerInfo = + map maintainersInfo + . groupBy (equating entryPackageName) + . sortBy (comparing entryPackageName) + where + entryPackageName (Entry _ _ pkgid) = packageName pkgid + + maintainersInfo :: [Entry] -> (PackageName, [UserName]) + maintainersInfo entries = + (packageName pkgid, maintainers) + where + Entry _ _ pkgid = head entries + maintainers = nub [ uname | Entry _ uname _ <- entries ] + diff --git a/Distribution/Client/UserAddressesDb.hs b/Distribution/Client/UserAddressesDb.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/UserAddressesDb.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE BangPatterns, PatternGuards #-} +-- | Parsing @hackage.addresses@ files +-- +module Distribution.Client.UserAddressesDb ( + UserAddressesDb, + UserEntry, + parseFile + ) where + +import Distribution.Server.Users.Types (UserName(..)) +import Data.List +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS -- Mixed encoding in old DB; Char8 intended +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import qualified Data.Text.Read as T +import Data.Functor +import Data.Char (chr) +import Data.Time (UTCTime, parseTime, zonedTimeToUTC) +import System.Locale (defaultTimeLocale) + +type UserAddressesDb = [UserEntry] +type UserEntry = (UserName, UserRealName, UserAddress, UTCTime, UserName) +type UserRealName = Text +type UserAddress = Text + +parseFile :: FilePath -> IO (Either String UserAddressesDb) +parseFile fn = parse <$> BS.readFile fn + +parse :: ByteString -> Either String UserAddressesDb +parse = accum 0 [] . map parseLine . BS.lines + where + accum _ entries [] = Right (reverse entries) + accum !n entries (Right entry:rest) = accum (n+1) (entry:entries) rest + accum n _ (Left line :_ ) = Left errmsg + where + errmsg = "parse error in addresses file on line " ++ show (n :: Int) + ++ "\n" ++ BS.unpack line + +parseLine :: ByteString -> Either ByteString UserEntry +parseLine line + -- entries like: + -- DuncanCoutts:Duncan Coutts:duncan.coutts@worc.ox.ac.uk:RossPaterson:Wed Jan 10 16:00:00 PDT 2007 + | [username,realname,email,adminname,timestr] <- splitFields line + , Just timestamp <- readTime (BS.unpack timestr) + = Right ( UserName (BS.unpack username) + , decodeMixed realname + , decodeMixed email + , timestamp + , UserName (BS.unpack adminname) ) + | otherwise + = Left line + + where + splitFields = fixTimeBreakage . fixUrlBreakage . splitOn ':' + where + fixUrlBreakage [] = [] + fixUrlBreakage (f:f':fs) | f == BS.pack "http" + = BS.concat [f, BS.singleton ':', f'] + : fixUrlBreakage fs + fixUrlBreakage (f:fs) = f : fixUrlBreakage fs + + fixTimeBreakage [a,b,c,d,t1,t2,t3] = + [a,b,c,d, BS.intercalate (BS.singleton ':') [t1,t2,t3] ] + fixTimeBreakage fs = fs + + readTime = fmap zonedTimeToUTC + . parseTime defaultTimeLocale "%c" + +-- Unfortunately the file uses mixed encoding, mostly UTF8 +-- but some Latin1 and some Html escape sequences +decodeMixed :: ByteString -> Text +decodeMixed bs + | T.any ('\xFFFD' ==) astext = unescape (T.pack (BS.unpack bs)) + | otherwise = unescape astext + where + astext = T.decodeUtf8With T.lenientDecode bs + +-- unescape things like "ğ" +unescape :: Text -> Text +unescape s + | let (s0,s1) = T.breakOn (T.pack "&#") s + , not (T.null s1) + , Right (n,s2) <- T.decimal (T.drop 2 s1) + = T.append s0 (T.cons (chr n) (T.drop 1 (unescape s2))) + + | otherwise = s + +splitOn :: Char -> ByteString -> [ByteString] +splitOn c = unfoldr $ \s -> if BS.null s then Nothing + else case BS.break (==c) s of + (x,s') -> Just (x, BS.drop 1 s') + diff --git a/Distribution/Server.hs b/Distribution/Server.hs --- a/Distribution/Server.hs +++ b/Distribution/Server.hs @@ -7,6 +7,7 @@ run, shutdown, checkpoint, + reloadDatafiles, -- * Server configuration ListenOn(..), @@ -23,12 +24,14 @@ tearDownTemp ) where +import Happstack.Server.SimpleHTTP 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.HtmlFormWrapper (htmlFormWrapperHack) import Distribution.Server.Framework.Feature as Feature import qualified Distribution.Server.Features as Features @@ -112,17 +115,8 @@ 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 +mkServerEnv :: ServerConfig -> IO ServerEnv +mkServerEnv config@(ServerConfig verbosity hostURI _ stateDir _ tmpDir cacheDelay) = do createDirectoryIfMissing False stateDir @@ -143,13 +137,28 @@ serverBaseURI = hostURI, serverVerbosity = verbosity } + return env + +-- | 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 = do + env <- mkServerEnv config + -- do feature initialization (features, userFeature) <- Features.initHackageFeatures env return Server { serverFeatures = features, serverUserFeature = userFeature, - serverListenOn = listenOn, + serverListenOn = confListenOn config, serverEnv = env } @@ -198,15 +207,14 @@ | 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. + -- This is a cunning hack to solve the problem that HTML 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 HTML does not + -- support HTTP properly, so we allow browsers using HTML forms to do + -- PUT/DELETE etc by POSTing with special body parameters. fakeBrowserHttpMethods part = msum [ do method POST - methodOverrideHack part + htmlFormWrapperHack part -- or just do things the normal way , part @@ -228,6 +236,10 @@ checkpoint :: Server -> IO () checkpoint server = Features.checkpointAllFeatures (serverFeatures server) + +reloadDatafiles :: Server -> IO () +reloadDatafiles server = + mapM_ Feature.featureReloadFiles (serverFeatures server) -- | Return /one/ abstract state component per feature serverState :: Server -> [(String, AbstractStateComponent)] diff --git a/Distribution/Server/Features.hs b/Distribution/Server/Features.hs --- a/Distribution/Server/Features.hs +++ b/Distribution/Server/Features.hs @@ -40,6 +40,8 @@ import Distribution.Server.Features.UserSignup (initUserSignupFeature) import Distribution.Server.Features.LegacyPasswds (initLegacyPasswdsFeature) import Distribution.Server.Features.EditCabalFiles (initEditCabalFilesFeature) +import Distribution.Server.Features.AdminFrontend (initAdminFrontendFeature) +import Distribution.Server.Features.HoogleData (initHoogleDataFeature) #endif import Distribution.Server.Features.ServerIntrospect (serverIntrospectFeature) @@ -64,115 +66,188 @@ -- best approach is probably to write backup tarball to disk and transfer -- it away through non-HTTP means (somewhat more secure) +-- | Initialize all features and run post-initialization hooks. initHackageFeatures :: ServerEnv -> IO ([HackageFeature], UserFeature) initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do - loginfo verbosity "Initialising features" + -- We have a three phase initialisation procedure... + -- 1. in phase 1 all features can start independently (could be parallel) + -- they load the data they need, but before having access to the other + -- features they depend on + -- 2. in phase 2 they have access to the other features they depend on + -- this is serialised according to the dependencies of the features + -- 3. in phase 3 we run all post-init actions. This could also be parallel. + loginfo verbosity "Initialising features, part 1" + + mkStaticFilesFeature <- logStartup "static files" $ + initStaticFilesFeature env + mkUserFeature <- logStartup "user" $ + initUserFeature env + mkCoreFeature <- logStartup "core" $ + initCoreFeature env + mkMirrorFeature <- logStartup "mirror" $ + initMirrorFeature env + mkUploadFeature <- logStartup "upload" $ + initUploadFeature env +#ifndef MINIMAL + mkTarIndexCacheFeature <- logStartup "tar index" $ + initTarIndexCacheFeature env + mkPackageContentsFeature <- logStartup "package contents" $ + initPackageContentsFeature env + mkRecentPackagesFeature <- logStartup "recent packages" $ + initRecentPackagesFeature env + mkUserDetailsFeature <- logStartup "user details" $ + initUserDetailsFeature env + mkUserSignupFeature <- logStartup "user signup" $ + initUserSignupFeature env + mkLegacyPasswdsFeature <- logStartup "legacy passwords" $ + initLegacyPasswdsFeature env + mkDistroFeature <- logStartup "distro" $ + initDistroFeature env + mkPackageCandidatesFeature <- logStartup "package candidates" $ + initPackageCandidatesFeature env + mkBuildReportsCoreFeature <- logStartup "reports (core)" $ + initBuildReportsFeature "reports-core" env + mkBuildReportsCandidatesFeature <- logStartup "reports (candidates)" $ + initBuildReportsFeature "reports-candidates" env + mkDocumentationCoreFeature <- logStartup "documentation (core)" $ + initDocumentationFeature "documentation-core" env + mkDocumentationCandidatesFeature <- logStartup "documentation (candidates)" $ + initDocumentationFeature "documentation-candidates" env + mkDownloadFeature <- logStartup "download counts" $ + initDownloadFeature env + mkTagsFeature <- logStartup "tags" $ + initTagsFeature env + mkVersionsFeature <- logStartup "versions" $ + initVersionsFeature env + -- mkReverseFeature <- logStartup "reverse deps" $ + -- initReverseFeature env + mkListFeature <- logStartup "list" $ + initListFeature env + mkSearchFeature <- logStartup "search" $ + initSearchFeature env + mkPlatformFeature <- logStartup "platform" $ + initPlatformFeature env + mkHtmlFeature <- logStartup "html" $ + initHtmlFeature env + mkEditCabalFilesFeature <- logStartup "edit cabal files" $ + initEditCabalFilesFeature env + mkAdminFrontendFeature <- logStartup "admn frontend" $ + initAdminFrontendFeature env + mkHoogleDataFeature <- logStartup "hoogle" $ + initHoogleDataFeature env +#endif + + loginfo verbosity "Initialising features, part 2" + -- Arguments denote feature dependencies. -- What follows is a topological sort along those lines - staticFilesFeature <- initStaticFilesFeature env + staticFilesFeature <- mkStaticFilesFeature - usersFeature <- initUserFeature env + usersFeature <- mkUserFeature - coreFeature <- initCoreFeature env + coreFeature <- mkCoreFeature usersFeature - mirrorFeature <- initMirrorFeature env + mirrorFeature <- mkMirrorFeature coreFeature usersFeature - uploadFeature <- initUploadFeature env - coreFeature + uploadFeature <- mkUploadFeature usersFeature + coreFeature #ifndef MINIMAL - tarIndexCacheFeature <- initTarIndexCacheFeature env usersFeature + tarIndexCacheFeature <- mkTarIndexCacheFeature + usersFeature - packageContentsFeature <- initPackageContentsFeature env + packageContentsFeature <- mkPackageContentsFeature coreFeature tarIndexCacheFeature - packagesFeature <- initRecentPackagesFeature env + packagesFeature <- mkRecentPackagesFeature usersFeature coreFeature packageContentsFeature - userDetailsFeature <- initUserDetailsFeature env + userDetailsFeature <- mkUserDetailsFeature usersFeature coreFeature - userSignupFeature <- initUserSignupFeature env + userSignupFeature <- mkUserSignupFeature usersFeature userDetailsFeature + uploadFeature - legacyPasswdsFeature <- initLegacyPasswdsFeature env + legacyPasswdsFeature <- mkLegacyPasswdsFeature usersFeature - distroFeature <- initDistroFeature env + distroFeature <- mkDistroFeature usersFeature coreFeature - candidatesFeature <- initPackageCandidatesFeature env + candidatesFeature <- mkPackageCandidatesFeature usersFeature coreFeature uploadFeature tarIndexCacheFeature - reportsCoreFeature <- initBuildReportsFeature "reports-core" env + reportsCoreFeature <- mkBuildReportsCoreFeature usersFeature uploadFeature (coreResource coreFeature) - reportsCandidatesFeature <- initBuildReportsFeature "reports-candidates" env + reportsCandidatesFeature <- mkBuildReportsCandidatesFeature usersFeature uploadFeature (candidatesCoreResource candidatesFeature) - documentationCoreFeature <- initDocumentationFeature "documentation-core" env + documentationCoreFeature <- mkDocumentationCoreFeature (coreResource coreFeature) (map packageId . allPackages <$> queryGetPackageIndex coreFeature) uploadFeature tarIndexCacheFeature - documentationCandidatesFeature <- initDocumentationFeature "documentation-candidates" env + documentationCandidatesFeature <- mkDocumentationCandidatesFeature (candidatesCoreResource candidatesFeature) (map packageId . allPackages <$> queryGetCandidateIndex candidatesFeature) uploadFeature tarIndexCacheFeature - downloadFeature <- initDownloadFeature env + downloadFeature <- mkDownloadFeature coreFeature usersFeature - tagsFeature <- initTagsFeature env + tagsFeature <- mkTagsFeature coreFeature uploadFeature - versionsFeature <- initVersionsFeature env + versionsFeature <- mkVersionsFeature coreFeature uploadFeature tagsFeature {- [reverse index disabled] - reverseFeature <- initReverseFeature env + reverseFeature <- mkReverseFeature coreFeature versionsFeature -} - searchFeature <- initSearchFeature env - coreFeature - - listFeature <- initListFeature env + listFeature <- mkListFeature coreFeature -- [reverse index disabled] reverseFeature downloadFeature tagsFeature versionsFeature - platformFeature <- initPlatformFeature env + searchFeature <- mkSearchFeature + coreFeature + listFeature - htmlFeature <- initHtmlFeature env + platformFeature <- mkPlatformFeature + + htmlFeature <- mkHtmlFeature usersFeature coreFeature packagesFeature @@ -188,12 +263,24 @@ distroFeature documentationCoreFeature documentationCandidatesFeature + reportsCoreFeature userDetailsFeature - editCabalFeature <- initEditCabalFilesFeature env + editCabalFeature <- mkEditCabalFilesFeature usersFeature coreFeature uploadFeature + + adminFrontendFeature <- mkAdminFrontendFeature + usersFeature + userDetailsFeature + userSignupFeature + legacyPasswdsFeature + + hoogleDataFeature <- mkHoogleDataFeature + coreFeature + documentationCoreFeature + tarIndexCacheFeature #endif -- The order of initialization above should be the same as @@ -227,6 +314,8 @@ , getFeatureInterface htmlFeature , legacyRedirectsFeature uploadFeature , editCabalFeature + , adminFrontendFeature + , getFeatureInterface hoogleDataFeature #endif , staticFilesFeature , serverIntrospectFeature allFeatures @@ -238,21 +327,32 @@ -- 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 + sequence_ + [ logStartup ("post-init for " ++ name ++ "feature") $ + featurePostInit feature + | feature@HackageFeature { featureName = name } <- allFeatures ] loginfo verbosity "Initialising features done" return (allFeatures, usersFeature) + where + logStartup feature action = do + loginfo verbosity ("Initialising " ++ feature ++ " feature") + logTiming verbosity ("Initialising " ++ feature ++ " feature done") action + +-- | Checkpoint a feature's persistent state to disk. featureCheckpoint :: HackageFeature -> IO () featureCheckpoint = mapM_ abstractStateCheckpoint . featureState +-- | Checkpoint all features' persistent state. checkpointAllFeatures :: [HackageFeature] -> IO () checkpointAllFeatures = mapM_ featureCheckpoint +-- | Cleanly shut down a feature's state components. featureShutdown :: HackageFeature -> IO () featureShutdown = mapM_ abstractStateClose . featureState +-- | Cleanly shut down all features' state components. shutdownAllFeatures :: [HackageFeature] -> IO () shutdownAllFeatures = mapM_ featureShutdown . reverse diff --git a/Distribution/Server/Features/BuildReports.hs b/Distribution/Server/Features/BuildReports.hs --- a/Distribution/Server/Features/BuildReports.hs +++ b/Distribution/Server/Features/BuildReports.hs @@ -18,11 +18,15 @@ import Distribution.Server.Features.BuildReports.BuildReports (BuildReports, BuildReportId(..), BuildLog(..)) import qualified Distribution.Server.Framework.ResponseContentTypes as Resource +import Distribution.Server.Packages.Types + import qualified Distribution.Server.Framework.BlobStorage as BlobStorage import Distribution.Text import Distribution.Package +import Distribution.Version (Version(..)) +import Control.Arrow (second) import Data.ByteString.Lazy.Char8 (unpack) -- Build reports are ASCII @@ -31,6 +35,13 @@ -- 2. Decide build report upload policy (anonymous and authenticated) data ReportsFeature = ReportsFeature { reportsFeatureInterface :: HackageFeature, + + packageReports :: DynamicPath -> ([(BuildReportId, BuildReport)] -> ServerPartE Response) -> ServerPartE Response, + packageReport :: DynamicPath -> ServerPartE (BuildReportId, BuildReport, Maybe BuildLog), + + queryPackageReports :: MonadIO m => PackageId -> m [(BuildReportId, BuildReport)], + queryBuildLog :: MonadIO m => BuildLog -> m Resource.BuildLog, + reportsResource :: ReportsResource } @@ -50,13 +61,19 @@ initBuildReportsFeature :: String -> ServerEnv - -> UserFeature -> UploadFeature - -> CoreResource - -> IO ReportsFeature -initBuildReportsFeature name env@ServerEnv{serverStateDir} user upload core = do + -> IO (UserFeature + -> UploadFeature + -> CoreResource + -> IO ReportsFeature) +initBuildReportsFeature name env@ServerEnv{serverStateDir} = do reportsState <- reportsStateComponent name serverStateDir - return $ buildReportsFeature name env user upload core reportsState + return $ \user upload core -> do + let feature = buildReportsFeature name env + user upload core + reportsState + return feature + reportsStateComponent :: String -> FilePath -> IO (StateComponent AcidState BuildReports) reportsStateComponent name stateDir = do st <- openLocalStateFrom (stateDir "db" name) initialBuildReports @@ -65,7 +82,7 @@ , stateHandle = st , getState = query st GetBuildReports , putState = update st . ReplaceBuildReports - , backupState = dumpBackup + , backupState = \_ -> dumpBackup , restoreState = restoreBackup , resetState = reportsStateComponent name } @@ -79,9 +96,10 @@ -> ReportsFeature buildReportsFeature name ServerEnv{serverBlobStore = store} - UserFeature{..} UploadFeature{trusteesGroup} + UserFeature{..} UploadFeature{..} CoreResource{ packageInPath , guardValidPackageId + , lookupPackageId , corePackagePage } reportsState @@ -127,30 +145,56 @@ , reportsLogUri = \pkgid repid -> renderResource (reportsLog reportsResource) [display pkgid, display repid] } - textPackageReports dpath = do + --------------------------------------------------------------------------- + + packageReports :: DynamicPath -> ([(BuildReportId, BuildReport)] -> ServerPartE Response) -> ServerPartE Response + packageReports dpath continue = do pkgid <- packageInPath dpath - guardValidPackageId pkgid - reportList <- queryState reportsState $ LookupPackageReports pkgid - return . toResponse $ show reportList + case pkgVersion pkgid of + Version [] [] -> do + -- Redirect to the latest version + pkginfo <- lookupPackageId pkgid + seeOther (reportsListUri reportsResource "" (pkgInfoId pkginfo)) $ + toResponse () + _ -> do + guardValidPackageId pkgid + queryPackageReports pkgid >>= continue - textPackageReport dpath = do + packageReport :: DynamicPath -> ServerPartE (BuildReportId, BuildReport, Maybe BuildLog) + packageReport 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] + 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) + queryPackageReports :: MonadIO m => PackageId -> m [(BuildReportId, BuildReport)] + queryPackageReports pkgid = do + reports <- queryState reportsState $ LookupPackageReports pkgid + return $ map (second fst) reports + + queryBuildLog :: MonadIO m => BuildLog -> m Resource.BuildLog + queryBuildLog (BuildLog blobId) = do + file <- liftIO $ BlobStorage.fetch store blobId + return $ Resource.BuildLog file + + --------------------------------------------------------------------------- + + textPackageReports dpath = packageReports dpath $ return . toResponse . show + + textPackageReport dpath = do + (_, report, _) <- packageReport dpath + return . toResponse $ BuildReport.show report + -- result: not-found error or text file serveBuildLog :: DynamicPath -> ServerPartE Response serveBuildLog dpath = do - pkgid <- packageInPath dpath - guardValidPackageId pkgid - (repid, _, mlog) <- packageReport dpath pkgid + (repid, _, mlog) <- packageReport dpath 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 + Just logId -> toResponse <$> queryBuildLog logId -- result: auth error, not-found error, parse error, or redirect submitBuildReport :: DynamicPath -> ServerPartE Response @@ -162,7 +206,11 @@ case BuildReport.parse $ unpack reportbody of Left err -> errBadRequest "Error submitting report" [MText err] Right report -> do - reportId <- updateState reportsState $ AddReport pkgid (report, Nothing) + when (BuildReport.docBuilder report) $ + -- Check that the submitter can actually upload docs + guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) + report' <- liftIO $ BuildReport.affixTimestamp report + reportId <- updateState reportsState $ AddReport pkgid (report', Nothing) -- redirect to new reports page seeOther (reportsPageUri reportsResource "" pkgid reportId) $ toResponse () @@ -188,7 +236,6 @@ 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 @@ -199,8 +246,7 @@ 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 () + noContent (toResponse ()) {- Example using curl: (TODO: why is this PUT, while logs are POST?) @@ -212,7 +258,6 @@ 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 @@ -220,19 +265,9 @@ 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 () + noContent (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) - diff --git a/Distribution/Server/Features/BuildReports/Backup.hs b/Distribution/Server/Features/BuildReports/Backup.hs --- a/Distribution/Server/Features/BuildReports/Backup.hs +++ b/Distribution/Server/Features/BuildReports/Backup.hs @@ -72,7 +72,7 @@ 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) + report <- either fail return $ 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') diff --git a/Distribution/Server/Features/BuildReports/BuildReport.hs b/Distribution/Server/Features/BuildReports/BuildReport.hs --- a/Distribution/Server/Features/BuildReports/BuildReport.hs +++ b/Distribution/Server/Features/BuildReports/BuildReport.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, RecordWildCards, + TemplateHaskell, TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Reporting @@ -23,10 +24,14 @@ parseList, show, showList, + + affixTimestamp, + + BuildReport_v0, ) where import Distribution.Package - ( PackageIdentifier ) + ( PackageIdentifier(..) ) import Distribution.PackageDescription ( FlagName(..), FlagAssignment ) --import Distribution.Version @@ -36,10 +41,10 @@ import Distribution.Compiler ( CompilerId ) import qualified Distribution.Text as Text - ( Text(disp, parse) ) + ( Text(disp, parse), display ) import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..), Field(..) - , simpleField, listField, readFields + , simpleField, boolField, listField, readFields , syntaxError, locatedErrorMsg, showFields ) import Distribution.Simple.Utils ( comparing ) @@ -48,26 +53,49 @@ 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 - ( (<+>), (<>) ) + ( (<+>), (<>), render ) +import Data.Serialize as Serialize + ( Serialize(..) ) +import Data.SafeCopy + ( SafeCopy(..), deriveSafeCopy, extension, base, Migrate(..) ) +import Test.QuickCheck + ( Arbitrary(..), elements, oneof ) +import Text.StringTemplate () +import Text.StringTemplate.Classes + ( SElem(..), ToSElem(..) ) +import Data.Foldable + ( foldMap ) import Data.List ( unfoldr, sortBy ) import Data.Char as Char ( isAlpha, isAlphaNum ) +import qualified Data.ByteString.Char8 as BS +import qualified Data.Map as Map +import Data.Time + ( UTCTime, getCurrentTime ) import Data.Typeable ( Typeable ) +import Control.Applicative +import Control.Monad import Prelude hiding (show, read) + data BuildReport = BuildReport { -- | The package this build report is about package :: PackageIdentifier, + -- | The time at which the report was uploaded + time :: Maybe UTCTime, + + -- | Whether the client was generating documentation for upload + docBuilder :: Bool, + -- | The OS and Arch the package was built on os :: OS, arch :: Arch, @@ -102,7 +130,8 @@ deriving (Eq, Typeable, Show) data InstallOutcome - = DependencyFailed PackageIdentifier + = PlanningFailed + | DependencyFailed PackageIdentifier | DownloadFailed | UnpackFailed | SetupFailed @@ -110,9 +139,9 @@ | BuildFailed | InstallFailed | InstallOk - deriving (Eq, Show) + deriving (Eq, Ord, Show) -data Outcome = NotTried | Failed | Ok deriving (Eq, Show) +data Outcome = NotTried | Failed | Ok deriving (Eq, Ord, Show) -- ------------------------------------------------------------ -- * External format @@ -121,6 +150,8 @@ initialBuildReport :: BuildReport initialBuildReport = BuildReport { package = requiredField "package", + time = Nothing, + docBuilder = False, os = requiredField "os", arch = requiredField "arch", compiler = requiredField "compiler", @@ -136,7 +167,20 @@ where requiredField fname = error ("required field: " ++ fname) +requiredFields :: [String] +requiredFields + = ["package", "os", "arch", "compiler", "client", "install-outcome"] + -- ----------------------------------------------------------------------------- +-- Timestamps + +-- | If the 'time' field is empty, fill it in with the current time. +affixTimestamp :: BuildReport -> IO BuildReport +affixTimestamp report = case time report of + Nothing -> (\v -> report { time = Just v }) <$> getCurrentTime + Just _ -> return report + +-- ----------------------------------------------------------------------------- -- Parsing read :: String -> BuildReport @@ -144,19 +188,18 @@ Left err -> error $ "error parsing build report: " ++ err Right rpt -> rpt -parse :: Monad m => String -> m BuildReport +parse :: String -> Either String BuildReport parse s = case parseFields s of - ParseFailed perror -> fail msg where (_, msg) = locatedErrorMsg perror - ParseOk _ report -> return report + ParseFailed perror -> Left msg where (_, msg) = locatedErrorMsg perror + ParseOk _ report -> Right 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 + foldM checkMerged initialBuildReport merged where extractField :: Field -> ParseResult (Int, String, String) @@ -164,15 +207,15 @@ 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 + checkMerged report merged = case merged of + InBoth fieldDescr (line, _name, value) -> + fieldSet fieldDescr line value report OnlyInRight (line, name, _) -> syntaxError line ("Unrecognized field " ++ name) - OnlyInLeft fieldDescr -> - fail ("Missing field " ++ fieldName fieldDescr) + OnlyInLeft fieldDescr + | fieldName fieldDescr `elem` requiredFields -> + fail ("Missing field " ++ fieldName fieldDescr) + | otherwise -> return report parseList :: String -> [BuildReport] parseList str = @@ -198,6 +241,9 @@ fieldDescrs = [ simpleField "package" Text.disp Text.parse package (\v r -> r { package = v }) + , simpleField "time" dispTime parseTime + time (\v r -> r { time = v }) + , boolField "doc-builder" docBuilder (\v r -> r { docBuilder = v }) , simpleField "os" Text.disp Text.parse os (\v r -> r { os = v }) , simpleField "arch" Text.disp Text.parse @@ -217,6 +263,9 @@ , simpleField "tests-outcome" Text.disp Text.parse testsOutcome (\v r -> r { testsOutcome = v }) ] + where + dispTime = foldMap Text.disp + parseTime = (Just <$> Text.parse) Parse.<++ pure Nothing sortedFieldDescrs :: [FieldDescr BuildReport] sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs @@ -233,6 +282,7 @@ flag -> return (FlagName flag, True) instance Text.Text InstallOutcome where + disp PlanningFailed = Disp.text "PlanningFailed" disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid disp DownloadFailed = Disp.text "DownloadFailed" disp UnpackFailed = Disp.text "UnpackFailed" @@ -245,6 +295,7 @@ parse = do name <- Parse.munch1 Char.isAlphaNum case name of + "PlanningFailed" -> return PlanningFailed "DependencyFailed" -> do Parse.skipSpaces pkgid <- Text.parse return (DependencyFailed pkgid) @@ -270,7 +321,7 @@ _ -> 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 + memSize (BuildReport a b c d e f g h i j k l) = memSize10 a b c d e f g h i j + memSize k + memSize l instance MemSize InstallOutcome where memSize (DependencyFailed a) = memSize1 a @@ -278,3 +329,154 @@ instance MemSize Outcome where memSize _ = memSize0 + +------------------- +-- HStringTemplate instances +-- + +instance ToSElem BuildReport where + toSElem BuildReport{..} = SM . Map.fromList $ + [ ("package", display package) + , ("time", toSElem time) + , ("docBuilder", toSElem docBuilder) + , ("os", display os) + , ("arch", display arch) + , ("compiler", display compiler) + , ("client", display client) + , ("flagAssignment", toSElem $ map (render . dispFlag) flagAssignment) + , ("dependencies", toSElem $ map Text.display dependencies) + , ("installOutcome", display installOutcome) + , ("docsOutcome", display docsOutcome) + , ("testsOutcome", display testsOutcome) + ] + where + display value = toSElem (Text.display value) + +------------------- +-- Arbitrary instances +-- + +instance Arbitrary BuildReport where + arbitrary = BuildReport <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary InstallOutcome where + arbitrary = oneof [ pure PlanningFailed + , pure DependencyFailed <*> arbitrary + , pure DownloadFailed + , pure UnpackFailed + , pure SetupFailed + , pure ConfigureFailed + , pure BuildFailed + , pure InstallFailed + , pure InstallOk + ] + +instance Arbitrary Outcome where + arbitrary = elements [ NotTried, Failed, Ok ] + + +------------------- +-- SafeCopy instances +-- + +deriveSafeCopy 0 'base ''Outcome +deriveSafeCopy 1 'extension ''InstallOutcome +deriveSafeCopy 3 'extension ''BuildReport + + +------------------- +-- Old SafeCopy versions +-- + +-- Note this is kind of backwards from a migration pov, but this is because +-- the oldest one used a textual external rep with a parser, and the only +-- version we have with a parser is the latest, but they're sufficiently +-- compatible that we can get away with it for now. +newtype BuildReport_v0 = BuildReport_v0 BuildReport + +instance SafeCopy BuildReport_v0 +instance Serialize BuildReport_v0 where + put (BuildReport_v0 br) = Serialize.put . BS.pack . show $ br + get = (BuildReport_v0 . read . BS.unpack) `fmap` Serialize.get + +instance Migrate BuildReport_v1 where + type MigrateFrom BuildReport_v1 = BuildReport_v0 + migrate (BuildReport_v0 BuildReport{..}) = BuildReport_v1 { + v1_package = package + , v1_os = os + , v1_arch = arch + , v1_compiler = compiler + , v1_client = client + , v1_flagAssignment = flagAssignment + , v1_dependencies = dependencies + , v1_installOutcome = case installOutcome of + PlanningFailed -> error "impossible rev migration" + DependencyFailed pkgid -> V0_DependencyFailed pkgid + DownloadFailed -> V0_DownloadFailed + UnpackFailed -> V0_UnpackFailed + SetupFailed -> V0_SetupFailed + ConfigureFailed -> V0_ConfigureFailed + BuildFailed -> V0_BuildFailed + InstallFailed -> V0_InstallFailed + InstallOk -> V0_InstallOk + , v1_docsOutcome = docsOutcome + , v1_testsOutcome = testsOutcome + } + +data BuildReport_v1 = BuildReport_v1 { + v1_package :: PackageIdentifier, + v1_os :: OS, + v1_arch :: Arch, + v1_compiler :: CompilerId, + v1_client :: PackageIdentifier, + v1_flagAssignment :: FlagAssignment, + v1_dependencies :: [PackageIdentifier], + v1_installOutcome :: InstallOutcome_v0, + v1_docsOutcome :: Outcome, + v1_testsOutcome :: Outcome + } + +data InstallOutcome_v0 + = V0_DependencyFailed PackageIdentifier + | V0_DownloadFailed + | V0_UnpackFailed + | V0_SetupFailed + | V0_ConfigureFailed + | V0_BuildFailed + | V0_InstallFailed + | V0_InstallOk + +deriveSafeCopy 0 'base ''InstallOutcome_v0 +deriveSafeCopy 2 'extension ''BuildReport_v1 + +instance Migrate BuildReport where + type MigrateFrom BuildReport = BuildReport_v1 + migrate BuildReport_v1{..} = BuildReport { + package = v1_package + , time = Nothing + , docBuilder = True -- Most old reports come from the doc builder anyway + , os = v1_os + , arch = v1_arch + , compiler = v1_compiler + , client = v1_client + , flagAssignment = v1_flagAssignment + , dependencies = v1_dependencies + , installOutcome = migrate v1_installOutcome + , docsOutcome = v1_docsOutcome + , testsOutcome = v1_testsOutcome + } + +instance Migrate InstallOutcome where + type MigrateFrom InstallOutcome = InstallOutcome_v0 + migrate outcome = case outcome of + V0_DependencyFailed pkgid -> DependencyFailed pkgid + V0_DownloadFailed -> DownloadFailed + V0_UnpackFailed -> UnpackFailed + V0_SetupFailed -> SetupFailed + V0_ConfigureFailed -> ConfigureFailed + V0_BuildFailed -> BuildFailed + V0_InstallFailed -> InstallFailed + V0_InstallOk -> InstallOk diff --git a/Distribution/Server/Features/BuildReports/BuildReports.hs b/Distribution/Server/Features/BuildReports/BuildReports.hs --- a/Distribution/Server/Features/BuildReports/BuildReports.hs +++ b/Distribution/Server/Features/BuildReports/BuildReports.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell, + TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Distribution.Server.Features.BuildReports.BuildReports ( BuildReport(..), @@ -17,28 +18,30 @@ ) 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.Server.Features.BuildReports.BuildReport + (BuildReport(..), BuildReport_v0) import Distribution.Package (PackageId) -import Distribution.Text (Text(..)) +import Distribution.Text (Text(..), display) import Distribution.Server.Framework.MemSize +import Distribution.Server.Framework.Instances import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Serialize as Serialize import Data.Serialize (Serialize) +import Data.SafeCopy import Data.Typeable (Typeable) import Control.Applicative ((<$>)) import qualified Distribution.Server.Util.Parse as Parse import qualified Text.PrettyPrint as Disp +import Text.StringTemplate (ToSElem(..)) -import qualified Data.ByteString.Char8 as BS.Char8 -- Build reports are ASCII newtype BuildReportId = BuildReportId Int - deriving (Eq, Ord, Serialize, Typeable, Show, MemSize) + deriving (Eq, Ord, Typeable, Show, MemSize) incrementReportId :: BuildReportId -> BuildReportId incrementReportId (BuildReportId n) = BuildReportId (n+1) @@ -48,7 +51,7 @@ parse = BuildReportId <$> Parse.int newtype BuildLog = BuildLog BlobStorage.BlobId - deriving (Eq, Serialize, Typeable, Show, MemSize) + deriving (Eq, Typeable, Show, MemSize) data PkgBuildReports = PkgBuildReports { -- for each report, other useful information: Maybe UserId, UTCTime @@ -117,39 +120,100 @@ in Just $ buildReports { reportsIndex = Map.insert pkgid pkgReports' (reportsIndex buildReports) } ------------------- --- Serialize instances +-- HStringTemplate instances -- -instance Serialize BuildReport where - put = Serialize.put . BS.Char8.pack . BuildReport.show - get = (BuildReport.read . BS.Char8.unpack) `fmap` Serialize.get +instance ToSElem BuildReportId where + toSElem = toSElem . display -instance Serialize BuildReports where - put (BuildReports index) = Serialize.put index - get = do - rs <- Serialize.get - return BuildReports { - reportsIndex = rs - } +------------------- +-- SafeCopy instances +-- +deriveSafeCopy 2 'extension ''BuildReportId +deriveSafeCopy 2 'extension ''BuildLog +deriveSafeCopy 2 'extension ''BuildReports + -- 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 SafeCopy PkgBuildReports where + version = 2 + kind = extension + putCopy (PkgBuildReports x _) = contain $ safePut x + getCopy = contain $ mkReports <$> safeGet + where + mkReports rs = PkgBuildReports rs + (if Map.null rs + then BuildReportId 1 + else incrementReportId (fst $ Map.findMax rs)) instance MemSize BuildReports where memSize (BuildReports a) = memSize1 a instance MemSize PkgBuildReports where memSize (PkgBuildReports a b) = memSize2 a b + + +------------------- +-- Old SafeCopy versions +-- + +newtype BuildReportId_v0 = BuildReportId_v0 Int deriving (Serialize, Enum, Eq, Ord) +instance SafeCopy BuildReportId_v0 + +instance Migrate BuildReportId where + type MigrateFrom BuildReportId = BuildReportId_v0 + migrate (BuildReportId_v0 bid) = BuildReportId bid + +--- + +newtype BuildLog_v0 = BuildLog_v0 BlobStorage.BlobId_v0 deriving Serialize +instance SafeCopy BuildLog_v0 + +instance Migrate BuildLog where + type MigrateFrom BuildLog = BuildLog_v0 + migrate (BuildLog_v0 bl) = BuildLog (migrate bl) + +--- + +data BuildReports_v0 = BuildReports_v0 + !(Map.Map PackageIdentifier_v0 PkgBuildReports_v0) + +instance SafeCopy BuildReports_v0 +instance Serialize BuildReports_v0 where + put (BuildReports_v0 index) = Serialize.put index + get = BuildReports_v0 <$> Serialize.get + +instance Migrate BuildReports where + type MigrateFrom BuildReports = BuildReports_v0 + migrate (BuildReports_v0 m) = + BuildReports (Map.mapKeys migrate $ Map.map migrate m) + +--- + +data PkgBuildReports_v0 = PkgBuildReports_v0 + !(Map BuildReportId_v0 (BuildReport_v0, Maybe BuildLog_v0)) + !BuildReportId_v0 + +instance SafeCopy PkgBuildReports_v0 +instance Serialize PkgBuildReports_v0 where + put (PkgBuildReports_v0 listing _) = Serialize.put listing + get = mkReports <$> Serialize.get + where + mkReports rs = PkgBuildReports_v0 rs + (if Map.null rs + then BuildReportId_v0 1 + else succ (fst $ Map.findMax rs)) + +instance Migrate PkgBuildReports where + type MigrateFrom PkgBuildReports = PkgBuildReports_v0 + migrate (PkgBuildReports_v0 m n) = + PkgBuildReports (migrateMap m) (migrate n) + where + migrateMap :: Map BuildReportId_v0 (BuildReport_v0, Maybe BuildLog_v0) + -> Map BuildReportId (BuildReport, Maybe BuildLog) + migrateMap = Map.mapKeys migrate + . Map.map (\(br, l) -> (migrate (migrate br), + fmap migrate l)) diff --git a/Distribution/Server/Features/BuildReports/Render.hs b/Distribution/Server/Features/BuildReports/Render.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/BuildReports/Render.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE RecordWildCards #-} + +module Distribution.Server.Features.BuildReports.Render + ( renderBuildStatus + ) where + +import Distribution.Server.Framework + +import Distribution.Server.Features.BuildReports +import Distribution.Server.Features.BuildReports.BuildReports (BuildReportId) +import Distribution.Server.Features.BuildReports.BuildReport (BuildReport(..), InstallOutcome(..), Outcome(..)) +import Distribution.Server.Features.Documentation + +import Distribution.Package + +import Text.XHtml.Strict + +import Control.Arrow ((&&&)) +import Data.Foldable (foldMap) +import Data.List (sortBy, maximumBy) +import Data.Ord (comparing) +import Data.Time (UTCTime(utctDay), showGregorian) + + +data BuildStatus = BuildStatus { + rendDocsReport :: Maybe (BuildReportId, BuildReport), + rendBuildability :: Maybe (Bool, Maybe UTCTime), + rendNumReports :: Int +} deriving (Show) + + +renderBuildStatus :: MonadIO m => DocumentationFeature -> ReportsFeature -> PackageId -> m Html +renderBuildStatus DocumentationFeature{..} ReportsFeature{..} pkgid = do + hasDocs <- queryHasDocumentation pkgid + reports <- queryPackageReports pkgid + return $ render reportsResource pkgid hasDocs (summarize reports) + + +summarize :: [(BuildReportId, BuildReport)] -> BuildStatus +summarize unsortedReports = BuildStatus{..} + where + -- Order the reports from oldest to newest. As maximumBy favors later + -- elements, this will ensure we pick the most recent report. + allReports = sortBy (comparing fst) unsortedReports + + -- When determining the doc status, only use reports generated by the server + docReports = filter (docBuilder . snd) allReports + + rendDocsReport + | null docReports = Nothing + | otherwise = Just $ maximumBy (comparing (docsOutcome . snd)) docReports + + rendBuildability + | null allReports = Nothing + | otherwise = Just $ (isSuccess &&& time) . snd $ + maximumBy (comparing (isSuccess . snd)) allReports + where + isSuccess BuildReport{..} + = installOutcome == InstallOk && testsOutcome /= Failed + + rendNumReports = length allReports + + +render :: ReportsResource -> PackageId -> Bool -> BuildStatus -> Html +render ReportsResource{..} pkgid hasDocs BuildStatus{..} + = mconcat + [ docsStatus + , reportLink + , br + , buildStatus + , reportsLink + ] + where + + docsStatus = toHtml $ case hasDocs of + False -> case rendDocsReport of + Nothing -> "Docs pending" + Just _ -> "Docs not available" + True -> case rendDocsReport of + Just (_, BuildReport{ docsOutcome = Ok }) -> "Docs available" + _ -> "Docs uploaded by user" + + reportLink = foldMap link rendDocsReport + where + link (repid, _) = (" " +++) . enclose $ + anchor ! [href $ reportsPageUri "" pkgid repid] << "build log" + + buildStatus = toHtml $ case rendBuildability of + Nothing -> "Build status unknown" + Just (False, mtime) -> "All reported builds failed" + ++ foldMap (\tm -> " as of " ++ showDate tm) mtime + Just (True, Nothing) -> "Successful builds reported" + Just (True, Just tm) -> "Last success reported on " ++ showDate tm + where + showDate = showGregorian . utctDay + + reportsLink = (" " +++) . enclose $ anchor ! [href $ reportsListUri "" pkgid] + << if rendNumReports > 0 + then "all " ++ show rendNumReports ++ " reports" + else "no reports yet" + + enclose item = thespan ! [thestyle "font-size: small"] + << ("[" +++ item +++ "]") diff --git a/Distribution/Server/Features/BuildReports/State.hs b/Distribution/Server/Features/BuildReports/State.hs --- a/Distribution/Server/Features/BuildReports/State.hs +++ b/Distribution/Server/Features/BuildReports/State.hs @@ -4,41 +4,14 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Distribution.Server.Features.BuildReports.State where -import Distribution.Server.Features.BuildReports.BuildReports (BuildReportId, BuildLog, BuildReport, BuildReports, PkgBuildReports) +import Distribution.Server.Features.BuildReports.BuildReports (BuildReportId, BuildLog, BuildReport, BuildReports) 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 diff --git a/Distribution/Server/Features/Core.hs b/Distribution/Server/Features/Core.hs --- a/Distribution/Server/Features/Core.hs +++ b/Distribution/Server/Features/Core.hs @@ -25,53 +25,105 @@ import Distribution.Server.Packages.Types import Distribution.Server.Users.Types (UserId) +import Distribution.Server.Users.Users (userIdToName) import qualified Distribution.Server.Packages.Index as Packages.Index import qualified Codec.Compression.GZip as GZip +import Data.Digest.Pure.MD5 (md5) 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.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Format (formatTime) +import System.Locale (defaultTimeLocale) import Data.Map (Map) import qualified Data.Map as Map import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BS import Distribution.Text (display) import Distribution.Package import Distribution.Version (Version(..)) +import Data.Aeson (Value(..)) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Vector as Vector +import qualified Data.Text as Text +-- | The core feature, responsible for the main package index and all access +-- and modifications of it. +-- +-- All packages must have a Cabal file, uploader, and upload time, and may have +-- a source tarball. data CoreFeature = CoreFeature { + -- | The core `HackageFeature`. coreFeatureInterface :: HackageFeature, - coreResource :: CoreResource, + -- | Core package resources and combinators. + coreResource :: CoreResource, - -- queries + -- Queries + -- | Retrieves the entire main package index. queryGetPackageIndex :: MonadIO m => m (PackageIndex PkgInfo), - -- update transactions + -- Update transactions + -- | Adds a version of a package which did not previously exist in the + -- index. This requires a Cabal file and context, and optionally a + -- reference to a tarball blob, and does not do any consistency checking + -- of these. + -- + -- If a package was able to be newly added, runs a `PackageChangeAdd` hook + -- when done and returns True. updateAddPackage :: MonadIO m => PackageId -> CabalFileText -> UploadInfo -> Maybe PkgTarball -> m Bool, + -- | Deletes a version of an existing package, deleting the package if it + -- was the last version. + -- + -- If a package was found and deleted, runs a `PackageChangeDelete` hook + -- when done and returns True. updateDeletePackage :: MonadIO m => PackageId -> m Bool, + + -- | Adds a new Cabal file for this package version, creating it if + -- necessary. Previous Cabal files are kept around. + -- + -- Runs either a `PackageChangeAdd` or `PackageChangeInfo` hook, depending + -- on whether a package with the given version already existed. updateAddPackageRevision :: MonadIO m => PackageId -> CabalFileText -> UploadInfo -> m (), + -- | Sets the source tarball for an existing package version. References to + -- previous tarballs, if any, are kept around. + -- + -- If this package was found, runs a `PackageChangeInfo` hook when done and + -- returns True. updateAddPackageTarball :: MonadIO m => PackageId -> PkgTarball -> UploadInfo -> m Bool, + -- | Sets the uploader of an existing package version. + -- + -- If this package was found, runs a `PackageChangeInfo` hook when done and + -- returns True. updateSetPackageUploader :: MonadIO m => PackageId -> UserId -> m Bool, + -- | Sets the upload time of an existing package version. + -- + -- If this package was found, runs a `PackageChangeInfo` hook when done and + -- returns True. 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. + -- or crypto signatures. This requires a file name, file contents, and + -- modification time for the tar entry. + -- + -- This runs a `PackageChangeIndexExtra` hook when done. updateArchiveIndexEntry :: MonadIO m => String -> (ByteString, UTCTime) -> m (), - -- | Notification of package or index changes + -- | Notification of package or index changes. packageChangeHook :: Hook PackageChange (), - -- | Notification of downloads + -- | Notification of tarball downloads. packageDownloadHook :: Hook PackageId () } @@ -80,25 +132,43 @@ -- | 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 +data PackageChange + -- | A package was newly added with this `PkgInfo`. + = PackageChangeAdd PkgInfo + -- | A package was deleted, and this `PkgInfo` is no longer accessible in + -- the package index. + | PackageChangeDelete PkgInfo + -- | A package was updated from the first `PkgInfo` to the second. + | PackageChangeInfo PkgInfo PkgInfo + -- | A file has changed in the package index tar not covered by any of the + -- other change types. + | PackageChangeIndexExtra String ByteString UTCTime +-- | A predicate to use with `packageChangeHook` and `registerHookJust` for +-- keeping other features synchronized with the main package index. +-- +-- This indicates an update for a given `PackageId`, and the new `PkgInfo` if +-- a new one has been added (`Nothing` in the case of deletion). 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 +-- | A predicate to use with `packageChangeHook` and `registerHookJust` for +-- newly added packages. isPackageAdd :: PackageChange -> Maybe PkgInfo isPackageAdd (PackageChangeAdd pkginfo) = Just pkginfo isPackageAdd _ = Nothing +-- | A predicate to use with `packageChangeHook` and `registerHookJust` for +-- deleted packages. isPackageDelete :: PackageChange -> Maybe PkgInfo isPackageDelete (PackageChangeDelete pkginfo) = Just pkginfo isPackageDelete _ = Nothing +-- | A predicate to use with `packageChangeHook` and `registerHookJust` for +-- any kind of change to packages or extras. isPackageIndexChange :: PackageChange -> Maybe () isPackageIndexChange _ = Just () @@ -113,38 +183,57 @@ -} data CoreResource = CoreResource { + -- | The collection all packages. corePackagesPage :: Resource, + -- | An individual package. corePackagePage :: Resource, + -- | A Cabal file for a package version. coreCabalFile :: Resource, + -- | A tarball for a package version. corePackageTarball :: Resource, - -- Render resources + -- Rendering resources. + -- | URI for `corePackagesPage`, given a format (blank for none). indexPackageUri :: String -> String, + -- | URI for `corePackagePage`, given a format and `PackageId`. corePackageIdUri :: String -> PackageId -> String, + -- | URI for `corePackagePage`, given a format and `PackageName`. corePackageNameUri :: String -> PackageName -> String, + -- | URI for `coreCabalFile`, given a PackageId. coreCabalUri :: PackageId -> String, + -- | URI for `corePackageTarball`, given a PackageId. coreTarballUri :: PackageId -> String, - -- Find a PackageId or PackageName inside a path + -- | Find a PackageId or PackageName inside a path. packageInPath :: (MonadPlus m, FromReqURI a) => DynamicPath -> m a, + -- | Find a tarball's PackageId from inside a path, doing some checking + -- for consistency between the package and tarball. + -- -- 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) + -- | Check that a particular version of a package exists (guard fails if + -- version is empty) guardValidPackageId :: PackageId -> ServerPartE (), + -- | Check that a package exists. guardValidPackageName :: PackageName -> ServerPartE (), - -- Find a package in the package DB + -- | Find a package in the package DB, failing if not found. This uses the + -- highest version number of a package. + -- + -- In the presence of deprecation or preferred versions, + -- `withPackagePreferred` should generally be used instead for user-facing + -- version resolution. lookupPackageName :: PackageName -> ServerPartE [PkgInfo], + -- | Find a package version in the package DB, failing if not found. Behaves + -- like `lookupPackageName` if the version is empty. lookupPackageId :: PackageId -> ServerPartE PkgInfo } -initCoreFeature :: ServerEnv -> UserFeature -> IO CoreFeature +initCoreFeature :: ServerEnv -> IO (UserFeature -> IO CoreFeature) initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay, - serverVerbosity = verbosity} users = do - loginfo verbosity "Initialising core feature, start" - + serverVerbosity = verbosity} = do -- Canonical state packagesState <- packagesStateComponent verbosity serverStateDir @@ -156,26 +245,26 @@ packageChangeHook <- newHook packageDownloadHook <- newHook - rec let (feature, getIndexTarball) - = coreFeature env users - packagesState extraMap indexTar - packageChangeHook packageDownloadHook + return $ \users -> do + 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 - } + -- Caches + -- The index.tar.gz file + indexTar <- newAsyncCacheNF getIndexTarball + defaultAsyncCachePolicy { + asyncCacheName = "index tarball", + asyncCacheUpdateDelay = serverCacheDelay, + asyncCacheSyncInit = False, + asyncCacheLogVerbosity = verbosity + } - registerHookJust packageChangeHook isPackageIndexChange $ \_ -> - prodAsyncCache indexTar + registerHookJust packageChangeHook isPackageIndexChange $ \_ -> + prodAsyncCache indexTar - loginfo verbosity "Initialising core feature, end" - return feature + return feature packagesStateComponent :: Verbosity -> FilePath -> IO (StateComponent AcidState PackagesState) @@ -188,7 +277,7 @@ , stateHandle = st , getState = query st GetPackagesState , putState = update st . ReplacePackagesState - , backupState = indexToAllVersions + , backupState = \_ -> indexToAllVersions , restoreState = packagesBackup , resetState = packagesStateComponent verbosity } @@ -197,11 +286,11 @@ -> UserFeature -> StateComponent AcidState PackagesState -> MemState (Map String (ByteString, UTCTime)) - -> AsyncCache ByteString + -> AsyncCache IndexTarball -> Hook PackageChange () -> Hook PackageId () -> ( CoreFeature - , IO ByteString ) + , IO IndexTarball ) coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} packagesState indexExtras cacheIndexTarball @@ -217,6 +306,8 @@ , corePackageRedirect , corePackageTarball , coreCabalFile + , coreCabalFileRevs + , coreCabalFileRev ] , featureState = [abstractAcidStateComponent packagesState] , featureCaches = [ @@ -239,7 +330,8 @@ , resourceGet = [("tarball", servePackagesIndex)] } corePackagesPage = (resourceAt "/packages/.:format") { - resourceGet = [] -- have basic packages listing? + resourceDesc = [(GET, "List of all packages")] + , resourceGet = [("json", servePackageList)] } corePackagePage = resourceAt "/package/:package.:format" corePackageRedirect = (resourceAt "/package/") { @@ -254,6 +346,14 @@ resourceDesc = [(GET, "Get package .cabal file")] , resourceGet = [("cabal", serveCabalFile)] } + coreCabalFileRevs = (resourceAt "/package/:package/revisions/") { + resourceDesc = [(GET, "List all package .cabal file revisions")] + , resourceGet = [("json", serveCabalFileRevisionsList)] + } + coreCabalFileRev = (resourceAt "/package/:package/revision/:revision.:format") { + resourceDesc = [(GET, "Get package .cabal file revision")] + , resourceGet = [("cabal", serveCabalFileRevision)] + } indexPackageUri = \format -> renderResource corePackagesPage [format] corePackageIdUri = \format pkgid -> @@ -355,13 +455,15 @@ -- Cache updates -- - getIndexTarball :: IO ByteString + getIndexTarball :: IO IndexTarball 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' + time <- getCurrentTime + let indexTarball = GZip.compress (Packages.Index.write users extras index) + return $! IndexTarball indexTarball (fromIntegral $ BS.length indexTarball) + (md5 indexTarball) time ------------------------------------------------------------------------------ packageError :: [MessageSpan] -> ServerPartE a @@ -389,9 +491,28 @@ servePackagesIndex :: DynamicPath -> ServerPartE Response servePackagesIndex _ = do - indexTarball <- readAsyncCache cacheIndexTarball - return $ toResponse (Resource.IndexTarball indexTarball) + tarball@(IndexTarball _ _ tarballmd5 _) <- readAsyncCache cacheIndexTarball + cacheControl [Public, NoTransform, maxAgeMinutes 5] + (ETag (show tarballmd5)) + return (toResponse tarball) + -- TODO: should we include more information here? description and + -- category for instance (but they are not readily available as long + -- as we don't keep the parsed cabal files in memory) + servePackageList :: DynamicPath -> ServerPartE Response + servePackageList _ = do + pkgIndex <- queryGetPackageIndex + let pkgs = PackageIndex.allPackagesByName pkgIndex + list = [display . pkgName . pkgInfoId $ pkg | pkg <- map head pkgs] + -- We construct the JSON manually so that we control what it looks like; + -- in particular, we use objects for the packages so that we can add + -- additional fields later without (hopefully) breaking clients + let json = flip map list $ \str -> + Object . HashMap.fromList $ [ + (Text.pack "packageName", String (Text.pack str)) + ] + return . toResponse $ Array (Vector.fromList json) + -- result: tarball or not-found error servePackageTarball :: DynamicPath -> ServerPartE Response servePackageTarball dpath = do @@ -402,6 +523,8 @@ [] -> errNotFound "Tarball not found" [MText "No tarball exists for this package version."] ((tb, _):_) -> do let blobId = pkgTarballGz tb + cacheControl [Public, NoTransform, maxAgeDays 30] + (BlobStorage.blobETag blobId) file <- liftIO $ BlobStorage.fetch store blobId runHook_ packageDownloadHook pkgid return $ toResponse $ Resource.PackageTarball file blobId (pkgUploadTime pkg) @@ -415,7 +538,37 @@ True -> return $ toResponse (Resource.CabalFile (cabalFileByteString (pkgData pkg))) False -> mzero + serveCabalFileRevisionsList :: DynamicPath -> ServerPartE Response + serveCabalFileRevisionsList dpath = do + pkginfo <- packageInPath dpath >>= lookupPackageId + users <- queryGetUserDb + let revisions = pkgUploadData pkginfo : map snd (pkgDataOld pkginfo) + revisionToObj (utime, uid) rev = + let uname = userIdToName users uid in + Object $ HashMap.fromList + [ (Text.pack "number", Number (fromIntegral rev)) + , (Text.pack "user", String (Text.pack (display uname))) + , (Text.pack "time", String (Text.pack (formatTime defaultTimeLocale "%c" utime))) + ] + revisionsJson = Array $ Vector.fromList $ + zipWith revisionToObj revisions [0 :: Int ..] + return (toResponse revisionsJson) + + serveCabalFileRevision :: DynamicPath -> ServerPartE Response + serveCabalFileRevision dpath = do + pkginfo <- packageInPath dpath >>= lookupPackageId + let mrev = lookup "revision" dpath >>= fromReqURI + revisions = reverse (pkgData pkginfo : map fst (pkgDataOld pkginfo)) + case mrev of + Just rev + | rev >= 0 + , (fileRev:_) <- drop rev revisions + -> return $ toResponse (Resource.CabalFile (cabalFileByteString fileRev)) + _ -> mzero + packageExists, packageIdExists :: (Package pkg, Package pkg') => PackageIndex pkg -> pkg' -> Bool +-- | Whether a package exists in the given package index. packageExists pkgs pkg = not . null $ PackageIndex.lookupPackageName pkgs (packageName pkg) +-- | Whether a particular package version exists in the given package index. packageIdExists pkgs pkg = maybe False (const True) $ PackageIndex.lookupPackageId pkgs (packageId pkg) diff --git a/Distribution/Server/Features/Core/State.hs b/Distribution/Server/Features/Core/State.hs --- a/Distribution/Server/Features/Core/State.hs +++ b/Distribution/Server/Features/Core/State.hs @@ -78,7 +78,7 @@ pkgDataOld = (pkgData pkginfo, pkgUploadData pkginfo) : pkgDataOld pkginfo } - pkgindex' = PackageIndex.insert pkginfo pkgindex + pkgindex' = PackageIndex.insert pkginfo' pkgindex State.put $! PackagesState pkgindex' return (Just pkginfo, pkginfo') Nothing -> do @@ -106,7 +106,7 @@ setPackageUploader pkgid uid = alterPackage pkgid $ \pkginfo -> pkginfo { - pkgUploadData = (pkgUploadTime pkginfo, uid) + pkgUploadData = (fst (pkgUploadData pkginfo), uid) } setPackageUploadTime :: PackageId -> UTCTime @@ -114,7 +114,7 @@ setPackageUploadTime pkgid time = alterPackage pkgid $ \pkginfo -> pkginfo { - pkgUploadData = (time, pkgUploadUser pkginfo) + pkgUploadData = (time, snd (pkgUploadData pkginfo)) } alterPackage :: PackageId -> (PkgInfo -> PkgInfo) @@ -166,10 +166,10 @@ 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) } +replacePackageUploader pkg uid = modifyPkgInfo pkg $ \pkgInfo -> pkgInfo { pkgUploadData = (fst (pkgUploadData pkgInfo), uid) } replacePackageUploadTime :: PackageId -> UTCTime -> Update PackagesState (Either String (PkgInfo, PkgInfo)) -replacePackageUploadTime pkg time = modifyPkgInfo pkg $ \pkgInfo -> pkgInfo { pkgUploadData = (time, pkgUploadUser pkgInfo) } +replacePackageUploadTime pkg time = modifyPkgInfo pkg $ \pkgInfo -> pkgInfo { pkgUploadData = (time, snd (pkgUploadData pkgInfo)) } addTarball :: PackageId -> PkgTarball -> UploadInfo -> Update PackagesState (Either String (PkgInfo, PkgInfo)) addTarball pkg tarball uploadInfo = modifyPkgInfo pkg $ \pkgInfo -> pkgInfo { pkgTarball = (tarball, uploadInfo) : pkgTarball pkgInfo } diff --git a/Distribution/Server/Features/Distro.hs b/Distribution/Server/Features/Distro.hs --- a/Distribution/Server/Features/Distro.hs +++ b/Distribution/Server/Features/Distro.hs @@ -44,14 +44,15 @@ distroPackage :: Resource } -initDistroFeature :: ServerEnv -> UserFeature -> CoreFeature -> IO DistroFeature -initDistroFeature ServerEnv{serverStateDir, serverVerbosity = verbosity} user core = do - loginfo verbosity "Initialising distro feature, start" +initDistroFeature :: ServerEnv + -> IO (UserFeature -> CoreFeature -> IO DistroFeature) +initDistroFeature ServerEnv{serverStateDir} = do distrosState <- distrosStateComponent serverStateDir - let feature = distroFeature user core distrosState - loginfo verbosity "Initialising distro feature, end" - return feature + return $ \user core -> do + let feature = distroFeature user core distrosState + return feature + distrosStateComponent :: FilePath -> IO (StateComponent AcidState Distros) distrosStateComponent stateDir = do st <- openLocalStateFrom (stateDir "db" "Distros") initialDistros @@ -60,7 +61,7 @@ , stateHandle = st , getState = query st GetDistributions , putState = \(Distros dists versions) -> update st (ReplaceDistributions dists versions) - , backupState = dumpBackup + , backupState = \_ -> dumpBackup , restoreState = restoreBackup , resetState = distrosStateComponent } @@ -76,7 +77,7 @@ where distroFeatureInterface = (emptyHackageFeature "distro") { featureResources = - map ($distroResource) [ + map ($ distroResource) [ distroIndexPage , distroAllPage , distroPackages @@ -122,15 +123,17 @@ 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 + distroDelete dpath = + withDistroNamePath dpath $ \distro -> do + guardAuthorised_ [InGroup adminGroup] --TODO: use the per-distro maintainer groups -- 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 + distroPackageDelete dpath = + withDistroPackagePath dpath $ \dname pkgname info -> do + guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups case info of Nothing -> notFound . toResponse $ "Package not found for " ++ display pkgname Just {} -> do @@ -138,13 +141,16 @@ 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 + distroPackagePut dpath = + withDistroPackagePath dpath $ \dname pkgname _ -> lookPackageInfo $ \newPkgInfo -> do + guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups 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 + distroPostNew _ = + lookDistroName $ \dname -> do + guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups success <- updateState distrosState $ AddDistro dname if success then seeOther ("/distro/" ++ display dname) $ toResponse "Ok!" @@ -152,6 +158,7 @@ distroPutNew dpath = withDistroNamePath dpath $ \dname -> do + guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups _success <- updateState distrosState $ AddDistro dname -- it doesn't matter if it exists already or not ok $ toResponse "Ok!" @@ -159,7 +166,7 @@ -- result: ok repsonse or not-found error distroPackageListPut dpath = withDistroPath dpath $ \dname _pkgs -> do - -- FIXME: authenticate distro maintainer + guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups lookCSVFile $ \csv -> case csvToPackageList csv of Nothing -> fail $ "Could not parse CSV File to a distro package list" diff --git a/Distribution/Server/Features/Documentation.hs b/Distribution/Server/Features/Documentation.hs --- a/Distribution/Server/Features/Documentation.hs +++ b/Distribution/Server/Features/Documentation.hs @@ -37,9 +37,18 @@ data DocumentationFeature = DocumentationFeature { documentationFeatureInterface :: HackageFeature, - queryHasDocumentation :: MonadIO m => PackageIdentifier -> m Bool, + queryHasDocumentation :: MonadIO m => PackageIdentifier -> m Bool, + queryDocumentation :: MonadIO m => PackageIdentifier -> m (Maybe BlobId), + queryDocumentationIndex :: MonadIO m => m (Map.Map PackageId BlobId), - documentationResource :: DocumentationResource + uploadDocumentation :: DynamicPath -> ServerPartE Response, + deleteDocumentation :: DynamicPath -> ServerPartE Response, + + documentationResource :: DocumentationResource, + + -- | Notification of documentation changes + documentationChangeHook :: Hook PackageId () + } instance IsHackageFeature DocumentationFeature where @@ -56,23 +65,26 @@ initDocumentationFeature :: String -> ServerEnv - -> CoreResource - -> IO [PackageIdentifier] - -> UploadFeature - -> TarIndexCacheFeature - -> IO DocumentationFeature + -> IO (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" + env@ServerEnv{serverStateDir} = do + -- Canonical state documentationState <- documentationStateComponent name serverStateDir - let feature = documentationFeature name env core getPackages upload tarIndexCache documentationState - loginfo verbosity "Initialising documentation feature, end" - return feature + -- Hooks + documentationChangeHook <- newHook + + return $ \core getPackages upload tarIndexCache -> do + let feature = documentationFeature name env + core getPackages upload tarIndexCache + documentationState + documentationChangeHook + return feature + documentationStateComponent :: String -> FilePath -> IO (StateComponent AcidState Documentation) documentationStateComponent name stateDir = do st <- openLocalStateFrom (stateDir "db" name) initialDocumentation @@ -81,7 +93,7 @@ , stateHandle = st , getState = query st GetDocumentation , putState = update st . ReplaceDocumentation - , backupState = dumpBackup + , backupState = \_ -> dumpBackup , restoreState = updateDocumentation (Documentation Map.empty) , resetState = documentationStateComponent name } @@ -113,6 +125,7 @@ -> UploadFeature -> TarIndexCacheFeature -> StateComponent AcidState Documentation + -> Hook PackageId () -> DocumentationFeature documentationFeature name ServerEnv{serverBlobStore = store} @@ -127,6 +140,7 @@ UploadFeature{..} TarIndexCacheFeature{cachedTarIndex} documentationState + documentationChangeHook = DocumentationFeature{..} where documentationFeatureInterface = (emptyHackageFeature name) { @@ -143,21 +157,30 @@ queryHasDocumentation :: MonadIO m => PackageIdentifier -> m Bool queryHasDocumentation pkgid = queryState documentationState (HasDocumentation pkgid) + queryDocumentation :: MonadIO m => PackageIdentifier -> m (Maybe BlobId) + queryDocumentation pkgid = queryState documentationState (LookupDocumentation pkgid) + + queryDocumentationIndex :: MonadIO m => m (Map.Map PackageId BlobId) + queryDocumentationIndex = + liftM documentation (queryState documentationState GetDocumentation) + documentationResource = fix $ \r -> DocumentationResource { packageDocsContent = (extendResourcePath "/docs/.." corePackagePage) { - resourceDesc = [ (GET, "Browse documentation") ] - , resourceGet = [ ("", serveDocumentation) ] + resourceDesc = [ (GET, "Browse documentation") ] + , resourceGet = [ ("", serveDocumentation) ] } , packageDocsWhole = (extendResourcePath "/docs.:format" corePackagePage) { resourceDesc = [ (GET, "Download documentation") , (PUT, "Upload documentation") + , (DELETE, "Delete documentation") ] - , resourceGet = [ ("tar", serveDocumentationTar) ] - , resourcePut = [ ("tar", uploadDocumentation) ] + , resourceGet = [ ("tar", serveDocumentationTar) ] + , resourcePut = [ ("tar", uploadDocumentation) ] + , resourceDelete = [ ("", deleteDocumentation) ] } , packageDocsStats = (extendResourcePath "/docs.:format" corePackagesPage) { - resourceDesc = [ (GET, "Get information about which packages have documentation") ] - , resourceGet = [ ("json", serveDocumentationStats) ] + resourceDesc = [ (GET, "Get information about which packages have documentation") ] + , resourceGet = [ ("json", serveDocumentationStats) ] } , packageDocsContentUri = \pkgid -> renderResource (packageDocsContent r) [display pkgid] @@ -176,9 +199,11 @@ serveDocumentationTar :: DynamicPath -> ServerPartE Response serveDocumentationTar dpath = withDocumentation (packageDocsWhole documentationResource) - dpath $ \_ blob _ -> do - file <- liftIO $ BlobStorage.fetch store blob - return $ toResponse $ Resource.DocTarball file blob + dpath $ \_ blobid _ -> do + cacheControl [Public, maxAgeDays 1] + (BlobStorage.blobETag blobid) + file <- liftIO $ BlobStorage.fetch store blobid + return $ toResponse $ Resource.DocTarball file blobid -- return: not-found error or tarball @@ -187,13 +212,12 @@ withDocumentation (packageDocsContent documentationResource) dpath $ \pkgid blob index -> do let tarball = BlobStorage.filepath store blob - etag = blobETag blob + etag = BlobStorage.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 + tarball index [Public, maxAgeDays 1] etag - -- return: not-found error (parsing) or see other uri uploadDocumentation :: DynamicPath -> ServerPartE Response uploadDocumentation dpath = do pkgid <- packageInPath dpath @@ -211,6 +235,7 @@ Left err -> errBadRequest "Invalid documentation tarball" [MText err] Right ((), blobid) -> do updateState documentationState $ InsertDocumentation pkgid blobid + runHook_ documentationChangeHook pkgid noContent (toResponse ()) {- @@ -236,6 +261,15 @@ transformers-0.3.0.0-docs/index.html .. -} + + deleteDocumentation :: DynamicPath -> ServerPartE Response + deleteDocumentation dpath = do + pkgid <- packageInPath dpath + guardValidPackageId pkgid + guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) + updateState documentationState $ RemoveDocumentation pkgid + runHook_ documentationChangeHook pkgid + noContent (toResponse ()) withDocumentation :: Resource -> DynamicPath -> (PackageId -> BlobId -> TarIndex -> ServerPartE Response) diff --git a/Distribution/Server/Features/Documentation/State.hs b/Distribution/Server/Features/Documentation/State.hs --- a/Distribution/Server/Features/Documentation/State.hs +++ b/Distribution/Server/Features/Documentation/State.hs @@ -43,6 +43,10 @@ insertDocumentation pkgId blob = State.modify $ \doc -> doc {documentation = Map.insert pkgId blob (documentation doc)} +removeDocumentation :: PackageIdentifier -> Update Documentation () +removeDocumentation pkgId + = State.modify $ \doc -> doc {documentation = Map.delete pkgId (documentation doc)} + getDocumentation :: Query Documentation Documentation getDocumentation = ask @@ -51,6 +55,7 @@ replaceDocumentation = State.put makeAcidic ''Documentation ['insertDocumentation + ,'removeDocumentation ,'lookupDocumentation ,'hasDocumentation ,'getDocumentation diff --git a/Distribution/Server/Features/DownloadCount.hs b/Distribution/Server/Features/DownloadCount.hs --- a/Distribution/Server/Features/DownloadCount.hs +++ b/Distribution/Server/Features/DownloadCount.hs @@ -21,6 +21,7 @@ , DownloadResource(..) , initDownloadFeature , RecentDownloads + , TotalDownloads ) where import Distribution.Server.Framework @@ -42,6 +43,7 @@ data DownloadFeature = DownloadFeature { downloadFeatureInterface :: HackageFeature , downloadResource :: DownloadResource + , totalPackageDownloads :: MonadIO m => m TotalDownloads , recentPackageDownloads :: MonadIO m => m RecentDownloads } @@ -52,20 +54,23 @@ topDownloads :: Resource } -initDownloadFeature :: ServerEnv -> CoreFeature -> UserFeature -> IO DownloadFeature -initDownloadFeature serverEnv@ServerEnv{serverStateDir, serverVerbosity = verbosity} core users = do - loginfo verbosity "Initialising download feature, start" - +initDownloadFeature :: ServerEnv + -> IO (CoreFeature -> UserFeature -> IO DownloadFeature) +initDownloadFeature serverEnv@ServerEnv{serverStateDir} = do inMemState <- inMemStateComponent serverStateDir let onDiskState = onDiskStateComponent serverStateDir - totalsCache <- newMemStateWHNF =<< computeRecentDownloads =<< getState onDiskState + (recentDownloads, + totalDownloads) <- computeRecentAndTotalDownloads =<< getState onDiskState + recentCache <- newMemStateWHNF recentDownloads + totalsCache <- newMemStateWHNF totalDownloads downChan <- newChan - let feature = downloadFeature core users serverEnv inMemState onDiskState totalsCache downChan + return $ \core users -> do + let feature = downloadFeature core users serverEnv inMemState + onDiskState totalsCache recentCache downChan - registerHook (packageDownloadHook core) (writeChan downChan) - loginfo verbosity "Initialising download feature, end" - return feature + registerHook (packageDownloadHook core) (writeChan downChan) + return feature inMemStateComponent :: FilePath -> IO (StateComponent AcidState InMemStats) inMemStateComponent stateDir = do @@ -76,7 +81,7 @@ , stateHandle = st , getState = query st GetInMemStats , putState = update st . ReplaceInMemStats - , backupState = inMemBackup + , backupState = \_ -> inMemBackup , restoreState = inMemRestore , resetState = inMemStateComponent } @@ -86,39 +91,22 @@ stateDesc = "All time download counts" , stateHandle = OnDiskState , getState = readOnDiskStats (dcPath stateDir "ondisk") - , putState = writeOnDisk stateDir Nothing ReconstructLog - , backupState = onDiskBackup + , putState = \onDiskStats -> do + --TODO: we should extend the backup system so we can + -- write these files out incrementally + writeOnDiskStats (dcPath stateDir "ondisk") onDiskStats + reconstructLog (dcPath stateDir) onDiskStats + , 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 TotalDownloads -> MemState RecentDownloads -> Chan PackageId -> DownloadFeature @@ -128,6 +116,7 @@ ServerEnv{serverStateDir} inMemState onDiskState + totalDownloadsCache recentDownloadsCache downloadStream = DownloadFeature{..} @@ -144,6 +133,10 @@ CacheComponent { cacheDesc = "recent package downloads cache", getCacheMemSize = memSize <$> readMemState recentDownloadsCache + }, + CacheComponent { + cacheDesc = "total package downloads cache", + getCacheMemSize = memSize <$> readMemState totalDownloadsCache } ] } @@ -151,23 +144,36 @@ recentPackageDownloads :: MonadIO m => m RecentDownloads recentPackageDownloads = readMemState recentDownloadsCache + totalPackageDownloads :: MonadIO m => m TotalDownloads + totalPackageDownloads = readMemState totalDownloadsCache + registerDownloads = forever $ do pkg <- readChan downloadStream today <- getToday today' <- query (stateHandle inMemState) RecordedToday + --TODO: do this asyncronously rather than blocking this request when (today /= today') $ do -- For the first download each day we reset the in-memory stats and.. inMemStats <- getState inMemState putState inMemState $ initInMemStats today + -- we can discard the large eventlog by writing a small checkpoint + createCheckpoint (stateHandle inMemState) -- 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' + writeOnDiskStats (dcPath serverStateDir "ondisk") onDiskStats' + --TODO: this is still stupid, writing it out only to read it back + -- we should be able to update the in memory ones incrementally + (recentDownloads, + totalDownloads) <- computeRecentAndTotalDownloads =<< getState onDiskState + writeMemState recentDownloadsCache recentDownloads + writeMemState totalDownloadsCache totalDownloads + updateState inMemState $ RegisterDownload pkg downloadResource = DownloadResource { @@ -184,6 +190,7 @@ getDownloadCounts :: DynamicPath -> ServerPartE Response getDownloadCounts _path = do + guardAuthorised_ [InGroup adminGroup] onDiskStats <- liftIO $ getState onDiskState let [BackupByteString _ bs] = onDiskBackup onDiskStats return $ toResponse bs @@ -194,7 +201,15 @@ fileContents <- expectCSV csv <- importCSV "PUT input" fileContents onDiskStats <- cmFromCSV csv - liftIO $ writeOnDisk serverStateDir (Just recentDownloadsCache) ReconstructLog onDiskStats + liftIO $ do + --TODO: if the onDiskStats are large, can we stream it? + writeOnDiskStats (dcPath serverStateDir "ondisk") onDiskStats + (recentDownloads, + totalDownloads) <- computeRecentAndTotalDownloads onDiskStats + writeMemState recentDownloadsCache recentDownloads + writeMemState totalDownloadsCache totalDownloads + reconstructLog (dcPath serverStateDir) onDiskStats + ok $ toResponse $ "Imported " ++ show (length csv) ++ " records\n" {------------------------------------------------------------------------------ @@ -204,17 +219,16 @@ getToday :: IO Day getToday = utctDay <$> getCurrentTime -getRecentDayRange :: Integer -> IO DayRange +getRecentDayRange :: Integer -> IO (Day, Day) getRecentDayRange numDays = do lastDay <- getToday - let firstDay = addDays (negate numDays) lastDay - secondDay = addDays 1 firstDay - return [firstDay, secondDay .. lastDay] + let firstDay = addDays (negate numDays) lastDay + return (firstDay, lastDay) -computeRecentDownloads :: OnDiskStats -> IO RecentDownloads -computeRecentDownloads onDiskStats = do +computeRecentAndTotalDownloads :: OnDiskStats -> IO (RecentDownloads, TotalDownloads) +computeRecentAndTotalDownloads onDiskStats = do recentRange <- getRecentDayRange 30 - return $ initRecentDownloads recentRange onDiskStats + return $ initRecentAndTotalDownloads recentRange onDiskStats dcPath :: FilePath -> FilePath dcPath stateDir = stateDir "db" "DownloadCount" diff --git a/Distribution/Server/Features/DownloadCount/Backup.hs b/Distribution/Server/Features/DownloadCount/Backup.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/DownloadCount/Backup.hs @@ -0,0 +1,65 @@ +module Distribution.Server.Features.DownloadCount.Backup ( + onDiskBackup + , onDiskRestore + , inMemBackup + , inMemRestore + ) where + +import Distribution.Server.Framework.BackupRestore +import Distribution.Server.Framework.BackupDump +import Distribution.Server.Features.DownloadCount.State +import Distribution.Server.Util.CountingMap +import Distribution.Text (display, simpleParse) +import Distribution.Version +import Text.CSV (CSV) + +onDiskBackup :: OnDiskStats -> [BackupEntry] +onDiskBackup onDisk = [csvToBackup ["ondisk.csv"] $ cmToCSV onDisk] + +onDiskRestore :: RestoreBackup OnDiskStats +onDiskRestore = importOne "ondisk.csv" cmFromCSV + +inMemBackup :: InMemStats -> [BackupEntry] +inMemBackup (InMemStats day inMemStats) = + [csvToBackup ["inmem.csv"] $ + [display versionCSV] + : [display day] + : cmToCSV inMemStats + ] + where + versionCSV = Version [0,1] ["unstable"] + +inMemRestore :: RestoreBackup InMemStats +inMemRestore = importOne "inmem.csv" importInMemStats + +importInMemStats :: Monad m => CSV -> m InMemStats +importInMemStats (_version : [dayStr] : inMemStatsCSV) = do + day <- case simpleParse dayStr of + Just day -> return day + Nothing -> fail "importInMemStats: Invalid day" + inMemStats <- cmFromCSV inMemStatsCSV + return (InMemStats day inMemStats) +importInMemStats _ = + fail "Invalid format for inmem.csv" + +{------------------------------------------------------------------------------ + Auxiliary +------------------------------------------------------------------------------} + +-- TODO: should probably move this to the RestoreBackup module and use it +-- elsewhere too +importOne :: String -> (CSV -> Restore a) -> RestoreBackup a +importOne name importA = aux Nothing + where + aux ma = RestoreBackup { + restoreEntry = \entry -> case entry of + BackupByteString name' bs | name' == [name] -> do + csv <- importCSV name bs + a <- importA csv + return $ aux (Just a) + _ -> + return $ aux ma + , restoreFinalize = case ma of + Just a -> return a + Nothing -> fail $ "Missing " ++ name + } diff --git a/Distribution/Server/Features/DownloadCount/State.hs b/Distribution/Server/Features/DownloadCount/State.hs --- a/Distribution/Server/Features/DownloadCount/State.hs +++ b/Distribution/Server/Features/DownloadCount/State.hs @@ -1,27 +1,32 @@ -{-# LANGUAGE TemplateHaskell, StandaloneDeriving, GeneralizedNewtypeDeriving, DeriveDataTypeable, TypeFamilies #-} +{-# LANGUAGE TemplateHaskell, StandaloneDeriving, GeneralizedNewtypeDeriving, + DeriveDataTypeable, TypeFamilies, FlexibleInstances, + MultiParamTypeClasses, BangPatterns #-} 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.Arrow (first) +import Control.Monad (liftM) +import Data.List (foldl', groupBy) +import Data.Function (on) 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 Control.Monad.State (get, put) +import qualified Data.Map.Lazy 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 System.IO.Unsafe (unsafeInterleaveIO) import Text.CSV (printCSV) -import Control.Exception (evaluate, handle, IOException) +import Control.Exception (evaluate) -import Data.Acid +import Data.Acid (Update, Query, makeAcidic) import Data.SafeCopy (base, deriveSafeCopy, safeGet, safePut) import Data.Serialize.Get (runGetLazy) import Data.Serialize.Put (runPutLazy) @@ -33,6 +38,7 @@ , packageVersion ) import Distribution.Text (simpleParse, display) +import Distribution.Simple.Utils (writeFileAtomic) import Distribution.Server.Framework.Instances () import Distribution.Server.Framework.MemSize @@ -43,26 +49,72 @@ ------------------------------------------------------------------------------} data InMemStats = InMemStats { - inMemToday :: Day - , inMemCounts :: SimpleCountingMap PackageId + inMemToday :: !Day + , inMemCounts :: !(SimpleCountingMap PackageId) } deriving (Show, Eq, Typeable) newtype OnDiskStats = OnDiskStats { onDiskStats :: NestedCountingMap PackageName OnDiskPerPkg } - deriving (CountingMap (PackageName, (Day, Version)), Show, Eq, MemSize) + deriving (Show, Eq, MemSize) +instance CountingMap (PackageName, (Day, Version)) OnDiskStats where + cmEmpty = OnDiskStats $ cmEmpty + cmTotal (OnDiskStats ncm) = cmTotal ncm + cmInsert kl n (OnDiskStats ncm) = OnDiskStats $ cmInsert kl n ncm + cmFind k (OnDiskStats ncm) = cmFind k ncm + cmUnion (OnDiskStats a) + (OnDiskStats b) = OnDiskStats (cmUnion a b) + cmToList (OnDiskStats ncm) = cmToList ncm + cmToCSV (OnDiskStats ncm) = cmToCSV ncm + cmInsertRecord r (OnDiskStats ncm) = first OnDiskStats `liftM` cmInsertRecord r ncm + newtype OnDiskPerPkg = OnDiskPerPkg { onDiskPerPkgCounts :: NestedCountingMap Day (SimpleCountingMap Version) } - deriving (CountingMap (Day, Version), Show, Eq, MemSize) + deriving (Show, Eq, Ord, MemSize) +instance CountingMap (Day, Version) OnDiskPerPkg where + cmEmpty = OnDiskPerPkg $ cmEmpty + cmTotal (OnDiskPerPkg ncm) = cmTotal ncm + cmInsert kl n (OnDiskPerPkg ncm) = OnDiskPerPkg $ cmInsert kl n ncm + cmFind k (OnDiskPerPkg ncm) = cmFind k ncm + cmUnion (OnDiskPerPkg a) (OnDiskPerPkg b) = OnDiskPerPkg (cmUnion a b) + cmToList (OnDiskPerPkg ncm) = cmToList ncm + cmToCSV (OnDiskPerPkg ncm) = cmToCSV ncm + cmInsertRecord r (OnDiskPerPkg ncm) = first OnDiskPerPkg `liftM` cmInsertRecord r ncm + newtype RecentDownloads = RecentDownloads { recentDownloads :: SimpleCountingMap PackageName } - deriving (CountingMap PackageName, Show, Eq, MemSize) + deriving (Show, Eq, MemSize) +instance CountingMap PackageName RecentDownloads where + cmEmpty = RecentDownloads $ cmEmpty + cmTotal (RecentDownloads ncm) = cmTotal ncm + cmInsert kl n (RecentDownloads ncm) = RecentDownloads $ cmInsert kl n ncm + cmFind k (RecentDownloads ncm) = cmFind k ncm + cmUnion (RecentDownloads a) (RecentDownloads b) = RecentDownloads (cmUnion a b) + cmToList (RecentDownloads ncm) = cmToList ncm + cmToCSV (RecentDownloads ncm) = cmToCSV ncm + cmInsertRecord r (RecentDownloads ncm) = first RecentDownloads `liftM` cmInsertRecord r ncm + +newtype TotalDownloads = TotalDownloads { + totalDownloads :: SimpleCountingMap PackageName + } + deriving (Show, Eq, MemSize) + +instance CountingMap PackageName TotalDownloads where + cmEmpty = TotalDownloads $ cmEmpty + cmTotal (TotalDownloads ncm) = cmTotal ncm + cmInsert kl n (TotalDownloads ncm) = TotalDownloads $ cmInsert kl n ncm + cmFind k (TotalDownloads ncm) = cmFind k ncm + cmUnion (TotalDownloads a) (TotalDownloads b) = TotalDownloads (cmUnion a b) + cmToList (TotalDownloads ncm) = cmToList ncm + cmToCSV (TotalDownloads ncm) = cmToCSV ncm + cmInsertRecord r (TotalDownloads ncm) = first TotalDownloads `liftM` cmInsertRecord r ncm + {------------------------------------------------------------------------------ Initial instances ------------------------------------------------------------------------------} @@ -73,33 +125,69 @@ , inMemCounts = cmEmpty } -type DayRange = [Day] +type DayRange = (Day, 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) +initRecentAndTotalDownloads :: DayRange -> OnDiskStats + -> (RecentDownloads, TotalDownloads) +initRecentAndTotalDownloads dayRange (OnDiskStats (NCM _ m)) = + foldl' (\(recent, total) (pname, pstats) -> + let !recent' = accumRecentDownloads dayRange pname pstats recent + !total' = accumTotalDownloads pname pstats total + in (recent', total')) + (emptyRecentDownloads, emptyTotalDownloads) + (Map.toList m) - 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) +emptyRecentDownloads :: RecentDownloads +emptyRecentDownloads = RecentDownloads cmEmpty +accumRecentDownloads :: DayRange + -> PackageName -> OnDiskPerPkg + -> RecentDownloads -> RecentDownloads +accumRecentDownloads dayRange pkgName (OnDiskPerPkg (NCM _ perDay)) + | let rangeTotal = sum (map cmTotal (lookupRange dayRange perDay)) + , rangeTotal > 0 + = cmInsert pkgName rangeTotal + + | otherwise = id + +lookupRange :: Ord k => (k,k) -> Map.Map k a -> [a] +lookupRange (l,u) m = + let (_,ml,above) = Map.splitLookup l m + (middle,mu,_) = Map.splitLookup u above + in maybe [] (\x->[x]) ml + ++ Map.elems middle + ++ maybe [] (\x->[x]) mu + +emptyTotalDownloads :: TotalDownloads +emptyTotalDownloads = TotalDownloads cmEmpty + +accumTotalDownloads :: PackageName -> OnDiskPerPkg + -> TotalDownloads -> TotalDownloads +accumTotalDownloads pkgName (OnDiskPerPkg perPkg) = + cmInsert pkgName (cmTotal perPkg) + {------------------------------------------------------------------------------ Pure updates/queries ------------------------------------------------------------------------------} updateHistory :: InMemStats -> OnDiskStats -> OnDiskStats -updateHistory (InMemStats day perPkg) = - foldr (.) id $ map goPackage (cmToList perPkg) +updateHistory (InMemStats day perPkg) (OnDiskStats (NCM _ m)) = + OnDiskStats (NCM 0 (Map.unionWith cmUnion m updatesMap)) where - goPackage :: (PackageId, Int) -> OnDiskStats -> OnDiskStats - goPackage (pkgId, count) = - cmInsert (packageName pkgId, (day, packageVersion pkgId)) count + updatesMap :: Map.Map PackageName OnDiskPerPkg + updatesMap = Map.fromList + [ (pkgname, applyUpdates pkgs) + | pkgs <- groupBy ((==) `on` (packageName . fst)) + (cmToList perPkg :: [(PackageId, Int)]) + , let pkgname = packageName (fst (head pkgs)) + ] + applyUpdates :: [(PackageId, Int)] -> OnDiskPerPkg + applyUpdates pkgs = foldr (.) id + [ cmInsert (day, packageVersion pkgId) count + | (pkgId, count) <- pkgs ] + cmEmpty + {------------------------------------------------------------------------------ MemSize ------------------------------------------------------------------------------} @@ -112,39 +200,30 @@ ------------------------------------------------------------------------------} readOnDiskStats :: FilePath -> IO OnDiskStats -readOnDiskStats stateDir = flip execStateT cmEmpty $ do - pkgs <- liftIO $ do createDirectoryIfMissing True stateDir - getDirectoryContents stateDir +readOnDiskStats stateDir = do + createDirectoryIfMissing True stateDir + pkgStrs <- getDirectoryContents stateDir + OnDiskStats . NCM 0 . Map.fromList <$> sequence + [ do onDiskPerPkg <- unsafeInterleaveIO $ + either (const cmEmpty) id + <$> readOnDiskPerPkg pkgFile + return (pkgName, onDiskPerPkg) + | Just pkgName <- map simpleParse pkgStrs + , let pkgFile = stateDir display pkgName ] - 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) +readOnDiskPerPkg :: FilePath -> IO (Either String OnDiskPerPkg) +readOnDiskPerPkg pkgFile = + 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) 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 () + writeFileAtomic pkgFile $ runPutLazy (safePut perPkg) {------------------------------------------------------------------------------ The append-only all-time log diff --git a/Distribution/Server/Features/EditCabalFiles.hs b/Distribution/Server/Features/EditCabalFiles.hs --- a/Distribution/Server/Features/EditCabalFiles.hs +++ b/Distribution/Server/Features/EditCabalFiles.hs @@ -3,6 +3,9 @@ StandaloneDeriving, GeneralizedNewtypeDeriving #-} module Distribution.Server.Features.EditCabalFiles ( initEditCabalFilesFeature + + , diffCabalRevisions + , Change(..) ) where import Distribution.Server.Framework @@ -20,7 +23,7 @@ (parsePackageDescription, sourceRepoFieldDescrs) import Distribution.PackageDescription.Check import Distribution.ParseUtils - ( ParseResult(..), locatedErrorMsg, PWarning(..), showPWarning ) + ( ParseResult(..), locatedErrorMsg, showPWarning ) import Distribution.Server.Util.Parse (unpackUTF8) import Distribution.ParseUtils (FieldDescr(..)) import Distribution.Text (Text(..)) @@ -41,18 +44,21 @@ -- | 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"] + -> IO (UserFeature + -> CoreFeature + -> UploadFeature + -> IO HackageFeature) +initEditCabalFilesFeature env@ServerEnv{ serverTemplatesDir, + serverTemplatesMode } = do + -- Page templates + templates <- loadTemplates serverTemplatesMode + [serverTemplatesDir, serverTemplatesDir "EditCabalFile"] + ["cabalFileEditPage.html", "cabalFilePublished.html"] - let feature = editCabalFilesFeature env templates user core upload + return $ \user core upload -> do + let feature = editCabalFilesFeature env templates user core upload - return feature + return feature editCabalFilesFeature :: ServerEnv -> Templates @@ -67,6 +73,7 @@ [ editCabalFileResource ] , featureState = [] + , featureReloadFiles = reloadTemplates templates } where @@ -88,7 +95,7 @@ -- check that the cabal name matches the package guard (lookup "cabal" dpath == Just (display pkgname)) ok $ toResponse $ template - [ "pkgid" $= display pkgid + [ "pkgid" $= pkgid , "cabalfile" $= insertRevisionField (1 + length (pkgDataOld pkg)) (cabalFileByteString (pkgData pkg)) ] @@ -106,7 +113,7 @@ let oldVersion = cabalFileByteString (pkgData pkg) newRevision <- getCabalFile shouldPublish <- getPublish - case runCheck $ checkCabalFileRevision pkgid oldVersion newRevision of + case diffCabalRevisions pkgid oldVersion newRevision of Left errs -> responseTemplate template pkgid newRevision shouldPublish [errs] [] @@ -118,7 +125,7 @@ updateAddPackageRevision pkgid (CabalFileText newRevision) (time, uid) ok $ toResponse $ template' - [ "pkgid" $= display pkgid + [ "pkgid" $= pkgid , "cabalfile" $= newRevision , "changes" $= changes ] @@ -136,17 +143,13 @@ -> ServerPartE Response responseTemplate template pkgid cabalFile publish errors changes = ok $ toResponse $ template - [ "pkgid" $= display pkgid + [ "pkgid" $= 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) @@ -173,6 +176,11 @@ type Check a = a -> a -> CheckM () +diffCabalRevisions :: PackageId -> ByteString -> ByteString + -> Either String [Change] +diffCabalRevisions pkgid oldVersion newRevision = + runCheck $ checkCabalFileRevision pkgid oldVersion newRevision + checkCabalFileRevision :: PackageId -> Check ByteString checkCabalFileRevision pkgid old new = do (pkg, warns) <- parseCabalFile old @@ -237,14 +245,14 @@ pkgUrlA bugReportsA sourceReposA synopsisA descriptionA categoryA customFieldsA _buildDependsA specVersionA buildTypeA _libraryA _executablesA _testSuitesA _benchmarksA dataFilesA dataDirA - extraSrcFilesA extraTmpFilesA {-_extraHtmlFilesA-}) + extraSrcFilesA extraTmpFilesA extraDocFilesA) (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-}) + extraSrcFilesB extraTmpFilesB extraDocFilesB) = do checkSame "Don't be silly! You can't change the package name!" (packageName packageIdA) (packageName packageIdB) @@ -278,6 +286,8 @@ extraTmpFilesA extraTmpFilesB checkSame "Changing extra-source-files would not make sense!" extraSrcFilesA extraSrcFilesB + checkSame "You can't change the extra-doc-files." + extraDocFilesA extraDocFilesB checkSame "Cannot change custom/extension fields" (filter (\(f,_) -> f /= "x-revision") customFieldsA) diff --git a/Distribution/Server/Features/HaskellPlatform.hs b/Distribution/Server/Features/HaskellPlatform.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/HaskellPlatform.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-} +module Distribution.Server.Features.HaskellPlatform ( + PlatformFeature, + PlatformResource(..), + initPlatformFeature, + ) where + +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore + +import Distribution.Server.Features.HaskellPlatform.State + +import Distribution.Package +import Distribution.Version +import Distribution.Text + +import Data.Function +import qualified Data.Map as Map +import qualified Data.Set as Set + + +-- Note: this can be generalized into dividing Hackage up into however many +-- subsets of packages are desired. One could implement a Debian-esque system +-- with this sort of feature. +-- + +data PlatformFeature = PlatformFeature { + platformFeatureInterface :: HackageFeature, + + platformResource :: PlatformResource, + + platformVersions :: MonadIO m => PackageName -> m [Version], + platformPackageLatest :: MonadIO m => m [(PackageName, Version)], + setPlatform :: MonadIO m => PackageName -> [Version] -> m (), + removePlatform :: MonadIO m => PackageName -> m () +} + +instance IsHackageFeature PlatformFeature where + getFeatureInterface = platformFeatureInterface + +data PlatformResource = PlatformResource { + platformPackage :: Resource, + platformPackages :: Resource, + platformPackageUri :: String -> PackageName -> String, + platformPackagesUri :: String -> String +} + +initPlatformFeature :: ServerEnv -> IO (IO PlatformFeature) +initPlatformFeature ServerEnv{serverStateDir} = do + platformState <- platformStateComponent serverStateDir + + return $ do + let feature = platformFeature platformState + return feature + +platformStateComponent :: FilePath -> IO (StateComponent AcidState PlatformPackages) +platformStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "PlatformPackages") initialPlatformPackages + return StateComponent { + stateDesc = "Platform packages" + , stateHandle = st + , getState = query st GetPlatformPackages + , putState = update st . ReplacePlatformPackages + , resetState = platformStateComponent + -- TODO: backup + -- For now backup is just empty, as this package is basically featureless + -- It defines state, but there is no way at all to modify this state + , backupState = \_ _ -> [] + , restoreState = RestoreBackup { + restoreEntry = error "Unexpected backup entry for platform" + , restoreFinalize = return initialPlatformPackages + } + } + +platformFeature :: StateComponent AcidState PlatformPackages + -> PlatformFeature +platformFeature platformState + = PlatformFeature{..} + where + platformFeatureInterface = (emptyHackageFeature "platform") { + featureDesc = "List packages which are part of the Haskell platform (this is work in progress)" + , featureResources = + map ($ platformResource) [ + platformPackage + , platformPackages + ] + , featureState = [abstractAcidStateComponent platformState] + } + + platformResource = fix $ \r -> PlatformResource + { platformPackage = (resourceAt "/platform/package/:package.:format") { + resourceGet = [] + , resourceDelete = [] + , resourcePut = [] + } + , platformPackages = (resourceAt "/platform/.:format") { + resourceGet = [] + , resourcePost = [] + } + , platformPackageUri = \format pkgid -> + renderResource (platformPackage r) [display pkgid, format] + , platformPackagesUri = \format -> + renderResource (platformPackages r) [format] + -- and maybe "/platform/haskell-platform.cabal" + } + + ------------------------------------------ + -- functionality: showing status for a single package, and for all packages, adding a package, deleting a package + platformVersions :: MonadIO m => PackageName -> m [Version] + platformVersions pkgname = liftM Set.toList $ queryState platformState $ GetPlatformPackage pkgname + + platformPackageLatest :: MonadIO m => m [(PackageName, Version)] + platformPackageLatest = liftM (Map.toList . Map.map Set.findMax . blessedPackages) $ queryState platformState $ GetPlatformPackages + + setPlatform :: MonadIO m => PackageName -> [Version] -> m () + setPlatform pkgname versions = updateState platformState $ SetPlatformPackage pkgname (Set.fromList versions) + + removePlatform :: MonadIO m => PackageName -> m () + removePlatform pkgname = updateState platformState $ SetPlatformPackage pkgname Set.empty + diff --git a/Distribution/Server/Features/HaskellPlatform/State.hs b/Distribution/Server/Features/HaskellPlatform/State.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/HaskellPlatform/State.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, + TypeFamilies, TemplateHaskell #-} + +module Distribution.Server.Features.HaskellPlatform.State where + +import Data.Acid (Query, Update, makeAcidic) +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 +import Data.Typeable + +import Distribution.Server.Framework.Instances () +import Distribution.Server.Framework.MemSize + +import Distribution.Package +import Distribution.Version + +import Control.Monad.Reader (ask, asks) +import Control.Monad.State (put, modify) + +newtype PlatformPackages = PlatformPackages { + blessedPackages :: Map PackageName (Set Version) +} deriving (Show, Typeable, Eq, MemSize) + +emptyPlatformPackages :: PlatformPackages +emptyPlatformPackages = PlatformPackages Map.empty + +getPlatformPackages :: Query PlatformPackages PlatformPackages +getPlatformPackages = ask + +getPlatformPackage :: PackageName -> Query PlatformPackages (Set Version) +getPlatformPackage pkgname = asks (Map.findWithDefault Set.empty pkgname . blessedPackages) + +setPlatformPackage :: PackageName -> Set Version -> Update PlatformPackages () +setPlatformPackage pkgname versions = modify $ \p -> case Set.null versions of + True -> p { blessedPackages = Map.delete pkgname $ blessedPackages p } + False -> p { blessedPackages = Map.insert pkgname versions $ blessedPackages p } + +replacePlatformPackages :: PlatformPackages -> Update PlatformPackages () +replacePlatformPackages = put + +$(deriveSafeCopy 0 'base ''PlatformPackages) + +initialPlatformPackages :: PlatformPackages +initialPlatformPackages = emptyPlatformPackages + +makeAcidic ''PlatformPackages ['getPlatformPackages + ,'getPlatformPackage + ,'setPlatformPackage + ,'replacePlatformPackages + ] + diff --git a/Distribution/Server/Features/HoogleData.hs b/Distribution/Server/Features/HoogleData.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/HoogleData.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, RankNTypes, NamedFieldPuns, RecordWildCards, DoRec, BangPatterns, CPP #-} +module Distribution.Server.Features.HoogleData ( + initHoogleDataFeature, + HoogleDataFeature(..), + ) where + +import Distribution.Server.Framework hiding (path) +import Distribution.Server.Framework.BlobStorage (BlobId) +import qualified Distribution.Server.Framework.BlobStorage as BlobStorage + +import Distribution.Server.Features.Core +import Distribution.Server.Features.Documentation +import Distribution.Server.Features.TarIndexCache + +import qualified Distribution.Server.Packages.PackageIndex as PackageIndex + +import Data.TarIndex as TarIndex + +import Distribution.Package +import Distribution.Text + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Compression.GZip as GZip +import qualified Codec.Compression.Zlib.Internal as Zlib + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as BS +import Data.Serialize (runGetLazy, runPutLazy) +import Data.SafeCopy (SafeCopy, safeGet, safePut) + +import Data.Maybe +import Control.Monad.State +import System.IO +import System.IO.Unsafe (unsafeInterleaveIO) +import System.Directory +import System.FilePath +import Control.Concurrent.MVar +import Control.Concurrent.Async +import Control.Exception +import qualified System.IO.Error as IOError + + +-- | A feature to serve up a tarball of hoogle files, for the hoogle client. +-- +data HoogleDataFeature = HoogleDataFeature { + hoogleDataFeatureInterface :: HackageFeature +} + +instance IsHackageFeature HoogleDataFeature where + getFeatureInterface = hoogleDataFeatureInterface + + +---------------------------------------- +-- Feature definition & initialisation +-- + +initHoogleDataFeature :: ServerEnv + -> IO (CoreFeature + -> DocumentationFeature + -> TarIndexCacheFeature + -> IO HoogleDataFeature) +initHoogleDataFeature env@ServerEnv{ serverCacheDelay, + serverVerbosity = verbosity } = do + -- Ephemeral state + docsUpdatedState <- newMemStateWHNF Set.empty + + hoogleBundleUpdateJob <- newAsyncUpdate serverCacheDelay verbosity + "hoogle.tar.gz" + + return $ \core docs tarIndexCache -> do + let feature = hoogleDataFeature docsUpdatedState + hoogleBundleUpdateJob + env core docs tarIndexCache + + return feature + + +hoogleDataFeature :: MemState (Set PackageId) + -> AsyncUpdate + -> ServerEnv + -> CoreFeature + -> DocumentationFeature + -> TarIndexCacheFeature + -> HoogleDataFeature +hoogleDataFeature docsUpdatedState hoogleBundleUpdateJob + ServerEnv{serverBlobStore = store, serverStateDir} + CoreFeature{..} DocumentationFeature{..} + TarIndexCacheFeature{..} + = HoogleDataFeature {..} + + where + hoogleDataFeatureInterface = (emptyHackageFeature "hoogle-data") { + featureDesc = "Provide a tarball of all package's hoogle files" + , featureResources = [hoogleBundleResource] + , featureState = [] + , featureCaches = [] + , featurePostInit = postInit + } + + -- Resources + -- + + hoogleBundleResource = + (resourceAt "/packages/hoogle.tar.gz") { + resourceDesc = [ (GET, "get the tarball of hoogle files for all packages") + ] + , resourceGet = [ ("tarball", serveHoogleData) ] + } + + -- Request handlers + -- + + featureStateDir = serverStateDir "db" "HoogleData" + bundleTarGzFile = featureStateDir "hoogle.tar.gz" + bundleCacheFile = featureStateDir "cache" + + serveHoogleData :: DynamicPath -> ServerPartE Response + serveHoogleData _ = + -- serve the cached hoogle.tar.gz file + serveFile (asContentType "application/x-gzip") bundleTarGzFile + + postInit :: IO () + postInit = do + createDirectoryIfMissing False featureStateDir + prodFileCacheUpdate + registerHook documentationChangeHook $ \pkgid -> do + modifyMemState docsUpdatedState (Set.insert pkgid) + prodFileCacheUpdate + + prodFileCacheUpdate :: IO () + prodFileCacheUpdate = + asyncUpdate hoogleBundleUpdateJob updateHoogleBundle + + -- Actually do the update. Here we are guaranteed that we're only doing + -- one update at once, no concurrent updates. + updateHoogleBundle :: IO () + updateHoogleBundle = do + docsUpdated <- readMemState docsUpdatedState + writeMemState docsUpdatedState Set.empty + updated <- maybeWithFile bundleTarGzFile $ \mhOldTar -> do + mcache <- readCacheFile bundleCacheFile + let docEntryCache = maybe Map.empty fst mcache + oldTarPkgids = maybe Set.empty snd mcache + tmpdir = featureStateDir + updateTarBundle mhOldTar tmpdir + docEntryCache oldTarPkgids + docsUpdated + case updated of + Nothing -> return () + Just (docEntryCache', newTarPkgids, newTarFile) -> do + renameFile newTarFile bundleTarGzFile + writeCacheFile bundleCacheFile (docEntryCache', newTarPkgids) + + updateTarBundle :: Maybe Handle -> FilePath + -> Map PackageId (Maybe (BlobId, TarEntryOffset)) + -> Set PackageId + -> Set PackageId + -> IO (Maybe (Map PackageId (Maybe (BlobId, TarEntryOffset)) + ,Set PackageId, FilePath)) + updateTarBundle mhOldTar tmpdir docEntryCache oldTarPkgids docsUpdated = do + + -- Invalidate cached info about any package docs that have been updated + let docEntryCache' = docEntryCache `Map.difference` fromSet docsUpdated + cachedPkgids = fromSet (oldTarPkgids `Set.difference` docsUpdated) + + -- get the package & docs index + pkgindex <- queryGetPackageIndex + docindex <- queryDocumentationIndex + + -- Select the package ids that have corresponding docs that contain a + -- hoogle .txt file. + -- We prefer later package versions, but if a later one is missing the + -- hoogle .txt file then we fall back to older ones. + -- + -- For the package ids we pick we keep the associated doc tarball blobid + -- and the offset of the hoogle .txt file within that tarball. + -- + -- Looking up if a package's docs contains the hoogle .txt file is + -- expensive (have to read the doc tarball's index) so we maintain a + -- cache of that information. + (selectedPkgids, docEntryCache'') <- + -- use a state monad for access to and updating the cache + flip runStateT docEntryCache' $ + fmap (Map.fromList . catMaybes) $ + sequence + [ findFirstCached (lookupHoogleEntry docindex) + (reverse (map packageId pkgs)) + | pkgs <- PackageIndex.allPackagesByName pkgindex ] + + -- the set of pkgids to try to reuse from the existing tar file + let reusePkgs :: Map PackageId () + reusePkgs = cachedPkgids `Map.intersection` selectedPkgids + + -- the packages where we need to read it fresh + readFreshPkgs :: Map PackageId (BlobId, TarEntryOffset) + readFreshPkgs = selectedPkgids `Map.difference` reusePkgs + + if Map.null readFreshPkgs && Map.keysSet reusePkgs == oldTarPkgids + then return Nothing + else liftM Just $ + withTempFile tmpdir "newtar" $ \hNewTar newTarFile -> + withWriter (tarWriter hNewTar) $ \putEntry -> do + + -- We truncate on tar format errors. This works for the empty case + -- and should be self-correcting for real errors. It just means we + -- miss a few entries from the tarball 'til next time its updated. + oldEntries <- case mhOldTar of + Nothing -> return [] + Just hOldTar -> + return . Tar.foldEntries (:) [] (const []) + . Tar.read + . BS.fromChunks + . Zlib.foldDecompressStream (:) [] (\_ _ -> []) + . Zlib.decompressWithErrors + Zlib.gzipFormat + Zlib.defaultDecompressParams + =<< BS.hGetContents hOldTar + + -- Write out the cached ones + sequence_ + [ putEntry entry + | entry <- oldEntries + , pkgid <- maybeToList (entryPkgId entry) + , pkgid `Map.member` reusePkgs ] + + -- Write out the new/changed ones + sequence_ + [ withFile doctarfile ReadMode $ \hDocTar -> do + mentry <- newCacheTarEntry pkgid hDocTar taroffset + maybe (return ()) putEntry mentry + | (pkgid, (doctarblobid, taroffset)) <- Map.toList readFreshPkgs + , let doctarfile = BlobStorage.filepath store doctarblobid ] + + return (docEntryCache'', Map.keysSet selectedPkgids, newTarFile) + + lookupHoogleEntry :: Map PackageId BlobId -> PackageId -> IO (Maybe (BlobId, TarEntryOffset)) + lookupHoogleEntry docindex pkgid + | Just doctarblobid <- Map.lookup pkgid docindex + = do doctarindex <- cachedTarIndex doctarblobid + case lookupPkgDocHoogleFile pkgid doctarindex of + Nothing -> return Nothing + Just offset -> return (Just (doctarblobid, offset)) + | otherwise = return Nothing + +fromSet :: Ord a => Set a -> Map a () +fromSet = Map.fromAscList . map (\x -> (x, ())) . Set.toAscList + +-- | Like list 'find' but with a monadic lookup function and we cache the +-- results of that lookup function. +-- +findFirstCached :: (Ord a, Monad m) + => (a -> m (Maybe b)) + -> [a] -> StateT (Map a (Maybe b)) m (Maybe (a, b)) +findFirstCached _ [] = return Nothing +findFirstCached f (x:xs) = do + cache <- get + case Map.lookup x cache of + Just m_y -> checkY m_y + Nothing -> do + m_y <- lift (f x) + put (Map.insert x m_y cache) + checkY m_y + where + checkY Nothing = findFirstCached f xs + checkY (Just y) = return (Just (x, y)) + +withTempFile :: FilePath -> String -> (Handle -> FilePath -> IO a) -> IO a +withTempFile tmpdir template action = + mask $ \restore -> do + (fname, hnd) <- openTempFile tmpdir template + x <- restore (action hnd fname) + `onException` (hClose hnd >> removeFile fname) + hClose hnd + return x + +maybeWithFile :: FilePath -> (Maybe Handle -> IO a) -> IO a +maybeWithFile file action = + mask $ \unmask -> do + mhnd <- try $ openFile file ReadMode + case mhnd of + Right hnd -> unmask (action (Just hnd)) `finally` hClose hnd + Left e | IOError.isDoesNotExistError e + , Just file == IOError.ioeGetFileName e + -> unmask (action Nothing) + Left e -> throw e + +readCacheFile :: SafeCopy a => FilePath -> IO (Maybe a) +readCacheFile file = + maybeWithFile file $ \mhnd -> + case mhnd of + Nothing -> return Nothing + Just hnd -> do + content <- BS.hGetContents hnd + case runGetLazy safeGet content of + Left _ -> return Nothing + Right x -> return (Just x) + +writeCacheFile :: SafeCopy a => FilePath -> a -> IO () +writeCacheFile file x = + BS.writeFile file (runPutLazy (safePut x)) + +lookupPkgDocHoogleFile :: PackageId -> TarIndex -> Maybe TarEntryOffset +lookupPkgDocHoogleFile pkgid index = do + TarFileEntry offset <- TarIndex.lookup index path + return offset + where + path = (display pkgid ++ "-docs") display (packageName pkgid) <.> "txt" + +newCacheTarEntry :: PackageId -> Handle -> TarEntryOffset -> IO (Maybe Tar.Entry) +newCacheTarEntry pkgid htar offset + | Just entrypath <- hoogleDataTarPath pkgid = do + morigEntry <- readTarEntryAt htar offset + case morigEntry of + Nothing -> return Nothing + Just origEntry -> + return $ Just + (Tar.simpleEntry entrypath (Tar.entryContent origEntry)) { + Tar.entryTime = Tar.entryTime origEntry + } + + | otherwise = return Nothing + +hoogleDataTarPath :: PackageId -> Maybe Tar.TarPath +hoogleDataTarPath pkgid = + either (const Nothing) Just (Tar.toTarPath False filepath) + where + -- like zlib/0.5.4.1/doc/html/zlib.txt + filepath = joinPath [ display (packageName pkgid) + , display (packageVersion pkgid) + , "doc", "html" + , display (packageName pkgid) <.> "txt" ] + +entryPkgId :: Tar.Entry -> Maybe PackageId +entryPkgId = parseEntryPath . Tar.entryPath + +parseEntryPath :: FilePath -> Maybe PackageId +parseEntryPath filename + | [namestr, verstr, + "doc", "html", + filestr] <- splitDirectories filename + , Just pkgname <- simpleParse namestr + , Just pkgver <- simpleParse verstr + , (namestr', ".txt") <- splitExtension filestr + , Just pkgname' <- simpleParse namestr' + , pkgname == pkgname' + = Just (PackageIdentifier pkgname pkgver) + + | otherwise + = Nothing + +readTarEntryAt :: Handle -> TarEntryOffset -> IO (Maybe Tar.Entry) +readTarEntryAt htar off = do + hSeek htar AbsoluteSeek (fromIntegral (off * 512)) + header <- BS.hGet htar 512 + case Tar.read header of + (Tar.Next entry@Tar.Entry{Tar.entryContent = Tar.NormalFile _ size} _) -> do + content <- BS.hGet htar (fromIntegral size) + return $ Just entry { Tar.entryContent = Tar.NormalFile content size } + _ -> return Nothing + + +data Writer a = Writer { wWrite :: a -> IO (), wClose :: IO () } + +withWriter :: IO (Writer b) -> ((b -> IO ()) -> IO a) -> IO a +withWriter mkwriter action = bracket mkwriter wClose (action . wWrite) + +tarWriter :: Handle -> IO (Writer Tar.Entry) +tarWriter hnd = do + chan <- newBChan + awriter <- async $ do + entries <- getBChanContents chan + BS.hPut hnd ((GZip.compress . Tar.write) entries) + return Writer { + wWrite = writeBChan chan, + wClose = do closeBChan chan + wait awriter + } + +newtype BChan a = BChan (MVar (Maybe a)) + +newBChan :: IO (BChan a) +newBChan = liftM BChan newEmptyMVar + +writeBChan :: BChan a -> a -> IO () +writeBChan (BChan c) = putMVar c . Just + +closeBChan :: BChan a -> IO () +closeBChan (BChan c) = putMVar c Nothing + +getBChanContents :: BChan a -> IO [a] +getBChanContents (BChan c) = do + res <- takeMVar c + case res of + Nothing -> return [] + Just x -> do xs <- unsafeInterleaveIO (getBChanContents (BChan c)) + return (x : xs) + diff --git a/Distribution/Server/Features/Html.hs b/Distribution/Server/Features/Html.hs --- a/Distribution/Server/Features/Html.hs +++ b/Distribution/Server/Features/Html.hs @@ -11,10 +11,13 @@ import Distribution.Server.Features.Core import Distribution.Server.Features.RecentPackages import Distribution.Server.Features.Upload +import Distribution.Server.Features.BuildReports +import Distribution.Server.Features.BuildReports.Render import Distribution.Server.Features.PackageCandidates import Distribution.Server.Features.Users import Distribution.Server.Features.DownloadCount import Distribution.Server.Features.Search +import Distribution.Server.Features.Search as Search import Distribution.Server.Features.PreferredVersions -- [reverse index disabled] import Distribution.Server.Features.ReverseDependencies import Distribution.Server.Features.PackageList @@ -23,6 +26,7 @@ import Distribution.Server.Features.Distro import Distribution.Server.Features.Documentation import Distribution.Server.Features.UserDetails +import Distribution.Server.Features.EditCabalFiles import Distribution.Server.Users.Types import qualified Distribution.Server.Users.Group as Group @@ -52,9 +56,15 @@ import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import qualified Data.Text as T +import Data.Traversable (traverse) import Control.Applicative (optional) +import Data.Array (Array, listArray) +import qualified Data.Array as Array +import qualified Data.Ix as Ix +import Data.Time.Format (formatTime) +import System.Locale (defaultTimeLocale) import Text.XHtml.Strict import qualified Text.XHtml.Strict as XHtml @@ -80,74 +90,82 @@ -- -- 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 + -> IO (UserFeature + -> CoreFeature + -> RecentPackagesFeature + -> UploadFeature -> PackageCandidatesFeature + -> VersionsFeature + -- [reverse index disabled] -> ReverseFeature + -> TagsFeature -> DownloadFeature + -> ListFeature -> SearchFeature + -> MirrorFeature -> DistroFeature + -> DocumentationFeature + -> DocumentationFeature + -> ReportsFeature + -> 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" - + serverVerbosity = verbosity} = do -- Page templates templates <- loadTemplates serverTemplatesMode [serverTemplatesDir, serverTemplatesDir "Html"] - [ "maintain.html" ] + [ "maintain.html", "maintain-candidate.html" + , "reports.html", "report.html" + , "maintain-docs.html" + , "distro-monitor.html" + , "revisions.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 + return $ \user core@CoreFeature{packageChangeHook} + packages upload + candidates versions + -- [reverse index disabled] reverse + tags download + list@ListFeature{itemUpdate} + names mirror + distros + docsCore docsCandidates + reportsCore + usersdetails -> do + -- 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 + reportsCore + 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 - } + -- 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 - } + 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 + registerHook itemUpdate $ \_ -> prodAsyncCache mainCache + >> prodAsyncCache namesCache + registerHook packageChangeHook $ \_ -> prodAsyncCache mainCache + >> prodAsyncCache namesCache - loginfo verbosity "Initialising html feature, end" - return feature + return feature htmlFeature :: UserFeature -> CoreFeature @@ -163,6 +181,7 @@ -> DistroFeature -> DocumentationFeature -> DocumentationFeature + -> ReportsFeature -> UserDetailsFeature -> HtmlUtilities -> AsyncCache Response @@ -179,7 +198,9 @@ list@ListFeature{getAllLists} names mirror distros - docsCore docsCandidates usersdetails + docsCore docsCandidates + reportsCore + usersdetails utilities@HtmlUtilities{..} cachePackagesPage cacheNamesPage templates @@ -199,14 +220,17 @@ } ] , featurePostInit = syncAsyncCache cachePackagesPage + , featureReloadFiles = reloadTemplates templates } htmlCore = mkHtmlCore utilities + user core versions upload tags docsCore + reportsCore download distros recent @@ -217,8 +241,10 @@ templates htmlUsers = mkHtmlUsers user usersdetails htmlUploads = mkHtmlUploads utilities upload + htmlDocUploads = mkHtmlDocUploads utilities core docsCore templates htmlDownloads = mkHtmlDownloads utilities download - htmlCandidates = mkHtmlCandidates utilities core versions upload docsCandidates candidates + htmlReports = mkHtmlReports utilities core reportsCore templates + htmlCandidates = mkHtmlCandidates utilities core versions upload docsCandidates candidates templates htmlPreferred = mkHtmlPreferred utilities core versions htmlTags = mkHtmlTags utilities core list tags htmlSearch = mkHtmlSearch utilities list names @@ -227,6 +253,8 @@ htmlCoreResources htmlCore , htmlUsersResources htmlUsers , htmlUploadsResources htmlUploads + , htmlDocUploadsResources htmlDocUploads + , htmlReportsResources htmlReports , htmlCandidatesResources htmlCandidates , htmlPreferredResources htmlPreferred , htmlDownloadsResources htmlDownloads @@ -383,11 +411,13 @@ } mkHtmlCore :: HtmlUtilities + -> UserFeature -> CoreFeature -> VersionsFeature -> UploadFeature -> TagsFeature -> DocumentationFeature + -> ReportsFeature -> DownloadFeature -> DistroFeature -> RecentPackagesFeature @@ -398,6 +428,7 @@ -> Templates -> HtmlCore mkHtmlCore HtmlUtilities{..} + UserFeature{queryGetUserDb} CoreFeature{coreResource} VersionsFeature{ versionsResource , queryGetDeprecatedFor @@ -406,8 +437,9 @@ } UploadFeature{guardAuthorisedAsMaintainerOrTrustee} TagsFeature{queryTagsForPackage} - DocumentationFeature{documentationResource, queryHasDocumentation} - DownloadFeature{recentPackageDownloads} + documentationFeature@DocumentationFeature{documentationResource, queryHasDocumentation} + reportsFeature + DownloadFeature{recentPackageDownloads,totalPackageDownloads} DistroFeature{queryPackageStatus} RecentPackagesFeature{packageRender} HtmlTags{..} @@ -417,7 +449,7 @@ templates = HtmlCore{..} where - cores@CoreResource{packageInPath, lookupPackageName} = coreResource + cores@CoreResource{packageInPath, lookupPackageName, lookupPackageId} = coreResource versions = versionsResource docs = documentationResource @@ -443,6 +475,13 @@ , resourceGet = [("html", const $ readAsyncCache cachePackagesPage)] } , maintainPackage + , (resourceAt "/package/:package/distro-monitor") { + resourceDesc = [(GET, "A handy page for distro package change monitor tools")] + , resourceGet = [("html", serveDistroMonitorPage)] + } + , (resourceAt "/package/:package/revisions/") { + resourceGet = [("html", serveCabalRevisionsPage)] + } ] -- Currently the main package page is thrown together by querying a bunch @@ -458,6 +497,9 @@ let realpkg = rendPkgId render pkgname = packageName realpkg middleHtml = Pages.renderFields render + -- render the build status line + buildStatus <- renderBuildStatus documentationFeature reportsFeature realpkg + let buildStatusHtml = [("Status", buildStatus)] -- get additional information from other features prefInfo <- queryGetPreferredInfo pkgname let infoUrl = fmap (\_ -> preferredPackageUri versions "" pkgname) $ sumRange prefInfo @@ -468,11 +510,12 @@ -- [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 + totalDown <- cmFind pkgname `liftM` totalPackageDownloads + recentDown <- cmFind pkgname `liftM` recentPackageDownloads let distHtml = case distributions of [] -> [] _ -> [("Distributions", concatHtml . intersperse (toHtml ", ") $ map showDist distributions)] - afterHtml = distHtml ++ [Pages.renderDownloads totalDown {- versionDown $ packageVersion realpkg-} + afterHtml = distHtml ++ [Pages.renderDownloads totalDown recentDown {- versionDown $ packageVersion realpkg-} -- [reverse index disabled] ,Pages.reversePackageSummary realpkg revr revCount ] -- bottom sections, currently only documentation @@ -493,7 +536,10 @@ Nothing -> noHtml -- and put it all together return $ toResponse $ Resource.XHtml $ - Pages.packagePage render [tagLinks] [deprHtml] (beforeHtml ++ middleHtml ++ afterHtml) [] docURL + Pages.packagePage render [tagLinks] [deprHtml] + (beforeHtml ++ middleHtml ++ afterHtml + ++ buildStatusHtml) + [] docURL False where showDist (dname, info) = toHtml (display dname ++ ":") +++ anchor ! [href $ distroUrl info] << toHtml (display $ distroVersion info) @@ -505,11 +551,58 @@ guardAuthorisedAsMaintainerOrTrustee (pkgname :: PackageName) template <- getTemplate templates "maintain.html" return $ toResponse $ template - [ "pkgname" $= display pkgname - , "versions" $= map (display . packageId) pkgs + [ "pkgname" $= pkgname + , "versions" $= map packageId pkgs ] + serveDistroMonitorPage :: DynamicPath -> ServerPartE Response + serveDistroMonitorPage dpath = do + pkgname <- packageInPath dpath + pkgs <- lookupPackageName pkgname + template <- getTemplate templates "distro-monitor.html" + return $ toResponse $ template + [ "pkgname" $= pkgname + , "versions" $= map packageId pkgs + ] + serveCabalRevisionsPage :: DynamicPath -> ServerPartE Response + serveCabalRevisionsPage dpath = do + pkginfo <- packageInPath dpath >>= lookupPackageId + users <- queryGetUserDb + template <- getTemplate templates "revisions.html" + let pkgid = packageId pkginfo + pkgname = packageName pkginfo + revisions = (pkgData pkginfo, pkgUploadData pkginfo) + : pkgDataOld pkginfo + numRevisions = length revisions + revchanges = [ case diffCabalRevisions pkgid + (cabalFileByteString old) + (cabalFileByteString new) + of Left _err -> [] + Right changes -> changes + | ((new, _), (old, _)) <- zip revisions (tail revisions) ] + + return $ toResponse $ template + [ "pkgname" $= pkgname + , "pkgid" $= pkgid + , "revisions" $= zipWith3 (revisionToTemplate users) + (map snd revisions) + [numRevisions-1, numRevisions-2..] + (revchanges ++ [[]]) + ] + where + revisionToTemplate :: Users.Users -> UploadInfo -> Int -> [Change] + -> TemplateVal + revisionToTemplate users (utime, uid) revision changes = + let uname = Users.userIdToName users uid + in templateDict + [ templateVal "number" revision + , templateVal "user" (display uname) + , templateVal "time" (formatTime defaultTimeLocale "%c" utime) + , templateVal "changes" changes + ] + + {------------------------------------------------------------------------------- Users -------------------------------------------------------------------------------} @@ -539,11 +632,8 @@ } -- 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") - ] + resourceDesc = [ (GET, "show user page") ] , resourceGet = [ ("html", serveUserPage) ] - , resourceDelete = [ ("html", serveDeleteUser) ] } -- form to PUT password , (extendResource $ passwordResource users) { @@ -553,14 +643,6 @@ , 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 @@ -625,41 +707,6 @@ ] ] - 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 @@ -716,6 +763,97 @@ _ -> [paragraph << "There were some warnings:", unordList warns] {------------------------------------------------------------------------------- + Documentation uploads +-------------------------------------------------------------------------------} + +data HtmlDocUploads = HtmlDocUploads { + htmlDocUploadsResources :: [Resource] + } + +mkHtmlDocUploads :: HtmlUtilities -> CoreFeature -> DocumentationFeature -> Templates -> HtmlDocUploads +mkHtmlDocUploads HtmlUtilities{..} CoreFeature{coreResource} DocumentationFeature{..} templates = HtmlDocUploads{..} + where + CoreResource{packageInPath} = coreResource + + htmlDocUploadsResources = [ + (extendResource $ packageDocsWhole documentationResource) { + resourcePut = [ ("html", serveUploadDocumentation) ] + , resourceDelete = [ ("html", serveDeleteDocumentation) ] + } + , (resourceAt "/package/:package/maintain/docs") { + resourceGet = [("html", serveDocUploadForm)] + } + ] + + serveUploadDocumentation :: DynamicPath -> ServerPartE Response + serveUploadDocumentation dpath = do + pkgid <- packageInPath dpath + uploadDocumentation dpath >> ignoreFilters -- Override 204 No Content + return $ toResponse $ Resource.XHtml $ hackagePage "Documentation uploaded" $ + [ paragraph << [toHtml "Successfully uploaded documentation for ", packageLink pkgid, toHtml "!"] + ] + + serveDeleteDocumentation :: DynamicPath -> ServerPartE Response + serveDeleteDocumentation dpath = do + pkgid <- packageInPath dpath + deleteDocumentation dpath >> ignoreFilters -- Override 204 No Content + return $ toResponse $ Resource.XHtml $ hackagePage "Documentation deleted" $ + [ paragraph << [toHtml "Successfully deleted documentation for ", packageLink pkgid, toHtml "!"] + ] + + serveDocUploadForm :: DynamicPath -> ServerPartE Response + serveDocUploadForm dpath = do + pkgid <- packageInPath dpath + template <- getTemplate templates "maintain-docs.html" + return $ toResponse $ template + [ "pkgid" $= (pkgid :: PackageIdentifier) + ] + +{------------------------------------------------------------------------------- + Build reports +-------------------------------------------------------------------------------} + +data HtmlReports = HtmlReports { + htmlReportsResources :: [Resource] + } + +mkHtmlReports :: HtmlUtilities -> CoreFeature -> ReportsFeature -> Templates -> HtmlReports +mkHtmlReports HtmlUtilities{..} CoreFeature{..} ReportsFeature{..} templates = HtmlReports{..} + where + CoreResource{packageInPath} = coreResource + ReportsResource{..} = reportsResource + + htmlReportsResources = [ + (extendResource reportsList) { + resourceGet = [ ("html", servePackageReports) ] + } + , (extendResource reportsPage) { + resourceGet = [ ("html", servePackageReport) ] + } + ] + + servePackageReports :: DynamicPath -> ServerPartE Response + servePackageReports dpath = packageReports dpath $ \reports -> do + pkgid <- packageInPath dpath + template <- getTemplate templates "reports.html" + return $ toResponse $ template + [ "pkgid" $= (pkgid :: PackageIdentifier) + , "reports" $= reports + ] + + servePackageReport :: DynamicPath -> ServerPartE Response + servePackageReport dpath = do + (repid, report, mlog) <- packageReport dpath + mlog' <- traverse queryBuildLog mlog + pkgid <- packageInPath dpath + template <- getTemplate templates "report.html" + return $ toResponse $ template + [ "pkgid" $= (pkgid :: PackageIdentifier) + , "report" $= (repid, report) + , "log" $= toMessage <$> mlog' + ] + +{------------------------------------------------------------------------------- Candidates -------------------------------------------------------------------------------} @@ -729,6 +867,7 @@ -> UploadFeature -> DocumentationFeature -> PackageCandidatesFeature + -> Templates -> HtmlCandidates mkHtmlCandidates HtmlUtilities{..} CoreFeature{ coreResource = CoreResource{packageInPath} @@ -737,7 +876,8 @@ VersionsFeature{ queryGetPreferredInfo } UploadFeature{ guardAuthorisedAsMaintainer } DocumentationFeature{documentationResource, queryHasDocumentation} - PackageCandidatesFeature{..} = HtmlCandidates{..} + PackageCandidatesFeature{..} + templates = HtmlCandidates{..} where candidates = candidatesResource candidatesCore = candidatesCoreResource @@ -795,6 +935,13 @@ , resourceGet = [ ("html", servePublishForm) ] , resourcePost = [ ("html", servePostPublish) ] } + , (extendResource $ deletePage candidates) { + resourceDesc = [ (GET, "Show candidate deletion form") + , (POST, "Delete a package candidate") + ] + , resourceGet = [ ("html", serveDeleteForm) ] + , resourcePost = [ ("html", doDeleteCandidate) ] + } ] serveCandidateUploadForm :: DynamicPath -> ServerPartE Response @@ -821,11 +968,13 @@ 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."] + template <- getTemplate templates "maintain-candidate.html" + return $ toResponse $ template + [ "pkgname" $= packageName candidate + , "pkgversion" $= packageVersion candidate + ] {-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 @@ -848,7 +997,7 @@ [] -> [] warn -> [thediv ! [theclass "notification"] << [toHtml "Warnings:", unordList warn]] return $ toResponse $ Resource.XHtml $ - Pages.packagePage render [maintainHtml] warningBox sectionHtml [] docURL + Pages.packagePage render [maintainHtml] warningBox sectionHtml [] docURL True servePublishForm :: DynamicPath -> ServerPartE Response servePublishForm dpath = do @@ -914,6 +1063,16 @@ [] -> [] warns -> [paragraph << "There were some warnings:", unordList warns] + serveDeleteForm :: DynamicPath -> ServerPartE Response + serveDeleteForm dpath = do + candidate <- packageInPath dpath >>= lookupCandidateId + guardAuthorisedAsMaintainer (packageName candidate) + let pkgid = packageId candidate + return $ toResponse $ Resource.XHtml $ hackagePage "Deleting candidates" + [form ! [theclass "box", XHtml.method "post", action $ deleteUri candidatesResource "" pkgid] + << input ! [thetype "submit", value "Delete package candidate"]] + + {------------------------------------------------------------------------------- Preferred versions -------------------------------------------------------------------------------} @@ -1303,18 +1462,31 @@ servePackageFind :: DynamicPath -> ServerPartE Response servePackageFind _ = do - (mtermsStr, offset, limit) <- - queryString $ (,,) <$> optional (look "terms") - <*> mplus (lookRead "offset") (pure 0) - <*> mplus (lookRead "limit") (pure 10) + (mtermsStr, offset, limit, mexplain) <- + queryString $ (,,,) <$> optional (look "terms") + <*> mplus (lookRead "offset") (pure 0) + <*> mplus (lookRead "limit") (pure 100) + <*> optional (look "explain") + let explain = isJust mexplain case mtermsStr of + Just termsStr | explain + , terms <- words termsStr, not (null terms) -> do + params <- queryString getSearchRankParameters + results <- searchPackagesExplain params terms + return $ toResponse $ Resource.XHtml $ + hackagePage "Package search" $ + [ toHtml $ paramsForm params termsStr + , resetParamsForm termsStr + , toHtml $ explainResults results + ] + 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 $ searchForm termsStr False , toHtml $ resultsArea pkgDetails offset limit moreResults termsStr , alternativeSearch ] @@ -1322,7 +1494,7 @@ _ -> return $ toResponse $ Resource.XHtml $ hackagePage "Text search" $ - [ toHtml $ searchForm "" + [ toHtml $ searchForm "" explain , alternativeSearch ] where @@ -1352,12 +1524,14 @@ ++ "&offset=" ++ show (offset + limit) ++ "&limit=" ++ show limit - searchForm termsStr = + searchForm termsStr explain = [ h2 << "Package search" - , form ! [theclass "box", XHtml.method "GET", action "/packages/search"] << + , form ! [XHtml.method "GET", action "/packages/search"] << [ input ! [value termsStr, name "terms", identifier "terms"] , toHtml " " , input ! [thetype "submit", value "Search"] + , if explain then input ! [thetype "hidden", name "explain"] + else noHtml ] ] @@ -1369,6 +1543,119 @@ , anchor ! [href "http://www.haskell.org/hoogle/"] << "Hoogle" ] + explainResults :: [(Search.Explanation PkgDocField PkgDocFeatures T.Text, PackageName)] -> [Html] + explainResults results = + [ h2 << "Results" + , case results of + [] -> noHtml + ((explanation1, _):_) -> + table ! [ border 1 ] << + ( ( tr << tableHeader explanation1) + : [ tr << tableRow explanation pkgname + | (explanation, pkgname) <- results ]) + ] + where + tableHeader Search.Explanation{..} = + [ th << "package", th << "overall score" ] + ++ [ th << (show term ++ " score") + | (term, _score) <- termScores ] + ++ [ th << (show term ++ " " ++ show field ++ " score") + | (term, fieldScores) <- termFieldScores + , (field, _score) <- fieldScores ] + ++ [ th << (show feature ++ " score") + | (feature, _score) <- nonTermScores ] + + tableRow Search.Explanation{..} pkgname = + [ td << display pkgname, td << show overallScore ] + ++ [ td << show score + | (_term, score) <- termScores ] + ++ [ td << show score + | (_term, fieldScores) <- termFieldScores + , (_field, score) <- fieldScores ] + ++ [ td << show score + | (_feature, score) <- nonTermScores ] + + getSearchRankParameters = do + let defaults = defaultSearchRankParameters + k1 <- lookRead "k1" `mplus` pure (paramK1 defaults) + bs <- sequence + [ lookRead ("b" ++ show field) + `mplus` pure (paramB defaults field) + | field <- Ix.range (minBound, maxBound :: PkgDocField) ] + ws <- sequence + [ lookRead ("w" ++ show field) + `mplus` pure (paramFieldWeights defaults field) + | field <- Ix.range (minBound, maxBound :: PkgDocField) ] + fs <- sequence + [ lookRead ("w" ++ show feature) + `mplus` pure (paramFeatureWeights defaults feature) + | feature <- Ix.range (minBound, maxBound :: PkgDocFeatures) ] + let barr, warr :: Array PkgDocField Float + barr = listArray (minBound, maxBound) bs + warr = listArray (minBound, maxBound) ws + farr = listArray (minBound, maxBound) fs + return defaults { + paramK1 = k1, + paramB = (barr Array.!), + paramFieldWeights = (warr Array.!), + paramFeatureWeights = (farr Array.!) + } + + paramsForm SearchRankParameters{..} termsStr = + [ h2 << "Package search (tuning & explanation)" + , form ! [XHtml.method "GET", action "/packages/search"] << + [ input ! [value termsStr, name "terms", identifier "terms"] + , toHtml " " + , input ! [thetype "submit", value "Search"] + , input ! [thetype "hidden", name "explain"] + , simpleTable [] [] $ + makeInput [thetype "text", value (show paramK1)] "k1" "K1 parameter" + : [ makeInput [thetype "text", value (show (paramB field))] + ("b" ++ fieldname) + ("B param for " ++ fieldname) + ++ makeInput [thetype "text", value (show (paramFieldWeights field)) ] + ("w" ++ fieldname) + ("Weight for " ++ fieldname) + | field <- Ix.range (minBound, maxBound :: PkgDocField) + , let fieldname = show field + ] + ++ [ makeInput [thetype "text", value (show (paramFeatureWeights feature)) ] + ("w" ++ featurename) + ("Weight for " ++ featurename) + | feature <- Ix.range (minBound, maxBound :: PkgDocFeatures) + , let featurename = show feature ] + ] + ] + resetParamsForm termsStr = + let SearchRankParameters{..} = defaultSearchRankParameters in + form ! [XHtml.method "GET", action "/packages/search"] << + (concat $ + [ input ! [ thetype "submit", value "Reset parameters" ] + , input ! [ thetype "hidden", name "terms", value termsStr ] + , input ! [ thetype "hidden", name "explain" ] + , input ! [ thetype "hidden", name "k1", value (show paramK1) ] ] + : [ [ input ! [ thetype "hidden" + , name ("b" ++ fieldname) + , value (show (paramB field)) + ] + , input ! [ thetype "hidden" + , name ("w" ++ fieldname) + , value (show (paramFieldWeights field)) + ] + ] + | field <- Ix.range (minBound, maxBound :: PkgDocField) + , let fieldname = show field + ] + ++ [ [ input ! [ thetype "hidden" + , name ("w" ++ featurename) + , value (show (paramFeatureWeights feature)) + ] + ] + | feature <- Ix.range (minBound, maxBound :: PkgDocFeatures) + , let featurename = show feature + ]) + + {------------------------------------------------------------------------------- Groups -------------------------------------------------------------------------------} @@ -1377,7 +1664,7 @@ htmlGroupResource UserFeature{..} r@(GroupResource groupR userR getGroup) = [ (extendResource groupR) { resourceDesc = [ (GET, "Show list of users") - , (POST, "Udd a user to the group") + , (POST, "Add a user to the group") ] , resourceGet = [ ("html", getList) ] , resourcePost = [ ("html", postUser) ] diff --git a/Distribution/Server/Features/LegacyPasswds.hs b/Distribution/Server/Features/LegacyPasswds.hs --- a/Distribution/Server/Features/LegacyPasswds.hs +++ b/Distribution/Server/Features/LegacyPasswds.hs @@ -2,6 +2,9 @@ module Distribution.Server.Features.LegacyPasswds ( initLegacyPasswdsFeature, LegacyPasswdsFeature(..), + LegacyPasswdsTable, + lookupUserLegacyPasswd, + enumerateAllUserLegacyPasswd, ) where import Prelude hiding (abs) @@ -39,7 +42,10 @@ -- hackage.haskell.org server. It is not needed by new installations. -- data LegacyPasswdsFeature = LegacyPasswdsFeature { - legacyPasswdsFeatureInterface :: HackageFeature + legacyPasswdsFeatureInterface :: HackageFeature, + + queryLegacyPasswds :: MonadIO m => m LegacyPasswdsTable, + updateDeleteLegacyPasswd :: MonadIO m => UserId -> m Bool } instance IsHackageFeature LegacyPasswdsFeature where @@ -55,10 +61,14 @@ emptyLegacyPasswdsTable :: LegacyPasswdsTable emptyLegacyPasswdsTable = LegacyPasswdsTable IntMap.empty -lookupUserLegacyPasswd :: LegacyPasswdsTable -> UserId -> Maybe LegacyAuth.HtPasswdHash -lookupUserLegacyPasswd (LegacyPasswdsTable tbl) (UserId uid) = +lookupUserLegacyPasswd :: UserId -> LegacyPasswdsTable -> Maybe LegacyAuth.HtPasswdHash +lookupUserLegacyPasswd (UserId uid) (LegacyPasswdsTable tbl) = IntMap.lookup uid tbl +enumerateAllUserLegacyPasswd :: LegacyPasswdsTable -> [UserId] +enumerateAllUserLegacyPasswd (LegacyPasswdsTable tbl) = + map UserId (IntMap.keys tbl) + $(deriveSafeCopy 0 'base ''LegacyPasswdsTable) instance MemSize LegacyPasswdsTable where @@ -110,7 +120,8 @@ , stateHandle = st , getState = query st GetLegacyPasswdsTable , putState = update st . ReplaceLegacyPasswdsTable - , backupState = \users -> [csvToBackup ["htpasswd.csv"] (legacyPasswdsToCSV users)] + , backupState = \backuptype users -> + [csvToBackup ["htpasswd.csv"] (legacyPasswdsToCSV backuptype users)] , restoreState = legacyPasswdsBackup , resetState = legacyPasswdsStateComponent } @@ -148,14 +159,16 @@ fromRecord x = fail $ "Error processing user details record: " ++ show x -legacyPasswdsToCSV :: LegacyPasswdsTable -> CSV -legacyPasswdsToCSV (LegacyPasswdsTable tbl) +legacyPasswdsToCSV :: BackupType -> LegacyPasswdsTable -> CSV +legacyPasswdsToCSV backuptype (LegacyPasswdsTable tbl) = ([display version]:) $ (headers:) $ flip map (IntMap.toList tbl) $ \(uid, LegacyAuth.HtPasswdHash passwdhash) -> [ display (UserId uid) - , passwdhash + , if backuptype == FullBackup + then passwdhash + else "" ] where headers = ["uid", "htpasswd"] @@ -165,9 +178,11 @@ -- Feature definition & initialisation -- -initLegacyPasswdsFeature :: ServerEnv -> UserFeature -> IO LegacyPasswdsFeature -initLegacyPasswdsFeature env@ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} users = do - +initLegacyPasswdsFeature :: ServerEnv + -> IO (UserFeature + -> IO LegacyPasswdsFeature) +initLegacyPasswdsFeature env@ServerEnv{serverStateDir, serverTemplatesDir, + serverTemplatesMode} = do -- Canonical state legacyPasswdsState <- legacyPasswdsStateComponent serverStateDir @@ -176,9 +191,10 @@ [serverTemplatesDir, serverTemplatesDir "LegacyPasswds"] ["htpasswd-upgrade.html", "htpasswd-upgrade-success.html"] - let feature = legacyPasswdsFeature env legacyPasswdsState templates users + return $ \users -> do + let feature = legacyPasswdsFeature env legacyPasswdsState templates users - return feature + return feature legacyPasswdsFeature :: ServerEnv -> StateComponent AcidState LegacyPasswdsTable @@ -195,14 +211,16 @@ , featureState = [abstractAcidStateComponent legacyPasswdsState] , featureCaches = [] , featurePostInit = interceptUserAuthFail + , featureReloadFiles = reloadTemplates templates } -- Resources -- htpasswordResource = (resourceAt "/user/:username/htpasswd") { - resourceDesc = [ (PUT, "Set a legacy password for a user account") ], - resourcePut = [ ("", handleUserHtpasswdPut) ] + resourceDesc = [ (PUT, "Set a legacy password for a user account") ], + resourcePut = [ ("", handleUserHtpasswdPut) ], + resourceDelete = [ ("", handleUserHtpasswdDelete) ] } htpasswordUpgradeResource = (resourceAt "/users/htpasswd-upgrade") { @@ -211,6 +229,16 @@ resourcePost = [ ("", handleUserAuthUpgradePost) ] } + -- Queries and updates + -- + + queryLegacyPasswds :: MonadIO m => m LegacyPasswdsTable + queryLegacyPasswds = queryState legacyPasswdsState GetLegacyPasswdsTable + + updateDeleteLegacyPasswd :: MonadIO m => UserId -> m Bool + updateDeleteLegacyPasswd uid = + updateState legacyPasswdsState (DeleteUserLegacyPasswd uid) + -- Request handlers -- @@ -219,12 +247,9 @@ 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] + guardAuthorised_ [InGroup adminGroup] users <- queryGetUserDb uname <- userNameInPath dpath (uid, uinfo) <- maybe errNoSuchUser return (Users.lookupUserName uname users) @@ -240,6 +265,16 @@ 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."] + handleUserHtpasswdDelete :: DynamicPath -> ServerPartE Response + handleUserHtpasswdDelete dpath = do + guardAuthorised_ [InGroup adminGroup] + uid <- lookupUserName =<< userNameInPath dpath + deleted <- updateState legacyPasswdsState (DeleteUserLegacyPasswd uid) + when (not deleted) errNoHtpasswd + noContent $ toResponse () + where + errNoHtpasswd = errBadRequest "No htpasswd" [MText "The user has no htpasswd"] + handleUserAuthUpgradePost :: DynamicPath -> ServerPartE Response handleUserAuthUpgradePost _ = do users <- queryGetUserDb @@ -247,7 +282,7 @@ (uid, uinfo, passwd) <- LegacyAuth.guardAuthenticated (RealmName "Old Hackage site") users - (lookupUserLegacyPasswd legacyPasswds) + (flip lookupUserLegacyPasswd legacyPasswds) when (userStatus uinfo /= Users.AccountDisabled Nothing) errHasAuth let auth = Users.UserAuth (Auth.newPasswdHash Auth.hackageRealm (userName uinfo) passwd) updateSetUserAuth uid auth @@ -276,7 +311,7 @@ onAuthFail (Auth.UserStatusError uid UserInfo { userStatus = AccountDisabled Nothing }) = do legacyPasswds <- queryLegacyPasswds - case lookupUserLegacyPasswd legacyPasswds uid of + case lookupUserLegacyPasswd uid legacyPasswds of Nothing -> return Nothing Just _ -> return (Just err) where diff --git a/Distribution/Server/Features/LegacyRedirects.hs b/Distribution/Server/Features/LegacyRedirects.hs --- a/Distribution/Server/Features/LegacyRedirects.hs +++ b/Distribution/Server/Features/LegacyRedirects.hs @@ -83,10 +83,10 @@ _ -> mzero _ -> mzero _ -> mzero + , simpleMove "recent" "/packages/recent" + , simpleMove "recent.html" "/packages/recent.html" + , simpleMove "recent.rss" "/packages/recent.rss" ] - 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' @@ -106,7 +106,7 @@ serveArchiveTree :: ServerPartE Response serveArchiveTree = msum - [ dir "pkg-list.html" $ method GET >> nullDir >> movedPermanently "/packages/" (toResponse "") + [ simpleMove "pkg-list.html" "/packages/" , dir "package" $ path $ \fileName -> method GET >> nullDir >> case Posix.splitExtension fileName of (fileName', ".gz") -> case Posix.splitExtension fileName' of @@ -116,24 +116,21 @@ _ -> mzero _ -> mzero _ -> mzero - , dir "00-index.tar.gz" $ method GET >> nullDir >> movedPermanently "/packages/index.tar.gz" (toResponse "") + , simpleMove "00-index.tar.gz" "/packages/index.tar.gz" + , simpleMove "recent.html" "/packages/recent" + , simpleMove "recent.rss" "/packages/recent.rss" + , simpleMove "00-hoogle.tar.gz" "/packages/hoogle.tar.gz" , 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 "") + [ simpleMove (display pkgid ++ ".tar.gz") (packageTarball pkgid) + , simpleMove (display name ++ ".cabal") (cabalPath pkgid) , dir "doc" $ dir "html" $ remainingPath $ \paths -> let doc = Posix.joinPath paths - in method GET >> nullDir >> - movedPermanently (docPath pkgid doc) (toResponse "") + in simpleMoveTo (docPath pkgid doc) ] ] ] @@ -146,4 +143,11 @@ packageTarball :: PackageId -> String packageTarball pkgid = "/package/" ++ display pkgid ++ "/" ++ display pkgid ++ ".tar.gz" + +-- HTTP 301 is suitable for permanently redirecting pages +simpleMove :: String -> String -> ServerPartE Response +simpleMove from to = dir from $ simpleMoveTo to + +simpleMoveTo :: String -> ServerPartE Response +simpleMoveTo to = method GET >> nullDir >> movedPermanently to (toResponse "") diff --git a/Distribution/Server/Features/Mirror.hs b/Distribution/Server/Features/Mirror.hs --- a/Distribution/Server/Features/Mirror.hs +++ b/Distribution/Server/Features/Mirror.hs @@ -6,7 +6,7 @@ initMirrorFeature ) where -import Distribution.Server.Framework hiding (formatTime) +import Distribution.Server.Framework import Distribution.Server.Features.Core import Distribution.Server.Features.Users @@ -52,23 +52,23 @@ } ------------------------------------------------------------------------- -initMirrorFeature :: ServerEnv -> CoreFeature -> UserFeature -> IO MirrorFeature -initMirrorFeature env@ServerEnv{serverStateDir, serverVerbosity = verbosity} - core user@UserFeature{..} = do - loginfo verbosity "Initialising mirror feature, start" - +initMirrorFeature :: ServerEnv + -> IO (CoreFeature + -> UserFeature + -> IO MirrorFeature) +initMirrorFeature env@ServerEnv{serverStateDir} = do -- Canonical state mirrorersState <- mirrorersStateComponent serverStateDir - -- Tie the knot with a do-rec - rec let (feature, mirrorersGroupDesc) - = mirrorFeature env core user - mirrorersState mirrorersG mirrorR + return $ \core user@UserFeature{..} -> do + -- Tie the knot with a do-rec + rec let (feature, mirrorersGroupDesc) + = mirrorFeature env core user + mirrorersState mirrorersG mirrorR - (mirrorersG, mirrorR) <- groupResourceAt "/packages/mirrorers" mirrorersGroupDesc + (mirrorersG, mirrorR) <- groupResourceAt "/packages/mirrorers" mirrorersGroupDesc - loginfo verbosity "Initialising mirror feature, end" - return feature + return feature mirrorersStateComponent :: FilePath -> IO (StateComponent AcidState MirrorClients) mirrorersStateComponent stateDir = do @@ -78,7 +78,7 @@ , stateHandle = st , getState = query st GetMirrorClients , putState = update st . ReplaceMirrorClients . mirrorClients - , backupState = \(MirrorClients clients) -> [csvToBackup ["clients.csv"] $ groupToCSV clients] + , backupState = \_ (MirrorClients clients) -> [csvToBackup ["clients.csv"] $ groupToCSV clients] , restoreState = MirrorClients <$> groupBackup ["clients.csv"] , resetState = mirrorersStateComponent } @@ -109,7 +109,7 @@ mirrorFeatureInterface = (emptyHackageFeature "mirror") { featureDesc = "Support direct (PUT) tarball uploads and overrides" , featureResources = - map ($mirrorResource) [ + map ($ mirrorResource) [ mirrorPackageTarball , mirrorPackageUploadTime , mirrorPackageUploader diff --git a/Distribution/Server/Features/PackageCandidates.hs b/Distribution/Server/Features/PackageCandidates.hs --- a/Distribution/Server/Features/PackageCandidates.hs +++ b/Distribution/Server/Features/PackageCandidates.hs @@ -92,8 +92,10 @@ data PackageCandidatesResource = PackageCandidatesResource { packageCandidatesPage :: Resource, publishPage :: Resource, + deletePage :: Resource, packageCandidatesUri :: String -> PackageName -> String, publishUri :: String -> PackageId -> String, + deleteUri :: String -> PackageId -> String, -- TODO: Why don't the following entries have a corresponding entry -- in CoreResource? @@ -114,15 +116,20 @@ -- 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 + -> IO (UserFeature + -> CoreFeature + -> UploadFeature + -> TarIndexCacheFeature + -> IO PackageCandidatesFeature) +initPackageCandidatesFeature env@ServerEnv{serverStateDir} = do candidatesState <- candidatesStateComponent serverStateDir - return $ candidatesFeature env user core upload tarIndexCache candidatesState + return $ \user core upload tarIndexCache -> do + let feature = candidatesFeature env + user core upload tarIndexCache + candidatesState + return feature + candidatesStateComponent :: FilePath -> IO (StateComponent AcidState CandidatePackages) candidatesStateComponent stateDir = do st <- openLocalStateFrom (stateDir "db" "CandidatePackages") initialCandidatePackages @@ -132,7 +139,7 @@ , getState = query st GetCandidatePackages , putState = update st . ReplaceCandidatePackages , resetState = candidatesStateComponent - , backupState = backupCandidates + , backupState = \_ -> backupCandidates , restoreState = restoreCandidates } @@ -157,13 +164,13 @@ candidatesFeatureInterface = (emptyHackageFeature "candidates") { featureDesc = "Support for package candidates" , featureResources = - map ($candidatesCoreResource) [ + map ($ candidatesCoreResource) [ corePackagesPage , corePackagePage , coreCabalFile , corePackageTarball ] ++ - map ($candidatesResource) [ + map ($ candidatesResource) [ publishPage , candidateContents , candidateChangeLog @@ -207,6 +214,7 @@ candidatesResource = fix $ \r -> PackageCandidatesResource { packageCandidatesPage = resourceAt "/package/:package/candidates/.:format" , publishPage = resourceAt "/package/:package/candidate/publish.:format" + , deletePage = resourceAt "/package/:package/candidate/delete.:format" , candidateContents = (resourceAt "/package/:package/candidate/src/..") { resourceGet = [("", serveContents)] } @@ -217,6 +225,8 @@ renderResource (packageCandidatesPage r) [display pkgname, format] , publishUri = \format pkgid -> renderResource (publishPage r) [display pkgid, format] + , deleteUri = \format pkgid -> + renderResource (deletePage r) [display pkgid, format] , candidateChangeLogUri = \pkgid -> renderResource (candidateChangeLog candidatesResource) [display pkgid, display (packageName pkgid)] } @@ -387,7 +397,7 @@ {------------------------------------------------------------------------------- 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. + isn't any "interesting" code here, except differences in http cache control. -------------------------------------------------------------------------------} -- result: changelog or not-found error @@ -398,8 +408,9 @@ case mChangeLog of Left err -> errNotFound "Changelog not found" [MText err] - Right (fp, etag, offset, name) -> - liftIO $ serveTarEntry fp offset name etag + Right (fp, etag, offset, name) -> do + cacheControl [Public, maxAgeMinutes 5] etag + liftIO $ serveTarEntry fp offset name -- return: not-found error or tarball serveContents :: DynamicPath -> ServerPartE Response @@ -410,13 +421,14 @@ Left err -> errNotFound "Could not serve package contents" [MText err] Right (fp, etag, index) -> - serveTarball ["index.html"] (display (packageId pkg)) fp index etag + serveTarball ["index.html"] (display (packageId pkg)) fp index + [Public, maxAgeMinutes 5] 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 + etag = BlobStorage.blobETag blobid index <- cachedPackageTarIndex pkgTarball return $ Right (fp, etag, index) packageTarball _ = @@ -425,5 +437,6 @@ 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) + (offset, fname) <- ErrorT $ return . maybe (Left "No changelog found") Right + $ findChangeLog pkgInfo index return (fp, etag, offset, fname) diff --git a/Distribution/Server/Features/PackageCandidates/Types.hs b/Distribution/Server/Features/PackageCandidates/Types.hs --- a/Distribution/Server/Features/PackageCandidates/Types.hs +++ b/Distribution/Server/Features/PackageCandidates/Types.hs @@ -16,8 +16,6 @@ import Distribution.Package ( PackageIdentifier(..), Package(..) ) -import qualified Data.Serialize as Serialize -import Data.Serialize (Serialize) import Data.Typeable (Typeable) import Data.SafeCopy @@ -44,22 +42,6 @@ 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 diff --git a/Distribution/Server/Features/PackageContents.hs b/Distribution/Server/Features/PackageContents.hs --- a/Distribution/Server/Features/PackageContents.hs +++ b/Distribution/Server/Features/PackageContents.hs @@ -40,18 +40,14 @@ } 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 + -> IO (CoreFeature + -> TarIndexCacheFeature + -> IO PackageContentsFeature) +initPackageContentsFeature env@ServerEnv{} = do + return $ \core tarIndexCache -> do + let feature = packageContentsFeature env core tarIndexCache - loginfo verbosity "Initialising package-contents feature, end" - return feature + return feature packageContentsFeature :: ServerEnv -> CoreFeature @@ -100,8 +96,9 @@ case mChangeLog of Left err -> errNotFound "Changelog not found" [MText err] - Right (fp, etag, offset, name) -> - liftIO $ serveTarEntry fp offset name etag + Right (fp, etag, offset, name) -> do + cacheControl [Public, maxAgeDays 30] etag + liftIO $ serveTarEntry fp offset name -- return: not-found error or tarball serveContents :: DynamicPath -> ServerPartE Response @@ -112,13 +109,14 @@ Left err -> errNotFound "Could not serve package contents" [MText err] Right (fp, etag, index) -> - serveTarball ["index.html"] (display (packageId pkg)) fp index etag + serveTarball ["index.html"] (display (packageId pkg)) fp index + [Public, maxAgeDays 30] 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 + etag = BlobStorage.blobETag blobid index <- cachedPackageTarIndex pkgTarball return $ Right (fp, etag, index) packageTarball _ = @@ -127,5 +125,6 @@ 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) + (offset, fname) <- ErrorT $ return . maybe (Left "No changelog found") Right + $ findChangeLog pkgInfo index return (fp, etag, offset, fname) diff --git a/Distribution/Server/Features/PackageList.hs b/Distribution/Server/Features/PackageList.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/PackageList.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-} +module Distribution.Server.Features.PackageList ( + ListFeature(..), + initListFeature, + PackageItem(..), + tagHistogram + ) where + +import Distribution.Server.Framework + +import Distribution.Server.Features.Core +-- [reverse index disabled] import Distribution.Server.Features.ReverseDependencies +import Distribution.Server.Features.DownloadCount +import Distribution.Server.Features.Tags +import Distribution.Server.Features.PreferredVersions +import qualified Distribution.Server.Packages.PackageIndex as PackageIndex +import Distribution.Server.Util.CountingMap (cmFind) + +import Distribution.Server.Packages.Types +-- [reverse index disabled] import Distribution.Server.Packages.Reverse + +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration + +import Control.Concurrent +import Data.Maybe (catMaybes) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + + +data ListFeature = ListFeature { + listFeatureInterface :: HackageFeature, + + itemUpdate :: Hook (Set PackageName) (), + + constructItemIndex :: IO (Map PackageName PackageItem), + makeItemList :: [PackageName] -> IO [PackageItem], + makeItemMap :: forall a. Map PackageName a -> IO (Map PackageName (PackageItem, a)), + getAllLists :: IO (Map PackageName PackageItem) +} + +instance IsHackageFeature ListFeature where + getFeatureInterface = listFeatureInterface + + +data PackageItem = PackageItem { + -- The name of the package + itemName :: !PackageName, + -- The tags for this package + itemTags :: !(Set Tag), + -- If the package is deprecated, what is it deprecated in favor of + itemDeprecated :: !(Maybe [PackageName]), + -- The description of the package from its Cabal file + itemDesc :: !String, + -- Whether the item is in the Haskell Platform + --itemPlatform :: Bool, + -- The total number of downloads. (For sorting, not displaying.) + -- Updated periodically. + itemDownloads :: !Int, + -- The number of direct revdeps. (Likewise.) + -- also: distinguish direct/flat? + -- [reverse index disabled] itemRevDepsCount :: !Int, + -- Whether there's a library here. + itemHasLibrary :: !Bool, + -- How many executables (>=0) this package has. + itemNumExecutables :: !Int + -- Hotness: a more heuristic way to sort packages. presently non-existent. + --itemHotness :: Int +} + +instance MemSize PackageItem where + memSize (PackageItem a b c d e f g) = memSize7 a b c d e f g + + +emptyPackageItem :: PackageName -> PackageItem +emptyPackageItem pkg = PackageItem pkg Set.empty Nothing "" 0 + -- [reverse index disabled] 0 + False 0 + + +initListFeature :: ServerEnv + -> IO (CoreFeature + -- [reverse index disabled] -> ReverseFeature + -> DownloadFeature + -> TagsFeature + -> VersionsFeature + -> IO ListFeature) +initListFeature ServerEnv{ serverVerbosity = verbosity } = do + itemCache <- newMemStateWHNF Map.empty + itemUpdate <- newHook + + return $ \core@CoreFeature{..} + -- [reverse index disabled] revs + download + tagsf@TagsFeature{..} + versions@VersionsFeature{..} -> do + + let (feature, modifyItem, updateDesc) = + listFeature core download tagsf versions + itemCache itemUpdate + + registerHookJust packageChangeHook isPackageChangeAny $ \(pkgid, _) -> + updateDesc (packageName pkgid) + + {- [reverse index disabled] + registerHook (reverseUpdateHook revs) $ \mrev -> do + let pkgs = Map.keys mrev + forM_ pkgs $ \pkgname -> do + revCount <- query . GetReverseCount $ pkgname + modifyItem pkgname (updateReverseItem revCount) + runHook' itemUpdate $ Set.fromDistinctAscList pkgs + -} + registerHook tagsUpdated $ \(pkgs, _) -> do + forM_ (Set.toList pkgs) $ \pkgname -> do + tags <- queryTagsForPackage pkgname + modifyItem pkgname (updateTagItem tags) + runHook_ itemUpdate pkgs + registerHook deprecatedHook $ \(pkgname, mpkgs) -> do + modifyItem pkgname (updateDeprecation mpkgs) + runHook_ itemUpdate (Set.singleton pkgname) + + return feature + + +listFeature :: CoreFeature + -> DownloadFeature + -> TagsFeature + -> VersionsFeature + -> MemState (Map PackageName PackageItem) + -> Hook (Set PackageName) () + -> (ListFeature, + PackageName -> (PackageItem -> PackageItem) -> IO (), + PackageName -> IO ()) + +listFeature CoreFeature{..} + DownloadFeature{..} TagsFeature{..} VersionsFeature{..} + itemCache itemUpdate + = (ListFeature{..}, modifyItem, updateDesc) + where + listFeatureInterface = (emptyHackageFeature "list") { + featurePostInit = do itemsCache + void $ forkIO periodicDownloadRefresh + , featureState = [] + , featureCaches = [ + CacheComponent { + cacheDesc = "per-package-name summary info", + getCacheMemSize = memSize <$> readMemState itemCache + } + ] + } + where itemsCache = do + items <- constructItemIndex + writeMemState itemCache items + periodicDownloadRefresh = forever $ do + --FIXME: don't do this if nothing has changed! + threadDelay (30 * 60 * 1000000) -- 30 minutes + refreshDownloads + + modifyItem pkgname token = do + hasItem <- fmap (Map.member pkgname) $ readMemState itemCache + case hasItem of + True -> modifyMemState itemCache $ Map.adjust token pkgname + False -> do + index <- queryGetPackageIndex + let pkgs = PackageIndex.lookupPackageName index pkgname + case pkgs of + [] -> return () --this shouldn't happen + _ -> modifyMemState itemCache . uncurry Map.insert =<< constructItem (last pkgs) + updateDesc pkgname = do + index <- queryGetPackageIndex + let pkgs = PackageIndex.lookupPackageName index pkgname + case pkgs of + [] -> modifyMemState itemCache (Map.delete pkgname) + _ -> modifyItem pkgname (updateDescriptionItem $ pkgDesc $ last pkgs) + runHook_ itemUpdate (Set.singleton pkgname) + + refreshDownloads = do + downs <- recentPackageDownloads + modifyMemState itemCache $ Map.mapWithKey $ \pkg item -> + updateDownload (cmFind pkg downs) item + -- Say all packages were updated here (detecting this is more laborious) + mainMap <- readMemState itemCache + runHook_ itemUpdate (Set.fromDistinctAscList $ Map.keys mainMap) + + constructItemIndex :: IO (Map PackageName PackageItem) + constructItemIndex = do + index <- queryGetPackageIndex + items <- mapM (constructItem . last) $ PackageIndex.allPackagesByName index + return $ Map.fromList items + + constructItem :: PkgInfo -> IO (PackageName, PackageItem) + constructItem pkg = do + let pkgname = packageName pkg + -- [reverse index disabled] revCount <- query . GetReverseCount $ pkgname + tags <- queryTagsForPackage pkgname + downs <- recentPackageDownloads + deprs <- queryGetDeprecatedFor pkgname + return $ (,) pkgname $ (updateDescriptionItem (pkgDesc pkg) $ emptyPackageItem pkgname) { + itemTags = tags + , itemDeprecated = deprs + , itemDownloads = cmFind pkgname downs + -- [reverse index disabled] , itemRevDepsCount = directReverseCount revCount + } + + ------------------------------ + makeItemList :: [PackageName] -> IO [PackageItem] + makeItemList pkgnames = do + mainMap <- readMemState itemCache + return $ catMaybes $ map (flip Map.lookup mainMap) pkgnames + + makeItemMap :: Map PackageName a -> IO (Map PackageName (PackageItem, a)) + makeItemMap pkgmap = do + mainMap <- readMemState itemCache + return $ Map.intersectionWith (,) mainMap pkgmap + + getAllLists :: IO (Map PackageName PackageItem) + getAllLists = readMemState itemCache + +tagHistogram :: [PackageItem] -> Map Tag Int +tagHistogram = Map.fromListWith (+) . map (flip (,) 1) . concatMap (Set.toList . itemTags) + +updateDescriptionItem :: GenericPackageDescription -> PackageItem -> PackageItem +updateDescriptionItem genDesc item = + let desc = flattenPackageDescription genDesc + in item { + itemDesc = synopsis desc, + -- This checks if the library is buildable. However, since + -- desc is flattened, we might miss some flags. Perhaps use the + -- CondTree instead. + itemHasLibrary = hasLibs desc, + itemNumExecutables = length . filter (buildable . buildInfo) $ executables desc + } + +updateTagItem :: Set Tag -> PackageItem -> PackageItem +updateTagItem tags item = + item { + itemTags = tags + } + +updateDeprecation :: Maybe [PackageName] -> PackageItem -> PackageItem +updateDeprecation pkgs item = + item { + itemDeprecated = pkgs + } + +{- [reverse index disabled] +updateReverseItem :: ReverseCount -> PackageItem -> PackageItem +updateReverseItem revCount item = + item { + itemRevDepsCount = directReverseCount revCount + } +-} + +updateDownload :: Int -> PackageItem -> PackageItem +updateDownload count item = + item { + itemDownloads = count + } diff --git a/Distribution/Server/Features/PreferredVersions.hs b/Distribution/Server/Features/PreferredVersions.hs --- a/Distribution/Server/Features/PreferredVersions.hs +++ b/Distribution/Server/Features/PreferredVersions.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, PatternGuards, OverloadedStrings #-} +{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, + PatternGuards, OverloadedStrings #-} module Distribution.Server.Features.PreferredVersions ( VersionsFeature(..), VersionsResource(..), @@ -88,18 +89,21 @@ } 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" +initVersionsFeature :: ServerEnv + -> IO (CoreFeature + -> UploadFeature + -> TagsFeature + -> IO VersionsFeature) +initVersionsFeature ServerEnv{serverStateDir} = do preferredState <- preferredStateComponent serverStateDir preferredHook <- newHook deprecatedHook <- newHook - let feature = versionsFeature core upload tags - preferredState preferredHook deprecatedHook - loginfo verbosity "Initialising versions feature, end" - return feature + return $ \core upload tags -> do + let feature = versionsFeature core upload tags + preferredState preferredHook deprecatedHook + return feature + preferredStateComponent :: FilePath -> IO (StateComponent AcidState PreferredVersions) preferredStateComponent stateDir = do st <- openLocalStateFrom (stateDir "db" "PreferredVersions") initialPreferredVersions @@ -109,7 +113,7 @@ , getState = query st GetPreferredVersions , putState = update st . ReplacePreferredVersions , resetState = preferredStateComponent - , backupState = backupPreferredVersions + , backupState = \_ -> backupPreferredVersions , restoreState = restorePreferredVersions } @@ -120,7 +124,8 @@ -> Hook (PackageName, PreferredInfo) () -> Hook (PackageName, Maybe [PackageName]) () -> VersionsFeature - +-- FIXME this packageInPath punning and shadowing makes +-- things harder to understand and modify later versionsFeature CoreFeature{ coreResource=CoreResource{ packageInPath , guardValidPackageName , lookupPackageName @@ -137,7 +142,7 @@ where versionsFeatureInterface = (emptyHackageFeature "versions") { featureResources = - map ($versionsResource) [ + map ($ versionsResource) [ preferredResource , preferredPackageResource , deprecatedResource @@ -190,6 +195,7 @@ textPreferred = fmap toResponse makePreferredVersions + handlePackagesDeprecatedGet :: DynamicPath -> ServerPartE Response handlePackagesDeprecatedGet _ = do deprPkgs <- deprecatedMap <$> queryState preferredState GetPreferredVersions return $ toResponse $ array @@ -200,6 +206,7 @@ ] | (deprPkg, replacementPkgs) <- Map.toList deprPkgs ] + handlePackageDeprecatedGet :: DynamicPath -> ServerPartE Response handlePackageDeprecatedGet dpath = do pkgname <- packageInPath dpath guardValidPackageName pkgname @@ -211,6 +218,7 @@ | pkg <- fromMaybe [] mdep ]) ] + handlePackageDeprecatedPut :: DynamicPath -> ServerPartE Response handlePackageDeprecatedPut dpath = do pkgname <- packageInPath dpath guardValidPackageName pkgname @@ -218,11 +226,16 @@ jv <- expectAesonContent case jv of Object o + -- FIXME should just be a nested case + -- or something more human friendly | fields <- HashMap.toList o , Just (Bool deprecated) <- lookup "is-deprecated" fields , Just (Array strs) <- lookup "in-favour-of" fields + -- FIXME Audit this parsing -> PackageName code, suspiciously + -- reliant on MonomorphismRestriction to resolve ambiguity , let asPackage (String s) = simpleParse (Text.unpack s) asPackage _ = Nothing + mpkgs :: [Maybe PackageName] mpkgs = map asPackage (Vector.toList strs) , all isJust mpkgs -> do let deprecatedInfo | deprecated = Just (catMaybes mpkgs) diff --git a/Distribution/Server/Features/RecentPackages.hs b/Distribution/Server/Features/RecentPackages.hs --- a/Distribution/Server/Features/RecentPackages.hs +++ b/Distribution/Server/Features/RecentPackages.hs @@ -43,35 +43,31 @@ } 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" + -> IO (UserFeature + -> CoreFeature + -> PackageContentsFeature + -> IO RecentPackagesFeature) +initRecentPackagesFeature env@ServerEnv{serverCacheDelay, serverVerbosity = verbosity} = do + return $ \user core@CoreFeature{packageChangeHook} packageContents -> do - -- 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 + -- 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 - } + cacheRecent <- newAsyncCacheNF updateRecentCache + defaultAsyncCachePolicy { + asyncCacheName = "recent uploads (html,rss)", + asyncCacheUpdateDelay = serverCacheDelay, + asyncCacheSyncInit = False, + asyncCacheLogVerbosity = verbosity + } - registerHookJust packageChangeHook isPackageChangeAny $ \_ -> - prodAsyncCache cacheRecent + registerHookJust packageChangeHook isPackageChangeAny $ \_ -> + prodAsyncCache cacheRecent - loginfo verbosity "Initialising recentPackages feature, end" - return feature + return feature recentPackagesFeature :: ServerEnv @@ -89,7 +85,7 @@ = (RecentPackagesFeature{..}, updateRecentCache) where recentPackagesFeatureInterface = (emptyHackageFeature "recentPackages") { - featureResources = map ($recentPackagesResource) [recentPackages] + featureResources = map ($ recentPackagesResource) [recentPackages] , featureState = [] , featureCaches = [ CacheComponent { @@ -101,7 +97,7 @@ } recentPackagesResource = RecentPackagesResource { - recentPackages = (resourceAt "/recent.:format") { + recentPackages = (extendResourcePath "/recent.:format" (corePackagesPage coreResource)) { resourceGet = [ ("html", const $ liftM fst $ readAsyncCache cacheRecent) , ("rss", const $ liftM snd $ readAsyncCache cacheRecent) diff --git a/Distribution/Server/Features/Search.hs b/Distribution/Server/Features/Search.hs --- a/Distribution/Server/Features/Search.hs +++ b/Distribution/Server/Features/Search.hs @@ -2,15 +2,24 @@ module Distribution.Server.Features.Search ( SearchFeature(..), initSearchFeature, + + -- * Search parameters + defaultSearchRankParameters, + SearchEngine.SearchRankParameters(..), + PkgDocField, PkgDocFeatures, + BM25F.Explanation(..), ) where import Distribution.Server.Framework import Distribution.Server.Framework.Templating import Distribution.Server.Features.Core +import Distribution.Server.Features.PackageList import Distribution.Server.Features.Search.PkgSearch +import Distribution.Server.Features.Search.SearchEngine (SearchRankParameters(..)) import qualified Distribution.Server.Features.Search.SearchEngine as SearchEngine +import qualified Distribution.Server.Features.Search.BM25F as BM25F import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Packages.Types @@ -19,6 +28,7 @@ import Distribution.PackageDescription.Configuration (flattenPackageDescription) import qualified Data.Text as T +import qualified Data.Map as Map data SearchFeature = SearchFeature { @@ -26,38 +36,44 @@ searchPackagesResource :: Resource, - searchPackages :: MonadIO m => [String] -> m [PackageName] + searchPackages :: MonadIO m => [String] -> m [PackageName], + searchPackagesExplain :: MonadIO m + => SearchRankParameters PkgDocField PkgDocFeatures + -> [String] + -> m [(BM25F.Explanation PkgDocField PkgDocFeatures T.Text + ,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" - +initSearchFeature :: ServerEnv + -> IO (CoreFeature + -> ListFeature + -> IO SearchFeature) +initSearchFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode} = do templates <- loadTemplates serverTemplatesMode [serverTemplatesDir, serverTemplatesDir "Search"] [ "opensearch.xml"] searchEngineState <- newMemStateWHNF initialPkgSearchEngine - let feature = searchFeature env core - searchEngineState templates + return $ \core@CoreFeature{..} list -> do + let feature = searchFeature env core list + searchEngineState templates - loginfo verbosity "Initialising search feature, end" - return feature + return feature searchFeature :: ServerEnv -> CoreFeature + -> ListFeature -> MemState PkgSearchEngine -> Templates -> SearchFeature -searchFeature ServerEnv{serverBaseURI} CoreFeature{..} +searchFeature ServerEnv{serverBaseURI} CoreFeature{..} ListFeature{getAllLists} searchEngineState templates = SearchFeature{..} where @@ -75,6 +91,7 @@ } ] , featurePostInit = postInit + , featureReloadFiles = reloadTemplates templates } searchOpenSearchResource = (resourceAt "/packages/opensearch.xml") { @@ -95,15 +112,19 @@ getSearchDoc = flattenPackageDescription . pkgDesc postInit = do - pkgindex <- queryGetPackageIndex - let pkgs = map (getSearchDoc . last) - . PackageIndex.allPackagesByName $ pkgindex + pkgindex <- queryGetPackageIndex + pkgdownloads <- getDownloadCounts + let pkgs = [ (getSearchDoc pkgLatestVer, pkgdownloads pkgname) + | pkgVers <- PackageIndex.allPackagesByName pkgindex + , let pkgLatestVer = last pkgVers + pkgname = packageName pkgLatestVer ] se = SearchEngine.insertDocs pkgs initialPkgSearchEngine writeMemState searchEngineState se registerHookJust packageChangeHook isPackageChangeAny $ \(pkgid, _) -> updatePackage (packageName pkgid) + --TODO: update periodically for download count changes updatePackage :: PackageName -> IO () updatePackage pkgname = do index <- queryGetPackageIndex @@ -111,14 +132,36 @@ case reverse pkgs of [] -> modifyMemState searchEngineState (SearchEngine.deleteDoc pkgname) - (pkg:_) -> modifyMemState searchEngineState - (SearchEngine.insertDoc (getSearchDoc pkg)) + (pkg:_) -> do downloads <- getDownloadCount pkgname + modifyMemState searchEngineState + (SearchEngine.insertDoc (getSearchDoc pkg, downloads)) + getDownloadCount :: PackageName -> IO Int + getDownloadCount pkgname = do + pkginfomap <- getAllLists + return $ maybe 0 itemDownloads (Map.lookup pkgname pkginfomap) + + getDownloadCounts :: IO (PackageName -> Int) + getDownloadCounts = do + pkginfomap <- getAllLists + return (\pkgname -> maybe 0 itemDownloads (Map.lookup pkgname pkginfomap)) + -- 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 + + searchPackagesExplain :: MonadIO m + => SearchRankParameters PkgDocField PkgDocFeatures + -> [String] + -> m [(BM25F.Explanation PkgDocField PkgDocFeatures T.Text, PackageName)] + searchPackagesExplain params terms = do + se <- readMemState searchEngineState + let results = SearchEngine.queryExplain + (SearchEngine.setRankParams params se) + (map T.pack terms) return results handlerGetOpenSearch :: DynamicPath -> ServerPartE Response diff --git a/Distribution/Server/Features/Search/BM25F.hs b/Distribution/Server/Features/Search/BM25F.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/Search/BM25F.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | See: +-- +-- * \"The Probabilistic Relevance Framework: BM25 and Beyond\" +-- +-- +-- * \"An Introduction to Information Retrieval\" +-- +-- +module Distribution.Server.Features.Search.BM25F ( + Context(..), + FeatureFunction(..), + Doc(..), + score, + + Explanation(..), + explain, + ) where + +import Data.Ix + +data Context term field feature = Context { + numDocsTotal :: !Int, + avgFieldLength :: field -> Float, + numDocsWithTerm :: term -> Int, + paramK1 :: !Float, + paramB :: field -> Float, + -- consider minimum length to prevent massive B bonus? + fieldWeight :: field -> Float, + featureWeight :: feature -> Float, + featureFunction :: feature -> FeatureFunction + } + +data Doc term field feature = Doc { + docFieldLength :: field -> Int, + docFieldTermFrequency :: field -> term -> Int, + docFeatureValue :: feature -> Float + } + + +-- | The BM25F score for a document for a given set of terms. +-- +score :: (Ix field, Bounded field, Ix feature, Bounded feature) => + Context term field feature -> + Doc term field feature -> [term] -> Float +score ctx doc terms = + sum (map (weightedTermScore ctx doc) terms) + + sum (map (weightedNonTermScore ctx doc) features) + + where + features = range (minBound, maxBound) + + +weightedTermScore :: (Ix field, Bounded field) => + Context term field feature -> + Doc term field feature -> term -> Float +weightedTermScore ctx doc t = + weightIDF ctx t * tf' + / (k1 + tf') + where + tf' = weightedDocTermFrequency ctx doc t + k1 = paramK1 ctx + + +weightIDF :: Context term field feature -> term -> Float +weightIDF ctx t = + log ((n - n_t + 0.5) / (n_t + 0.5)) + where + n = fromIntegral (numDocsTotal ctx) + n_t = fromIntegral (numDocsWithTerm ctx t) + + +weightedDocTermFrequency :: (Ix field, Bounded field) => + Context term field feature -> + Doc term field feature -> term -> Float +weightedDocTermFrequency ctx doc t = + sum [ w_f * tf_f / _B_f + | field <- range (minBound, maxBound) + , let w_f = fieldWeight ctx field + tf_f = fromIntegral (docFieldTermFrequency doc field t) + _B_f = lengthNorm ctx doc field + ] + + +lengthNorm :: Context term field feature -> + Doc term field feature -> field -> Float +lengthNorm ctx doc field = + (1-b_f) + b_f * sl_f / avgsl_f + where + b_f = paramB ctx field + sl_f = fromIntegral (docFieldLength doc field) + avgsl_f = avgFieldLength ctx field + + +weightedNonTermScore :: (Ix feature, Bounded feature) => + Context term field feature -> + Doc term field feature -> feature -> Float +weightedNonTermScore ctx doc feature = + w_f * _V_f f_f + where + w_f = featureWeight ctx feature + _V_f = applyFeatureFunction (featureFunction ctx feature) + f_f = docFeatureValue doc feature + + +data FeatureFunction + = LogarithmicFunction Float -- ^ @log (\lambda_i + f_i)@ + | RationalFunction Float -- ^ @f_i / (\lambda_i + f_i)@ + | SigmoidFunction Float Float -- ^ @1 / (\lambda + exp(-(\lambda' * f_i))@ + +applyFeatureFunction :: FeatureFunction -> (Float -> Float) +applyFeatureFunction (LogarithmicFunction p1) = \fi -> log (p1 + fi) +applyFeatureFunction (RationalFunction p1) = \fi -> fi / (p1 + fi) +applyFeatureFunction (SigmoidFunction p1 p2) = \fi -> 1 / (p1 + exp (-fi * p2)) + + +------------------ +-- Explanation +-- + +-- | A breakdown of the BM25F score, to explain somewhat how it relates to +-- the inputs, and so you can compare the scores of different documents. +-- +data Explanation field feature term = Explanation { + -- | The overall score is the sum of the 'termScores', 'positionScore' + -- and 'nonTermScore' + overallScore :: Float, + + -- | There is a score contribution from each query term. This is the + -- score for the term across all fields in the document (but see + -- 'termFieldScores'). + termScores :: [(term, Float)], +{- + -- | There is a score contribution for positional information. Terms + -- appearing in the document close together give a bonus. + positionScore :: [(field, Float)], +-} + -- | The document can have an inate bonus score independent of the terms + -- in the query. For example this might be a popularity score. + nonTermScores :: [(feature, Float)], + + -- | This does /not/ contribute to the 'overallScore'. It is an + -- indication of how the 'termScores' relates to per-field scores. + -- Note however that the term score for all fields is /not/ simply + -- sum of the per-field scores. The point of the BM25F scoring function + -- is that a linear combination of per-field scores is wrong, and BM25F + -- does a more cunning non-linear combination. + -- + -- However, it is still useful as an indication to see scores for each + -- field for a term, to see how the compare. + -- + termFieldScores :: [(term, [(field, Float)])] + } + deriving Show + +instance Functor (Explanation field feature) where + fmap f e@Explanation{..} = + e { + termScores = [ (f t, s) | (t, s) <- termScores ], + termFieldScores = [ (f t, fs) | (t, fs) <- termFieldScores ] + } + +explain :: (Ix field, Bounded field, Ix feature, Bounded feature) => + Context term field feature -> + Doc term field feature -> [term] -> Explanation field feature term +explain ctx doc ts = + Explanation {..} + where + overallScore = sum (map snd termScores) +-- + sum (map snd positionScore) + + sum (map snd nonTermScores) + termScores = [ (t, weightedTermScore ctx doc t) | t <- ts ] +-- positionScore = [ (f, 0) | f <- range (minBound, maxBound) ] + nonTermScores = [ (feature, weightedNonTermScore ctx doc feature) + | feature <- range (minBound, maxBound) ] + + termFieldScores = + [ (t, fieldScores) + | t <- ts + , let fieldScores = + [ (f, weightedTermScore ctx' doc t) + | f <- range (minBound, maxBound) + , let ctx' = ctx { fieldWeight = fieldWeightOnly f } + ] + ] + fieldWeightOnly f f' | sameField f f' = fieldWeight ctx f' + | otherwise = 0 + + sameField f f' = index (minBound, maxBound) f + == index (minBound, maxBound) f' diff --git a/Distribution/Server/Features/Search/DocFeatVals.hs b/Distribution/Server/Features/Search/DocFeatVals.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/Search/DocFeatVals.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-} +module Distribution.Server.Features.Search.DocFeatVals ( + DocFeatVals, + featureValue, + create, + ) where + +import Distribution.Server.Features.Search.DocTermIds (vecIndexIx, vecCreateIx) +import Distribution.Server.Framework.MemSize +import Data.Vector (Vector) +import Data.Ix (Ix) + + +-- | Storage for the non-term feature values i a document. +-- +newtype DocFeatVals feature = DocFeatVals (Vector Float) + deriving (Show, MemSize) + +featureValue :: (Ix feature, Bounded feature) => DocFeatVals feature -> feature -> Float +featureValue (DocFeatVals featVec) = vecIndexIx featVec + +create :: (Ix feature, Bounded feature) => + (feature -> Float) -> DocFeatVals feature +create docFeatVals = + DocFeatVals (vecCreateIx docFeatVals) + diff --git a/Distribution/Server/Features/Search/DocIdSet.hs b/Distribution/Server/Features/Search/DocIdSet.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/Search/DocIdSet.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses #-} + +module Distribution.Server.Features.Search.DocIdSet ( + DocId, + DocIdSet, + null, + size, + empty, + singleton, + fromList, + toList, + toSet, + insert, + delete, + union, + invariant, + ) where + +import Distribution.Server.Framework.MemSize + +import Data.Word +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as MVU +import qualified Data.Vector.Generic.Base as VG +import qualified Data.Vector.Generic.Mutable as MVG +import Control.Monad (liftM) +import Control.Monad.ST +import Data.Set (Set) +import qualified Data.Set as Set + +import Prelude hiding (null) + +--import Test.QuickCheck +--import qualified Data.List as List + +newtype DocId = DocId Word32 + deriving (Eq, Ord, Show, Enum, Bounded, MemSize, VU.Unbox) + +newtype DocIdSet = DocIdSet (VU.Vector DocId) + deriving (Eq, Show) + + +newtype instance MVU.MVector s DocId = MVU_DocId (MVU.MVector s Word32) +newtype instance VU.Vector DocId = VU_DocId (VU.Vector Word32) + +instance VG.Vector VU.Vector DocId where +-- fixme, can i do a noop/coerce/unsafecoerce instead of these fmaps on newtypes? +-- or does it even matter? + basicUnsafeFreeze (MVU_DocId mvw)= VU_DocId `liftM` VG.basicUnsafeFreeze mvw + basicUnsafeThaw (VU_DocId vw) = MVU_DocId `liftM` VG.basicUnsafeThaw vw + basicLength (VU_DocId vw) = VG.basicLength vw + basicUnsafeSlice start end (VU_DocId vw) = VU_DocId $ VG.basicUnsafeSlice start end vw + basicUnsafeIndexM (VU_DocId vw) ix = DocId `liftM` VG.basicUnsafeIndexM vw ix + + -- basicLength, basicUnsafeSlice, basicOverlaps, basicUnsafeNew, basicUnsafeRead, basicUnsafeWrite +instance MVG.MVector MVU.MVector DocId where + basicLength (MVU_DocId vw) = MVG.basicLength vw + basicUnsafeSlice start end (MVU_DocId vw) = MVU_DocId $ MVG.basicUnsafeSlice start end vw + basicOverlaps (MVU_DocId vw1) (MVU_DocId vw2) = MVG.basicOverlaps vw1 vw2 + basicUnsafeNew size = MVU_DocId `liftM` MVG.basicUnsafeNew size + basicUnsafeRead (MVU_DocId vw) ix = DocId `liftM` MVG.basicUnsafeRead vw ix + basicUnsafeWrite (MVU_DocId vw) ix (DocId word) = MVG.basicUnsafeWrite vw ix word + +-- represented as a sorted sequence of ids +invariant :: DocIdSet -> Bool +invariant (DocIdSet vec) = + strictlyAscending (VU.toList vec) + where + strictlyAscending (a:xs@(b:_)) = a < b && strictlyAscending xs + strictlyAscending _ = True + + +size :: DocIdSet -> Int +size (DocIdSet vec) = VU.length vec + +null :: DocIdSet -> Bool +null (DocIdSet vec) = VU.null vec + +empty :: DocIdSet +empty = DocIdSet VU.empty + +singleton :: DocId -> DocIdSet +singleton = DocIdSet . VU.singleton + +fromList :: [DocId] -> DocIdSet +fromList = DocIdSet . VU.fromList . Set.toAscList . Set.fromList + +toList :: DocIdSet -> [DocId] +toList (DocIdSet vec) = VU.toList vec + +toSet :: DocIdSet -> Set DocId +toSet (DocIdSet vec) = Set.fromDistinctAscList (VU.toList vec) + +insert :: DocId -> DocIdSet -> DocIdSet +insert x (DocIdSet vec) = + case binarySearch vec 0 (VU.length vec - 1) x of + (_, True) -> DocIdSet vec + (i, False) -> case VU.splitAt i vec of + (before, after) -> + DocIdSet (VU.concat [before, VU.singleton x, after]) + +delete :: DocId -> DocIdSet -> DocIdSet +delete x (DocIdSet vec) = + case binarySearch vec 0 (VU.length vec - 1) x of + (_, False) -> DocIdSet vec + (i, True) -> case VU.splitAt i vec of + (before, after) -> + DocIdSet (before VU.++ VU.tail after) + +binarySearch :: VU.Vector DocId -> Int -> Int -> DocId -> (Int, Bool) +binarySearch vec !a !b !key + | a > b = (a, False) + | otherwise = + let mid = (a + b) `div` 2 + in case compare key (vec VU.! mid) of + LT -> binarySearch vec a (mid-1) key + EQ -> (mid, True) + GT -> binarySearch vec (mid+1) b key + +union :: DocIdSet -> DocIdSet -> DocIdSet +union x y | null x = y + | null y = x +union (DocIdSet xs) (DocIdSet ys) = + DocIdSet (VU.create (MVU.new sizeBound >>= writeMerged xs ys)) + where + sizeBound = VU.length xs + VU.length ys + +writeMerged :: VU.Vector DocId -> VU.Vector DocId -> + MVU.MVector s DocId -> ST s (MVU.MVector s DocId) +writeMerged xs0 ys0 out = do + i <- go xs0 ys0 0 + return $! MVU.take i out + where + go !xs !ys !i + | VU.null xs = do VU.copy (MVU.slice i (VU.length ys) out) ys; + return (i + VU.length ys) + | VU.null ys = do VU.copy (MVU.slice i (VU.length xs) out) xs; + return (i + VU.length xs) + | otherwise = let x = VU.head xs; y = VU.head ys + in case compare x y of + GT -> do MVU.write out i y + go xs (VU.tail ys) (i+1) + EQ -> do MVU.write out i x + go (VU.tail xs) (VU.tail ys) (i+1) + LT -> do MVU.write out i x + go (VU.tail xs) ys (i+1) + +instance MemSize DocIdSet where + memSize (DocIdSet vec) = memSizeUVector 2 vec + + +------------- +-- tests +-- +{- +instance Arbitrary DocIdSet where + arbitrary = fromList `fmap` (listOf arbitrary) + +instance Arbitrary DocId where + arbitrary = DocId `fmap` choose (0,15) + + +prop_insert :: DocIdSet -> DocId -> Bool +prop_insert dset x = + let dset' = insert x dset + in invariant dset && invariant dset' + && all (`member` dset') (x : toList dset) + +prop_delete :: DocIdSet -> DocId -> Bool +prop_delete dset x = + let dset' = DocIdSet.delete x dset + in invariant dset && invariant dset' + && all (`member` dset') (List.delete x (toList dset)) + && not (x `member` dset') + +prop_delete' :: DocIdSet -> Bool +prop_delete' dset = + all (prop_delete dset) (toList dset) + +prop_union :: DocIdSet -> DocIdSet -> Bool +prop_union dset1 dset2 = + let dset = union dset1 dset2 + dset' = fromList (List.union (toList dset1) (toList dset2)) + + in invariant dset && invariant dset' + && dset == dset' + +prop_union' :: DocIdSet -> DocIdSet -> Bool +prop_union' dset1 dset2 = + let dset = union dset1 dset2 + dset' = List.foldl' (\s i -> insert i s) dset1 (toList dset2) + dset'' = List.foldl' (\s i -> insert i s) dset2 (toList dset1) + in invariant dset && invariant dset' && invariant dset'' + && dset == dset' + && dset' == dset'' + +member :: DocId -> DocIdSet -> Bool +member x (DocIdSet vec) = + x `List.elem` VU.toList vec +-} diff --git a/Distribution/Server/Features/Search/DocTermIds.hs b/Distribution/Server/Features/Search/DocTermIds.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/Search/DocTermIds.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} +module Distribution.Server.Features.Search.DocTermIds ( + DocTermIds, + TermId, + fieldLength, + fieldTermCount, + fieldElems, + create, + vecIndexIx, + vecCreateIx, + ) where + +import Distribution.Server.Features.Search.TermBag (TermBag, TermId) +import qualified Distribution.Server.Features.Search.TermBag as TermBag + +import Distribution.Server.Framework.MemSize + +import Data.Vector (Vector, (!)) +import qualified Data.Vector as Vec +import Data.Ix (Ix) +import qualified Data.Ix as Ix + + +-- | The 'TermId's for the 'Term's that occur in a document. Documents may have +-- multiple fields and the 'DocTerms' type holds them separately for each field. +-- +newtype DocTermIds field = DocTermIds (Vector TermBag) + deriving (Show, MemSize) + +getField :: (Ix field, Bounded field) => DocTermIds field -> field -> TermBag +getField (DocTermIds fieldVec) = vecIndexIx fieldVec + +create :: (Ix field, Bounded field) => + (field -> [TermId]) -> DocTermIds field +create docTermIds = + DocTermIds (vecCreateIx (TermBag.fromList . docTermIds)) + +-- | The number of terms in a field within the document. +fieldLength :: (Ix field, Bounded field) => DocTermIds field -> field -> Int +fieldLength docterms field = + TermBag.size (getField docterms field) + +-- | The frequency of a particular term in a field within the document. +fieldTermCount :: (Ix field, Bounded field) => DocTermIds field -> field -> TermId -> Int +fieldTermCount docterms field termid = + TermBag.termCount (getField docterms field) termid + +fieldElems :: (Ix field, Bounded field) => DocTermIds field -> field -> [TermId] +fieldElems docterms field = + TermBag.elems (getField docterms field) + +--------------------------------- +-- Vector indexed by Ix Bounded +-- + +vecIndexIx :: forall ix a . (Ix ix, Bounded ix) => Vector a -> ix -> a +vecIndexIx vec ix = vec ! Ix.index (minBound :: ix, maxBound :: ix) ix + +vecCreateIx :: forall ix a . (Ix ix, Bounded ix) => (ix -> a) -> Vector a +vecCreateIx f = Vec.fromListN (Ix.rangeSize bounds) + [ y | ix <- Ix.range bounds, let !y = f ix ] + where + bounds :: (ix, ix) + bounds = (minBound, maxBound) diff --git a/Distribution/Server/Features/Search/ExtractDescriptionTerms.hs b/Distribution/Server/Features/Search/ExtractDescriptionTerms.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/Search/ExtractDescriptionTerms.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE BangPatterns, NamedFieldPuns, GeneralizedNewtypeDeriving #-} + +module Distribution.Server.Features.Search.ExtractDescriptionTerms ( + extractSynopsisTerms, + extractDescriptionTerms + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Char +import qualified NLP.Tokenize as NLP +import qualified NLP.Snowball as NLP +import Control.Monad ((>=>)) +import Data.Maybe + +import Distribution.Server.Pages.Package.HaddockHtml as Haddock (markup) +import Distribution.Server.Pages.Package.HaddockTypes as Haddock +import qualified Distribution.Server.Pages.Package.HaddockParse as Haddock (parseHaddockParagraphs) +import qualified Distribution.Server.Pages.Package.HaddockLex as Haddock (tokenise) + + +extractSynopsisTerms :: Set Text -> String -> [Text] +extractSynopsisTerms stopWords = + NLP.stems NLP.English + . filter (`Set.notMember` stopWords) + . map (T.toCaseFold . T.pack) + . concatMap splitTok + . filter (not . ignoreTok) + . NLP.tokenize + + +ignoreTok :: String -> Bool +ignoreTok = all isPunctuation + +splitTok :: String -> [String] +splitTok tok = + case go tok of + toks@(_:_:_) -> tok:toks + toks -> toks + where + go remaining = + case break (\c -> c == ')' || c == '-' || c == '/') remaining of + ([], _:trailing) -> go trailing + (leading, _:trailing) -> leading : go trailing + ([], []) -> [] + (leading, []) -> leading : [] + + +extractDescriptionTerms :: Set Text -> String -> [Text] +extractDescriptionTerms stopWords = + NLP.stems NLP.English + . filter (`Set.notMember` stopWords) + . map (T.toCaseFold . T.pack) + . maybe + [] --TODO: something here + ( filter (not . ignoreTok) + . NLP.tokenize + . concat . markup termsMarkup) + . (Haddock.tokenise >=> Haddock.parseHaddockParagraphs) + +termsMarkup :: DocMarkup String [String] +termsMarkup = Markup { + markupEmpty = [], + markupString = \s -> [s], + markupParagraph = id, + markupAppend = (++), + markupIdentifier = \s -> [s], + markupModule = const [], -- i.e. filter these out + markupEmphasis = id, + markupMonospaced = \s -> if length s > 1 then [] else s, + markupUnorderedList = concat, + markupOrderedList = concat, + markupDefList = concatMap (\(d,t) -> d ++ t), + markupCodeBlock = const [], + markupHyperlink = \(Hyperlink _url mLabel) -> maybeToList mLabel, + --TODO: extract main part of hostname + markupPic = const [], + markupAName = const [] + } + +{- +------------------- +-- Main experiment +-- + +main = do + pkgsFile <- readFile "pkgs" + let mostFreq :: [String] + pkgs :: [PackageDescription] + (mostFreq, pkgs) = read pkgsFile + + stopWordsFile <- T.readFile "stopwords.txt" +-- wordsFile <- T.readFile "/usr/share/dict/words" +-- let ws = Set.fromList (map T.toLower $ T.lines wordsFile) + + + print "reading file" + evaluate (length mostFreq + length pkgs) + print "done" + + let stopWords = Set.fromList $ T.lines stopWordsFile + print stopWords + + sequence_ + [ putStrLn $ display (packageName pkg) ++ ": " + ++ --intercalate ", " + (description pkg) ++ "\n" + ++ intercalate ", " + (map T.unpack $ extractDescriptionTerms stopWords (description pkg)) ++ "\n" + | pkg <- pkgs + , let pkgname = display (packageName pkg) ] +-} diff --git a/Distribution/Server/Features/Search/ExtractNameTerms.hs b/Distribution/Server/Features/Search/ExtractNameTerms.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/Search/ExtractNameTerms.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE BangPatterns, NamedFieldPuns, GeneralizedNewtypeDeriving #-} + +module Distribution.Server.Features.Search.ExtractNameTerms ( + extractPackageNameTerms, + extractModuleNameTerms, + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Char (isUpper, isDigit) +import Data.List +import Data.List.Split hiding (Splitter) +import Data.Maybe (maybeToList) + +import Data.Functor.Identity +import Control.Monad +import Control.Monad.List +import Control.Monad.Writer +import Control.Monad.State + + +extractModuleNameTerms :: String -> [Text] +extractModuleNameTerms modname = + map T.toCaseFold $ + nub $ + map T.pack $ + flip runSplitter modname $ do + _ <- forEachPart splitDot + _ <- forEachPart splitCamlCase + satisfy (not . singleChar) + get >>= emit + +extractPackageNameTerms :: String -> [Text] +extractPackageNameTerms pkgname = + map T.toCaseFold $ + nub $ + map T.pack $ + flip runSplitter pkgname $ do + + fstComponentHyphen <- forEachPart splitHyphen + + satisfy (`notElem` ["hs", "haskell"]) + + _ <- forEachPart stripPrefixH + + fstComponentCaml <- forEachPart splitCamlCase + + fstComponent2 <- forEachPart splitOn2 + + when (fstComponentHyphen && fstComponentCaml && fstComponent2) $ do + forEachPartAndWhole stripPrefix_h + _ <- forEachPart (maybeToList . stripPrefix "lib") + _ <- forEachPart (maybeToList . stripSuffix "lib") + _ <- forEachPart stripSuffixNum + satisfy (not . singleChar) + + get >>= emit + +newtype Split a = Split (StateT String (ListT (WriterT [String] Identity)) a) + deriving (Monad, MonadPlus, MonadState String) + +emit :: String -> Split () +emit x = Split (lift (lift (tell [x]))) + +forEach :: [a] -> Split a +forEach = msum . map return + +runSplitter :: Split () -> String -> [String] +runSplitter (Split m) s = snd (runWriter (runListT (runStateT m s))) + +singleChar :: String -> Bool +singleChar [_] = True +singleChar _ = False + +satisfy :: (String -> Bool) -> Split () +satisfy p = get >>= guard . p + +forEachPart :: (String -> [String]) -> Split Bool +forEachPart parts = do + t <- get + case parts t of + [] -> return True + [t'] | t == t' -> return True + ts -> do emit t + (t', n) <- forEach (zip ts [1::Int ..]) + put t' + return (n==1) + +forEachPartAndWhole :: (String -> [String]) -> Split () +forEachPartAndWhole parts = do + t <- get + case parts t of + [] -> return () + ts -> forEach (t:ts) >>= put + + +splitDot :: String -> [String] +splitDot = split (dropBlanks $ dropDelims $ whenElt (=='.')) + +splitHyphen :: String -> [String] +splitHyphen = split (dropBlanks $ dropDelims $ whenElt (=='-')) + +splitCamlCase :: String -> [String] +splitCamlCase = split (dropInitBlank $ condense $ keepDelimsL $ whenElt isUpper) + +stripPrefixH :: String -> [String] +stripPrefixH ('H':'S':frag) | all isUpper frag = [frag] +stripPrefixH "HTTP" = [] +stripPrefixH ('H':frag@(c:_)) | isUpper c = [frag] +stripPrefixH _ = [] + +stripPrefix_h :: String -> [String] +stripPrefix_h "http" = [] +stripPrefix_h "html" = [] +stripPrefix_h ('h':'s':frag) = ['s':frag, frag] +stripPrefix_h ('h':frag) {- | Set.notMember (T.pack w) ws -} = [frag] +stripPrefix_h _ = [] + +stripSuffix :: String -> String -> Maybe String +stripSuffix s t = fmap reverse (stripPrefix (reverse s) (reverse t)) + +stripSuffixNum :: String -> [String] +stripSuffixNum s + | null rd || null rs' = [] + | otherwise = [s', d] + where + rs = reverse s + (rd, rs') = span isDigit rs + d = reverse rd + s' = reverse rs' + +splitOn2 :: String -> [String] +splitOn2 t = + case break (=='2') t of + (from@(_:_), '2':to@(c:_)) + | not (isDigit c) + , not (length from == 1 && length to == 1) + -> [from, to] + _ -> [] + + +------------------- +-- experiment +-- +{- +main = do + pkgsFile <- readFile "pkgs3" + let pkgs :: [PackageDescription] + pkgs = map read (lines pkgsFile) + +-- print "forcing pkgs..." +-- evaluate (foldl' (\a p -> seq p a) () pkgs) + + sequence_ + [ putStrLn $ display (packageName pkg) ++ ": " ++ display mod ++ " -> " + ++ intercalate ", " (map T.unpack $ extractModuleNameTerms (display mod)) + | pkg <- pkgs + , Just lib <- [library pkg] + , let mods = exposedModules lib + , mod <- mods ] +-} diff --git a/Distribution/Server/Features/Search/PkgSearch.hs b/Distribution/Server/Features/Search/PkgSearch.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/Search/PkgSearch.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-} + +module Distribution.Server.Features.Search.PkgSearch ( + PkgSearchEngine, + initialPkgSearchEngine, + defaultSearchRankParameters, + PkgDocField(..), + PkgDocFeatures, + ) where + +import Distribution.Server.Features.Search.SearchEngine +import Distribution.Server.Features.Search.ExtractNameTerms +import Distribution.Server.Features.Search.ExtractDescriptionTerms + +import Data.Ix +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import NLP.Snowball + +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Text (display) + + +type PkgSearchEngine = SearchEngine + (PackageDescription, DownloadCount) + PackageName + PkgDocField + PkgDocFeatures +type DownloadCount = Int + +data PkgDocField = NameField + | SynopsisField + | DescriptionField + deriving (Eq, Ord, Enum, Bounded, Ix, Show) + +data PkgDocFeatures = Downloads + deriving (Eq, Ord, Enum, Bounded, Ix, Show) + +initialPkgSearchEngine :: PkgSearchEngine +initialPkgSearchEngine = + initSearchEngine pkgSearchConfig defaultSearchRankParameters + +pkgSearchConfig :: SearchConfig (PackageDescription, DownloadCount) + PackageName PkgDocField PkgDocFeatures +pkgSearchConfig = + SearchConfig { + documentKey = packageName . fst, + extractDocumentTerms = extractTokens . fst, + transformQueryTerm = normaliseQueryToken, + documentFeatureValue = getFeatureValue + } + where + extractTokens :: PackageDescription -> PkgDocField -> [Text] + extractTokens pkg NameField = extractPackageNameTerms (display $ packageName pkg) + extractTokens pkg SynopsisField = extractSynopsisTerms stopWords (synopsis pkg) + extractTokens pkg DescriptionField = extractDescriptionTerms stopWords (description pkg) + + normaliseQueryToken :: Text -> PkgDocField -> Text + normaliseQueryToken tok = + let tokFold = T.toCaseFold tok + tokStem = stem English tokFold + in \field -> case field of + NameField -> tokFold + SynopsisField -> tokStem + DescriptionField -> tokStem + + getFeatureValue (_pkg, downloadcount) Downloads = fromIntegral downloadcount + +defaultSearchRankParameters :: SearchRankParameters PkgDocField PkgDocFeatures +defaultSearchRankParameters = + SearchRankParameters { + paramK1, + paramB, + paramFieldWeights, + paramFeatureWeights, + paramFeatureFunctions, + paramResultsetSoftLimit = 200, + paramResultsetHardLimit = 400 + } + where + paramK1 :: Float + paramK1 = 1.5 + + paramB :: PkgDocField -> Float + paramB NameField = 0.9 + paramB SynopsisField = 0.5 + paramB DescriptionField = 0.5 + + paramFieldWeights :: PkgDocField -> Float + paramFieldWeights NameField = 20 + paramFieldWeights SynopsisField = 5 + paramFieldWeights DescriptionField = 1 + + paramFeatureWeights :: PkgDocFeatures -> Float + paramFeatureWeights Downloads = 0.5 + + paramFeatureFunctions :: PkgDocFeatures -> FeatureFunction + paramFeatureFunctions Downloads = LogarithmicFunction 1 + + +stopWords :: Set Term +stopWords = + Set.fromList + ["haskell","library","simple","using","interface","functions", + "implementation","package","support","'s","based","for","a","and","the", + "to","of","with","in","an","on","from","that","as","into","by","is", + "some","which","or","like","your","other","can","at","over","be","it", + "within","their","this","but","are","get","one","all","you","so","only", + "now","how","where","when","up","has","been","about","them","then","see", + "no","do","than","should","out","off","much","if","i","have","also"] + + +{- +------------------- +-- Main experiment +-- + +main :: IO () +main = do + pkgsFile <- readFile "pkgs2" + let pkgs :: [PackageDescription] + pkgs = map read (lines pkgsFile) + +-- print "reading file" +-- evaluate (length mostFreq + length pkgs) +-- print "done" + + stopWordsFile <- T.readFile "stopwords.txt" + + let stopWords = Set.fromList (T.lines stopWordsFile) + + print "forcing pkgs..." + evaluate (foldl' (\a p -> seq p a) () pkgs `seq` Set.size stopWords) + + let config = pkgSearchConfig stopWords + searchengine = insertDocs pkgs $ initSearchEngine config + + print "constructing index..." + printTiming "done" $ + evaluate searchengine + print ("search engine invariant", invariant searchengine) + +-- print [ avgFieldLength ctx s | s <- [minBound..maxBound] ] + +-- print $ take 100 $ sortBy (flip compare) $ map Set.size $ Map.elems (termMap searchindex) +-- T.putStr $ T.unlines $ Map.keys (termMap searchindex) +-- let SearchEngine{searchIndex=SearchIndex{termMap, termIdMap, docKeyMap, docIdMap}} = searchengine +-- print (Map.size termMap, IntMap.size termIdMap, Map.size docKeyMap, IntMap.size docIdMap) + + let loop = do + putStr "search term> " + hFlush stdout + t <- getLine + unless (null t) $ do + let terms = stems English + . map (T.toCaseFold . T.pack) + $ words t + + putStrLn "Ranked results:" + let rankedResults = query searchengine terms + + putStr $ unlines + [ {-show rank ++ ": " ++ -}display pkgname + | ({-rank, -}pkgname) <- take 10 rankedResults ] + + loop + return () + loop + +printTiming msg action = do + t <- getCurrentTime + action + t' <- getCurrentTime + print (msg ++ ". time: " ++ show (diffUTCTime t' t)) +-} diff --git a/Distribution/Server/Features/Search/SearchEngine.hs b/Distribution/Server/Features/Search/SearchEngine.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/Search/SearchEngine.hs @@ -0,0 +1,383 @@ +{-# LANGUAGE BangPatterns, NamedFieldPuns, RecordWildCards #-} + +module Distribution.Server.Features.Search.SearchEngine ( + SearchEngine, + SearchConfig(..), + SearchRankParameters(..), + BM25F.FeatureFunction(..), + Term, + initSearchEngine, + insertDoc, + insertDocs, + deleteDoc, + query, + + NoFeatures, + noFeatures, + + queryExplain, + BM25F.Explanation(..), + setRankParams, + + invariant, + ) where + +import Distribution.Server.Features.Search.SearchIndex (SearchIndex, Term, TermId) +import qualified Distribution.Server.Features.Search.SearchIndex as SI +import Distribution.Server.Features.Search.DocIdSet (DocIdSet, DocId) +import qualified Distribution.Server.Features.Search.DocIdSet as DocIdSet +import Distribution.Server.Features.Search.DocTermIds (DocTermIds) +import qualified Distribution.Server.Features.Search.DocTermIds as DocTermIds +import Distribution.Server.Features.Search.DocFeatVals (DocFeatVals) +import qualified Distribution.Server.Features.Search.DocFeatVals as DocFeatVals +import qualified Distribution.Server.Features.Search.BM25F as BM25F + +import Distribution.Server.Framework.MemSize + +import Data.Ix +import Data.Array.Unboxed +import Data.List +import Data.Function +import Data.Maybe + +------------------- +-- Doc layer +-- +-- That is, at the layer of documents, so covering the issues of: +-- - inserting/removing whole documents +-- - documents having multiple fields +-- - documents having multiple terms +-- - transformations (case-fold/normalisation/stemming) on the doc terms +-- - transformations on the search terms +-- + +data SearchConfig doc key field feature = SearchConfig { + documentKey :: doc -> key, + extractDocumentTerms :: doc -> field -> [Term], + transformQueryTerm :: Term -> field -> Term, + documentFeatureValue :: doc -> feature -> Float + } + +data SearchRankParameters field feature = SearchRankParameters { + paramK1 :: !Float, + paramB :: field -> Float, + paramFieldWeights :: field -> Float, + paramFeatureWeights :: feature -> Float, + paramFeatureFunctions :: feature -> BM25F.FeatureFunction, + paramResultsetSoftLimit :: !Int, + paramResultsetHardLimit :: !Int + } + +data SearchEngine doc key field feature = SearchEngine { + searchIndex :: !(SearchIndex key field feature), + searchConfig :: !(SearchConfig doc key field feature), + searchRankParams :: !(SearchRankParameters field feature), + + -- cached info + sumFieldLengths :: !(UArray field Int), + bm25Context :: BM25F.Context TermId field feature + } + +initSearchEngine :: (Ix field, Bounded field, Ix feature, Bounded feature) => + SearchConfig doc key field feature -> + SearchRankParameters field feature -> + SearchEngine doc key field feature +initSearchEngine config params = + cacheBM25Context + SearchEngine { + searchIndex = SI.emptySearchIndex, + searchConfig = config, + searchRankParams = params, + sumFieldLengths = listArray (minBound, maxBound) (repeat 0), + -- FIXME this use of undefined bears explaining + bm25Context = undefined + } + +setRankParams :: SearchRankParameters field feature -> + SearchEngine doc key field feature -> + SearchEngine doc key field feature +setRankParams params@SearchRankParameters{..} se = + se { + searchRankParams = params, + bm25Context = (bm25Context se) { + BM25F.paramK1 = paramK1, + BM25F.paramB = paramB, + BM25F.fieldWeight = paramFieldWeights, + BM25F.featureWeight = paramFeatureWeights, + BM25F.featureFunction = paramFeatureFunctions + } + } + +invariant :: (Ord key, Ix field, Bounded field) => + SearchEngine doc key field feature -> Bool +invariant SearchEngine{searchIndex} = + SI.invariant searchIndex +-- && check caches + +cacheBM25Context :: Ix field => + SearchEngine doc key field feature -> + SearchEngine doc key field feature +cacheBM25Context + se@SearchEngine { + searchRankParams = SearchRankParameters{..}, + searchIndex, + sumFieldLengths + } + = se { bm25Context = bm25Context' } + where + bm25Context' = BM25F.Context { + BM25F.numDocsTotal = SI.docCount searchIndex, + BM25F.avgFieldLength = \f -> fromIntegral (sumFieldLengths ! f) + / fromIntegral (SI.docCount searchIndex), + BM25F.numDocsWithTerm = DocIdSet.size . SI.lookupTermId searchIndex, + BM25F.paramK1 = paramK1, + BM25F.paramB = paramB, + BM25F.fieldWeight = paramFieldWeights, + BM25F.featureWeight = paramFeatureWeights, + BM25F.featureFunction = paramFeatureFunctions + } + +updateCachedFieldLengths :: (Ix field, Bounded field) => + Maybe (DocTermIds field) -> Maybe (DocTermIds field) -> + SearchEngine doc key field feature -> + SearchEngine doc key field feature +updateCachedFieldLengths Nothing (Just newDoc) se@SearchEngine{sumFieldLengths} = + se { + sumFieldLengths = + array (bounds sumFieldLengths) + [ (i, n + DocTermIds.fieldLength newDoc i) + | (i, n) <- assocs sumFieldLengths ] + } +updateCachedFieldLengths (Just oldDoc) (Just newDoc) se@SearchEngine{sumFieldLengths} = + se { + sumFieldLengths = + array (bounds sumFieldLengths) + [ (i, n - DocTermIds.fieldLength oldDoc i + + DocTermIds.fieldLength newDoc i) + | (i, n) <- assocs sumFieldLengths ] + } +updateCachedFieldLengths (Just oldDoc) Nothing se@SearchEngine{sumFieldLengths} = + se { + sumFieldLengths = + array (bounds sumFieldLengths) + [ (i, n - DocTermIds.fieldLength oldDoc i) + | (i, n) <- assocs sumFieldLengths ] + } +updateCachedFieldLengths Nothing Nothing se = se + +insertDocs :: (Ord key, Ix field, Bounded field, Ix feature, Bounded feature) => + [doc] -> + SearchEngine doc key field feature -> + SearchEngine doc key field feature +insertDocs docs se = foldl' (\se' doc -> insertDoc doc se') se docs + +insertDoc :: (Ord key, Ix field, Bounded field, Ix feature, Bounded feature) => + doc -> + SearchEngine doc key field feature -> + SearchEngine doc key field feature +insertDoc doc se@SearchEngine{ searchConfig = SearchConfig { + documentKey, + extractDocumentTerms, + documentFeatureValue + } + , searchIndex } = + let key = documentKey doc + searchIndex' = SI.insertDoc key (extractDocumentTerms doc) + (documentFeatureValue doc) + searchIndex + oldDoc = SI.lookupDocKey searchIndex key + newDoc = SI.lookupDocKey searchIndex' key + + in cacheBM25Context $ + updateCachedFieldLengths oldDoc newDoc $ + se { searchIndex = searchIndex' } + +deleteDoc :: (Ord key, Ix field, Bounded field) => + key -> + SearchEngine doc key field feature -> + SearchEngine doc key field feature +deleteDoc key se@SearchEngine{searchIndex} = + let searchIndex' = SI.deleteDoc key searchIndex + oldDoc = SI.lookupDocKey searchIndex key + + in cacheBM25Context $ + updateCachedFieldLengths oldDoc Nothing $ + se { searchIndex = searchIndex' } + +query :: (Ix field, Bounded field, Ix feature, Bounded feature) => + SearchEngine doc key field feature -> + [Term] -> [key] +query se@SearchEngine{ searchIndex, + searchConfig = SearchConfig{transformQueryTerm}, + searchRankParams = SearchRankParameters{..} } + terms = + + let -- Start by transforming/normalising all the query terms. + -- This can be done differently for each field we search by. + lookupTerms :: [Term] + lookupTerms = [ term' + | term <- terms + , let transformForField = transformQueryTerm term + , term' <- nub [ transformForField field + | field <- range (minBound, maxBound) ] + ] + + -- Then we look up all the normalised terms in the index. + rawresults :: [Maybe (TermId, DocIdSet)] + rawresults = map (SI.lookupTerm searchIndex) lookupTerms + + -- For the terms that occur in the index, this gives us the term's id + -- and the set of documents that the term occurs in. + termids :: [TermId] + docidsets :: [DocIdSet] + (termids, docidsets) = unzip (catMaybes rawresults) + + -- We looked up the documents that *any* of the term occur in (not all) + -- so this could be rather a lot of docs if the user uses a few common + -- terms. Scoring these result docs is a non-trivial cost so we want to + -- limit the number that we have to score. The standard trick is to + -- consider the doc sets in the order of size, smallest to biggest. Once + -- we have gone over a certain threshold of docs then don't bother with + -- the doc sets for the remaining terms. This tends to work because the + -- scoring gives lower weight to terms that occur in many documents. + unrankedResults :: DocIdSet + unrankedResults = pruneRelevantResults + paramResultsetSoftLimit + paramResultsetHardLimit + docidsets + + --TODO: technically this isn't quite correct. Because each field can + -- be normalised differently, we can end up with different termids for + -- the same original search term, and then we score those as if they + -- were different terms, which makes a difference when the term appears + -- in multiple fields (exactly the case BM25F is supposed to deal with). + -- What we ought to have instead is an Array (Int, field) TermId, and + -- make the scoring use the appropriate termid for each field, but to + -- consider them the "same" term. + in rankResults se termids (DocIdSet.toList unrankedResults) + +rankResults :: (Ix field, Bounded field, Ix feature, Bounded feature) => + SearchEngine doc key field feature -> + [TermId] -> [DocId] -> [key] +rankResults se@SearchEngine{searchIndex} queryTerms docids = + map snd + $ sortBy (flip compare `on` fst) + [ (relevanceScore se queryTerms doctermids docfeatvals, dockey) + | docid <- docids + , let (dockey, doctermids, docfeatvals) = SI.lookupDocId searchIndex docid ] + +relevanceScore :: (Ix field, Bounded field, Ix feature, Bounded feature) => + SearchEngine doc key field feature -> + [TermId] -> DocTermIds field -> DocFeatVals feature -> Float +relevanceScore SearchEngine{bm25Context} queryTerms doctermids docfeatvals = + BM25F.score bm25Context doc queryTerms + where + doc = indexDocToBM25Doc doctermids docfeatvals + +indexDocToBM25Doc :: (Ix field, Bounded field, Ix feature, Bounded feature) => + DocTermIds field -> + DocFeatVals feature -> + BM25F.Doc TermId field feature +indexDocToBM25Doc doctermids docfeatvals = + BM25F.Doc { + BM25F.docFieldLength = DocTermIds.fieldLength doctermids, + BM25F.docFieldTermFrequency = DocTermIds.fieldTermCount doctermids, + BM25F.docFeatureValue = DocFeatVals.featureValue docfeatvals + } + +pruneRelevantResults :: Int -> Int -> [DocIdSet] -> DocIdSet +pruneRelevantResults softLimit hardLimit = + -- Look at the docsets starting with the smallest ones. Smaller docsets + -- correspond to the rarer terms, which are the ones that score most highly. + go DocIdSet.empty . sortBy (compare `on` DocIdSet.size) + where + go !acc [] = acc + go !acc (d:ds) + -- If this is the first one, we add it anyway, otherwise we're in + -- danger of returning no results at all. + | DocIdSet.null acc = go d ds + -- We consider the size our docset would be if we add this extra one... + -- If it puts us over the hard limit then stop. + | size > hardLimit = acc + -- If it puts us over soft limit then we add it and stop + | size > softLimit = DocIdSet.union acc d + -- Otherwise we can add it and carry on to consider the remainder + | otherwise = go (DocIdSet.union acc d) ds + where + size = DocIdSet.size acc + DocIdSet.size d + +----------------------------- + +queryExplain :: (Ix field, Bounded field, Ix feature, Bounded feature) => + SearchEngine doc key field feature -> + [Term] -> [(BM25F.Explanation field feature Term, key)] +queryExplain se@SearchEngine{ searchIndex, + searchConfig = SearchConfig{transformQueryTerm}, + searchRankParams = SearchRankParameters{..} } + terms = + + -- See 'query' above for explanation. Really we ought to combine them. + let lookupTerms :: [Term] + lookupTerms = [ term' + | term <- terms + , let transformForField = transformQueryTerm term + , term' <- nub [ transformForField field + | field <- range (minBound, maxBound) ] + ] + + rawresults :: [Maybe (TermId, DocIdSet)] + rawresults = map (SI.lookupTerm searchIndex) lookupTerms + + termids :: [TermId] + docidsets :: [DocIdSet] + (termids, docidsets) = unzip (catMaybes rawresults) + + unrankedResults :: DocIdSet + unrankedResults = pruneRelevantResults + paramResultsetSoftLimit + paramResultsetHardLimit + docidsets + + in rankExplainResults se termids (DocIdSet.toList unrankedResults) + +rankExplainResults :: (Ix field, Bounded field, Ix feature, Bounded feature) => + SearchEngine doc key field feature -> + [TermId] -> + [DocId] -> + [(BM25F.Explanation field feature Term, key)] +rankExplainResults se@SearchEngine{searchIndex} queryTerms docids = + sortBy (flip compare `on` (BM25F.overallScore . fst)) + [ (explainRelevanceScore se queryTerms doctermids docfeatvals, dockey) + | docid <- docids + , let (dockey, doctermids, docfeatvals) = SI.lookupDocId searchIndex docid ] + +explainRelevanceScore :: (Ix field, Bounded field, Ix feature, Bounded feature) => + SearchEngine doc key field feature -> + [TermId] -> + DocTermIds field -> + DocFeatVals feature -> + BM25F.Explanation field feature Term +explainRelevanceScore SearchEngine{bm25Context, searchIndex} + queryTerms doctermids docfeatvals = + fmap (SI.getTerm searchIndex) (BM25F.explain bm25Context doc queryTerms) + where + doc = indexDocToBM25Doc doctermids docfeatvals + +----------------------------- + +data NoFeatures = NoFeatures + deriving (Eq, Ord, Bounded) + +instance Ix NoFeatures where + range _ = [] + inRange _ _ = False + index _ _ = -1 + +noFeatures :: NoFeatures -> a +noFeatures _ = error "noFeatures" + +----------------------------- + +instance MemSize key => MemSize (SearchEngine doc key field feature) where + memSize SearchEngine {searchIndex} = 25 + memSize searchIndex + diff --git a/Distribution/Server/Features/Search/SearchIndex.hs b/Distribution/Server/Features/Search/SearchIndex.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/Search/SearchIndex.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE BangPatterns, NamedFieldPuns #-} + +module Distribution.Server.Features.Search.SearchIndex ( + SearchIndex, + Term, + TermId, + DocId, + + emptySearchIndex, + insertDoc, + deleteDoc, + + docCount, + lookupTerm, + lookupTermId, + lookupDocId, + lookupDocKey, + + getTerm, + + invariant, + ) where + +import Distribution.Server.Features.Search.DocIdSet (DocIdSet, DocId) +import qualified Distribution.Server.Features.Search.DocIdSet as DocIdSet +import Distribution.Server.Features.Search.DocTermIds (DocTermIds, TermId, vecIndexIx, vecCreateIx) +import qualified Distribution.Server.Features.Search.DocTermIds as DocTermIds +import Distribution.Server.Features.Search.DocFeatVals (DocFeatVals) +import qualified Distribution.Server.Features.Search.DocFeatVals as DocFeatVals + +import Distribution.Server.Framework.MemSize + +import Data.Ix (Ix) +import qualified Data.Ix as Ix +import Data.Map (Map) +import qualified Data.Map as Map +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.Set as Set +import Data.Text (Text) +import Data.List (foldl') + +import Control.Exception (assert) + +type Term = Text + +-- | The search index is essentially a many-to-many mapping between documents +-- and terms. Each document contains many terms and each term occurs in many +-- documents. It is a bidirectional mapping as we need to support lookups in +-- both directions. +-- +-- Documents are identified by a key (in Ord) while terms are text values. +-- Inside the index however we assign compact numeric ids to both documents and +-- terms. The advantage of this is a much more compact in-memory representation +-- and the disadvantage is greater complexity. In particular it means we have +-- to manage bidirectional mappings between document keys and ids, and between +-- terms and term ids. +-- +-- So the mappings we maintain can be depicted as: +-- +-- > Term <-- 1:1 --> TermId +-- > ^ +-- > | +-- > many:many +-- > | +-- > v +-- > DocKey <-- 1:1 --> DocId +-- +-- For efficiency, these details are exposed in the interface. In particular +-- the mapping from TermId to many DocIds is exposed via a 'DocIdSet', +-- and the mapping from DocIds to TermIds is exposed via 'DocTermIds'. +-- +data SearchIndex key field feature = SearchIndex { + -- the indexes + termMap :: !(Map Term TermInfo), + termIdMap :: !(IntMap Term), + docIdMap :: !(IntMap (DocInfo key field feature)), + docKeyMap :: !(Map key DocId), + + -- auto-increment key counters + nextTermId :: TermId, + nextDocId :: DocId + } + deriving Show + +data TermInfo = TermInfo !TermId !DocIdSet + deriving Show + +data DocInfo key field feature = DocInfo !key !(DocTermIds field) + !(DocFeatVals feature) + deriving Show + + +----------------------- +-- SearchIndex basics +-- + +emptySearchIndex :: SearchIndex key field feature +emptySearchIndex = + SearchIndex + Map.empty + IntMap.empty + IntMap.empty + Map.empty + minBound + minBound + +checkInvariant :: (Ord key, Ix field, Bounded field) => + SearchIndex key field feature -> SearchIndex key field feature +checkInvariant si = assert (invariant si) si + +invariant :: (Ord key, Ix field, Bounded field) => + SearchIndex key field feature -> Bool +invariant SearchIndex{termMap, termIdMap, docKeyMap, docIdMap} = + and [ IntMap.lookup (fromEnum termId) termIdMap == Just term + | (term, (TermInfo termId _)) <- Map.assocs termMap ] + && and [ case Map.lookup term termMap of + Just (TermInfo termId' _) -> toEnum termId == termId' + Nothing -> False + | (termId, term) <- IntMap.assocs termIdMap ] + && and [ case IntMap.lookup (fromEnum docId) docIdMap of + Just (DocInfo docKey' _ _) -> docKey == docKey' + Nothing -> False + | (docKey, docId) <- Map.assocs docKeyMap ] + && and [ Map.lookup docKey docKeyMap == Just (toEnum docId) + | (docId, DocInfo docKey _ _) <- IntMap.assocs docIdMap ] + && and [ DocIdSet.invariant docIdSet + | (_term, (TermInfo _ docIdSet)) <- Map.assocs termMap ] + && and [ any (\field -> DocTermIds.fieldTermCount docterms field termId > 0) fields + | (_term, (TermInfo termId docIdSet)) <- Map.assocs termMap + , docId <- DocIdSet.toList docIdSet + , let DocInfo _ docterms _ = docIdMap IntMap.! fromEnum docId ] + && and [ IntMap.member (fromEnum termid) termIdMap + | (_docId, DocInfo _ docTerms _) <- IntMap.assocs docIdMap + , field <- fields + , termid <- DocTermIds.fieldElems docTerms field ] + where + fields = Ix.range (minBound, maxBound) + + +------------------- +-- Lookups +-- + +docCount :: SearchIndex key field feature -> Int +docCount SearchIndex{docIdMap} = IntMap.size docIdMap + +lookupTerm :: SearchIndex key field feature -> Term -> Maybe (TermId, DocIdSet) +lookupTerm SearchIndex{termMap} term = + case Map.lookup term termMap of + Nothing -> Nothing + Just (TermInfo termid docidset) -> Just (termid, docidset) + +lookupTermId :: SearchIndex key field feature -> TermId -> DocIdSet +lookupTermId SearchIndex{termIdMap, termMap} termid = + case IntMap.lookup (fromEnum termid) termIdMap of + Nothing -> error $ "lookupTermId: not found " ++ show termid + Just term -> + case Map.lookup term termMap of + Nothing -> error "lookupTermId: internal error" + Just (TermInfo _ docidset) -> docidset + +lookupDocId :: SearchIndex key field feature -> + DocId -> (key, DocTermIds field, DocFeatVals feature) +lookupDocId SearchIndex{docIdMap} docid = + case IntMap.lookup (fromEnum docid) docIdMap of + Nothing -> errNotFound + Just (DocInfo key doctermids docfeatvals) -> (key, doctermids, docfeatvals) + where + errNotFound = error $ "lookupDocId: not found " ++ show docid + +lookupDocKey :: Ord key => SearchIndex key field feature -> key -> Maybe (DocTermIds field) +lookupDocKey SearchIndex{docKeyMap, docIdMap} key = do + case Map.lookup key docKeyMap of + Nothing -> Nothing + Just docid -> + case IntMap.lookup (fromEnum docid) docIdMap of + Nothing -> error "lookupDocKey: internal error" + Just (DocInfo _key doctermids _) -> Just doctermids + + +getTerm :: SearchIndex key field feature -> TermId -> Term +getTerm SearchIndex{termIdMap} termId = + termIdMap IntMap.! fromEnum termId + +getTermId :: SearchIndex key field feature -> Term -> TermId +getTermId SearchIndex{termMap} term = + case termMap Map.! term of TermInfo termid _ -> termid + +getDocTermIds :: SearchIndex key field feature -> DocId -> DocTermIds field +getDocTermIds SearchIndex{docIdMap} docid = + case docIdMap IntMap.! fromEnum docid of + DocInfo _ doctermids _ -> doctermids + +-------------------- +-- Insert & delete +-- + +-- Procedure for adding a new doc... +-- (key, field -> [Term]) +-- alloc docid for key +-- add term occurences for docid (include rev map for termid) +-- construct indexdoc now that we have all the term -> termid entries +-- insert indexdoc + +-- Procedure for updating a doc... +-- (key, field -> [Term]) +-- find docid for key +-- lookup old terms for docid (using termid rev map) +-- calc term occurrences to add, term occurrences to delete +-- add new term occurrences, delete old term occurrences +-- construct indexdoc now that we have all the term -> termid entries +-- insert indexdoc + +-- Procedure for deleting a doc... +-- (key, field -> [Term]) +-- find docid for key +-- lookup old terms for docid (using termid rev map) +-- delete old term occurrences +-- delete indexdoc + +-- | This is the representation for documents to be added to the index. +-- Documents may +-- +type DocTerms field = field -> [Term] +type DocFeatureValues feature = feature -> Float + +insertDoc :: (Ord key, Ix field, Bounded field, Ix feature, Bounded feature) => + key -> DocTerms field -> DocFeatureValues feature -> + SearchIndex key field feature -> SearchIndex key field feature +insertDoc key userDocTerms userDocFeats si@SearchIndex{docKeyMap} + | Just docid <- Map.lookup key docKeyMap + = -- Some older version of the doc is already present in the index, + -- So we keep its docid. Now have to update the doc itself + -- and update the terms by removing old ones and adding new ones. + let oldTermsIds = getDocTermIds si docid + userDocTerms' = memoiseDocTerms userDocTerms + newTerms = docTermSet userDocTerms' + oldTerms = docTermIdsTermSet si oldTermsIds + -- We optimise for the typical case of significant overlap between + -- the terms in the old and new versions of the document. + delTerms = oldTerms `Set.difference` newTerms + addTerms = newTerms `Set.difference` oldTerms + + -- Note: adding the doc relies on all the terms being in the termMap + -- already, so we first add all the term occurences for the docid. + in checkInvariant + . insertDocIdToDocEntry docid key userDocTerms' userDocFeats + . insertTermToDocIdEntries (Set.toList addTerms) docid + . deleteTermToDocIdEntries (Set.toList delTerms) docid + $ si + + | otherwise + = -- We're dealing with a new doc, so allocate a docid for the key + let (si', docid) = allocFreshDocId si + userDocTerms' = memoiseDocTerms userDocTerms + addTerms = docTermSet userDocTerms' + + -- Note: adding the doc relies on all the terms being in the termMap + -- already, so we first add all the term occurences for the docid. + in checkInvariant + . insertDocIdToDocEntry docid key userDocTerms' userDocFeats + . insertDocKeyToIdEntry key docid + . insertTermToDocIdEntries (Set.toList addTerms) docid + $ si' + +deleteDoc :: (Ord key, Ix field, Bounded field) => + key -> + SearchIndex key field feature -> SearchIndex key field feature +deleteDoc key si@SearchIndex{docKeyMap} + | Just docid <- Map.lookup key docKeyMap + = let oldTermsIds = getDocTermIds si docid + oldTerms = docTermIdsTermSet si oldTermsIds + in checkInvariant + . deleteDocEntry docid key + . deleteTermToDocIdEntries (Set.toList oldTerms) docid + $ si + + | otherwise = si + + +---------------------------------- +-- Insert & delete support utils +-- + + +memoiseDocTerms :: (Ix field, Bounded field) => DocTerms field -> DocTerms field +memoiseDocTerms docTermsFn = + \field -> vecIndexIx vec field + where + vec = vecCreateIx docTermsFn + +docTermSet :: (Bounded t, Ix t) => DocTerms t -> Set.Set Term +docTermSet docterms = + Set.unions [ Set.fromList (docterms field) + | field <- Ix.range (minBound, maxBound) ] + +docTermIdsTermSet :: (Bounded field, Ix field) => + SearchIndex key field feature -> + DocTermIds field -> Set.Set Term +docTermIdsTermSet si doctermids = + Set.unions [ Set.fromList terms + | field <- Ix.range (minBound, maxBound) + , let termids = DocTermIds.fieldElems doctermids field + terms = map (getTerm si) termids ] + +-- +-- The Term <-> DocId mapping +-- + +-- | Add an entry into the 'Term' to 'DocId' mapping. +insertTermToDocIdEntry :: Term -> DocId -> + SearchIndex key field feature -> + SearchIndex key field feature +insertTermToDocIdEntry term !docid si@SearchIndex{termMap, termIdMap, nextTermId} = + case Map.lookup term termMap of + Nothing -> + let !termInfo' = TermInfo nextTermId (DocIdSet.singleton docid) + in si { termMap = Map.insert term termInfo' termMap + , termIdMap = IntMap.insert (fromEnum nextTermId) term termIdMap + , nextTermId = succ nextTermId } + + Just (TermInfo termId docIdSet) -> + let !termInfo' = TermInfo termId (DocIdSet.insert docid docIdSet) + in si { termMap = Map.insert term termInfo' termMap } + +-- | Add multiple entries into the 'Term' to 'DocId' mapping: many terms that +-- map to the same document. +insertTermToDocIdEntries :: [Term] -> DocId -> + SearchIndex key field feature -> + SearchIndex key field feature +insertTermToDocIdEntries terms !docid si = + foldl' (\si' term -> insertTermToDocIdEntry term docid si') si terms + +-- | Delete an entry from the 'Term' to 'DocId' mapping. +deleteTermToDocIdEntry :: Term -> DocId -> + SearchIndex key field feature -> + SearchIndex key field feature +deleteTermToDocIdEntry term !docid si@SearchIndex{termMap, termIdMap} = + case Map.lookup term termMap of + Nothing -> si + Just (TermInfo termId docIdSet) -> + let docIdSet' = DocIdSet.delete docid docIdSet + termInfo' = TermInfo termId docIdSet' + in if DocIdSet.null docIdSet' + then si { termMap = Map.delete term termMap + , termIdMap = IntMap.delete (fromEnum termId) termIdMap } + else si { termMap = Map.insert term termInfo' termMap } + +-- | Delete multiple entries from the 'Term' to 'DocId' mapping: many terms +-- that map to the same document. +deleteTermToDocIdEntries :: [Term] -> DocId -> + SearchIndex key field feature -> + SearchIndex key field feature +deleteTermToDocIdEntries terms !docid si = + foldl' (\si' term -> deleteTermToDocIdEntry term docid si') si terms + +-- +-- The DocId <-> Doc mapping +-- + +allocFreshDocId :: SearchIndex key field feature -> + (SearchIndex key field feature, DocId) +allocFreshDocId si@SearchIndex{nextDocId} = + let !si' = si { nextDocId = succ nextDocId } + in (si', nextDocId) + +insertDocKeyToIdEntry :: Ord key => key -> DocId -> + SearchIndex key field feature -> + SearchIndex key field feature +insertDocKeyToIdEntry dockey !docid si@SearchIndex{docKeyMap} = + si { docKeyMap = Map.insert dockey docid docKeyMap } + +insertDocIdToDocEntry :: (Ix field, Bounded field, + Ix feature, Bounded feature) => + DocId -> key -> + DocTerms field -> + DocFeatureValues feature -> + SearchIndex key field feature -> + SearchIndex key field feature +insertDocIdToDocEntry !docid dockey userdocterms userdocfeats + si@SearchIndex{docIdMap} = + let doctermids = DocTermIds.create (map (getTermId si) . userdocterms) + docfeatvals= DocFeatVals.create userdocfeats + !docinfo = DocInfo dockey doctermids docfeatvals + in si { docIdMap = IntMap.insert (fromEnum docid) docinfo docIdMap } + +deleteDocEntry :: Ord key => DocId -> key -> + SearchIndex key field feature -> SearchIndex key field feature +deleteDocEntry docid key si@SearchIndex{docIdMap, docKeyMap} = + si { docIdMap = IntMap.delete (fromEnum docid) docIdMap + , docKeyMap = Map.delete key docKeyMap } + + +---------------------- +-- MemSize instances + +instance MemSize key => MemSize (SearchIndex key field feature) where + memSize (SearchIndex a b c d e f) = memSize6 a b c d e f + +instance MemSize TermInfo where + memSize (TermInfo a b) = memSize2 a b + +instance MemSize key => MemSize (DocInfo key field feature) where + memSize (DocInfo a b c) = memSize3 a b c + diff --git a/Distribution/Server/Features/Search/TermBag.hs b/Distribution/Server/Features/Search/TermBag.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/Search/TermBag.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-} +module Distribution.Server.Features.Search.TermBag ( + TermId, + TermBag, + size, + fromList, + elems, + termCount, + ) where + +import Distribution.Server.Framework.MemSize + +import qualified Data.Vector.Unboxed as Vec +import qualified Data.Map as Map +import Data.Word (Word32) +import Data.Bits + +newtype TermId = TermId Word32 + deriving (Eq, Ord, Show, Enum, MemSize) + +instance Bounded TermId where + minBound = TermId 0 + maxBound = TermId 0x00FFFFFF + +data TermBag = TermBag !Int !(Vec.Vector TermIdAndCount) + deriving Show + +-- We sneakily stuff both the TermId and the bag count into one 32bit word +type TermIdAndCount = Word32 + +-- Bottom 24 bits is the TermId, top 8 bits is the bag count +termIdAndCount :: TermId -> Int -> TermIdAndCount +termIdAndCount (TermId termid) freq = + (min (fromIntegral freq) 255 `shiftL` 24) + .|. (termid .&. 0x00FFFFFF) + +getTermId :: TermIdAndCount -> TermId +getTermId word = TermId (word .&. 0x00FFFFFF) + +getTermCount :: TermIdAndCount -> Int +getTermCount word = fromIntegral (word `shiftR` 24) + + +size :: TermBag -> Int +size (TermBag sz _) = sz + +elems :: TermBag -> [TermId] +elems (TermBag _ vec) = map getTermId (Vec.toList vec) + +termCount :: TermBag -> TermId -> Int +termCount (TermBag _ vec) = + binarySearch 0 (Vec.length vec - 1) + where + binarySearch :: Int -> Int -> TermId -> Int + binarySearch !a !b !key + | a > b = 0 + | otherwise = + let mid = (a + b) `div` 2 + tidAndCount = vec Vec.! mid + in case compare key (getTermId tidAndCount) of + LT -> binarySearch a (mid-1) key + EQ -> getTermCount tidAndCount + GT -> binarySearch (mid+1) b key + +fromList :: [TermId] -> TermBag +fromList termids = + let bag = Map.fromListWith (+) [ (t, 1) | t <- termids ] + sz = Map.foldl' (+) 0 bag + vec = Vec.fromListN (Map.size bag) + [ termIdAndCount termid freq + | (termid, freq) <- Map.toAscList bag ] + in TermBag sz vec + +instance MemSize TermBag where + memSize (TermBag _ vec) = 2 + memSizeUVector 2 vec + diff --git a/Distribution/Server/Features/ServerIntrospect.hs b/Distribution/Server/Features/ServerIntrospect.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/ServerIntrospect.hs @@ -0,0 +1,344 @@ +{-# LANGUAGE PatternGuards #-} +module Distribution.Server.Features.ServerIntrospect ( + serverIntrospectFeature + ) where + +import Distribution.Server.Framework +import qualified Distribution.Server.Framework.ResponseContentTypes as Resource +import Distribution.Server.Pages.Template (hackagePage) + +import Text.XHtml.Strict + ( Html, URL, (+++), concatHtml, noHtml, toHtml, (<<) + , h2, h3, h4, p, tt, emphasize, bold, primHtmlChar + , blockquote, thespan, thestyle + , anchor, (!), href, name + , ordList, unordList ) +import Data.Aeson (Value(..)) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Vector as Vector +import qualified Data.Text as Text +import Data.List +import Data.Function (on) +import Control.Arrow (first) + +-- | A feature to serve information and status about the server itself. +-- It has access to all the other features on the server so can do some +-- amount of introspection. +-- +-- In particular it provides: +-- +-- * API introspection: let people find out what the API of this hackage server +-- instance is. It lists all the active features and all the resources they +-- serve, including what methods and formats they support. +-- This should make things more obvious to people writing clients. +-- +-- * Memory consumption by each of the features +-- +serverIntrospectFeature :: [HackageFeature] -> HackageFeature +serverIntrospectFeature serverFeatures = (emptyHackageFeature "serverapi") { + featureDesc = "Lists the resources available on this server." + , featureResources = + [ (resourceAt "/api.:format") { + resourceDesc = [ (GET, "This page") ] + , resourceGet = [ ("html", \_ -> serveApiDocHtml serverFeatures) + , ("json", \_ -> serveApiDocJSON serverFeatures) + ] + } + , (resourceAt "/server-status/memory.:format") { + resourceDesc = [ (GET, "Server memory usage") ] + , resourceGet = [ ("html", \_ -> serveMemSizeHtml serverFeatures) + ] + } + ] + , featureState = [] + } + +------------------- +-- Server API stuff +-- + +serveApiDocHtml :: [HackageFeature] -> ServerPartE Response +serveApiDocHtml = return . toResponse . Resource.XHtml . apiDocPageHtml + +serveApiDocJSON :: [HackageFeature] -> ServerPartE Response +serveApiDocJSON = return . toResponse . apiDocJSON + + +-- TODO: all-resources from all features combined +-- and also for the JSON that's all we really want. + +apiDocPageHtml :: [HackageFeature] -> Html +apiDocPageHtml serverFeatures = hackagePage title content + where + title = "Server API" + descr = "This page lists all of the resources available on this server. " + ++ "The same list is also available in machine readable formats " + ++ "(see link below)." + content = [ h2 << title + , p << descr + , featureLinks + , featureList ] + + featureLinks = + h3 << "Enabled server features" +++ + unordList + [ anchor ! [ href ('#' : featureName feature) ] << featureName feature + | feature <- serverFeatures ] + + featureList = + concatHtml + [ anchor ! [ name (featureName feature) ] << h3 << ("The " +++ featureName feature +++ " feature") + +++ p << (let desc = featureDesc feature + in if null desc then thespan ! [thestyle "color: red"] << "Feature description unavailable" + else toHtml desc) + +++ stateList feature + +++ resourceList feature + | feature <- serverFeatures ] + + stateList feature = + let states = map abstractStateDesc (featureState feature) in + if null states + then p << "This feature does not have any state." + else p << emphasize << "State" + +++ unordList states + + resourceList feature = + p << emphasize << "Resources" + +++ unordList [ + renderLocationTemplate resource + +++ renderResourceWithExtensions (Just feature) resource + | resource <- featureResources feature + ] + + renderResourceWithExtensions mFeature resource = + methodList resource + +++ case mFeature of + Nothing -> mempty + Just feature -> extensionsElsewhere feature resource + + methodList resource = + unordList + [ show httpMethod +++ ": " +++ formatList formats +++ " -- " +++ description + | (httpMethod, formats, description) <- resourceMethodsAndFormats resource ] + + formatList formats = + intersperse (toHtml ", ") + [ tt << format | format <- formats ] + + renderLocationTemplate :: Resource -> Html + renderLocationTemplate resource = + let (components, mUrl) = renderComponents pathComponents + trailer = renderTrailer (resourceFormat resource) (resourcePathEnd resource) + in tt << case mUrl of + Nothing -> components +++ trailer + Just url -> anchor ! [href (url ++ trailer)] << (components +++ trailer) + where + pathComponents = reverse (resourceLocation resource) + + renderComponents :: [BranchComponent] -> (Html, Maybe URL) + renderComponents (StaticBranch sdir:cs) = + let (rest, url) = renderComponents cs + in ("/" +++ sdir +++ rest, liftM (("/" ++ sdir) ++) url) + renderComponents (DynamicBranch leaf:[]) + | ResourceFormat _ (Just (StaticBranch _)) <- resourceFormat resource = + ("/" +++ leaf, Just ("/" ++ leaf)) + renderComponents (DynamicBranch ddir:cs) = + let (rest, _) = renderComponents cs + in ("/" +++ emphasize << (":" ++ ddir) +++ rest, Nothing) + renderComponents (TrailingBranch :_ ) = + (emphasize << "/..", Nothing) + renderComponents [] = + (noHtml, Just "") + + renderTrailer (ResourceFormat (StaticFormat ext) _) _ = "." ++ ext + renderTrailer _ Slash = "/" + renderTrailer _ _ = "" + + extensionsElsewhere feature resource = + if null matchingResources + then mempty + else p << "Methods defined in other features:" + +++ blockquote << matchingResources + where + matchingResources :: [Html] + matchingResources = + [ toHtml [ p << ("In the " +++ featureName feature' +++ " feature") + , p << renderResourceWithExtensions Nothing resource' ] + | feature' <- serverFeatures + , featureName feature' /= featureName feature + , resource' <- featureResources feature' + , resourceLocation resource' == resourceLocation resource + , not (null (resourceMethods resource')) + ] + +resourceMethodsAndFormats :: Resource -> [(Method, [String], Html)] +resourceMethodsAndFormats (Resource _ rget rput rpost rdelete _ _ desc) = + [ (httpMethod, [ formatName | (formatName, _) <- handlers ], descriptionFor httpMethod desc) + | (handlers@(_:_), httpMethod) <- zip methodsHandlers methodsKinds ] + where + methodsHandlers = [rget, rput, rpost, rdelete] + methodsKinds = [GET, PUT, POST, DELETE] + + descriptionFor :: Method -> [(Method, String)] -> Html + descriptionFor _ [] = thespan ! [thestyle "color: red"] << "Method description unavailable" + descriptionFor m ((m',d):ds) + | m == m' = toHtml d + | otherwise = descriptionFor m ds + +apiDocJSON :: [HackageFeature] -> Value +apiDocJSON serverFeatures = featureList + where + featureList = + array + [ object + [ ("feature", string $ featureName feature) + , ("resources", resourceList feature) ] + | feature <- serverFeatures ] + + resourceList :: HackageFeature -> Value + resourceList feature = + array + [ object + [ ("location", string $ renderLocationTemplate resource) + , ("methods", methodList resource) ] + | resource <- featureResources feature ] + + methodList :: Resource -> Value + methodList resource = + array + [ object + [ ("method", string $ show httpMethod) + , ("formats", formatList formats) ] + | (httpMethod, formats, _) <- resourceMethodsAndFormats resource ] + + formatList formats = + array + [ object + [ ("name", string format) + ] -- could add here ("mimetype", ...) + | format <- formats ] + + renderLocationTemplate :: Resource -> String + renderLocationTemplate resource = + renderComponents pathComponents + ++ renderTrailer (resourceFormat resource) (resourcePathEnd resource) + where + pathComponents = reverse (resourceLocation resource) + + renderComponents (StaticBranch sdir:cs) = "/" ++ sdir + ++ renderComponents cs + renderComponents (DynamicBranch leaf:[]) + | ResourceFormat _ (Just (StaticBranch _)) <- resourceFormat resource + = "/" ++ leaf + renderComponents (DynamicBranch ddir:cs) = "/" ++ ":" ++ ddir + ++ renderComponents cs + renderComponents (TrailingBranch :_ ) = "/.." + renderComponents [] = "" + + renderTrailer (ResourceFormat (StaticFormat ext) _) _ = "." ++ ext + renderTrailer _ Slash = "/" + renderTrailer _ _ = "" + +---------------------- +-- Memory consumption +-- + +serveMemSizeHtml :: [HackageFeature] -> ServerPartE Response +serveMemSizeHtml serverFeatures = + toResponse + . Resource.XHtml + . memSizePageHtml + <$> liftIO (mapM getFeatureSizes serverFeatures) + where + getFeatureSizes feature = + (,,,) <$> pure (featureName feature) + <*> pure (featureDesc feature) + <*> mapM getCanonicalStateSizes (featureState feature) + <*> mapM getCacheStateSizes (featureCaches feature) + + getCanonicalStateSizes component = + (,) <$> pure (abstractStateDesc component) + <*> abstractStateSize component + + getCacheStateSizes component = + (,) <$> pure (cacheDesc component) + <*> getCacheMemSize component + +memSizePageHtml :: [(String, String, [(String, Int)], [(String, Int)])] -> Html +memSizePageHtml featureStateSizes = + hackagePage title content + where + title = "Server memory use" + descr = "This page lists the memory use all of the in-memory data stores " + ++ "and caches on the server." + content = [ h2 << title + , p << descr + , sectionLinks + , totalSection + , bySizeList + , byFeatureList + ] + + sectionLinks = + h3 << "Contents" +++ + unordList + [ anchor ! [ href ('#' : ref) ] << section + | (section, ref) <- [("Total", "total") + ,("By size", "by-size") + ,("By feature", "by-feature")] ] + + orderedStateSizes = sortBy (flip compare `on` (\(x,_,_,_) -> x)) + [ (sz, isCanonical, cname, fname) + | (fname, _, canonical, caches) <- featureStateSizes + , ((cname, sz), isCanonical) <- zip canonical (repeat True) + ++ zip caches (repeat False) ] + + totalSize = sum [ sz | (sz,_,_,_) <- orderedStateSizes ] + + totalSection = + h3 << (anchor ! [ name "total" ] << "Total") + +++ p << "Total memory use of all state components and all caches:" + +++ unordList [ show (memSizeMb totalSize) ++ "MB" ] + +++ p << ("Note that the real heap size is usually 2x-3x greater than " + ++ "this due to the way the GC works.") + + bySizeList = + h3 << (anchor ! [ name "by-size" ] << "By size") +++ + ordList + [ bold << (show (memSizeMb sz) ++ " MB: ") + +++ cname +++ " " +++ primHtmlChar "mdash" +++ " " + ++ (if isCanonical then "state component" else "cache") + ++ " from feature " + +++ anchor ! [ href ('#' : fname) ] << fname + | (sz, isCanonical, cname, fname) <- orderedStateSizes ] + + + byFeatureList = + h3 << (anchor ! [ name "by-feature" ] << "By feature") +++ + concatHtml + [ anchor ! [ name fname ] << h4 << fname + +++ p << fdesc + +++ stateList "state" "State components:" states + +++ stateList "caches" "Cache components:" caches + | (fname, fdesc, states, caches) <- featureStateSizes ] + + stateList thing1 thing2 states = + if null states + then p << ("This feature does not have any " ++ thing1 ++ ".") + else p << emphasize << thing2 + +++ unordList [ bold << (show (memSizeMb sz) ++ " MB: ") + +++ cname + | (cname, sz) <- states ] + +{------------------------------------------------------------------------------ + Some aeson auxiliary functions +------------------------------------------------------------------------------} + +array :: [Value] -> Value +array = Array . Vector.fromList + +object :: [(String, Value)] -> Value +object = Object . HashMap.fromList . map (first Text.pack) + +string :: String -> Value +string = String . Text.pack diff --git a/Distribution/Server/Features/StaticFiles.hs b/Distribution/Server/Features/StaticFiles.hs --- a/Distribution/Server/Features/StaticFiles.hs +++ b/Distribution/Server/Features/StaticFiles.hs @@ -7,7 +7,6 @@ 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 @@ -17,9 +16,8 @@ -- and also serve the genuinely static files. -- initStaticFilesFeature :: ServerEnv - -> IO HackageFeature + -> IO (IO HackageFeature) initStaticFilesFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode} = do - -- Page templates templates <- loadTemplates serverTemplatesMode [serverTemplatesDir] @@ -27,9 +25,10 @@ staticFiles <- find (isSuffixOf ".html.st") serverTemplatesDir - let feature = staticFilesFeature env templates staticFiles + return $ do + let feature = staticFilesFeature env templates staticFiles - return feature + return feature -- Simpler version of Syhstem.FilePath.Find (which requires unix-compat) find :: (FilePath -> Bool) -> FilePath -> IO [FilePath] @@ -38,7 +37,8 @@ return (filter p contents) staticFilesFeature :: ServerEnv -> Templates -> [FilePath] -> HackageFeature -staticFilesFeature ServerEnv{serverStaticDir} templates staticFiles = +staticFilesFeature ServerEnv{serverStaticDir, serverTemplatesMode} + templates staticFiles = (emptyHackageFeature "static-files") { featureResources = [ (resourceAt "/") { @@ -65,15 +65,23 @@ , featureState = [] , featureErrHandlers = [("txt", textErrorPage) ,("html", htmlErrorPage)] + , featureReloadFiles = reloadTemplates templates } where + staticResourceCacheControls = + case serverTemplatesMode of + DesignMode -> [Public, maxAgeSeconds 0, NoCache] + NormalMode -> [Public, maxAgeDays 1] + serveStaticDirFiles :: ServerPartE Response - serveStaticDirFiles = + serveStaticDirFiles = do + cacheControlWithoutETag staticResourceCacheControls serveDirectory DisableBrowsing [] serverStaticDir serveStaticToplevelFile :: String -> FilePath -> ServerPartE Response - serveStaticToplevelFile mimetype filename = + serveStaticToplevelFile mimetype filename = do + cacheControlWithoutETag staticResourceCacheControls serveFile (asContentType mimetype) (serverStaticDir filename) serveStaticTemplate :: String -> ServerPartE Response @@ -95,7 +103,9 @@ mtemplate <- tryGetTemplate templates name case mtemplate of Nothing -> mzero - Just template -> ok $ toResponse $ template [] + Just template -> do + cacheControlWithoutETag staticResourceCacheControls + ok $ toResponse $ template [] textErrorPage (ErrorResponse errCode hdrs errTitle message) = do template <- getTemplate templates "hackageErrorPage.txt" @@ -115,7 +125,7 @@ let formattedMessage = paragraph << errorToHtml message response = toResponse $ template [ "errorTitle" $= errTitle - , "errorMessage" $= XHtml.showHtmlFragment formattedMessage + , "errorMessage" $= formattedMessage ] return $ response { rsCode = errCode, diff --git a/Distribution/Server/Features/Tags.hs b/Distribution/Server/Features/Tags.hs --- a/Distribution/Server/Features/Tags.hs +++ b/Distribution/Server/Features/Tags.hs @@ -81,24 +81,29 @@ packageTagsUri :: String -> PackageName -> String } -initTagsFeature :: ServerEnv -> CoreFeature -> UploadFeature -> IO TagsFeature -initTagsFeature ServerEnv{serverStateDir} core@CoreFeature{..} upload = do +initTagsFeature :: ServerEnv + -> IO (CoreFeature + -> UploadFeature + -> IO TagsFeature) +initTagsFeature ServerEnv{serverStateDir} = 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 $ \core@CoreFeature{..} upload -> do + let feature = tagsFeature core upload tagsState specials updateTag - return feature + 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_ updateTag (Set.singleton pkgname, tags) + return feature + tagsStateComponent :: FilePath -> IO (StateComponent AcidState PackageTags) tagsStateComponent stateDir = do st <- openLocalStateFrom (stateDir "db" "Tags") initialPackageTags @@ -107,7 +112,7 @@ , stateHandle = st , getState = query st GetPackageTags , putState = update st . ReplacePackageTags - , backupState = \pkgTags -> [csvToBackup ["tags.csv"] $ tagsToCSV pkgTags] + , backupState = \_ pkgTags -> [csvToBackup ["tags.csv"] $ tagsToCSV pkgTags] , restoreState = tagsBackup , resetState = tagsStateComponent } @@ -145,7 +150,7 @@ tagsFeatureInterface = (emptyHackageFeature "tags") { featureResources = - map ($tagsResource) [ + map ($ tagsResource) [ tagsListing , tagListing , packageTagsListing @@ -244,11 +249,14 @@ licenseToTag :: License -> [Tag] licenseToTag l = case l of GPL _ -> [Tag "gpl"] + AGPL _ -> [Tag "agpl"] LGPL _ -> [Tag "lgpl"] + BSD2 -> [Tag "bsd2"] BSD3 -> [Tag "bsd3"] BSD4 -> [Tag "bsd4"] MIT -> [Tag "mit"] + MPL _ -> [Tag "mpl"] + Apache _ -> [Tag "apache"] PublicDomain -> [Tag "public-domain"] AllRightsReserved -> [Tag "all-rights-reserved"] _ -> [] - diff --git a/Distribution/Server/Features/Tags/Backup.hs b/Distribution/Server/Features/Tags/Backup.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Features/Tags/Backup.hs @@ -0,0 +1,49 @@ +module Distribution.Server.Features.Tags.Backup ( + tagsBackup, + tagsToCSV, + tagsToRecord + ) where + +import Distribution.Server.Features.Tags.State +import Distribution.Server.Framework.BackupRestore + +import Distribution.Package +import Distribution.Text (display) + +import Text.CSV (CSV, Record) +import qualified Data.Map as Map +-- import Data.Set (Set) +import qualified Data.Set as Set + +tagsBackup :: RestoreBackup PackageTags +tagsBackup = updateTags emptyPackageTags + +updateTags :: PackageTags -> RestoreBackup PackageTags +updateTags tagsState = RestoreBackup { + restoreEntry = \(BackupByteString entry bs) -> + if entry == ["tags.csv"] + then do csv <- importCSV "tags.csv" bs + tagsState' <- updateFromCSV csv tagsState + return (updateTags tagsState') + else return (updateTags tagsState) + , restoreFinalize = return tagsState + } + +updateFromCSV :: CSV -> PackageTags -> Restore PackageTags +updateFromCSV = concatM . map fromRecord + where + fromRecord :: Record -> PackageTags -> Restore PackageTags + fromRecord (packageField:tagFields) tagsState | not (null tagFields) = do + pkgname <- parseText "package name" packageField + tags <- mapM (parseText "tag") tagFields + return (setTags pkgname (Set.fromList tags) tagsState) + fromRecord x _ = fail $ "Invalid tags record: " ++ show x + +------------------------------------------------------------------------------ +tagsToCSV :: PackageTags -> CSV +tagsToCSV = map (\(p, t) -> tagsToRecord p $ Set.toList t) + . Map.toList . packageTags + +tagsToRecord :: PackageName -> [Tag] -> Record -- [String] +tagsToRecord pkgname tags = display pkgname:map display tags + diff --git a/Distribution/Server/Features/TarIndexCache.hs b/Distribution/Server/Features/TarIndexCache.hs --- a/Distribution/Server/Features/TarIndexCache.hs +++ b/Distribution/Server/Features/TarIndexCache.hs @@ -31,11 +31,16 @@ 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 +initTarIndexCacheFeature :: ServerEnv + -> IO (UserFeature + -> IO TarIndexCacheFeature) +initTarIndexCacheFeature env@ServerEnv{serverStateDir} = do + tarIndexCache <- tarIndexCacheStateComponent serverStateDir + return $ \users -> do + let feature = tarIndexCacheFeature env users tarIndexCache + return feature + tarIndexCacheStateComponent :: FilePath -> IO (StateComponent AcidState TarIndexCache) tarIndexCacheStateComponent stateDir = do st <- openLocalStateFrom (stateDir "db" "TarIndexCache") initialTarIndexCache @@ -46,7 +51,7 @@ , putState = update st . ReplaceTarIndexCache , resetState = tarIndexCacheStateComponent -- We don't backup the tar indices, but reconstruct them on demand - , backupState = \_ -> [] + , backupState = \_ _ -> [] , restoreState = RestoreBackup { restoreEntry = error "The impossible happened" , restoreFinalize = return initialTarIndexCache diff --git a/Distribution/Server/Features/Upload.hs b/Distribution/Server/Features/Upload.hs --- a/Distribution/Server/Features/Upload.hs +++ b/Distribution/Server/Features/Upload.hs @@ -37,21 +37,33 @@ data UploadFeature = UploadFeature { + -- | The package upload `HackageFeature`. uploadFeatureInterface :: HackageFeature, + -- | Upload resources. uploadResource :: UploadResource, + -- | The main upload routine. This uses extractPackage on a multipart + -- request to get contextual information. 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 + -- | The group of Hackage trustees. trusteesGroup :: UserGroup, + -- | The group of package uploaders. uploadersGroup :: UserGroup, + -- | The group of maintainers for a given package. maintainersGroup :: PackageName -> UserGroup, + -- | Requiring being logged in as the maintainer of a package. guardAuthorisedAsMaintainer :: PackageName -> ServerPartE (), + -- | Requiring being logged in as the maintainer of a package or a trustee. guardAuthorisedAsMaintainerOrTrustee :: PackageName -> ServerPartE (), + -- | Takes an upload request and, depending on the result of the + -- passed-in function, either commits the uploaded tarball to the blob + -- storage or throws it away and yields an error. extractPackage :: (Users.UserId -> UploadResult -> IO (Maybe ErrorResponse)) -> ServerPartE (Users.UserId, UploadResult, PkgTarball) } @@ -60,57 +72,74 @@ getFeatureInterface = uploadFeatureInterface data UploadResource = UploadResource { + -- | The page for uploading a package, the same as `corePackagesPage`. uploadIndexPage :: Resource, + -- | The page for deleting a package, the same as `corePackagePage`. + -- + -- This is fairly dangerous and is not currently used. deletePackagePage :: Resource, + -- | The maintainers group for each package. maintainersGroupResource :: GroupResource, + -- | The trustee group. trusteesGroupResource :: GroupResource, + -- | The allowed-uploaders group. uploadersGroupResource :: GroupResource, + + -- | URI for `maintainersGroupResource` given a format and `PackageId`. packageMaintainerUri :: String -> PackageId -> String, + -- | URI for `trusteesGroupResource` given a format. trusteeUri :: String -> String, + -- | URI for `uploadersGroupResource` given a format. uploaderUri :: String -> String } +-- | The representation of an intermediate result in the upload process, +-- indicating a package which meets the requirements to go into Hackage. data UploadResult = UploadResult { + -- The parsed Cabal file. uploadDesc :: !GenericPackageDescription, + -- The text of the Cabal file. uploadCabal :: !ByteString, + -- Any warnings from unpacking the tarball. uploadWarnings :: ![String] } -initUploadFeature :: ServerEnv -> CoreFeature -> UserFeature -> IO UploadFeature -initUploadFeature env@ServerEnv{serverStateDir} - core@CoreFeature{..} user@UserFeature{..} = do - +initUploadFeature :: ServerEnv + -> IO (UserFeature -> CoreFeature -> IO UploadFeature) +initUploadFeature env@ServerEnv{serverStateDir} = 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 + return $ \user@UserFeature{..} core@CoreFeature{..} -> do - (trusteesGroup, trusteesGroupResource) <- - groupResourceAt "/packages/trustees" (getTrusteesGroup [adminGroup]) + -- 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 - (uploadersGroup, uploadersGroupResource) <- - groupResourceAt "/packages/uploaders" (getUploadersGroup [adminGroup]) + (trusteesGroup, trusteesGroupResource) <- + groupResourceAt "/packages/trustees" (getTrusteesGroup [adminGroup]) - pkgNames <- PackageIndex.packageNames <$> queryGetPackageIndex - (maintainersGroup, maintainersGroupResource) <- - groupResourcesAt "/package/:package/maintainers" - (makeMaintainersGroup [adminGroup, trusteesGroup]) - (\pkgname -> [("package", display pkgname)]) - (packageInPath coreResource) - pkgNames + (uploadersGroup, uploadersGroupResource) <- + groupResourceAt "/packages/uploaders" (getUploadersGroup [adminGroup]) - return feature + 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 @@ -119,7 +148,7 @@ , stateHandle = st , getState = query st GetHackageTrustees , putState = update st . ReplaceHackageTrustees . trusteeList - , backupState = \(HackageTrustees trustees) -> [csvToBackup ["trustees.csv"] $ groupToCSV trustees] + , backupState = \_ (HackageTrustees trustees) -> [csvToBackup ["trustees.csv"] $ groupToCSV trustees] , restoreState = HackageTrustees <$> groupBackup ["trustees.csv"] , resetState = trusteesStateComponent } @@ -132,7 +161,7 @@ , stateHandle = st , getState = query st GetHackageUploaders , putState = update st . ReplaceHackageUploaders . uploaderList - , backupState = \(HackageUploaders uploaders) -> [csvToBackup ["uploaders.csv"] $ groupToCSV uploaders] + , backupState = \_ (HackageUploaders uploaders) -> [csvToBackup ["uploaders.csv"] $ groupToCSV uploaders] , restoreState = HackageUploaders <$> groupBackup ["uploaders.csv"] , resetState = uploadersStateComponent } @@ -145,7 +174,7 @@ , stateHandle = st , getState = query st AllPackageMaintainers , putState = update st . ReplacePackageMaintainers - , backupState = \(PackageMaintainers mains) -> [maintToExport mains] + , backupState = \_ (PackageMaintainers mains) -> [maintToExport mains] , restoreState = maintainerBackup , resetState = maintainersStateComponent } @@ -327,11 +356,12 @@ do -- initial check to ensure logged in. --FIXME: this should have been covered earlier uid <- guardAuthenticated + now <- liftIO getCurrentTime 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 + case Upload.unpackPackage now name content' of Left err -> return . Left $ ErrorResponse 400 [] "Invalid package" [MText err] Right ((pkg, pkgStr), warnings) -> do let uresult = UploadResult pkg pkgStr warnings diff --git a/Distribution/Server/Features/UserDetails.hs b/Distribution/Server/Features/UserDetails.hs --- a/Distribution/Server/Features/UserDetails.hs +++ b/Distribution/Server/Features/UserDetails.hs @@ -61,7 +61,7 @@ data AccountKind = AccountKindRealUser | AccountKindSpecial - deriving (Eq, Show, Typeable) + deriving (Eq, Show, Typeable, Enum, Bounded) newtype UserDetailsTable = UserDetailsTable (IntMap AccountDetails) deriving (Eq, Show, Typeable) @@ -154,7 +154,8 @@ , stateHandle = st , getState = query st GetUserDetailsTable , putState = update st . ReplaceUserDetailsTable - , backupState = \users -> [csvToBackup ["users.csv"] (userDetailsToCSV users)] + , backupState = \backuptype users -> + [csvToBackup ["users.csv"] (userDetailsToCSV backuptype users)] , restoreState = userDetailsBackup , resetState = userDetailsStateComponent } @@ -201,15 +202,17 @@ parseKind "special" = return (Just AccountKindSpecial) parseKind sts = fail $ "unable to parse account kind: " ++ sts -userDetailsToCSV :: UserDetailsTable -> CSV -userDetailsToCSV (UserDetailsTable tbl) +userDetailsToCSV :: BackupType -> UserDetailsTable -> CSV +userDetailsToCSV backuptype (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) + , if backuptype == FullBackup + then T.unpack (accountContactEmail udetails) + else "hidden-email@nowhere.org" , infoToAccountKind udetails , T.unpack (accountAdminNotes udetails) ] @@ -235,17 +238,19 @@ -- 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 +initUserDetailsFeature :: ServerEnv + -> IO (UserFeature + -> CoreFeature + -> IO UserDetailsFeature) +initUserDetailsFeature ServerEnv{serverStateDir} = do + -- Canonical state + usersDetailsState <- userDetailsStateComponent serverStateDir - --TODO: link up to user feature to delete + --TODO: link up to user feature to delete - return feature + return $ \users core -> do + let feature = userDetailsFeature usersDetailsState users core + return feature userDetailsFeature :: StateComponent AcidState UserDetailsTable diff --git a/Distribution/Server/Features/UserSignup.hs b/Distribution/Server/Features/UserSignup.hs --- a/Distribution/Server/Features/UserSignup.hs +++ b/Distribution/Server/Features/UserSignup.hs @@ -4,6 +4,9 @@ module Distribution.Server.Features.UserSignup ( initUserSignupFeature, UserSignupFeature(..), + SignupResetInfo(..), + + accountSuitableForPasswordReset ) where import Distribution.Server.Framework @@ -11,9 +14,11 @@ import Distribution.Server.Framework.BackupDump import Distribution.Server.Framework.BackupRestore +import Distribution.Server.Features.Upload import Distribution.Server.Features.Users import Distribution.Server.Features.UserDetails +import Distribution.Server.Users.Group import Distribution.Server.Users.Types import qualified Distribution.Server.Users.Users as Users @@ -24,7 +29,7 @@ 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.Char (isSpace, isPrint) import Data.Typeable (Typeable) import Control.Monad.Reader (ask) @@ -43,7 +48,9 @@ -- both with email confirmation. -- data UserSignupFeature = UserSignupFeature { - userSignupFeatureInterface :: HackageFeature + userSignupFeatureInterface :: HackageFeature, + + queryAllSignupResetInfo :: MonadIO m => m [SignupResetInfo] } instance IsHackageFeature UserSignupFeature where @@ -173,8 +180,9 @@ , stateHandle = st , getState = query st GetSignupResetTable , putState = update st . ReplaceSignupResetTable - , backupState = \tbl -> [csvToBackup ["signups.csv"] (signupInfoToCSV tbl) - ,csvToBackup ["resets.csv"] (resetInfoToCSV tbl)] + , backupState = \backuptype tbl -> + [csvToBackup ["signups.csv"] (signupInfoToCSV backuptype tbl) + ,csvToBackup ["resets.csv"] (resetInfoToCSV backuptype tbl)] , restoreState = signupResetBackup , resetState = signupResetStateComponent } @@ -222,14 +230,18 @@ return (nonce, signupinfo) fromRecord x = fail $ "Error processing signup info record: " ++ show x -signupInfoToCSV :: SignupResetTable -> CSV -signupInfoToCSV (SignupResetTable tbl) +signupInfoToCSV :: BackupType -> SignupResetTable -> CSV +signupInfoToCSV backuptype (SignupResetTable tbl) = ["0.1"] : [ "token", "username", "realname", "email", "timestamp" ] - : [ [ renderNonce nonce + : [ [ if backuptype == FullBackup + then renderNonce nonce + else "" , T.unpack signupUserName , T.unpack signupRealName - , T.unpack signupContactEmail + , if backuptype == FullBackup + then T.unpack signupContactEmail + else "hidden-email@nowhere.org" , formatUTCTime nonceTimestamp ] | (nonce, SignupInfo{..}) <- Map.toList tbl ] @@ -249,11 +261,13 @@ return (nonce, signupinfo) fromRecord x = fail $ "Error processing signup info record: " ++ show x -resetInfoToCSV :: SignupResetTable -> CSV -resetInfoToCSV (SignupResetTable tbl) +resetInfoToCSV :: BackupType -> SignupResetTable -> CSV +resetInfoToCSV backuptype (SignupResetTable tbl) = ["0.1"] : [ "token", "userid", "timestamp" ] - : [ [ renderNonce nonce + : [ [ if backuptype == FullBackup + then renderNonce nonce + else "" , display resetUserId , formatUTCTime nonceTimestamp ] @@ -265,37 +279,39 @@ -- 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" ] + -> IO (UserFeature + -> UserDetailsFeature + -> UploadFeature + -> IO UserSignupFeature) +initUserSignupFeature env@ServerEnv{ serverStateDir, serverTemplatesDir, + serverTemplatesMode } = do + -- Canonical state + signupResetState <- signupResetStateComponent serverStateDir - let feature = userSignupFeature env users userdetails - signupResetState templates + -- Page templates + templates <- loadTemplates serverTemplatesMode + [serverTemplatesDir, serverTemplatesDir "UserSignupReset"] + [ "SignupRequest.html", "SignupConfirmation.email" + , "SignupEmailSent.html", "SignupConfirm.html" + , "ResetRequest.html", "ResetConfirmation.email" + , "ResetEmailSent.html", "ResetConfirm.html" ] - return feature + return $ \users userdetails upload -> do + let feature = userSignupFeature env + users userdetails upload + signupResetState templates + return feature userSignupFeature :: ServerEnv -> UserFeature -> UserDetailsFeature + -> UploadFeature -> StateComponent AcidState SignupResetTable -> Templates -> UserSignupFeature userSignupFeature ServerEnv{serverBaseURI} UserFeature{..} UserDetailsFeature{..} - signupResetState templates + UploadFeature{uploadersGroup} signupResetState templates = UserSignupFeature {..} where @@ -307,6 +323,7 @@ resetRequestResource] , featureState = [abstractAcidStateComponent signupResetState] , featureCaches = [] + , featureReloadFiles = reloadTemplates templates } -- Resources @@ -348,6 +365,11 @@ -- Queries and updates -- + queryAllSignupResetInfo :: MonadIO m => m [SignupResetInfo] + queryAllSignupResetInfo = + queryState signupResetState GetSignupResetTable + >>= \(SignupResetTable tbl) -> return (Map.elems tbl) + querySignupInfo :: Nonce -> MonadIO m => m (Maybe SignupResetInfo) querySignupInfo nonce = queryState signupResetState (LookupSignupResetInfo nonce) @@ -392,13 +414,13 @@ handlerGetSignupRequestNew :: DynamicPath -> ServerPartE Response handlerGetSignupRequestNew _ = do - template <- getTemplate templates "SignupRequest" + template <- getTemplate templates "SignupRequest.html" ok $ toResponse $ template [] handlerPostSignupRequestNew :: DynamicPath -> ServerPartE Response handlerPostSignupRequestNew _ = do - templateEmail <- getTemplate templates "SignupConfirmationEmail" - templateConfirmation <- getTemplate templates "SignupEmailSent" + templateEmail <- getTemplate templates "SignupConfirmation.email" + templateConfirmation <- getTemplate templates "SignupEmailSent.html" (username, realname, useremail) <- lookUserNameEmail @@ -422,11 +444,11 @@ } mailBody = renderTemplate $ templateEmail [ "realname" $= realname - , "confirmlink" $= show serverBaseURI { + , "confirmlink" $= serverBaseURI { uriPath = "/users/register-request/" ++ renderNonce nonce } - , "serverhost" $= show serverBaseURI + , "serverhost" $= serverBaseURI ] Just ourHost = uriAuthority serverBaseURI @@ -458,9 +480,7 @@ 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 + guard (T.all isValidUserNameChar str) ?! "Sorry, login names have to be ASCII characters only or _, no spaces or other symbols." guardValidLookingEmail str = either errBadEmail return $ do guard (T.length str <= 100) ?! "Sorry, we didn't expect email addresses to be longer than 100 characters." @@ -484,7 +504,7 @@ handlerGetSignupRequestOutstanding dpath = do nonce <- nonceInPath dpath SignupInfo {..} <- lookupSignupInfo nonce - template <- getTemplate templates "SignupConfirm" + template <- getTemplate templates "SignupConfirm.html" resp 202 $ toResponse $ template [ "realname" $= signupRealName @@ -515,6 +535,7 @@ uid <- updateAddUser username userauth >>= either errNameClash return updateUserDetails uid acctDetails + liftIO $ addUserList uploadersGroup uid seeOther (userPageUri userResource "" username) (toResponse ()) where lookPasswd = body $ (,) <$> look "password" @@ -534,13 +555,13 @@ handlerGetResetRequestNew :: DynamicPath -> ServerPartE Response handlerGetResetRequestNew _ = do - template <- getTemplate templates "ResetRequest" + template <- getTemplate templates "ResetRequest.html" ok $ toResponse $ template [] handlerPostResetRequestNew :: DynamicPath -> ServerPartE Response handlerPostResetRequestNew _ = do - templateEmail <- getTemplate templates "ResetConfirmationEmail" - templateConfirmation <- getTemplate templates "ResetEmailSent" + templateEmail <- getTemplate templates "ResetConfirmation.email" + templateConfirmation <- getTemplate templates "ResetEmailSent.html" (supplied_username, supplied_useremail) <- lookUserNameEmail (uid, uinfo) <- lookupUserNameFull supplied_username @@ -566,11 +587,11 @@ } mailBody = renderTemplate $ templateEmail [ "realname" $= accountName - , "confirmlink" $= show serverBaseURI { + , "confirmlink" $= serverBaseURI { uriPath = "/users/password-reset/" ++ renderNonce nonce } - , "serverhost" $= show serverBaseURI + , "serverhost" $= serverBaseURI ] Just ourHost = uriAuthority serverBaseURI @@ -590,15 +611,14 @@ , errBadRequest "Missing form fields" [] ] guardEmailMatches (Just AccountDetails {accountContactEmail}) useremail - | accountContactEmail == useremail = return () + | T.toCaseFold accountContactEmail == T.toCaseFold 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 uinfo (Just udetails) + | accountSuitableForPasswordReset uinfo udetails + = return udetails guardSuitableAccountType _ _ = errForbidden "Cannot reset password for this account" [MText $ "Sorry, the self-service password reset system cannot be " @@ -613,7 +633,7 @@ mudetails <- queryUserDetails resetUserId AccountDetails{..} <- guardSuitableAccountType uinfo mudetails - template <- getTemplate templates "ResetConfirm" + template <- getTemplate templates "ResetConfirm.html" resp 202 $ toResponse $ template [ "realname" $= accountName @@ -653,3 +673,11 @@ [MText "Cannot set a new password as the user account has just been deleted."] errDeleted (Left Users.ErrNoSuchUserId) = errInternalError [MText "No such user id!"] + +accountSuitableForPasswordReset :: UserInfo -> AccountDetails -> Bool +accountSuitableForPasswordReset + (UserInfo { userStatus = AccountEnabled{} }) + (AccountDetails { accountKind = Just AccountKindRealUser }) + = True +accountSuitableForPasswordReset _ _ = False + diff --git a/Distribution/Server/Features/Users.hs b/Distribution/Server/Features/Users.hs --- a/Distribution/Server/Features/Users.hs +++ b/Distribution/Server/Features/Users.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, DoRec, BangPatterns, OverloadedStrings #-} +{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, DoRec, + BangPatterns, OverloadedStrings, CPP, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Distribution.Server.Features.Users ( initUserFeature, @@ -28,61 +29,112 @@ 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 Data.Aeson (toJSON) +import Data.Aeson.TH +import qualified Data.Text as T import Distribution.Text (display, simpleParse) -- | A feature to allow manipulation of the database of users. -- +-- TODO: clean up mismatched and duplicate functionality (some noted below). data UserFeature = UserFeature { + -- | The users `HackageFeature`. userFeatureInterface :: HackageFeature, + -- | User resources. userResource :: UserResource, + -- | Notification that a user has been added. Currently unused. userAdded :: Hook () (), --TODO: delete, other status changes? + -- | The admin user group, including its description, members, and + -- modification thereof. adminGroup :: UserGroup, -- Authorisation + -- | Require any of a set of privileges. guardAuthorised_ :: [PrivilegeCondition] -> ServerPartE (), + -- | Require any of a set of privileges, giving the id of the current user. guardAuthorised :: [PrivilegeCondition] -> ServerPartE UserId, + -- | Require being logged in, giving the id of the current user. guardAuthenticated :: ServerPartE UserId, + -- | A hook to override the default authentication error in particular + -- circumstances. authFailHook :: Hook Auth.AuthError (Maybe ErrorResponse), + -- | Retrieves the entire user base. queryGetUserDb :: forall m. MonadIO m => m Users.Users, + -- | Creates a Hackage 2 user credential. newUserAuth :: UserName -> PasswdPlain -> UserAuth, + -- | Adds a user with a fresh name. updateAddUser :: forall m. MonadIO m => UserName -> UserAuth -> m (Either Users.ErrUserNameClash UserId), + -- | Sets the account-enabled status of an existing user to True or False. updateSetUserEnabledStatus :: MonadIO m => UserId -> Bool -> m (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser)), + -- | Sets the credentials of an existing user. updateSetUserAuth :: MonadIO m => UserId -> UserAuth -> m (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser)), + -- | Adds a user to a group based on a "user" path component. + -- + -- Use the UserGroup or GroupResource directly instead, as this is a hack. groupAddUser :: UserGroup -> DynamicPath -> ServerPartE (), + -- | Likewise, deletes a user, will go away soon. groupDeleteUser :: UserGroup -> DynamicPath -> ServerPartE (), + -- | Get a username from a path. userNameInPath :: forall m. MonadPlus m => DynamicPath -> m UserName, + -- | Lookup a `UserId` from a name, if the name exists. lookupUserName :: UserName -> ServerPartE UserId, + -- | Lookup full `UserInfo` from a name, if the name exists. lookupUserNameFull :: UserName -> ServerPartE (UserId, UserInfo), + -- | Lookup full `UserInfo` from an id, if the id exists. lookupUserInfo :: UserId -> ServerPartE UserInfo, + -- | An action to change a password directly, using "password" and + -- "repeat-password" form fields. Only admins and the user themselves + -- can do this. This is messy, as it was one of the first things writen + -- for the users feature. + -- + -- TODO: update and make more usable. changePassword :: UserName -> ServerPartE (), + -- | Determine if the first user can change the second user's password, + -- replicating auth functionality. Avoid using. canChangePassword :: forall m. MonadIO m => UserId -> UserId -> m Bool, + -- | Action to create a new user with the given credentials. This takes the + -- desired name, a password, and a repeated password, validating all. newUserWithAuth :: String -> PasswdPlain -> PasswdPlain -> ServerPartE UserName, + -- | Action for an admin to create a user with "username", "password", and + -- "repeat-password" username fields. adminAddUser :: ServerPartE Response, - enabledAccount :: UserName -> ServerPartE (), - deleteAccount :: UserName -> ServerPartE (), + + -- Create a group resource for the given resource path. groupResourceAt :: String -> UserGroup -> IO (UserGroup, GroupResource), + -- | Create a parameretrized group resource for the given resource path. + -- The parameter `a` can here be called a group key, and there is + -- potentially a set of initial values. + -- + -- This takes functions to create a user group on the fly for the given + -- key, go from a key to a DynamicPath (for URI generation), as well as + -- go from a DynamicPath to a key with some possibility of failure. This + -- should check key membership, as well. + -- + -- When these parameretrized `UserGroup`s need to be modified, the returned + -- `a -> UserGroup` function should be used, as it wraps the given + -- `a -> UserGroup` function to keep user-to-group mappings up-to-date. groupResourcesAt :: forall a. String -> (a -> UserGroup) -> (a -> DynamicPath) -> (DynamicPath -> ServerPartE a) -> [a] -> IO (a -> UserGroup, GroupResource), + -- | Look up whether the current user has (add, remove) capabilities for + -- the given group, erroring out if neither are present. lookupGroupEditAuth :: UserGroup -> ServerPartE (Bool, Bool), + -- | For a given user, return all of the URIs for groups they are in. getGroupIndex :: forall m. (Functor m, MonadIO m) => UserId -> m [String], + -- | For a given URI, get a GroupDescription for it, if one can be found. getIndexDesc :: forall m. MonadIO m => String -> m GroupDescription } @@ -90,16 +142,26 @@ getFeatureInterface = userFeatureInterface data UserResource = UserResource { + -- | The list of all users. userList :: Resource, + -- | The main page for a given user. userPage :: Resource, + -- | A user's password. passwordResource :: Resource, + -- | A user's enabled status. enabledResource :: Resource, + -- | The admin group. adminResource :: GroupResource, + -- | URI for `userList` given a format. userListUri :: String -> String, + -- | URI for `userPage` given a format and name. userPageUri :: String -> UserName -> String, + -- | URI for `passwordResource` given a format and name. userPasswordUri :: String -> UserName -> String, + -- | URI for `enabledResource` given a format and name. userEnabledUri :: String -> UserName -> String, + -- | URI for `adminResource` given a format. adminPageUri :: String -> String } @@ -107,15 +169,18 @@ fromReqURI = simpleParse data GroupResource = GroupResource { + -- | A group, potentially parametetrized over some collection. groupResource :: Resource, + -- | A user's presence in a group. groupUserResource :: Resource, + -- | A `UserGroup` for a group, with a `DynamicPath` for any parameterization. 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. +-- and not globally, to be perfectly modular. data GroupIndex = GroupIndex { usersToGroupUri :: !(IntMap (Set String)), groupUrisToDesc :: !(Map String GroupDescription) @@ -127,9 +192,8 @@ memSize (GroupIndex a b) = memSize2 a b -- TODO: add renaming -initUserFeature :: ServerEnv -> IO UserFeature +initUserFeature :: ServerEnv -> IO (IO UserFeature) initUserFeature ServerEnv{serverStateDir} = do - -- Canonical state usersState <- usersStateComponent serverStateDir adminsState <- adminsStateComponent serverStateDir @@ -141,22 +205,23 @@ 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 + return $ do + -- 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 + (adminG, adminR) <- groupResourceAt "/users/admins/" adminGroupDesc - return feature + return feature usersStateComponent :: FilePath -> IO (StateComponent AcidState Users.Users) usersStateComponent stateDir = do @@ -166,7 +231,8 @@ , stateHandle = st , getState = query st GetUserDb , putState = update st . ReplaceUserDb - , backupState = \users -> [csvToBackup ["users.csv"] (usersToCSV users)] + , backupState = \backuptype users -> + [csvToBackup ["users.csv"] (usersToCSV backuptype users)] , restoreState = userBackup , resetState = usersStateComponent } @@ -179,7 +245,7 @@ , stateHandle = st , getState = query st GetHackageAdmins , putState = update st . ReplaceHackageAdmins . adminList - , backupState = \(HackageAdmins admins) -> [csvToBackup ["admins.csv"] (groupToCSV admins)] + , backupState = \_ (HackageAdmins admins) -> [csvToBackup ["admins.csv"] (groupToCSV admins)] , restoreState = HackageAdmins <$> groupBackup ["admins.csv"] , resetState = adminsStateComponent } @@ -223,18 +289,29 @@ } userResource = fix $ \r -> UserResource { - userList = (resourceAt "/users/.:format") + userList = (resourceAt "/users/.:format") { + resourceDesc = [ (GET, "list of users") ] + , resourceGet = [ ("json", serveUsersGet) ] + } , userPage = (resourceAt "/user/:username.:format") { - resourceDesc = [ (PUT, "create user") + resourceDesc = [ (GET, "user id info") + , (PUT, "create user") , (DELETE, "delete user") ] - , resourcePut = [ ("", handleUserPut) ] - , resourceDelete = [ ("", handleUserDelete) ] + , resourceGet = [ ("json", serveUserGet) ] + , resourcePut = [ ("", serveUserPut) ] + , resourceDelete = [ ("", serveUserDelete) ] } , passwordResource = resourceAt "/user/:username/password.:format" --TODO: PUT - , enabledResource = resourceAt "/user/:username/enabled.:format" - --TODO: GET & PUT + , enabledResource = (resourceAt "/user/:username/enabled.:format") { + resourceDesc = [ (GET, "return if the user is enabled") + , (PUT, "set if the user is enabled") + ] + , resourceGet = [("json", serveUserEnabledGet)] + , resourcePut = [("json", serveUserEnabledPut)] + } + , adminResource = adminResource , userListUri = \format -> @@ -249,6 +326,8 @@ renderResource (groupResource adminResource) [format] } + -- Queries and updates + -- queryGetUserDb :: MonadIO m => m Users.Users queryGetUserDb = queryState usersState GetUserDb @@ -267,9 +346,14 @@ -- -- Authorisation: authentication checks and privilege checks -- + + -- High level, all in one check that the client is authenticated as a + -- particular user and has an appropriate privilege, but then ignore the + -- identity of the user. guardAuthorised_ :: [PrivilegeCondition] -> ServerPartE () guardAuthorised_ = void . guardAuthorised + -- As above but also return the identity of the client guardAuthorised :: [PrivilegeCondition] -> ServerPartE UserId guardAuthorised privconds = do users <- queryGetUserDb @@ -277,11 +361,15 @@ Auth.guardPriviledged users uid privconds return uid + -- Simply check if the user is authenticated as some user, without any + -- check that they have any particular priveledges. Only useful as a + -- building block. guardAuthenticated :: ServerPartE UserId guardAuthenticated = do users <- queryGetUserDb guardAuthenticatedWithErrHook users + -- As above but using the given userdb snapshot guardAuthenticatedWithErrHook :: Users.Users -> ServerPartE UserId guardAuthenticatedWithErrHook users = do (uid,_) <- Auth.checkAuthenticated realm users @@ -296,53 +384,88 @@ 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) + -- | 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 + -- - handleUserPut :: DynamicPath -> ServerPartE Response - handleUserPut dpath = do - _ <- guardAuthorised [InGroup adminGroup] + serveUsersGet :: DynamicPath -> ServerPartE Response + serveUsersGet _ = do + userlist <- Users.enumerateActiveUsers <$> queryGetUserDb + let users = [ UserNameIdResource { + ui_username = userName uinfo, + ui_userid = uid + } + | (uid, uinfo) <- userlist ] + return . toResponse $ toJSON users + + serveUserGet :: DynamicPath -> ServerPartE Response + serveUserGet dpath = do + (uid, uinfo) <- lookupUserNameFull =<< userNameInPath dpath + groups <- getGroupIndex uid + return . toResponse $ + toJSON UserInfoResource { + ui1_username = userName uinfo, + ui1_userid = uid, + ui1_groups = map T.pack groups + } + + serveUserPut :: DynamicPath -> ServerPartE Response + serveUserPut 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 () + Left Users.ErrUserNameClash -> + errBadRequest "Username already exists" + [MText "Cannot create a new user account with that username because already exists"] + Right uid -> return . toResponse $ + toJSON UserNameIdResource { + ui_username = username, + ui_userid = uid + } - handleUserDelete :: DynamicPath -> ServerPartE Response - handleUserDelete dpath = do - _ <- guardAuthorised [InGroup adminGroup] + serveUserDelete :: DynamicPath -> ServerPartE Response + serveUserDelete dpath = do + guardAuthorised_ [InGroup adminGroup] uid <- lookupUserName =<< userNameInPath dpath merr <- updateState usersState $ DeleteUser uid case merr of - Nothing -> noContent $ toResponse () + 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)"] + Just Users.ErrNoSuchUserId -> errInternalError [MText "uid does not exist"] + serveUserEnabledGet :: DynamicPath -> ServerPartE Response + serveUserEnabledGet dpath = do + guardAuthorised_ [InGroup adminGroup] + (_uid, uinfo) <- lookupUserNameFull =<< userNameInPath dpath + let enabled = case userStatus uinfo of + AccountEnabled _ -> True + _ -> False + return . toResponse $ toJSON EnabledResource { ui_enabled = enabled } - -- | Resources representing the collection of known users. - -- - -- Features: + serveUserEnabledPut :: DynamicPath -> ServerPartE Response + serveUserEnabledPut dpath = do + guardAuthorised_ [InGroup adminGroup] + uid <- lookupUserName =<< userNameInPath dpath + EnabledResource enabled <- expectAesonContent + merr <- updateState usersState (SetUserEnabledStatus uid enabled) + case merr of + Nothing -> noContent $ toResponse () + Just (Left Users.ErrNoSuchUserId) -> + errInternalError [MText "uid does not exist"] + Just (Right Users.ErrDeletedUser) -> + errBadRequest "User deleted" + [MText "Cannot disable account, it has already been deleted"] + -- - -- * listing the collection of users - -- * adding and deleting users - -- * enabling and disabling accounts - -- * changing user's name and password + -- Exported utils for looking up user names in URLs\/paths -- userNameInPath :: forall m. MonadPlus m => DynamicPath -> m UserName @@ -491,14 +614,14 @@ 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) ] + , resourceGet = [ ("json", serveUserGroupGet 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) ] + , resourcePut = [ ("", serveUserGroupUserPut groupr) ] + , resourceDelete = [ ("", serveUserGroupUserDelete groupr) ] } , getGroup = \_ -> return group' } @@ -541,43 +664,44 @@ 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) ] + , resourceGet = [ ("json", serveUserGroupGet 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) ] + , resourcePut = [ ("", serveUserGroupUserPut groupr) ] + , resourceDelete = [ ("", serveUserGroupUserDelete groupr) ] } , getGroup = \dpath -> mkGroup' <$> getGroupData dpath } return (mkGroup', groupr) - handleUserGroupGet groupr dpath = do + serveUserGroupGet 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 ]) - ] + return . toResponse $ toJSON + UserGroupResource { + ui_title = T.pack $ groupTitle (groupDesc group), + ui_description = T.pack $ groupPrologue (groupDesc group), + ui_members = [ UserNameIdResource { + ui_username = Users.userIdToName userDb uid, + ui_userid = uid + } + | uid <- Group.enumerate userlist ] + } - --TODO: add handleUserGroupUserPost for the sake of the html frontend + --TODO: add serveUserGroupUserPost for the sake of the html frontend -- and then remove groupAddUser & groupDeleteUser - handleUserGroupUserPut groupr dpath = do + serveUserGroupUserPut 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 + serveUserGroupUserDelete groupr dpath = do group <- getGroup groupr dpath guardAuthorised_ (map InGroup (canRemoveGroup group)) uid <- lookupUserName =<< userNameInPath dpath @@ -627,15 +751,29 @@ -> GroupIndex -> GroupIndex adjustGroupIndex f g (GroupIndex a b) = GroupIndex (f a) (g b) + {------------------------------------------------------------------------------ - Some aeson auxiliary functions + Some types for JSON resources ------------------------------------------------------------------------------} -array :: [Value] -> Value -array = Array . Vector.fromList - -object :: [(Text.Text, Value)] -> Value -object = Object . HashMap.fromList +data UserNameIdResource = UserNameIdResource { ui_username :: UserName, + ui_userid :: UserId } +data UserInfoResource = UserInfoResource { ui1_username :: UserName, + ui1_userid :: UserId, + ui1_groups :: [T.Text] } +data EnabledResource = EnabledResource { ui_enabled :: Bool } +data UserGroupResource = UserGroupResource { ui_title :: T.Text, + ui_description :: T.Text, + ui_members :: [UserNameIdResource] } -string :: String -> Value -string = String . Text.pack +#if MIN_VERSION_aeson(0,6,2) +$(deriveJSON defaultOptions{fieldLabelModifier = drop 3} ''UserNameIdResource) +$(deriveJSON defaultOptions{fieldLabelModifier = drop 4} ''UserInfoResource) +$(deriveJSON defaultOptions{fieldLabelModifier = drop 3} ''EnabledResource) +$(deriveJSON defaultOptions{fieldLabelModifier = drop 3} ''UserGroupResource) +#else +$(deriveJSON (drop 3) ''UserNameIdResource) +$(deriveJSON (drop 4) ''UserInfoResource) +$(deriveJSON (drop 3) ''EnabledResource) +$(deriveJSON (drop 3) ''UserGroupResource) +#endif diff --git a/Distribution/Server/Framework.hs b/Distribution/Server/Framework.hs --- a/Distribution/Server/Framework.hs +++ b/Distribution/Server/Framework.hs @@ -2,7 +2,13 @@ -- module Distribution.Server.Framework ( - module Happstack.Server, + module Happstack.Server.Routing, + module Happstack.Server.Response, + module Happstack.Server.RqData, + module Happstack.Server.FileServe, + module Happstack.Server.Error, + module Happstack.Server.Monads, + module Happstack.Server.Types, module Data.Acid, module Distribution.Server.Framework.MemState, module Distribution.Server.Framework.Cache, @@ -14,10 +20,11 @@ module Distribution.Server.Framework.Resource, module Distribution.Server.Framework.RequestContentTypes, module Distribution.Server.Framework.ResponseContentTypes, + module Distribution.Server.Framework.CacheControl, module Distribution.Server.Framework.Hook, module Distribution.Server.Framework.Error, module Distribution.Server.Framework.Logging, - module Distribution.Server.Util.Happstack, + module Distribution.Server.Framework.HappstackUtils, module Data.Monoid, module Control.Applicative, @@ -27,7 +34,13 @@ ) where -import Happstack.Server +import Happstack.Server.Routing +import Happstack.Server.Response +import Happstack.Server.RqData +import Happstack.Server.FileServe +import Happstack.Server.Error +import Happstack.Server.Monads +import Happstack.Server.Types import Data.Acid import Distribution.Server.Framework.MemState @@ -40,12 +53,11 @@ import Distribution.Server.Framework.Resource import Distribution.Server.Framework.RequestContentTypes import Distribution.Server.Framework.ResponseContentTypes +import Distribution.Server.Framework.CacheControl import Distribution.Server.Framework.Hook import Distribution.Server.Framework.Error import Distribution.Server.Framework.Logging - -import Distribution.Server.Util.Happstack - +import Distribution.Server.Framework.HappstackUtils import Data.Monoid (Monoid(..)) import Control.Applicative (Applicative(..), (<$>)) diff --git a/Distribution/Server/Framework/Auth.hs b/Distribution/Server/Framework/Auth.hs --- a/Distribution/Server/Framework/Auth.hs +++ b/Distribution/Server/Framework/Auth.hs @@ -36,7 +36,7 @@ import Distribution.Server.Framework.AuthCrypt import Distribution.Server.Framework.AuthTypes import Distribution.Server.Framework.Error -import Distribution.Server.Util.Happstack (rqRealMethod) +import Distribution.Server.Framework.HtmlFormWrapper (rqRealMethod) import Happstack.Server @@ -248,6 +248,8 @@ nc <- Map.lookup "nc" authMap cnonce <- Map.lookup "cnonce" authMap return (QopAuth nc cnonce) + `mplus` + return QopNone Nothing -> return QopNone _ -> mzero return DigestAuthInfo { @@ -293,12 +295,11 @@ 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 "" + , "qop=" ++ inQuotes "auth" , "nonce=" ++ inQuotes nonce , "opaque=" ++ inQuotes "" ] diff --git a/Distribution/Server/Framework/AuthTypes.hs b/Distribution/Server/Framework/AuthTypes.hs --- a/Distribution/Server/Framework/AuthTypes.hs +++ b/Distribution/Server/Framework/AuthTypes.hs @@ -3,7 +3,6 @@ import Distribution.Server.Framework.MemSize -import Data.Binary (Binary) import Data.SafeCopy (base, deriveSafeCopy) import Data.Typeable (Typeable) @@ -20,7 +19,7 @@ -- us to use either the basic or digest HTTP authentication methods. -- newtype PasswdHash = PasswdHash String - deriving (Eq, Ord, Show, Binary, Typeable, MemSize) + deriving (Eq, Ord, Show, Typeable, MemSize) newtype RealmName = RealmName String deriving (Show, Eq) diff --git a/Distribution/Server/Framework/BackupDump.hs b/Distribution/Server/Framework/BackupDump.hs --- a/Distribution/Server/Framework/BackupDump.hs +++ b/Distribution/Server/Framework/BackupDump.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Server.Framework.BackupDump ( + BackupType (..), dumpServerBackup, csvToBackup, blobToBackup, @@ -38,6 +39,9 @@ import Data.Maybe (catMaybes, fromMaybe) import Data.Time +data BackupType = FullBackup | ScrubbedBackup + deriving (Eq, Show) + -- 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). -- @@ -63,9 +67,11 @@ -- > backups/blobs/ecfdf802c16bab706b6985de57c73663 -- -dumpServerBackup :: Verbosity -> FilePath -> Maybe String -> BlobStorage -> Bool +dumpServerBackup :: Verbosity -> BackupType -> FilePath -> Maybe String + -> BlobStorage -> Bool -> [(String, IO [BackupEntry])] -> IO () -dumpServerBackup verbosity backupDir tarfileTemplate store linkBlobs backupActions = do +dumpServerBackup verbosity backupType backupDir tarfileTemplate + store linkBlobs backupActions = do now <- getCurrentTime let template = fromMaybe defaultTarfileTemplate tarfileTemplate @@ -97,7 +103,8 @@ lognotice verbosity "Backup complete" where - defaultTarfileTemplate = "backup-" ++ iso8601DateFormat Nothing + leadin = if backupType == ScrubbedBackup then "scrubbed-" else "" + defaultTarfileTemplate = leadin ++ "backup-" ++ iso8601DateFormat Nothing substTemplate = formatTime defaultTimeLocale -- MVar as 1-place chan diff --git a/Distribution/Server/Framework/BlobStorage.hs b/Distribution/Server/Framework/BlobStorage.hs --- a/Distribution/Server/Framework/BlobStorage.hs +++ b/Distribution/Server/Framework/BlobStorage.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, - ScopedTypeVariables, BangPatterns, CPP #-} + ScopedTypeVariables, TypeFamilies, BangPatterns, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Server.BlobStorage @@ -15,6 +15,7 @@ BlobStorage, BlobId, blobMd5, + blobETag, open, add, addWith, @@ -22,9 +23,12 @@ consumeFileWith, fetch, filepath, + BlobId_v0, ) where import Distribution.Server.Framework.MemSize +import Distribution.Server.Framework.Instances () +import Distribution.Server.Framework.CacheControl (ETag(..)) import qualified Data.ByteString.Lazy as BSL import qualified Data.Digest.Pure.MD5 as MD5 @@ -33,6 +37,7 @@ import System.FilePath (()) import Control.Exception (handle, throwIO, evaluate, bracket) import Control.Monad +import Control.Applicative import Data.SafeCopy import System.Directory import System.IO @@ -62,7 +67,7 @@ -- | An id for a blob. The content of the blob is stable. -- newtype BlobId = BlobId MD5Digest - deriving (Eq, Ord, Show, Serialize, Typeable) + deriving (Eq, Ord, Show, Typeable, MemSize) instance ToJSON BlobId where toJSON (BlobId md5digest) = toJSON (show md5digest) @@ -70,12 +75,14 @@ blobMd5 :: BlobId -> String blobMd5 (BlobId digest) = show digest -instance SafeCopy BlobId where - putCopy = contain . put - getCopy = contain get +blobETag :: BlobId -> ETag +blobETag = ETag . blobMd5 -instance MemSize BlobId where - memSize _ = 7 --TODO: pureMD5 package wastes 5 words! +instance SafeCopy BlobId where + version = 2 + kind = extension + putCopy (BlobId x) = contain $ put x + getCopy = contain $ BlobId <$> get -- | A persistent blob storage area. Blobs can be added and retrieved but -- not removed or modified. @@ -313,3 +320,15 @@ foreign import ccall "fsync" c_fsync :: CInt -> IO CInt #endif + +-------------------------- +-- Old SafeCopy versions +-- + +newtype BlobId_v0 = BlobId_v0 MD5Digest deriving Serialize + +instance SafeCopy BlobId_v0 +instance Migrate BlobId where + type MigrateFrom BlobId = BlobId_v0 + migrate (BlobId_v0 digest) = BlobId digest + diff --git a/Distribution/Server/Framework/Cache.hs b/Distribution/Server/Framework/Cache.hs --- a/Distribution/Server/Framework/Cache.hs +++ b/Distribution/Server/Framework/Cache.hs @@ -7,6 +7,10 @@ readAsyncCache, prodAsyncCache, syncAsyncCache, + + AsyncUpdate, + newAsyncUpdate, + asyncUpdate, ) where import Control.Concurrent (forkIO, threadDelay) @@ -19,7 +23,9 @@ import Distribution.Server.Framework.Logging import qualified Distribution.Verbosity as Verbosity +import Prelude hiding (catch) + -- | An in-memory cache with asynchronous updates. -- -- Cache reads never block but may get stale results. So it is suitable for @@ -138,3 +144,50 @@ writeAsyncVar (AsyncVar inChan _) value = atomically (writeTChan inChan value) + +----------------------------------------------------------------- +-- A mechanism for async updates with multiple update prevention +-- + +newtype AsyncUpdate = AsyncUpdate (TChan (IO ())) + +newAsyncUpdate :: Int -> Verbosity -> String -> IO AsyncUpdate +newAsyncUpdate delay verbosity logname = do + + inChan <- atomically newTChan + + let loop = do + + when (delay > 0) (threadDelay delay) + + avail <- readAllAvailable inChan + -- We have a series of new actions. + -- We want the last one, skipping all intermediate updates. + let action = last avail + + logTiming verbosity (logname ++ " updated") $ + action `catch` \e -> + loginfo verbosity $ "Exception in update " ++ logname ++ ": " + ++ show (e :: SomeException) + + loop + + void $ forkIO loop + return (AsyncUpdate inChan) + 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) + +asyncUpdate :: AsyncUpdate -> IO () -> IO () +asyncUpdate (AsyncUpdate inChan) action = + atomically (writeTChan inChan action) diff --git a/Distribution/Server/Framework/CacheControl.hs b/Distribution/Server/Framework/CacheControl.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Framework/CacheControl.hs @@ -0,0 +1,72 @@ + +-- | Handler helpers to use HTTP cache headers: @Cache-Control@ and @ETag@. +-- +module Distribution.Server.Framework.CacheControl ( + cacheControl, + cacheControlWithoutETag, + CacheControl(..), + ETag(..), + maxAgeSeconds, maxAgeMinutes, maxAgeHours, maxAgeDays, maxAgeMonths, + ) where + +import Happstack.Server.Types +import Happstack.Server.Monads + +import Data.List +import qualified Data.ByteString.Char8 as BS8 + + +data CacheControl = MaxAge Int | Public | Private | NoCache | NoTransform + +maxAgeSeconds, maxAgeMinutes, maxAgeHours, + maxAgeDays, maxAgeMonths :: Int -> CacheControl +maxAgeSeconds n = MaxAge n +maxAgeMinutes n = MaxAge (n * 60) +maxAgeHours n = MaxAge (n * 60 * 60) +maxAgeDays n = MaxAge (n * 60 * 60 * 24) +maxAgeMonths n = MaxAge (n * 60 * 60 * 24 * 30) + +formatCacheControl :: CacheControl -> String +formatCacheControl (MaxAge n) = "max-age=" ++ show n +formatCacheControl Public = "public" +formatCacheControl Private = "private" +formatCacheControl NoCache = "no-cache" +formatCacheControl NoTransform = "no-transform" + +-- | Adds a @Cache-Control@ and @ETag@ header to the response. Also handles the +-- @if-none-match@ request header by returning 304 if the request ETag matches. +cacheControl :: Monad m => [CacheControl] -> ETag -> ServerPartT m () +cacheControl ctls etag = do + setCacheControl ctls + handleETag etag + +-- | Just adds a @Cache-Control@. Whenever possible you should use +-- 'cacheControl' instead and supply an ETag. +cacheControlWithoutETag :: Monad m => [CacheControl] -> ServerPartT m () +cacheControlWithoutETag ctls = + setCacheControl ctls + +-- | Set the Cache-Control header on the response +setCacheControl :: Monad m => [CacheControl] -> ServerPartT m () +setCacheControl ctls = + let hdr = intercalate ", " (map formatCacheControl ctls) in + setHeaderM "Cache-Control" hdr + +newtype ETag = ETag String + deriving (Eq, Ord, Show) + +formatETag :: ETag -> String +formatETag (ETag etag) = '"' : etag ++ ['"'] + +handleETag :: Monad m => ETag -> ServerPartT m () +handleETag expectedtag = do + -- Set the ETag header on the response. + setHeaderM "ETag" (formatETag expectedtag) + + -- Check the request for a matching ETag, return 304 if found. + rq <- askRq + case getHeader "if-none-match" rq of + Just actualtag | formatETag expectedtag == BS8.unpack actualtag + -> finishWith (noContentLength . result 304 $ "") + _ -> return () + diff --git a/Distribution/Server/Framework/Feature.hs b/Distribution/Server/Framework/Feature.hs --- a/Distribution/Server/Framework/Feature.hs +++ b/Distribution/Server/Framework/Feature.hs @@ -22,6 +22,7 @@ , BlobStorage ) where +import Distribution.Server.Framework.BackupDump (BackupType (..)) import Distribution.Server.Framework.BackupRestore (RestoreBackup(..), AbstractRestoreBackup(..), BackupEntry, abstractRestoreBackup) import Distribution.Server.Framework.Resource (Resource, ServerErrorResponse) import Distribution.Server.Framework.BlobStorage (BlobStorage) @@ -47,6 +48,7 @@ , featureErrHandlers :: [(String, ServerErrorResponse)] , featurePostInit :: IO () + , featureReloadFiles :: IO () , featureState :: [AbstractStateComponent] , featureCaches :: [CacheComponent] @@ -68,6 +70,7 @@ featureErrHandlers= [], featurePostInit = return (), + featureReloadFiles = return (), featureState = error $ "'featureState' not defined for feature '" ++ name ++ "'", featureCaches = [] @@ -91,7 +94,7 @@ -- | Overwrite the state , putState :: st -> IO () -- | (Pure) backup function - , backupState :: st -> [BackupEntry] + , backupState :: BackupType -> st -> [BackupEntry] -- | (Pure) backup restore , restoreState :: RestoreBackup st -- | Clone the state component in the given state directory @@ -106,7 +109,7 @@ abstractStateDesc :: String , abstractStateCheckpoint :: IO () , abstractStateClose :: IO () - , abstractStateBackup :: IO [BackupEntry] + , abstractStateBackup :: BackupType -> IO [BackupEntry] , abstractStateRestore :: AbstractRestoreBackup , abstractStateNewEmpty :: FilePath -> IO (AbstractStateComponent, IO [String]) , abstractStateSize :: IO Int @@ -150,7 +153,7 @@ abstractStateDesc = stateDesc st , abstractStateCheckpoint = createCheckpoint (stateHandle st) , abstractStateClose = closeAcidState (stateHandle st) - , abstractStateBackup = liftM (backupState st) (getState st) + , abstractStateBackup = \t -> liftM (backupState st t) (getState st) , abstractStateRestore = abstractRestoreBackup (putState st) (restoreState st) , abstractStateNewEmpty = \stateDir -> do st' <- resetState st stateDir @@ -164,7 +167,7 @@ abstractStateDesc = stateDesc st , abstractStateCheckpoint = return () , abstractStateClose = return () - , abstractStateBackup = liftM (backupState st) (getState st) + , abstractStateBackup = \t -> liftM (backupState st t) (getState st) , abstractStateRestore = abstractRestoreBackup (putState st) (restoreState st) , abstractStateNewEmpty = \stateDir -> do st' <- resetState st stateDir @@ -178,7 +181,7 @@ abstractStateDesc = "" , abstractStateCheckpoint = return () , abstractStateClose = return () - , abstractStateBackup = return [] + , abstractStateBackup = \_ -> return [] , abstractStateRestore = mempty , abstractStateNewEmpty = \_stateDir -> return (mempty, return []) , abstractStateSize = return 0 @@ -187,7 +190,7 @@ abstractStateDesc = abstractStateDesc a ++ "\n" ++ abstractStateDesc b , abstractStateCheckpoint = abstractStateCheckpoint a >> abstractStateCheckpoint b , abstractStateClose = abstractStateClose a >> abstractStateClose b - , abstractStateBackup = liftM2 (++) (abstractStateBackup a) (abstractStateBackup b) + , abstractStateBackup = \t -> liftM2 (++) (abstractStateBackup a t) (abstractStateBackup b t) , abstractStateRestore = abstractStateRestore a `mappend` abstractStateRestore b , abstractStateNewEmpty = \stateDir -> do (a', cmpA) <- abstractStateNewEmpty a stateDir diff --git a/Distribution/Server/Framework/HappstackUtils.hs b/Distribution/Server/Framework/HappstackUtils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Framework/HappstackUtils.hs @@ -0,0 +1,84 @@ + +{-| + +Functions and combinators to expose functioanlity buiding +on happstack bit is not really specific to any one area +of Hackage. + +-} + +module Distribution.Server.Framework.HappstackUtils ( + remainingPath, + remainingPathString, + mime, + consumeRequestBody, + + uriEscape, + showContentType + ) where + +import Happstack.Server.Types +import Happstack.Server.Monads +import Happstack.Server.Response +import Happstack.Server.FileServe + +import qualified Data.Map as Map +import System.FilePath.Posix (takeExtension, ()) +import Control.Monad +import qualified Data.ByteString.Lazy as BS +import qualified Network.URI as URI + + +-- |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 + +-- The following functions are in happstack-server, but not exported. So we +-- copy them here. + +-- | Produce the standard string representation of a content-type, +-- e.g. \"text\/html; charset=ISO-8859-1\". +showContentType :: ContentType -> String +showContentType (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps + +-- | Helper for 'showContentType'. +showParameters :: [(String,String)] -> String +showParameters = concatMap f + where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\"" + esc '\\' = "\\\\" + esc '"' = "\\\"" + esc c | c `elem` ['\\','"'] = '\\':[c] + | otherwise = [c] diff --git a/Distribution/Server/Framework/Instances.hs b/Distribution/Server/Framework/Instances.hs --- a/Distribution/Server/Framework/Instances.hs +++ b/Distribution/Server/Framework/Instances.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, FlexibleContexts, CPP #-} +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, FlexibleContexts, CPP, + TypeFamilies, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -8,25 +9,24 @@ -- Major version changes may break this module. -- -module Distribution.Server.Framework.Instances () where +module Distribution.Server.Framework.Instances (PackageIdentifier_v0) 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 Distribution.Package (PackageIdentifier(..), PackageName(..)) +import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) +import Distribution.System (OS(..), Arch(..)) +import Distribution.PackageDescription (FlagName(..)) +import Distribution.Version +import Data.Time (Day(..), DiffTime, UTCTime(..)) +import Control.Applicative import Control.DeepSeq -import qualified Data.Serialize as Serialize -import Data.Serialize (Serialize) -import Data.SafeCopy (SafeCopy(getCopy, putCopy), contain) +import Data.Serialize as Serialize +import Data.SafeCopy hiding (Version) +import Test.QuickCheck import Happstack.Server @@ -38,33 +38,157 @@ import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS #endif +import Data.Digest.Pure.MD5 (MD5Digest) -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 +deriveSafeCopy 2 'extension ''PackageName +deriveSafeCopy 2 'extension ''PackageIdentifier -instance SafeCopy PackageName where - getCopy = contain textGet - putCopy = contain . textPut +-- These types are not defined in this package, so we cannot easily control +-- changing these instances when the types change. So it's not safe to derive +-- them (except for the really stable ones). instance SafeCopy Version where - getCopy = contain textGet - putCopy = contain . textPut + version = 2 + kind = extension + putCopy (Version ns _) = contain $ safePut ns + getCopy = contain $ (\ns -> Version ns []) <$> safeGet instance SafeCopy VersionRange where - getCopy = contain textGet - putCopy = contain . textPut + version = 2 + kind = extension + putCopy = contain . foldVersionRange' + (putWord8 0) + (\v -> putWord8 1 >> safePut v) + (\v -> putWord8 2 >> safePut v) + (\v -> putWord8 3 >> safePut v) + (\v -> putWord8 4 >> safePut v) + (\v -> putWord8 5 >> safePut v) + (\v _ -> putWord8 6 >> safePut v) + (\r1 r2 -> putWord8 7 >> r1 >> r2) + (\r1 r2 -> putWord8 8 >> r1 >> r2) + (\r -> putWord8 9 >> r) + getCopy = contain getVR + where + getVR = do + tag <- getWord8 + case tag of + 0 -> return anyVersion + 1 -> thisVersion <$> safeGet + 2 -> laterVersion <$> safeGet + 3 -> earlierVersion <$> safeGet + 4 -> orLaterVersion <$> safeGet + 5 -> orEarlierVersion <$> safeGet + 6 -> withinVersion <$> safeGet + 7 -> unionVersionRanges <$> getVR <*> getVR + 8 -> intersectVersionRanges <$> getVR <*> getVR + 9 -> VersionRangeParens <$> getVR + _ -> fail "VersionRange.getCopy: bad tag" +instance SafeCopy OS where + putCopy (OtherOS s) = contain $ putWord8 0 >> safePut s + putCopy Linux = contain $ putWord8 1 + putCopy Windows = contain $ putWord8 2 + putCopy OSX = contain $ putWord8 3 + putCopy FreeBSD = contain $ putWord8 4 + putCopy OpenBSD = contain $ putWord8 5 + putCopy NetBSD = contain $ putWord8 6 + putCopy Solaris = contain $ putWord8 7 + putCopy AIX = contain $ putWord8 8 + putCopy HPUX = contain $ putWord8 9 + putCopy IRIX = contain $ putWord8 10 + putCopy HaLVM = contain $ putWord8 11 + putCopy IOS = contain $ putWord8 12 + + getCopy = contain $ do + tag <- getWord8 + case tag of + 0 -> return OtherOS <*> safeGet + 1 -> return Linux + 2 -> return Windows + 3 -> return OSX + 4 -> return FreeBSD + 5 -> return OpenBSD + 6 -> return NetBSD + 7 -> return Solaris + 8 -> return AIX + 9 -> return HPUX + 10 -> return IRIX + 11 -> return HaLVM + 12 -> return IOS + _ -> fail "SafeCopy OS getCopy: unexpected tag" + +instance SafeCopy Arch where + putCopy (OtherArch s) = contain $ putWord8 0 >> safePut s + putCopy I386 = contain $ putWord8 1 + putCopy X86_64 = contain $ putWord8 2 + putCopy PPC = contain $ putWord8 3 + putCopy PPC64 = contain $ putWord8 4 + putCopy Sparc = contain $ putWord8 5 + putCopy Arm = contain $ putWord8 6 + putCopy Mips = contain $ putWord8 7 + putCopy SH = contain $ putWord8 8 + putCopy IA64 = contain $ putWord8 9 + putCopy S390 = contain $ putWord8 10 + putCopy Alpha = contain $ putWord8 11 + putCopy Hppa = contain $ putWord8 12 + putCopy Rs6000 = contain $ putWord8 13 + putCopy M68k = contain $ putWord8 14 + putCopy Vax = contain $ putWord8 15 + + getCopy = contain $ do + tag <- getWord8 + case tag of + 0 -> return OtherArch <*> safeGet + 1 -> return I386 + 2 -> return X86_64 + 3 -> return PPC + 4 -> return PPC64 + 5 -> return Sparc + 6 -> return Arm + 7 -> return Mips + 8 -> return SH + 9 -> return IA64 + 10 -> return S390 + 11 -> return Alpha + 12 -> return Hppa + 13 -> return Rs6000 + 14 -> return M68k + 15 -> return Vax + _ -> fail "SafeCopy Arch getCopy: unexpected tag" + +instance SafeCopy CompilerFlavor where + putCopy (OtherCompiler s) = contain $ putWord8 0 >> safePut s + putCopy GHC = contain $ putWord8 1 + putCopy NHC = contain $ putWord8 2 + putCopy YHC = contain $ putWord8 3 + putCopy Hugs = contain $ putWord8 4 + putCopy HBC = contain $ putWord8 5 + putCopy Helium = contain $ putWord8 6 + putCopy JHC = contain $ putWord8 7 + putCopy LHC = contain $ putWord8 8 + putCopy UHC = contain $ putWord8 9 + + getCopy = contain $ do + tag <- getWord8 + case tag of + 0 -> return OtherCompiler <*> safeGet + 1 -> return GHC + 2 -> return NHC + 3 -> return YHC + 4 -> return Hugs + 5 -> return HBC + 6 -> return Helium + 7 -> return JHC + 8 -> return LHC + 9 -> return UHC + _ -> fail "SafeCopy CompilerFlavor getCopy: unexpected tag" + + +deriveSafeCopy 0 'base ''CompilerId +deriveSafeCopy 0 'base ''FlagName + + instance FromReqURI PackageIdentifier where fromReqURI = simpleParse @@ -74,23 +198,7 @@ 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 @@ -107,12 +215,6 @@ 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 @@ -123,6 +225,12 @@ rnf (ModifiedJulianDay a) = rnf a #endif +instance NFData MD5Digest where + rnf = rnf . show --TODO: MD5Digest should be a newtype wrapper and an instance of NFData + +instance MemSize MD5Digest where + memSize _ = 7 --TODO: pureMD5 package wastes 5 words! + instance MemSize Response where memSize (Response a b c d e) = memSize5 a b c d e memSize (SendFile{}) = 42 @@ -137,6 +245,125 @@ memSize _ = memSize0 instance Text Day where - disp = PP.text . show + disp = PP.text . show parse = readS_to_P (reads :: ReadS Day) +instance Text UTCTime where + disp = PP.text . show + parse = readS_to_P (reads :: ReadS UTCTime) + +------------------- +-- Arbitrary instances +-- + +instance Arbitrary PackageName where + arbitrary = PackageName <$> vectorOf 4 (choose ('a', 'z')) + +instance Arbitrary Version where + arbitrary = Version <$> listOf1 (choose (1, 15)) <*> pure [] + +instance Arbitrary PackageIdentifier where + arbitrary = PackageIdentifier <$> arbitrary <*> arbitrary + +instance Arbitrary CompilerFlavor where + arbitrary = oneof [ pure OtherCompiler <*> vectorOf 3 (choose ('A', 'Z')) + , pure GHC, pure NHC, pure YHC, pure Hugs, pure HBC + , pure Helium, pure JHC, pure LHC, pure UHC ] + +instance Arbitrary CompilerId where + arbitrary = CompilerId <$> arbitrary <*> arbitrary + +instance Arbitrary Arch where + arbitrary = oneof [ pure OtherArch <*> vectorOf 3 (choose ('A', 'Z')) + , pure I386, pure X86_64, pure PPC, pure PPC64, pure Sparc + , pure Arm, pure Mips, pure SH, pure IA64, pure S390 + , pure Alpha, pure Hppa, pure Rs6000, pure M68k, pure Vax ] + +instance Arbitrary OS where + arbitrary = oneof [ pure OtherOS <*> vectorOf 3 (choose ('A', 'Z')) + , pure Linux, pure Windows, pure OSX, pure FreeBSD + , pure OpenBSD, pure NetBSD, pure Solaris, pure AIX + , pure HPUX, pure IRIX, pure HaLVM, pure IOS ] + +instance Arbitrary FlagName where + arbitrary = FlagName <$> vectorOf 4 (choose ('a', 'z')) + +-- Below instances copied from +-- + +instance Arbitrary Day where + arbitrary = ModifiedJulianDay <$> (2000 +) <$> arbitrary + shrink = (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay + +instance Arbitrary DiffTime where + arbitrary = arbitrarySizedFractional +#if MIN_VERSION_time(1,3,0) + shrink = shrinkRealFrac +#else + shrink = (fromRational <$>) . shrink . toRational +#endif + +instance Arbitrary UTCTime where + arbitrary = + UTCTime + <$> arbitrary + <*> (fromRational . toRational <$> choose (0::Double, 86400)) + shrink ut@(UTCTime day dayTime) = + [ ut { utctDay = d' } | d' <- shrink day ] ++ + [ ut { utctDayTime = t' } | t' <- shrink dayTime ] + +-------------------------- +-- Old SafeCopy versions +-- + +newtype PackageIdentifier_v0 = PackageIdentifier_v0 PackageIdentifier + deriving (Eq, Ord) + +instance SafeCopy PackageIdentifier_v0 +instance Serialize PackageIdentifier_v0 where + put (PackageIdentifier_v0 pkgid) = Serialize.put (show pkgid) + get = PackageIdentifier_v0 . read <$> Serialize.get + +instance Migrate PackageIdentifier where + type MigrateFrom PackageIdentifier = PackageIdentifier_v0 + migrate (PackageIdentifier_v0 pkgid) = pkgid + + +newtype PackageName_v0 = PackageName_v0 PackageName + +instance SafeCopy PackageName_v0 where + putCopy (PackageName_v0 nm) = contain $ textPut_v0 nm + getCopy = contain $ PackageName_v0 <$> textGet_v0 + +instance Migrate PackageName where + type MigrateFrom PackageName = PackageName_v0 + migrate (PackageName_v0 pn) = pn + + +newtype Version_v0 = Version_v0 Version + +instance SafeCopy Version_v0 where + putCopy (Version_v0 v) = contain $ textPut_v0 v + getCopy = contain $ Version_v0 <$> textGet_v0 + +instance Migrate Version where + type MigrateFrom Version = Version_v0 + migrate (Version_v0 v) = v + + +newtype VersionRange_v0 = VersionRange_v0 VersionRange + +instance SafeCopy VersionRange_v0 where + putCopy (VersionRange_v0 v) = contain $ textPut_v0 v + getCopy = contain $ VersionRange_v0 <$> textGet_v0 + +instance Migrate VersionRange where + type MigrateFrom VersionRange = VersionRange_v0 + migrate (VersionRange_v0 v) = v + + +textGet_v0 :: Text a => Serialize.Get a +textGet_v0 = (fromJust . simpleParse) <$> Serialize.get + +textPut_v0 :: Text a => a -> Serialize.Put +textPut_v0 = Serialize.put . display diff --git a/Distribution/Server/Framework/Logging.hs b/Distribution/Server/Framework/Logging.hs --- a/Distribution/Server/Framework/Logging.hs +++ b/Distribution/Server/Framework/Logging.hs @@ -22,8 +22,8 @@ hFlush stdout loginfo :: Verbosity -> String -> IO () -loginfo verboisty msg = - when (verboisty >= verbose) $ do +loginfo verbosity msg = + when (verbosity >= verbose) $ do BS.hPutStrLn stderr (BS.pack msg) hFlush stderr diff --git a/Distribution/Server/Framework/MemSize.hs b/Distribution/Server/Framework/MemSize.hs --- a/Distribution/Server/Framework/MemSize.hs +++ b/Distribution/Server/Framework/MemSize.hs @@ -26,7 +26,7 @@ import Distribution.Package (PackageIdentifier(..), PackageName(..)) import Distribution.PackageDescription (FlagName(..)) -import Distribution.Version (Version(..), VersionRange(..)) +import Distribution.Version (Version(..), VersionRange, foldVersionRange') import Distribution.System (Arch(..), OS(..)) import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) @@ -55,7 +55,7 @@ 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 @@ -98,6 +98,9 @@ instance MemSize Integer where memSize _ = 2 +instance MemSize Float where + memSize _ = 2 + instance MemSize UTCTime where memSize _ = 7 @@ -165,14 +168,17 @@ 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 + memSize = + foldVersionRange' memSize0 -- any + memSize1 -- == v + memSize1 -- > v + memSize1 -- < v + (\v -> 7 + 2 * memSize v) -- >= v + (\v -> 7 + 2 * memSize v) -- <= v + (\v _v' -> memSize1 v) -- == v.* + memSize2 -- _ || _ + memSize2 -- _ && _ + memSize1 -- (_) instance MemSize PackageIdentifier where memSize (PackageIdentifier a b) = memSize2 a b diff --git a/Distribution/Server/Framework/RequestContentTypes.hs b/Distribution/Server/Framework/RequestContentTypes.hs --- a/Distribution/Server/Framework/RequestContentTypes.hs +++ b/Distribution/Server/Framework/RequestContentTypes.hs @@ -29,7 +29,7 @@ ) where import Happstack.Server -import Distribution.Server.Util.Happstack +import Distribution.Server.Framework.HappstackUtils 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) diff --git a/Distribution/Server/Framework/Resource.hs b/Distribution/Server/Framework/Resource.hs --- a/Distribution/Server/Framework/Resource.hs +++ b/Distribution/Server/Framework/Resource.hs @@ -38,7 +38,7 @@ ) where import Happstack.Server -import Distribution.Server.Util.Happstack (remainingPathString, uriEscape) +import Distribution.Server.Framework.HappstackUtils (remainingPathString, uriEscape) import Distribution.Server.Util.ContentType (parseContentAccept) import Distribution.Server.Framework.Error @@ -514,8 +514,11 @@ format <- mformat lookup format errRes -negotiateContent :: ServerMonad m => (Content, a) -> [(Content, a)] -> m (Content, a) +negotiateContent :: (FilterMonad Response m, ServerMonad m) + => (Content, a) -> [(Content, a)] -> m (Content, a) negotiateContent def available = do + when (length available > 1) $ + setHeaderM "Vary" "Accept" maccept <- getHeaderM "Accept" case maccept of Nothing -> return def diff --git a/Distribution/Server/Framework/ResponseContentTypes.hs b/Distribution/Server/Framework/ResponseContentTypes.hs --- a/Distribution/Server/Framework/ResponseContentTypes.hs +++ b/Distribution/Server/Framework/ResponseContentTypes.hs @@ -17,6 +17,8 @@ import Distribution.Server.Framework.BlobStorage ( BlobId, blobMd5 ) +import Distribution.Server.Framework.MemSize +import Distribution.Server.Framework.Instances () import Distribution.Server.Util.Parse (packUTF8) import Happstack.Server @@ -24,6 +26,7 @@ , noContentLength ) import qualified Data.ByteString.Lazy as BS.Lazy +import Data.Digest.Pure.MD5 (MD5Digest) import Text.RSS (RSS) import qualified Text.RSS as RSS (rssToXML, showXML) import qualified Text.XHtml.Strict as XHtml (Html, showHtml) @@ -32,21 +35,24 @@ import qualified Data.Time.Format as Time (formatTime) import System.Locale (defaultTimeLocale) import Text.CSV (printCSV, CSV) +import Control.DeepSeq -newtype ETag = ETag String - deriving (Eq, Ord, Show) -blobETag :: BlobId -> ETag -blobETag = ETag . blobMd5 +data IndexTarball = IndexTarball !BS.Lazy.ByteString !Int !MD5Digest !UTCTime -formatETag :: ETag -> String -formatETag (ETag etag) = '"' : etag ++ ['"'] +instance ToMessage IndexTarball where + toResponse (IndexTarball bs len md5 time) = mkResponseLen bs len + [ ("Content-Type", "application/x-gzip") + , ("Content-MD5", md5str) + , ("Last-modified", formatLastModifiedTime time) + ] + where md5str = show md5 -data IndexTarball = IndexTarball BS.Lazy.ByteString +instance NFData IndexTarball where + rnf (IndexTarball a b c d) = rnf (a,b,c,d) -instance ToMessage IndexTarball where - toContentType _ = "application/x-gzip" - toMessage (IndexTarball bs) = bs +instance MemSize IndexTarball where + memSize (IndexTarball a b c d) = memSize4 a b c d data PackageTarball = PackageTarball BS.Lazy.ByteString BlobId UTCTime @@ -55,8 +61,7 @@ toResponse (PackageTarball bs blobid time) = mkResponse bs [ ("Content-Type", "application/x-gzip") , ("Content-MD5", md5sum) - , ("ETag", formatETag (ETag md5sum)) - , ("Last-modified", formatTime time) + , ("Last-modified", formatLastModifiedTime time) ] where md5sum = blobMd5 blobid @@ -66,12 +71,11 @@ 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 +formatLastModifiedTime :: UTCTime -> String +formatLastModifiedTime = Time.formatTime defaultTimeLocale rfc822DateFormat where -- HACK! we're using UTC but http requires GMT -- hopefully it's ok to just say it's GMT diff --git a/Distribution/Server/Framework/Templating.hs b/Distribution/Server/Framework/Templating.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Framework/Templating.hs @@ -0,0 +1,240 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Server.Framework.Templating +-- Copyright : (c) Duncan Coutts 2013 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Support for templates, html and text, based on @HStringTemplate@ package. +----------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings, RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Distribution.Server.Framework.Templating ( + Template, + renderTemplate, + Templates, + TemplatesMode(..), + loadTemplates, + reloadTemplates, + getTemplate, + tryGetTemplate, + TemplateAttr, + ($=), + TemplateVal, + templateDict, + templateVal, + templateEnumDesriptor, + ) where + +import Text.StringTemplate +import Text.StringTemplate.Classes +import Happstack.Server (ToMessage(..), toResponseBS) + +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS + +--TODO: switch to bytestring builder, once we can depend on bytestring-0.10 +--import qualified Data.ByteString.Lazy.Builder as Builder +--import Data.ByteString.Lazy.Builder (Builder) +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder as Builder +import qualified Blaze.ByteString.Builder.Html.Utf8 as Builder +import qualified Text.XHtml.Strict as XHtml +import Network.URI (URI) +import qualified Data.Aeson as JSON + +import Distribution.Package (PackageName, PackageIdentifier) +import Distribution.Version (Version) +import Distribution.Text (display) + +import Control.Monad (when) +import Control.Monad.Trans (MonadIO, liftIO) +import Data.List +import Data.Maybe (isJust) +import Data.IORef +import System.FilePath ((<.>), takeExtension) +import qualified Data.Map as Map + + +type RawTemplate = StringTemplate Builder +type RawTemplateGroup = STGroup Builder + +data Template = Template !TemplateKind !RawTemplate +data TemplateKind = TextTemplate | HtmlTemplate | XmlTemplate | OtherTemplate + +renderTemplate :: Template -> LBS.ByteString +renderTemplate (Template _ st) = Builder.toLazyByteString (render st) + +instance ToMessage Template where + toResponse t@(Template tkind _) = + toResponseBS (templateContentType tkind) (renderTemplate t) + +newtype TemplateAttr = TemplateAttr (RawTemplate -> RawTemplate) + +infix 0 $= +($=) :: ToSElem a => String -> a -> TemplateAttr +($=) k v = TemplateAttr (setAttribute k v) + +newtype TemplateVal = TemplateVal (forall b. Stringable b => SElem b) + +instance ToSElem TemplateVal where + toSElem (TemplateVal se) = se + +templateDict :: [(String, TemplateVal)] -> TemplateVal +templateDict kvs = + TemplateVal (SM (Map.fromList (fmap (\(k, TemplateVal v) -> (k, v)) kvs))) + +templateVal :: ToSElem a => String -> a -> (String, TemplateVal) +templateVal k v = (k, TemplateVal (toSElem v)) + +-- | Helper to make it easier to construct forms that use enumeration types +templateEnumDesriptor :: (Eq a, JSON.ToJSON a) => (a -> String) -> + [a] -> a -> [TemplateVal] +templateEnumDesriptor tostr xs x = + [ templateDict + [ templateVal "index" i + , templateVal "selected" (x' == x) + , templateVal "asstring" (tostr x') + , templateVal "asjson" (JSON.encode x') + ] + | (i, x') <- zip [0::Int ..] xs ] + +instance ToSElem XHtml.Html where + -- The use of SBLE here is to prevent the html being escaped + toSElem = SBLE . stFromString . XHtml.showHtmlFragment + +instance ToSElem URI where toSElem = toSElem . show +instance ToSElem PackageName where toSElem = toSElem . display +instance ToSElem Version where toSElem = toSElem . display +instance ToSElem PackageIdentifier where toSElem = toSElem . display + + +data Templates = TemplatesNormalMode !(IORef RawTemplateGroup) + [FilePath] [String] + | TemplatesDesignMode [FilePath] [String] + +data TemplatesMode = NormalMode | DesignMode + +loadTemplates :: TemplatesMode -> [FilePath] -> [String] -> IO Templates +loadTemplates templateMode templateDirs expectedTemplates = do + templateGroup <- loadTemplateGroup templateDirs + checkTemplates templateGroup templateDirs expectedTemplates + case templateMode of + NormalMode -> do + templateGroupRef <- newIORef templateGroup + return (TemplatesNormalMode templateGroupRef + templateDirs expectedTemplates) + + DesignMode -> + return (TemplatesDesignMode templateDirs expectedTemplates) + +reloadTemplates :: Templates -> IO () +reloadTemplates (TemplatesNormalMode templateGroupRef + templateDirs expectedTemplates) = do + templateGroup' <- loadTemplateGroup templateDirs + checkTemplates templateGroup' templateDirs expectedTemplates + writeIORef templateGroupRef templateGroup' + +reloadTemplates (TemplatesDesignMode _ _) = return () + +getTemplate :: MonadIO m => Templates -> String -> m ([TemplateAttr] -> Template) +getTemplate templates@(TemplatesNormalMode _ _ expectedTemplates) name = do + when (name `notElem` expectedTemplates) $ failMissingTemplate name + tryGetTemplate templates name >>= maybe (failMissingTemplate name) return + +getTemplate templates@(TemplatesDesignMode _ expectedTemplates) name = do + when (name `notElem` expectedTemplates) $ failMissingTemplate name + tryGetTemplate templates name >>= maybe (failMissingTemplate name) return + +tryGetTemplate :: MonadIO m => Templates -> String -> m (Maybe ([TemplateAttr] -> Template)) +tryGetTemplate (TemplatesNormalMode templateGroupRef _ _) name = do + templateGroup <- liftIO $ readIORef templateGroupRef + let tkind = templateKindFromExt name + mtemplate = fmap (\t -> Template tkind + . applyEscaping tkind + . applyTemplateAttrs t) + (getStringTemplate name templateGroup) + return mtemplate + +tryGetTemplate (TemplatesDesignMode templateDirs expectedTemplates) name = do + templateGroup <- liftIO $ loadTemplateGroup templateDirs + checkTemplates templateGroup templateDirs expectedTemplates + let tkind = templateKindFromExt name + mtemplate = fmap (\t -> Template tkind + . applyEscaping tkind + . applyTemplateAttrs t) + (getStringTemplate name templateGroup) + return mtemplate + +templateKindFromExt :: FilePath -> TemplateKind +templateKindFromExt tname = + case takeExtension tname of + ".txt" -> TextTemplate + ".html" -> HtmlTemplate + ".xml" -> XmlTemplate + _ -> OtherTemplate + +applyEscaping :: TemplateKind -> RawTemplate -> RawTemplate +applyEscaping TextTemplate = id +applyEscaping HtmlTemplate = setEncoder escapeHtml +applyEscaping XmlTemplate = setEncoder escapeHtml -- ok to reuse +applyEscaping OtherTemplate = id + +escapeHtml :: Builder -> Builder +escapeHtml = Builder.fromHtmlEscapedString + . LBS.unpack + . Builder.toLazyByteString + +templateContentType :: TemplateKind -> BS.ByteString +templateContentType TextTemplate = "text/plain; charset=utf-8" +templateContentType HtmlTemplate = "text/html; charset=utf-8" +templateContentType XmlTemplate = "application/xml" +templateContentType OtherTemplate = "text/plain" + +applyTemplateAttrs :: RawTemplate -> [TemplateAttr] -> RawTemplate +applyTemplateAttrs = foldl' (\t' (TemplateAttr a) -> a t') + +failMissingTemplate :: Monad m => String -> m a +failMissingTemplate name = + fail $ "getTemplate: request for unexpected template " ++ name + ++ ". So we can do load-time checking, all templates used " + ++ "must be listed in the call to loadTemplates." + +loadTemplateGroup :: [FilePath] -> IO RawTemplateGroup +loadTemplateGroup [] = return nullGroup +loadTemplateGroup templateDirs = do + templateGroup <- mapM directoryGroup templateDirs +-- `catchJust` IOError + return (foldr1 (flip addSuperGroup) templateGroup) + +checkTemplates :: Monad m => RawTemplateGroup -> [FilePath] -> [String] -> m () +checkTemplates templateGroup templateDirs expectedTemplates = do + let checks = [ (t, fmap checkTemplate + (getStringTemplate t templateGroup)) + | t <- expectedTemplates ] + missing = [ t | (t,Nothing) <- checks ] + problems = [ (t, p) | (t,Just p@(es,_ma,mt)) <- checks + , isJust es || {-isJust ma ||-} isJust mt ] + + when (not (null missing)) $ + fail $ "Missing template files: " ++ intercalate ", " (map (<.> "st") missing) + ++ ". Search path was: " ++ intercalate " " templateDirs + + when (not (null problems)) $ + fail $ reportTemplateProblems problems + + where + reportTemplateProblems :: [(String, (Maybe String, Maybe [String], Maybe [String]))] -> String + reportTemplateProblems problems = + unlines + [ "Problem with template " ++ t ++ ":\n" + ++ formatTemplateProblem p + | (t, p) <- problems ] + + formatTemplateProblem :: (Maybe String, Maybe [String], Maybe [String]) -> String + formatTemplateProblem (Just e, _ma, _mt) = e + + formatTemplateProblem (_es, _ma, Just mt) = + "References to missing templates: " ++ intercalate ", " mt + formatTemplateProblem _ = "Unknown error with template" diff --git a/Distribution/Server/Packages/ChangeLog.hs b/Distribution/Server/Packages/ChangeLog.hs --- a/Distribution/Server/Packages/ChangeLog.hs +++ b/Distribution/Server/Packages/ChangeLog.hs @@ -3,35 +3,33 @@ 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(..)) +import Distribution.Server.Packages.Types (PkgInfo) +import Distribution.Package (packageId) +import Distribution.Text (display) -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 +import System.FilePath ((), splitExtension) +import Data.Char as Char +import Data.Maybe + + +findChangeLog :: PkgInfo -> TarIndex -> Maybe (TarEntryOffset, String) +findChangeLog pkg index = do + let topdir = display (packageId pkg) + TarIndex.TarDir fnames <- TarIndex.lookup index topdir + listToMaybe + [ (offset, fname') + | fname <- fnames + , isChangelogFile fname + , let fname' = topdir fname + , Just (TarIndex.TarFileEntry offset) <- [TarIndex.lookup index fname'] ] where - lookupFile fname = do - entry <- TarIndex.lookup index fname - case entry of - TarIndex.TarFileEntry offset -> return (offset, fname) - _ -> fail "is a directory" + isChangelogFile fname = + let (base, ext) = splitExtension fname + in map Char.toLower base `elem` basenames + && ext `elem` extensions - candidates = let pkgId = Pretty.render $ disp pkgInfoId - in map (pkgId ) $ filenames ++ map (++ ".html") filenames + basenames = ["changelog", "change_log", "changes"] + extensions = ["", ".txt", ".md", ".markdown"] - filenames = [ "ChangeLog" - , "CHANGELOG" - , "CHANGE_LOG" - , "Changelog" - , "changelog" - ] diff --git a/Distribution/Server/Packages/PackageIndex.hs b/Distribution/Server/Packages/PackageIndex.hs --- a/Distribution/Server/Packages/PackageIndex.hs +++ b/Distribution/Server/Packages/PackageIndex.hs @@ -50,8 +50,8 @@ import Prelude hiding (lookup) import Control.Exception (assert) -import qualified Data.Map as Map -import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) import qualified Data.Foldable as Foldable import Data.List (groupBy, sortBy, find, isInfixOf) import Data.Monoid (Monoid(..)) diff --git a/Distribution/Server/Packages/Render.hs b/Distribution/Server/Packages/Render.hs --- a/Distribution/Server/Packages/Render.hs +++ b/Distribution/Server/Packages/Render.hs @@ -49,7 +49,9 @@ rendHasTarball :: Bool, rendHasChangeLog :: Bool, rendUploadInfo :: (UTCTime, Maybe UserInfo), + rendUpdateInfo :: Maybe (Int, UTCTime, Maybe UserInfo), rendPkgUri :: String, + rendFlags :: [Flag], -- 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 @@ -75,9 +77,16 @@ , rendModules = fmap (moduleForest . exposedModules) (library flatDesc) , rendHasTarball = not . null $ pkgTarball info , rendHasChangeLog = hasChangeLog - , rendUploadInfo = let (utime, uid) = pkgUploadData info + , rendUploadInfo = let (utime, uid) = pkgOriginalUploadData info in (utime, Users.lookupUserId uid users) + , rendUpdateInfo = let revision = length (pkgDataOld info) + (utime, uid) = pkgUploadData info + uinfo = Users.lookupUserId uid users + in if revision > 0 + then Just (revision, utime, uinfo) + else Nothing , rendPkgUri = pkgUri + , rendFlags = genPackageFlags genDesc , rendOther = desc } where @@ -241,4 +250,3 @@ 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'])] - diff --git a/Distribution/Server/Packages/Types.hs b/Distribution/Server/Packages/Types.hs --- a/Distribution/Server/Packages/Types.hs +++ b/Distribution/Server/Packages/Types.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, StandaloneDeriving, TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, + StandaloneDeriving, TemplateHaskell, TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Server.Packages.Types @@ -13,9 +14,9 @@ ----------------------------------------------------------------------------- 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.Users.Types (UserId(..)) +import Distribution.Server.Framework.BlobStorage (BlobId, BlobId_v0) +import Distribution.Server.Framework.Instances (PackageIdentifier_v0) import Distribution.Server.Framework.MemSize import Distribution.Server.Util.Parse (unpackUTF8) @@ -26,24 +27,27 @@ import Distribution.PackageDescription.Parse ( parsePackageDescription, ParseResult(..) ) +import Control.Applicative import qualified Data.Serialize as Serialize import Data.Serialize (Serialize) import Data.ByteString.Lazy (ByteString) -import Data.Time.Clock (UTCTime) +import Data.Time.Clock (UTCTime(..)) +import Data.Time.Calendar (Day(..)) import Data.Typeable (Typeable) import Data.List (sortBy) import Data.Ord (comparing) import Data.SafeCopy + newtype CabalFileText = CabalFileText { cabalFileByteString :: ByteString } - deriving (Eq, Serialize, MemSize) + deriving (Eq, MemSize) cabalFileString :: CabalFileText -> String cabalFileString = unpackUTF8 . cabalFileByteString instance SafeCopy CabalFileText where - putCopy = contain . Serialize.put - getCopy = contain Serialize.get + putCopy (CabalFileText bs) = contain $ Serialize.put bs + getCopy = contain $ CabalFileText <$> Serialize.get instance Show CabalFileText where show cft = "CabalFileText (Data.ByteString.Lazy.Char8.pack (Distribution.Simple.Utils.toUTF8 " ++ show (cabalFileString cft) ++ "))" @@ -71,10 +75,6 @@ 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 @@ -91,11 +91,17 @@ type UploadInfo = (UTCTime, UserId) +-- The structure above should really be rearranged to make this less confusing. +-- The original upload info is the one at the end of the pkgDataOld. +pkgOriginalUploadData :: PkgInfo -> UploadInfo +pkgOriginalUploadData PkgInfo { pkgDataOld = [], pkgUploadData = uinfo } = uinfo +pkgOriginalUploadData PkgInfo { pkgDataOld = old@(_:_) } = snd (last old) + pkgUploadTime :: PkgInfo -> UTCTime -pkgUploadTime = fst . pkgUploadData +pkgUploadTime = fst . pkgOriginalUploadData pkgUploadUser :: PkgInfo -> UserId -pkgUploadUser = snd . pkgUploadData +pkgUploadUser = snd . pkgOriginalUploadData -- a small utility descendUploadTimes :: [(a, UploadInfo)] -> [(a, UploadInfo)] @@ -103,46 +109,74 @@ 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 +deriveSafeCopy 2 'extension ''PkgInfo +deriveSafeCopy 2 'extension ''PkgTarball 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 + +-------------------------- +-- Old SafeCopy versions +-- + +data PkgInfo_v0 = PkgInfo_v0 !PackageIdentifier_v0 !CabalFileText + ![(PkgTarball_v0, UploadInfo_v0)] + ![(CabalFileText, UploadInfo_v0)] + !UploadInfo_v0 + +instance SafeCopy PkgInfo_v0 +instance Serialize PkgInfo_v0 where + put (PkgInfo_v0 a (CabalFileText b) c d e) = + Serialize.put a + >> Serialize.put b + >> Serialize.put c + >> Serialize.put [ (bs, uinf) | (CabalFileText bs, uinf) <- d ] + >> Serialize.put e + get = PkgInfo_v0 <$> + Serialize.get + <*> (CabalFileText <$> Serialize.get) + <*> Serialize.get + <*> (map (\(bs,uinf) -> (CabalFileText bs, uinf)) <$> Serialize.get) + <*> Serialize.get + +instance Migrate PkgInfo where + type MigrateFrom PkgInfo = PkgInfo_v0 + migrate (PkgInfo_v0 a b c d e) = + PkgInfo (migrate a) b + [ (migrate pt, migrateUploadInfo ui) | (pt, ui) <- c ] + [ (cf, (migrateUploadInfo ui)) | (cf, ui) <- d ] + (migrateUploadInfo e) + where + migrateUploadInfo (UTCTime_v0 ts, UserId_v0 uid) = (ts, UserId uid) + + +type UploadInfo_v0 = (UTCTime_v0, UserId_v0) + +newtype UTCTime_v0 = UTCTime_v0 UTCTime +instance Serialize UTCTime_v0 where + put (UTCTime_v0 time) = do + Serialize.put (toModifiedJulianDay $ utctDay time) + Serialize.put (toRational $ utctDayTime time) + get = do + day <- Serialize.get + secs <- Serialize.get + return (UTCTime_v0 (UTCTime (ModifiedJulianDay day) (fromRational secs))) + +newtype UserId_v0 = UserId_v0 Int +instance Serialize UserId_v0 where + put (UserId_v0 x) = Serialize.put x + get = UserId_v0 <$> Serialize.get + + +data PkgTarball_v0 = PkgTarball_v0 !BlobId_v0 !BlobId_v0 +instance SafeCopy PkgTarball_v0 +instance Serialize PkgTarball_v0 where + put (PkgTarball_v0 a b) = Serialize.put a >> Serialize.put b + get = PkgTarball_v0 <$> Serialize.get <*> Serialize.get + +instance Migrate PkgTarball where + type MigrateFrom PkgTarball = PkgTarball_v0 + migrate (PkgTarball_v0 a b) = PkgTarball (migrate a) (migrate b) diff --git a/Distribution/Server/Packages/Unpack.hs b/Distribution/Server/Packages/Unpack.hs --- a/Distribution/Server/Packages/Unpack.hs +++ b/Distribution/Server/Packages/Unpack.hs @@ -5,7 +5,9 @@ unpackPackageRaw, ) where -import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Archive.Tar.Check as Tar import Distribution.Version ( Version(..) ) @@ -31,6 +33,10 @@ import Data.List ( nub, (\\), partition, intercalate ) +import Data.Time + ( UTCTime(..), fromGregorian, addUTCTime ) +import Data.Time.Clock.POSIX + ( posixSecondsToUTCTime ) import Control.Monad ( unless, when ) import Control.Monad.Error @@ -44,21 +50,21 @@ ( ByteString ) import qualified Data.ByteString.Lazy as LBS import System.FilePath - ( (), (<.>), splitExtension, splitDirectories, normalise ) + ( (), (<.>), splitDirectories, splitExtension, 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 +unpackPackage :: UTCTime -> FilePath -> ByteString -> Either String ((GenericPackageDescription, ByteString), [String]) -unpackPackage tarGzFile contents = +unpackPackage now tarGzFile contents = runUploadMonad $ do - (entries, pkgDesc, warnings, cabalEntry) <- basicChecks False tarGzFile contents + (pkgDesc, warnings, cabalEntry) <- basicChecks False now tarGzFile contents mapM_ fail warnings - extraChecks entries pkgDesc + extraChecks pkgDesc return (pkgDesc, cabalEntry) unpackPackageRaw :: FilePath -> ByteString @@ -66,12 +72,14 @@ ((GenericPackageDescription, ByteString), [String]) unpackPackageRaw tarGzFile contents = runUploadMonad $ do - (_entries, pkgDesc, _warnings, cabalEntry) <- basicChecks True tarGzFile contents + (pkgDesc, _warnings, cabalEntry) <- basicChecks True noTime tarGzFile contents return (pkgDesc, cabalEntry) + where + noTime = UTCTime (fromGregorian 1970 1 1) 0 -basicChecks :: Bool -> FilePath -> ByteString - -> UploadMonad (Tar.Entries Tar.FormatError, GenericPackageDescription, [String], ByteString) -basicChecks lax tarGzFile contents = do +basicChecks :: Bool -> UTCTime -> FilePath -> ByteString + -> UploadMonad (GenericPackageDescription, [String], ByteString) +basicChecks lax now tarGzFile contents = do let (pkgidStr, ext) = (base, tar ++ gz) where (tarFile, gz) = splitExtension (portableTakeFileName tarGzFile) (base, tar) = splitExtension tarFile @@ -80,14 +88,24 @@ pkgid <- case simpleParse pkgidStr of Just pkgid + | null . versionBranch . packageVersion $ pkgid + -> fail $ "Invalid package id " ++ quote pkgidStr + ++ ". It must include the package version number, and not just " + ++ "the package name, e.g. 'foo-1.0'." + | 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 + _ -> fail $ "Invalid package id " ++ quote pkgidStr ++ ". The tarball must use the name of the package." + -- Extract entries and check the tar format / portability + let entries = tarballChecks lax now expectedDir + $ Tar.read (GZip.decompressNamed tarGzFile contents) + expectedDir = display pkgid + -- Extract the .cabal file from the tarball let selectEntry entry = case Tar.entryContent entry of Tar.NormalFile bs _ | cabalFileName == normalise (Tar.entryPath entry) @@ -95,8 +113,7 @@ _ -> Nothing PackageName name = packageName pkgid cabalFileName = display pkgid name <.> "cabal" - entries = Tar.read (GZip.decompressNamed tarGzFile contents) - cabalEntries <- selectEntries lax selectEntry entries + cabalEntries <- selectEntries explainTarError 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). @@ -123,7 +140,7 @@ when (packageVersion pkgDesc /= packageVersion pkgid) $ fail "Package version in the cabal file does not match the file name." - return (entries, pkgDesc, warnings, cabalEntry) + return (pkgDesc, warnings, cabalEntry) where showError (Nothing, msg) = msg @@ -138,8 +155,8 @@ portableTakeFileName = System.FilePath.Windows.takeFileName -- Miscellaneous checks on package description -extraChecks :: Tar.Entries Tar.FormatError -> GenericPackageDescription -> UploadMonad () -extraChecks entries genPkgDesc = do +extraChecks :: GenericPackageDescription -> UploadMonad () +extraChecks genPkgDesc = do let pkgDesc = flattenPackageDescription genPkgDesc -- various checks @@ -162,13 +179,6 @@ 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 -> [] @@ -199,58 +209,116 @@ "Distribution", "DotNet", "Foreign", "Graphics", "Language", "Network", "Numeric", "Prelude", "Sound", "System", "Test", "Text"] -selectEntries :: Bool -> (Tar.Entry -> Maybe a) - -> Tar.Entries Tar.FormatError +selectEntries :: (err -> String) + -> (Tar.Entry -> Maybe a) + -> Tar.Entries err -> UploadMonad [a] -selectEntries lax select = extract [] +selectEntries formatErr 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 _ (Tar.Fail err) = fail (formatErr 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 +data CombinedTarErrs = + FormatError Tar.FormatError + | PortabilityError Tar.PortabilityError + | TarBombError FilePath FilePath + | FutureTimeError FilePath UTCTime - | 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." +tarballChecks :: Bool -> UTCTime -> FilePath + -> Tar.Entries Tar.FormatError + -> Tar.Entries CombinedTarErrs +tarballChecks lax now expectedDir = + (if not lax then checkFutureTimes now else id) + . checkTarbomb expectedDir + . (if lax then ignoreShortTrailer + else fmapTarError (either id PortabilityError) + . Tar.checkPortability) + . fmapTarError FormatError + where + ignoreShortTrailer = + Tar.foldEntries Tar.Next Tar.Done + (\e -> case e of + FormatError Tar.ShortTrailer -> Tar.Done + _ -> Tar.Fail e) + fmapTarError f = Tar.foldEntries Tar.Next Tar.Done (Tar.Fail . f) -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 +checkFutureTimes :: UTCTime + -> Tar.Entries CombinedTarErrs + -> Tar.Entries CombinedTarErrs +checkFutureTimes now = + checkEntries checkEntry where - dirs = splitDirectories (Tar.entryPath entry) - pkgstr = display pkgid - inPkgSubdir (".":pkgstr':_) = pkgstr == pkgstr' - inPkgSubdir ( pkgstr':_) = pkgstr == pkgstr' - inPkgSubdir _ = False + -- Allow 30s for client clock skew + now' = addUTCTime 30 now + checkEntry entry + | entryUTCTime > now' + = Just (FutureTimeError posixPath entryUTCTime) + where + entryUTCTime = posixSecondsToUTCTime (realToFrac (Tar.entryTime entry)) + posixPath = Tar.fromTarPathToPosixPath (Tar.entryTarPath entry) + + checkEntry _ = Nothing + +checkTarbomb :: FilePath -> Tar.Entries CombinedTarErrs -> Tar.Entries CombinedTarErrs +checkTarbomb expectedTopDir = + checkEntries checkEntry + where + checkEntry entry = + case splitDirectories (Tar.entryPath entry) of + (topDir:_) | topDir == expectedTopDir -> Nothing + _ -> Just $ TarBombError (Tar.entryPath entry) expectedTopDir + +checkEntries :: (Tar.Entry -> Maybe e) -> Tar.Entries e -> Tar.Entries e +checkEntries checkEntry = + Tar.foldEntries (\entry rest -> maybe (Tar.Next entry rest) Tar.Fail + (checkEntry entry)) + Tar.Done Tar.Fail + +explainTarError :: CombinedTarErrs -> String +explainTarError (TarBombError filename expectedDir) = + "Bad file name in package tarball: " ++ quote filename + ++ "\nAll the file in the package tarball must be in the subdirectory " + ++ quote expectedDir ++ "." +explainTarError (PortabilityError (Tar.NonPortableFormat Tar.GnuFormat)) = + "This tarball is in the non-standard GNU tar format. " + ++ "For portability and long-term data preservation, hackage requires that " + ++ "package tarballs use the standard 'ustar' format. If you are using GNU " + ++ "tar, use --format=ustar to get the standard portable format." +explainTarError (PortabilityError (Tar.NonPortableFormat Tar.V7Format)) = + "This tarball is in the old Unix V7 tar format. " + ++ "For portability and long-term data preservation, hackage requires that " + ++ "package tarballs use the standard 'ustar' format. Virtually all tar " + ++ "programs can now produce ustar format (POSIX 1988). For example if you " + ++ "are using GNU tar, use --format=ustar to get the standard portable format." +explainTarError (PortabilityError (Tar.NonPortableFormat Tar.UstarFormat)) = + error "explainTarError: impossible UstarFormat" +explainTarError (PortabilityError Tar.NonPortableFileType) = + "The package tarball contains a non-portable entry type. " + ++ "For portability, package tarballs should use the 'ustar' format " + ++ "and only contain normal files, directories and file links." +explainTarError (PortabilityError (Tar.NonPortableEntryNameChar _)) = + "The package tarball contains an entry with a non-ASCII file name. " + ++ "For portability, package tarballs should contain only ASCII file names " + ++ "(e.g. not UTF8 encoded Unicode)." +explainTarError (PortabilityError (err@Tar.NonPortableFileName {})) = + show err + ++ ". For portability, hackage requires that file names be valid on both Unix " + ++ "and Windows systems, and not refer outside of the tarball." +explainTarError (FormatError formateror) = + "There is an error in the format of the tar file: " ++ show formateror + ++ ". Check that it is a valid tar file (e.g. 'tar -xtf thefile.tar'). " + ++ "You may need to re-create the package tarball and try again." +explainTarError (FutureTimeError entryname time) = + "The tarball entry " ++ quote entryname ++ " has a file timestamp that is " + ++ "in the future (" ++ show time ++ "). This tends to cause problems " + ++ "for build systems and other tools, so hackage does not allow it. This " + ++ "problem can be caused by having a misconfigured system time, or by bugs " + ++ "in the tools (tarballs created by 'cabal sdist' on Windows with " + ++ "cabal-install-1.18.0.2 or older have this problem)." quote :: String -> String quote s = "'" ++ s ++ "'" diff --git a/Distribution/Server/Pages/BuildReports.hs b/Distribution/Server/Pages/BuildReports.hs deleted file mode 100644 --- a/Distribution/Server/Pages/BuildReports.hs +++ /dev/null @@ -1,96 +0,0 @@ --- 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] - diff --git a/Distribution/Server/Pages/Package.hs b/Distribution/Server/Pages/Package.hs --- a/Distribution/Server/Pages/Package.hs +++ b/Distribution/Server/Pages/Package.hs @@ -25,14 +25,15 @@ import Distribution.Text (display) import Text.XHtml.Strict hiding (p, name, title, content) +import Data.Monoid (Monoid(..)) 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 = +packagePage :: PackageRender -> [Html] -> [Html] -> [(String, Html)] -> [(String, Html)] -> Maybe URL -> Bool -> Html +packagePage render headLinks top sections bottom docURL isCandidate = hackagePageWith [] docTitle docSubtitle docBody [docFooter] where pkgid = rendPkgId render @@ -43,16 +44,15 @@ short -> ": " ++ short docSubtitle = toHtml docTitle - docBody = - h1 << - bodyTitle : - concat [ + docBody = h1 << bodyTitle + : concat [ renderHeads, top, pkgBody render sections, moduleSection render docURL, + packageFlags render, downloadSection render, - maintainerSection pkgid, + maintainerSection pkgid isCandidate, map pair bottom ] bodyTitle = "The " ++ display (pkgName pkgid) ++ " package" @@ -76,14 +76,25 @@ -- | Body of the package page pkgBody :: PackageRender -> [(String, Html)] -> [Html] pkgBody render sections = - prologue (description $ rendOther render) ++ - propertySection sections + descriptionSection render + ++ propertySection sections +descriptionSection :: PackageRender -> [Html] +descriptionSection PackageRender{..} = + prologue (description rendOther) + ++ [ hr + , ulist << li << changelogLink] + where + changelogLink + | rendHasChangeLog = anchor ! [href changeLogURL] << "Changelog" + | otherwise = toHtml << "No changelog available" + changeLogURL = rendPkgUri "changelog" + prologue :: String -> [Html] prologue [] = [] prologue desc = case tokenise desc >>= parseHaddockParagraphs of - Left _ -> [paragraph << p | p <- paragraphs desc] - Right doc -> [markup htmlMarkup doc] + Nothing -> [paragraph << p | p <- paragraphs desc] + Just doc -> [markup htmlMarkup doc] -- Break text into paragraphs (separated by blank lines) paragraphs :: String -> [String] @@ -111,36 +122,69 @@ , [ 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 = +maintainerSection :: PackageId -> Bool -> [Html] +maintainerSection pkgid isCandidate = [ h4 << "Maintainers' corner" , paragraph << "For package maintainers and hackage trustees" , ulist << li << anchor ! [href maintainURL] << "edit package information" ] where - maintainURL = display (packageName pkgid) "maintain" + maintainURL | isCandidate = "candidate/maintain" + | otherwise = display (packageName pkgid) "maintain" +-- | Render a table of the package's flags and along side it a tip +-- indicating how to enable/disable flags with Cabal. +packageFlags :: PackageRender -> [Html] +packageFlags render = + case rendFlags render of + [] -> mempty + flags -> + [h2 << "Flags" + ,flagsTable flags + ,tip] + where tip = + paragraph ! [theclass "tip"] << + [thespan << "Use " + ,code "-f " + ,thespan << " to enable a flag, or " + ,code "-f -" + ,thespan << " to disable that flag. " + ,anchor ! [href tipLink] << "More info" + ] + tipLink = "http://www.haskell.org/cabal/users-guide/installing-packages.html#controlling-flag-assignments" + flagsTable flags = + table ! [theclass "flags-table"] << + [thead << flagsHeadings + ,tbody << map flagRow flags] + flagsHeadings = [th << "Name" + ,th << "Description" + ,th << "Default"] + flagRow flag = + tr << [td ! [theclass "flag-name"] << code (case flagName flag of FlagName name -> name) + ,td ! [theclass "flag-desc"] << flagDescription flag + ,td ! [theclass (if flagDefault flag then "flag-enabled" else "flag-disabled")] << + if flagDefault flag then "Enabled" else "Disabled"] + code = (thespan ! [theclass "code"] <<) + moduleSection :: PackageRender -> Maybe URL -> [Html] moduleSection render docURL = maybeToList $ fmap msect (rendModules render) where msect lib = toHtml [ h2 << "Modules" , renderModuleForest docURL lib + , renderDocIndexLink docURL ] + renderDocIndexLink = maybe mempty $ \docURL' -> + let docIndexURL = docURL' "doc-index.html" + in paragraph ! [thestyle "font-size: small"] + << ("[" +++ anchor ! [href docIndexURL] << "Index" +++ "]") propertySection :: [(String, Html)] -> [Html] propertySection sections = @@ -149,8 +193,8 @@ ] tabulate :: [(String, Html)] -> Html -tabulate items = table << - [tr << [th ! [align "left", valign "top"] << t, td << d] | (t, d) <- items] +tabulate items = table ! [theclass "properties"] << + [tr << [th << t, td << d] | (t, d) <- items] renderDependencies :: PackageRender -> (String, Html) @@ -198,10 +242,11 @@ -- 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 -} = +renderDownloads :: Int -> Int -> {- Int -> Version -> -} (String, Html) +renderDownloads totalDown recentDown {- versionDown version -} = ("Downloads", toHtml $ {- show versionDown ++ " for " ++ display version ++ - " and " ++ -} show totalDown ++ " total") + " and " ++ -} show totalDown ++ " total (" ++ + show recentDown ++ " in last 30 days)") renderFields :: PackageRender -> [(String, Html)] renderFields render = [ @@ -216,25 +261,36 @@ ("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) + ("Uploaded", uncurry renderUploadInfo (rendUploadInfo render)) ] - where desc = rendOther render - (utime, uinfo) = rendUploadInfo render - uname = maybe "Unknown" (display . userName) uinfo + ++ [ ("Updated", renderUpdateInfo revisionNo utime uinfo) + | (revisionNo, utime, uinfo) <- maybeToList (rendUpdateInfo render) ] + where + desc = rendOther render + renderUploadInfo utime uinfo = + formatTime defaultTimeLocale "%c" utime +++ " by " +++ user + where + 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 + user | uactive = anchor ! [href $ "/user/" ++ uname] << uname + | otherwise = toHtml uname + renderUpdateInfo revisionNo utime uinfo = + renderUploadInfo utime uinfo +++ " to " +++ + anchor ! [href revisionsURL] << ("revision " +++ show revisionNo) + where + revisionsURL = display (rendPkgId render) "revisions/" + + 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 + sourceRepositoryField sr = sourceRepositoryToHtml sr + + sourceRepositoryToHtml :: SourceRepo -> Html sourceRepositoryToHtml sr = toHtml (display (repoKind sr) ++ ": ") @@ -285,10 +341,16 @@ Just sd -> toHtml ("(" ++ sd ++ ")") Nothing -> noHtml] Just Mercurial - | (Just url, Nothing, Nothing, Nothing) <- - (repoLocation sr, repoModule sr, repoBranch sr, repoTag sr) -> + | (Just url, Nothing) <- + (repoLocation sr, repoModule sr) -> concatHtml [toHtml "hg clone ", anchor ! [href url] << toHtml url, + case repoBranch sr of + Just branch -> toHtml (" -b " ++ branch) + Nothing -> noHtml, + case repoTag sr of + Just tag' -> toHtml (" -u " ++ tag') + Nothing -> noHtml, case repoSubdir sr of Just sd -> toHtml ("(" ++ sd ++ ")") Nothing -> noHtml] diff --git a/Distribution/Server/Pages/Package/HaddockHtml.hs b/Distribution/Server/Pages/Package/HaddockHtml.hs --- a/Distribution/Server/Pages/Package/HaddockHtml.hs +++ b/Distribution/Server/Pages/Package/HaddockHtml.hs @@ -1,58 +1,18 @@ --- stolen from Haddock's HsSyn.lhs and HaddockHtml.hs +-- stolen from Haddock's Util.hs and Doc.hs module Distribution.Server.Pages.Package.HaddockHtml where +import Distribution.Server.Pages.Package.HaddockTypes import Data.Char (isSpace) +import Data.Maybe (fromMaybe) 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 :: DocMarkup id a -> Doc 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 (DocIdentifier x) = markupIdentifier m x 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) @@ -60,15 +20,16 @@ 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 (DocHyperlink l) = markupHyperlink m l markup m (DocAName ref) = markupAName m ref +markup m (DocPic img) = markupPic m img -markupPair :: DocMarkup id a -> (GenDoc id, GenDoc id) -> (a, a) +markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a) markupPair m (a,b) = (markup m a, markup m b) + -- | The identity markup -idMarkup :: DocMarkup a (GenDoc a) +idMarkup :: DocMarkup a (Doc a) idMarkup = Markup { markupEmpty = DocEmpty, markupString = DocString, @@ -82,16 +43,16 @@ markupOrderedList = DocOrderedList, markupDefList = DocDefList, markupCodeBlock = DocCodeBlock, - markupURL = DocURL, - markupPic = DocPic, - markupAName = DocAName + markupHyperlink = DocHyperlink, + markupAName = DocAName, + markupPic = DocPic } htmlMarkup :: DocMarkup String Html htmlMarkup = Markup { - markupParagraph = paragraph, - markupEmpty = toHtml "", + markupEmpty = noHtml, markupString = toHtml, + markupParagraph = paragraph, markupAppend = (+++), markupIdentifier = tt . toHtml . init . tail, markupModule = tt . toHtml, @@ -101,9 +62,9 @@ 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 "" + markupHyperlink = \(Hyperlink url mLabel) -> anchor ! [href url] << toHtml (fromMaybe url mLabel), + markupAName = \aname -> namedAnchor aname << toHtml "", + markupPic = \path -> image ! [src path] } where markupDef (a,b) = dterm << a +++ ddef << b @@ -117,7 +78,7 @@ -- ** Smart constructors -- used to make parsing easier; we group the list items later -docAppend :: Doc -> Doc -> Doc +docAppend :: Doc id -> Doc id -> Doc id docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) = DocUnorderedList (ds1++ds2) docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d) @@ -135,20 +96,39 @@ 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 :: Doc id -> Doc id docParagraph (DocMonospaced p) - = DocCodeBlock p + = DocCodeBlock (docCodeBlock p) docParagraph (DocAppend (DocString s1) (DocMonospaced p)) | all isSpace s1 - = DocCodeBlock p + = DocCodeBlock (docCodeBlock p) docParagraph (DocAppend (DocString s1) - (DocAppend (DocMonospaced p) (DocString s2))) + (DocAppend (DocMonospaced p) (DocString s2))) | all isSpace s1 && all isSpace s2 - = DocCodeBlock p + = DocCodeBlock (docCodeBlock p) docParagraph (DocAppend (DocMonospaced p) (DocString s2)) | all isSpace s2 - = DocCodeBlock p + = DocCodeBlock (docCodeBlock p) docParagraph p = DocParagraph p + + +-- Drop trailing whitespace from @..@ code blocks. Otherwise this: +-- +-- -- @ +-- -- foo +-- -- @ +-- +-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML +-- gives an extra vertical space after the code block. The single space +-- on the final line seems to trigger the extra vertical space. +-- +docCodeBlock :: Doc id -> Doc id +docCodeBlock (DocString s) + = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s) +docCodeBlock (DocAppend l r) + = DocAppend l (docCodeBlock r) +docCodeBlock d = d diff --git a/Distribution/Server/Pages/Package/HaddockLex.x b/Distribution/Server/Pages/Package/HaddockLex.x --- a/Distribution/Server/Pages/Package/HaddockLex.x +++ b/Distribution/Server/Pages/Package/HaddockLex.x @@ -20,8 +20,10 @@ import Data.Char import Data.Word (Word8) +import qualified Data.Bits import Numeric import Control.Monad (liftM) +import Distribution.Server.Pages.Package.HaddockTypes (RdrName) } $ws = $white # \n @@ -29,7 +31,7 @@ $hexdigit = [0-9a-fA-F] $special = [\"\@] $alphanum = [A-Za-z0-9] -$ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~] +$ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:] :- @@ -56,13 +58,13 @@ () { begin string } } - .* \n? { strtoken TokBirdTrack `andBegin` line } + .* \n? { strtokenNL TokBirdTrack `andBegin` line } { $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 -> 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) } @@ -71,7 +73,7 @@ -- 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 \'\` \& \\ \]]* \n { strtokenNL TokString `andBegin` line } [^ $special \/ \< \# \n \'\` \& \\ \]]+ { strtoken TokString } } @@ -93,7 +95,7 @@ | TokDefStart | TokDefEnd | TokSpecial Char - | TokIdent String + | TokIdent RdrName | TokString String | TokURL String | TokPic String @@ -106,32 +108,58 @@ -- Alex support stuff type StartCode = Int -type Action = String -> StartCode -> (StartCode -> Either String [Token]) -> Either String [Token] +type Action = String -> StartCode -> (StartCode -> Maybe [Token]) -> Maybe [Token] -type AlexInput = (Char,String) +--TODO: we ought to switch to ByteString input. +type AlexInput = (Char, [Word8], String) -- | For alex >= 3 -- -- See also alexGetChar -alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) -alexGetByte (_, []) = Nothing -alexGetByte (_, c:cs) = Just (fromIntegral (ord c), (c,cs)) +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte (c,(b:bs),s) = Just (b,(c,bs,s)) +alexGetByte (c,[],[]) = Nothing +alexGetByte (_,[],(c:s)) = case utf8Encode c of + (b:bs) -> Just (b, (c, bs, s)) +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +utf8Encode :: Char -> [Word8] +utf8Encode = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) + , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + -- | For alex < 3 -- -- See also alexGetByte alexGetChar :: AlexInput -> Maybe (Char, AlexInput) -alexGetChar (_, []) = Nothing -alexGetChar (_, c:cs) = Just (c, (c,cs)) +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 = +tokenise :: String -> Maybe [Token] +tokenise str = + go ('\n', [], eofHack str) para + where + go inp@(_,_,str') sc = case alexScan inp sc of - AlexEOF -> Right [] - AlexError _ -> Left "lexical error" + AlexEOF -> Just [] + AlexError _ -> Nothing AlexSkip inp' _ -> go inp' sc AlexToken inp' len act -> act (take len str') sc (\sc' -> go inp' sc') @@ -145,8 +173,11 @@ token :: Token -> Action token t = \_ sc cont -> liftM (t :) (cont sc) -strtoken :: (String -> Token) -> Action +strtoken, strtokenNL :: (String -> Token) -> Action strtoken t = \str sc cont -> liftM (t str :) (cont sc) +strtokenNL t = \str sc cont -> liftM (t (filter (/= '\r') str) :) (cont sc) +-- ^ We only want LF line endings in our internal doc string format, so we +-- filter out all CRs. begin :: StartCode -> Action begin sc = \_ _ cont -> cont sc diff --git a/Distribution/Server/Pages/Package/HaddockParse.y b/Distribution/Server/Pages/Package/HaddockParse.y --- a/Distribution/Server/Pages/Package/HaddockParse.y +++ b/Distribution/Server/Pages/Package/HaddockParse.y @@ -12,8 +12,12 @@ import Distribution.Server.Pages.Package.HaddockLex import Distribution.Server.Pages.Package.HaddockHtml +import Distribution.Server.Pages.Package.HaddockTypes +import Data.Char (isSpace) } +%expect 0 + %tokentype { Token } %token @@ -32,59 +36,59 @@ PARA { TokPara } STRING { TokString $$ } -%monad { Either String } +%monad { Maybe } %name parseHaddockParagraphs doc %name parseHaddockString seq %% -doc :: { Doc } +doc :: { Doc RdrName } : apara PARA doc { docAppend $1 $3 } | PARA doc { $2 } | apara { $1 } | {- empty -} { DocEmpty } -apara :: { Doc } +apara :: { Doc RdrName } : ulpara { DocUnorderedList [$1] } | olpara { DocOrderedList [$1] } | defpara { DocDefList [$1] } | para { $1 } -ulpara :: { Doc } +ulpara :: { Doc RdrName } : '-' para { $2 } -olpara :: { Doc } +olpara :: { Doc RdrName } : '(n)' para { $2 } -defpara :: { (Doc,Doc) } +defpara :: { (Doc RdrName, Doc RdrName) } : '[' seq ']' seq { ($2, $4) } -para :: { Doc } +para :: { Doc RdrName } : seq { docParagraph $1 } | codepara { DocCodeBlock $1 } -codepara :: { Doc } +codepara :: { Doc RdrName } : '>..' codepara { docAppend (DocString $1) $2 } | '>..' { DocString $1 } -seq :: { Doc } +seq :: { Doc RdrName } : elem seq { docAppend $1 $2 } | elem { $1 } -elem :: { Doc } +elem :: { Doc RdrName } : elem1 { $1 } | '@' seq1 '@' { DocMonospaced $2 } -seq1 :: { Doc } +seq1 :: { Doc RdrName } : PARA seq1 { docAppend (DocString "\n") $2 } | elem1 seq1 { docAppend $1 $2 } | elem1 { $1 } -elem1 :: { Doc } +elem1 :: { Doc RdrName } : STRING { DocString $1 } | '/../' { DocEmphasis (DocString $1) } - | URL { DocURL $1 } + | URL { DocHyperlink (makeHyperlink $1) } | PIC { DocPic $1 } | ANAME { DocAName $1 } | IDENT { DocIdentifier $1 } @@ -95,7 +99,19 @@ | STRING strings { $1 ++ $2 } { -happyError :: [Token] -> Either String a -happyError toks = - Left ("parse error in doc string: " ++ show (take 3 toks)) +happyError :: [Token] -> Maybe a +happyError toks = Nothing + +-- | Create a `Hyperlink` from given string. +-- +-- A hyperlink consists of a URL and an optional label. The label is separated +-- from the url by one or more whitespace characters. +makeHyperlink :: String -> Hyperlink +makeHyperlink input = case break isSpace $ strip input of + (url, "") -> Hyperlink url Nothing + (url, label) -> Hyperlink url (Just . dropWhile isSpace $ label) + +-- | Remove all leading and trailing whitespace +strip :: String -> String +strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse } diff --git a/Distribution/Server/Pages/Package/HaddockTypes.hs b/Distribution/Server/Pages/Package/HaddockTypes.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Pages/Package/HaddockTypes.hs @@ -0,0 +1,48 @@ +-- stolen from Haddock's Types.hs +module Distribution.Server.Pages.Package.HaddockTypes where + +data Doc id + = DocEmpty + | DocAppend (Doc id) (Doc id) + | DocString String + | DocParagraph (Doc id) + | DocIdentifier id + | DocModule String + | DocEmphasis (Doc id) + | DocMonospaced (Doc id) + | DocUnorderedList [Doc id] + | DocOrderedList [Doc id] + | DocDefList [(Doc id, Doc id)] + | DocCodeBlock (Doc id) + | DocHyperlink Hyperlink + | DocPic String + | DocAName String + +data Hyperlink = Hyperlink + { hyperlinkUrl :: String + , hyperlinkLabel :: Maybe String + } deriving (Eq, Show) + +-- | DocMarkup is a set of instructions for marking up documentation. +-- In fact, it's really just a mapping from 'Doc' 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, + markupHyperlink :: Hyperlink -> a, + markupAName :: String -> a, + markupPic :: String -> a + } + +type RdrName = String diff --git a/Distribution/Server/Pages/Recent.hs b/Distribution/Server/Pages/Recent.hs --- a/Distribution/Server/Pages/Recent.hs +++ b/Distribution/Server/Pages/Recent.hs @@ -49,10 +49,7 @@ in hackagePageWithHead [rss_link] "recent additions" docBody makeRow :: Users -> PkgInfo -> Html -makeRow users PkgInfo { - pkgInfoId = pkgid - , pkgUploadData = (time, userId) - } = +makeRow users pkginfo = XHtml.tr << [XHtml.td ! [XHtml.align "right"] << [XHtml.toHtml (showTime time), nbsp, nbsp], @@ -60,9 +57,13 @@ 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 + where + nbsp = XHtml.primHtmlChar "nbsp" + user = Users.userIdToName users userId + (time, userId) = pkgOriginalUploadData pkginfo + pkgid = pkgInfoId pkginfo + showTime :: UTCTime -> String showTime = formatTime defaultTimeLocale "%c" @@ -96,13 +97,10 @@ , RSS.Generator "rss-feed" ] where - email = "duncan@haskell.org (Duncan Coutts)" + email = "admin@hackage.haskell.org" --TODO: make this configurable releaseItem :: Users -> URI -> PkgInfo -> [RSS.ItemElem] -releaseItem users hostURI pkgInfo@(PkgInfo { - pkgInfoId = pkgId - , pkgUploadData = (time, userId) - }) = +releaseItem users hostURI pkgInfo = [ RSS.Title title , RSS.Link uri , RSS.Guid True (uriToString id uri "") @@ -116,6 +114,9 @@ desc = "Added by " ++ display user ++ ", " ++ showTime time ++ "." ++ if null body then "" else "

" ++ body user = Users.userIdToName users userId + + (time, userId) = pkgOriginalUploadData pkgInfo + pkgId = pkgInfoId pkgInfo unPackageName :: PackageName -> String unPackageName (PackageName name) = name diff --git a/Distribution/Server/Pages/Template.hs b/Distribution/Server/Pages/Template.hs --- a/Distribution/Server/Pages/Template.hs +++ b/Distribution/Server/Pages/Template.hs @@ -25,7 +25,7 @@ toHtml [ header << (docHead ++ headExtra) , body << (docBody ++ bodyExtra) ] where - docHead = [ thetitle << ("Hackage: " ++ docTitle) + docHead = [ thetitle << (docTitle ++ " | Hackage") , thelink ! [ rel "stylesheet" , href stylesheetURL , thetype "text/css"] << noHtml @@ -78,5 +78,5 @@ -- URL of the list of recent additions to the database recentAdditionsURL :: URL -recentAdditionsURL = "/recent" +recentAdditionsURL = "/packages/recent" diff --git a/Distribution/Server/Users/Backup.hs b/Distribution/Server/Users/Backup.hs --- a/Distribution/Server/Users/Backup.hs +++ b/Distribution/Server/Users/Backup.hs @@ -14,7 +14,9 @@ import Distribution.Server.Users.Group (UserList(..)) import qualified Distribution.Server.Users.Group as Group import Distribution.Server.Users.Types +import qualified Distribution.Server.Framework.Auth as Auth +import Distribution.Server.Framework.BackupDump (BackupType(..)) import Distribution.Server.Framework.BackupRestore import Distribution.Text (display) import Data.Version @@ -108,8 +110,8 @@ 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 +usersToCSV :: BackupType -> Users -> CSV +usersToCSV backuptype users = ([showVersion userCSVVer]:) $ (usersCSVKey:) $ @@ -117,7 +119,9 @@ [ display uid , display (userName uinfo) , infoToStatus uinfo - , infoToAuth uinfo + , if backuptype == FullBackup + then infoToAuth uinfo + else scrubbedAuth uinfo ] where @@ -128,6 +132,17 @@ , "auth-info" ] userCSVVer = Version [0,2] [] + + scrubbedAuth :: UserInfo -> String + scrubbedAuth userInfo = case userStatus userInfo of + AccountEnabled (UserAuth (PasswdHash _)) -> testHash userInfo + AccountDisabled (Just (UserAuth (PasswdHash _))) -> testHash userInfo + _ -> "" + + testHash :: UserInfo -> String + testHash userInfo = case Auth.newPasswdHash Auth.hackageRealm + (userName userInfo) (PasswdPlain "test") of + PasswdHash pwd -> pwd -- one of "enabled" "disabled" or "deleted" infoToStatus :: UserInfo -> String diff --git a/Distribution/Server/Users/Group.hs b/Distribution/Server/Users/Group.hs --- a/Distribution/Server/Users/Group.hs +++ b/Distribution/Server/Users/Group.hs @@ -21,21 +21,17 @@ 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 Control.Applicative ((<$>)) 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 + deriving (Eq, Monoid, Typeable, Show, MemSize) empty :: UserList empty = UserList IntSet.empty @@ -100,6 +96,11 @@ queryGroups :: [UserGroup] -> IO UserList queryGroups = fmap unions . mapM queryUserList + + +instance SafeCopy UserList where + putCopy (UserList x) = contain $ Serialize.put x + getCopy = contain $ UserList <$> Serialize.get -- for use in Caches, really... instance NFData GroupDescription where diff --git a/Distribution/Server/Users/State.hs b/Distribution/Server/Users/State.hs --- a/Distribution/Server/Users/State.hs +++ b/Distribution/Server/Users/State.hs @@ -9,7 +9,7 @@ import Distribution.Server.Users.Types import Distribution.Server.Users.Group as Group (UserList(..), add, remove, empty) -import Distribution.Server.Users.Users as Users +import qualified Distribution.Server.Users.Users as Users import Data.Acid (Query, Update, makeAcidic) import Data.SafeCopy (base, deriveSafeCopy) @@ -18,42 +18,42 @@ import Control.Monad.Reader import qualified Control.Monad.State as State -initialUsers :: Users +initialUsers :: Users.Users initialUsers = Users.emptyUsers -------------------------------------------- -- Returns 'Nothing' if the user name is in use -addUserEnabled :: UserName -> UserAuth -> Update Users (Either Users.ErrUserNameClash UserId) +addUserEnabled :: UserName -> UserAuth -> Update Users.Users (Either Users.ErrUserNameClash UserId) addUserEnabled uname auth = updateUsers $ Users.addUserEnabled uname auth -addUserDisabled :: UserName -> Update Users (Either Users.ErrUserNameClash UserId) +addUserDisabled :: UserName -> Update Users.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 :: UserId -> Bool -> Update Users.Users (Maybe (Either Users.ErrNoSuchUserId Users.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 :: UserId -> Update Users.Users (Maybe Users.ErrNoSuchUserId) deleteUser uid = updateUsers_ $ Users.deleteUser uid --- Set the user autenication info -setUserAuth :: UserId -> UserAuth -> Update Users (Maybe (Either ErrNoSuchUserId ErrDeletedUser)) +-- Set the user authentication info +setUserAuth :: UserId -> UserAuth -> Update Users.Users (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser)) setUserAuth userId auth = updateUsers_ $ Users.setUserAuth userId auth -setUserName :: UserId -> UserName -> Update Users (Maybe (Either ErrNoSuchUserId ErrUserNameClash)) +setUserName :: UserId -> UserName -> Update Users.Users (Maybe (Either Users.ErrNoSuchUserId Users.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_ :: (Users.Users -> Either err Users.Users) -> Update Users.Users (Maybe err) updateUsers_ upd = do users <- State.get case upd users of @@ -62,7 +62,7 @@ return Nothing -- Helper function for updating the users db -updateUsers :: (Users -> Either err (Users, a)) -> Update Users (Either err a) +updateUsers :: (Users.Users -> Either err (Users.Users, a)) -> Update Users.Users (Either err a) updateUsers upd = do users <- State.get case upd users of @@ -70,21 +70,21 @@ Right (users',a) -> do State.put users' return (Right a) -getUserDb :: Query Users Users +getUserDb :: Query Users.Users Users.Users getUserDb = ask -replaceUserDb :: Users -> Update Users () +replaceUserDb :: Users.Users -> Update Users.Users () replaceUserDb = State.put -$(makeAcidic ''Users ['addUserEnabled - ,'addUserDisabled - ,'setUserEnabledStatus - ,'setUserAuth - ,'setUserName - ,'deleteUser - ,'getUserDb - ,'replaceUserDb - ]) +$(makeAcidic ''Users.Users [ 'addUserEnabled + , 'addUserDisabled + , 'setUserEnabledStatus + , 'setUserAuth + , 'setUserName + , 'deleteUser + , 'getUserDb + , 'replaceUserDb + ]) ----------------------------------------------------- diff --git a/Distribution/Server/Users/Types.hs b/Distribution/Server/Users/Types.hs --- a/Distribution/Server/Users/Types.hs +++ b/Distribution/Server/Users/Types.hs @@ -14,17 +14,17 @@ import qualified Text.PrettyPrint as Disp import qualified Data.Char as Char -import Data.Serialize (Serialize) import Control.Applicative ((<$>)) - +import Data.Aeson (ToJSON, FromJSON) import Data.SafeCopy (base, deriveSafeCopy) import Data.Typeable (Typeable) + newtype UserId = UserId Int - deriving (Eq, Ord, Show, Serialize, Typeable, MemSize) + deriving (Eq, Ord, Show, Typeable, MemSize, ToJSON, FromJSON) newtype UserName = UserName String - deriving (Eq, Ord, Show, Serialize, Typeable, MemSize) + deriving (Eq, Ord, Show, Typeable, MemSize, ToJSON, FromJSON) data UserInfo = UserInfo { userName :: !UserName, @@ -62,8 +62,10 @@ instance Text UserName where disp (UserName name) = Disp.text name - parse = UserName <$> Parse.munch1 Char.isAlphaNum + parse = UserName <$> Parse.munch1 isValidUserNameChar +isValidUserNameChar :: Char -> Bool +isValidUserNameChar c = (c < '\127' && Char.isAlphaNum c) || (c == '_') $(deriveSafeCopy 0 'base ''UserId) $(deriveSafeCopy 0 'base ''UserName) diff --git a/Distribution/Server/Users/Users.hs b/Distribution/Server/Users/Users.hs --- a/Distribution/Server/Users/Users.hs +++ b/Distribution/Server/Users/Users.hs @@ -50,7 +50,7 @@ import Control.Exception (assert) --- | The entrie collection of users. Manages the mapping between 'UserName' +-- | The entire collection of users. Manages the mapping between 'UserName' -- and 'UserId'. -- data Users = Users { diff --git a/Distribution/Server/Util/ContentType.hs b/Distribution/Server/Util/ContentType.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Util/ContentType.hs @@ -0,0 +1,48 @@ +module Distribution.Server.Util.ContentType ( + parseContentAccept + ) where + +import Happstack.Server.Types (ContentType(..)) + +import qualified Text.ParserCombinators.ReadP as Parse +import Control.Monad +import Data.List (find, sortBy) +import Data.Char (isAlphaNum, isDigit) +import Data.Ord (comparing) + +-- data VaryFormat = Json | Xml | Html | Plain | Other + +-- do some special processing here to fix Webkit's effing issues (and IE's, less so) +-- hackageVaryingAccept :: String -> [VaryFormat] + +-- this just returns a list of content-types sorted by quality preference +parseContentAccept :: String -> [ContentType] +parseContentAccept = process . maybe [] fst . find (null . snd) . Parse.readP_to_S parser + where + process :: [(a, Int)] -> [a] + process = map fst . sortBy (flip (comparing snd)) . filter ((/=0) . snd) + parser :: Parse.ReadP [(ContentType, Int)] + parser = flip Parse.sepBy1 (Parse.char ',') $ do + Parse.skipSpaces + -- a more 'accurate' type than (String, String) + -- might be Maybe (String, Maybe String) + typ <- parseMediaType + void $ Parse.char '/' + subTyp <- parseMediaType + quality <- Parse.option 1000 $ do + Parse.skipSpaces >> Parse.string ";q=" >> Parse.skipSpaces + parseQuality + -- TODO: parse other parameters + return (ContentType {ctType = typ, ctSubtype = subTyp, ctParameters = []}, quality) + parseMediaType = (Parse.char '*' >> return []) Parse.<++ Parse.munch1 (\c -> case c of '-' -> True; '.' -> True; '+' -> True; _ -> isAlphaNum c) + -- other characters technically allowed but never found in the wild: !#$%&^_`|~ + parseQuality :: Parse.ReadP Int -- returns a quality in fixed point (0.75 -> 750) + parseQuality = (Parse.char '1' >> Parse.optional (Parse.char '.' >> Parse.many (Parse.char '0')) >> return 1000) Parse.<++ + (Parse.char '0' >> zeroOption (Parse.char '.' >> zeroOption munch3Digits)) + zeroOption :: Parse.ReadP Int -> Parse.ReadP Int + zeroOption p = p Parse.<++ return 0 + munch3Digits :: Parse.ReadP Int + munch3Digits = fmap (\s -> read $ take 3 (s++"00") :: Int) (Parse.munch1 isDigit) + +--application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5 + diff --git a/Distribution/Server/Util/CountingMap.hs b/Distribution/Server/Util/CountingMap.hs --- a/Distribution/Server/Util/CountingMap.hs +++ b/Distribution/Server/Util/CountingMap.hs @@ -8,8 +8,8 @@ import Prelude hiding (rem) -import Data.Map (Map) -import qualified Data.Map as Map +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Typeable (Typeable) import Text.CSV (CSV, Record) @@ -33,21 +33,22 @@ ------------------------------------------------------------------------------} data NestedCountingMap a b = NCM { - nestedTotalCount :: Int - , nestedCountingMap :: Map a b + nestedTotalCount :: !Int + , nestedCountingMap :: !(Map a b) } - deriving (Show, Eq, Typeable) + deriving (Show, Eq, Ord, Typeable) newtype SimpleCountingMap a = SCM { simpleCountingMap :: NestedCountingMap a Int } - deriving (Show, Eq, Typeable) + deriving (Show, Eq, Ord, Typeable) class CountingMap k a | a -> k where cmEmpty :: a cmTotal :: a -> Int cmInsert :: k -> Int -> a -> a cmFind :: k -> a -> Int + cmUnion :: a -> a -> a cmToList :: a -> [(k, Int)] cmToCSV :: a -> CSV @@ -61,6 +62,9 @@ cmInsert k n (SCM (NCM total m)) = SCM (NCM (total + n) (adjustFrom (+ n) k 0 m)) + cmUnion (SCM (NCM total1 m1)) (SCM (NCM total2 m2)) = + SCM (NCM (total1 + total2) (Map.unionWith (+) m1 m2)) + cmFind k (SCM (NCM _ m)) = Map.findWithDefault 0 k m cmToList (SCM (NCM _ m)) = Map.toList m @@ -86,6 +90,9 @@ NCM (total + n) (adjustFrom (cmInsert l n) k cmEmpty m) cmFind (k, l) (NCM _ m) = cmFind l (Map.findWithDefault cmEmpty k m) + + cmUnion (NCM total1 m1) (NCM total2 m2) = + NCM (total1 + total2) (Map.unionWith cmUnion m1 m2) cmToList (NCM _ m) = concatMap aux (Map.toList m) where diff --git a/Distribution/Server/Util/GZip.hs b/Distribution/Server/Util/GZip.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Util/GZip.hs @@ -0,0 +1,19 @@ +module Distribution.Server.Util.GZip ( + decompressNamed + ) where + +import qualified Codec.Compression.GZip as GZip +import Control.Exception +import Data.ByteString.Lazy.Internal + +decompressNamed :: String -> ByteString -> ByteString +decompressNamed n bs = + mapExceptionRecursive mapError $ GZip.decompress bs + where + mapError (ErrorCall str) = ErrorCall $ str ++ " in " ++ show n + +mapExceptionRecursive :: (Exception e1, Exception e2) => (e1 -> e2) -> ByteString -> ByteString +mapExceptionRecursive f bs = + case mapException f bs of + Empty -> Empty + Chunk b bs' -> Chunk b (mapExceptionRecursive f bs') diff --git a/Distribution/Server/Util/Happstack.hs b/Distribution/Server/Util/Happstack.hs deleted file mode 100644 --- a/Distribution/Server/Util/Happstack.hs +++ /dev/null @@ -1,95 +0,0 @@ - -{-| - -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 diff --git a/Distribution/Server/Util/ServeTarball.hs b/Distribution/Server/Util/ServeTarball.hs --- a/Distribution/Server/Util/ServeTarball.hs +++ b/Distribution/Server/Util/ServeTarball.hs @@ -23,7 +23,8 @@ 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.Framework.HappstackUtils (remainingPath) +import Distribution.Server.Framework.CacheControl import Distribution.Server.Pages.Template (hackagePage) import Distribution.Server.Framework.ResponseContentTypes as Resource @@ -48,9 +49,10 @@ -> FilePath -- root dir in tar to serve -> FilePath -- the tarball -> TarIndex -- index for tarball + -> [CacheControl] -> ETag -- the etag -> ServerPartT m Response -serveTarball indices tarRoot tarball tarIndex etag = do +serveTarball indices tarRoot tarball tarIndex cacheCtls etag = do rq <- askRq action GET $ remainingPath $ \paths -> do @@ -70,7 +72,8 @@ case TarIndex.lookup tarIndex path of Just (TarIndex.TarFileEntry off) -> do - tfe <- liftIO $ serveTarEntry tarball off path etag + cacheControl cacheCtls etag + tfe <- liftIO $ serveTarEntry tarball off path ok (toResponse tfe) _ -> mzero @@ -84,8 +87,9 @@ -> seeOther (addTrailingPathSeparator fullPath) (toResponse ()) | otherwise - -> ok $ setHeader "ETag" (formatETag etag) $ - toResponse $ Resource.XHtml $ renderDirIndex fs + -> do + cacheControl cacheCtls etag + ok $ toResponse $ Resource.XHtml $ renderDirIndex fs _ -> mzero renderDirIndex :: [FilePath] -> XHtml.Html @@ -94,8 +98,8 @@ XHtml.+++ XHtml.br | e <- entries ] -serveTarEntry :: FilePath -> Int -> FilePath -> ETag -> IO Response -serveTarEntry tarfile off fname etag = do +serveTarEntry :: FilePath -> Int -> FilePath -> IO Response +serveTarEntry tarfile off fname = do htar <- openFile tarfile ReadMode hSeek htar AbsoluteSeek (fromIntegral (off * 512)) header <- BS.hGet htar 512 @@ -107,8 +111,7 @@ ext -> ext mimeType = Map.findWithDefault "text/plain" extension mimeTypes' response = ((setHeader "Content-Length" (show size)) . - (setHeader "Content-Type" mimeType) . - (setHeader "ETag" (formatETag etag))) $ + (setHeader "Content-Type" mimeType)) $ resultBS 200 body return response _ -> fail "oh noes!!" diff --git a/Distribution/Server/Util/SigTerm.hs b/Distribution/Server/Util/SigTerm.hs new file mode 100644 --- /dev/null +++ b/Distribution/Server/Util/SigTerm.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} +#if !(MIN_VERSION_base(4,6,0)) +{-# LANGUAGE MagicHash, UnboxedTuples #-} +#endif + +module Distribution.Server.Util.SigTerm (onSigTermCleanShutdown) where + +import System.Posix.Signals + ( installHandler + , Handler(Catch) + , softwareTermination + ) +import Control.Exception + ( AsyncException(UserInterrupt), throwTo ) +import Control.Concurrent + ( myThreadId ) +#if MIN_VERSION_base(4,6,0) +import Control.Concurrent + ( ThreadId, mkWeakThreadId ) +import System.Mem.Weak + ( Weak ) +#else +import GHC.Conc.Sync + ( ThreadId(..) ) +import GHC.Weak + ( Weak(..) ) +import GHC.IO + ( IO(IO) ) +import GHC.Exts + ( mkWeak#, unsafeCoerce# ) +#endif +import System.Mem.Weak + ( deRefWeak ) + +-- | On SIGTERM, throw 'UserInterrupt' to the calling thread. +-- +onSigTermCleanShutdown :: IO () +onSigTermCleanShutdown = do + wtid <- mkWeakThreadId =<< myThreadId + _ <- installHandler softwareTermination + (Catch (cleanShutdownHandler wtid)) + Nothing + return () + where + cleanShutdownHandler :: Weak ThreadId -> IO () + cleanShutdownHandler wtid = do + mtid <- deRefWeak wtid + case mtid of + Nothing -> return () + Just tid -> throwTo tid UserInterrupt + +#if !(MIN_VERSION_base(4,6,0)) +mkWeakThreadId :: ThreadId -> IO (Weak ThreadId) +mkWeakThreadId t@(ThreadId t#) = IO $ \s -> + case mkWeak# t# t (unsafeCoerce# 0#) s of + (# s1, w #) -> (# s1, Weak w #) +#endif + diff --git a/Distribution/Server/Util/TextSearch.hs b/Distribution/Server/Util/TextSearch.hs deleted file mode 100644 --- a/Distribution/Server/Util/TextSearch.hs +++ /dev/null @@ -1,63 +0,0 @@ -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 diff --git a/ImportClient.hs b/ImportClient.hs --- a/ImportClient.hs +++ b/ImportClient.hs @@ -245,7 +245,7 @@ =<< readFile htpasswdFile concForM_ jobs htpasswdDb $ \tasks -> - httpSession $ do + httpSession "hackage-import" version $ do setAuthorityFromURI baseURI tasks $ \(username, mPasswdhash) -> putUserAccount baseURI username mPasswdhash makeUploader diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2008, Duncan Coutts and David Himmelstrup. +Copyright 2014, Duncan Coutts and David Himmelstrup. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -7,8 +7,9 @@ import Distribution.Server.Framework.Feature import Distribution.Server.Framework.Logging import Distribution.Server.Framework.BackupRestore (equalTarBall, restoreServerBackup) -import Distribution.Server.Framework.BackupDump (dumpServerBackup) +import Distribution.Server.Framework.BackupDump (dumpServerBackup, BackupType(..)) import qualified Distribution.Server.Framework.BlobStorage as BlobStorage +import Distribution.Server.Util.SigTerm import Distribution.Text ( display ) @@ -26,8 +27,9 @@ ( Signal , installHandler , Handler(Catch) - , userDefinedSignal1 - , userDefinedSignal2 + , sigUSR1 + , sigUSR2 + , sigHUP ) import System.IO import System.Directory @@ -185,7 +187,8 @@ flagRunCacheDelay :: Flag String, -- Online backup flags flagRunBackupOutputDir :: Flag FilePath, - flagRunBackupLinkBlobs :: Flag Bool + flagRunBackupLinkBlobs :: Flag Bool, + flagRunBackupScrubbed :: Flag Bool } defaultRunFlags :: RunFlags @@ -200,7 +203,8 @@ flagRunTemp = Flag False, flagRunCacheDelay = NoFlag, flagRunBackupOutputDir = Flag "backups", - flagRunBackupLinkBlobs = Flag False + flagRunBackupLinkBlobs = Flag False, + flagRunBackupScrubbed = Flag False } runCommand :: CommandUI RunFlags @@ -258,15 +262,20 @@ ++ " (reduces disk space and I/O but is less robust to errors).") flagRunBackupLinkBlobs (\v flags -> flags { flagRunBackupLinkBlobs = v }) (noArg (Flag True)) + , option [] ["scrubbed-backup"] + ("Generate a scrubbed backup containing no user " ++ + "identifying information (for development use)") + flagRunBackupScrubbed (\v flags -> flags { flagRunBackupScrubbed = 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 + 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) @@ -286,11 +295,14 @@ } outputDir = fromFlag (flagRunBackupOutputDir opts) linkBlobs = fromFlag (flagRunBackupLinkBlobs opts) + scrubbed = fromFlag (flagRunBackupScrubbed opts) checkBlankServerState =<< Server.hasSavedState config checkStaticDir staticDir (flagRunStaticDir opts) checkTmpDir tmpDir + onSigTermCleanShutdown + let checkpointHandler server = do lognotice verbosity "Writing checkpoint..." Server.checkpoint server @@ -298,15 +310,21 @@ let backupHandler server = do lognotice verbosity "Starting backup..." - startBackup verbosity outputDir linkBlobs server + startBackup verbosity scrubbed outputDir linkBlobs server lognotice verbosity "Done" + let reloadHandler server = do + lognotice verbosity "Dropping cached static files..." + Server.reloadDatafiles 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 + withHandler sigUSR1 (checkpointHandler server) $ + withHandler sigUSR2 (backupHandler server) $ + withHandler sigHUP (reloadHandler server) $ do + lognotice verbosity $ "Ready! Point your browser at " ++ show hosturi + Server.run server where verbosity = fromFlag (flagRunVerbosity opts) @@ -499,7 +517,8 @@ flagBackupOutputDir :: Flag FilePath, flagBackupStateDir :: Flag FilePath, flagBackupStaticDir :: Flag FilePath, - flagBackupLinkBlobs :: Flag Bool + flagBackupLinkBlobs :: Flag Bool, + flagBackupScrubbed :: Flag Bool } defaultBackupFlags :: BackupFlags @@ -508,7 +527,8 @@ flagBackupOutputDir = Flag "backups", flagBackupStateDir = NoFlag, flagBackupStaticDir = NoFlag, - flagBackupLinkBlobs = Flag False + flagBackupLinkBlobs = Flag False, + flagBackupScrubbed = Flag False } backupCommand :: CommandUI BackupFlags @@ -539,6 +559,11 @@ ++ " (reduces disk space and I/O but is less robust to errors).") flagBackupLinkBlobs (\v flags -> flags { flagBackupLinkBlobs = v }) (noArg (Flag True)) + , option [] ["scrubbed-backup"] + ("Generate a scrubbed backup containing no user " ++ + "identifying information (for development use)") + flagBackupScrubbed (\v flags -> flags { flagBackupScrubbed = v }) + (noArg (Flag True)) ] backupAction :: BackupFlags -> IO () @@ -549,6 +574,7 @@ staticDir = fromFlagOrDefault (confStaticDir defaults) (flagBackupStaticDir opts) outputDir = fromFlag (flagBackupOutputDir opts) linkBlobs = fromFlag (flagBackupLinkBlobs opts) + scrubbed = fromFlag (flagBackupScrubbed opts) verbosity = fromFlag (flagBackupVerbosity opts) config = defaults { confVerbosity = verbosity, @@ -556,14 +582,15 @@ confStaticDir = staticDir } - withServer config False $ startBackup verbosity outputDir linkBlobs + withServer config False $ startBackup verbosity scrubbed outputDir linkBlobs -startBackup :: Verbosity -> FilePath -> Bool -> Server -> IO () -startBackup verbosity outputDir linkBlobs server = do +startBackup :: Verbosity -> Bool -> FilePath -> Bool -> Server -> IO () +startBackup verbosity scrubbed 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) + backupType = if scrubbed then ScrubbedBackup else FullBackup + dumpServerBackup verbosity backupType outputDir Nothing store linkBlobs + (map (second (\s -> abstractStateBackup s backupType)) state) ------------------------------------------------------------------------------- -- Test backup command @@ -575,6 +602,7 @@ flagTestBackupStaticDir :: Flag FilePath, flagTestBackupTestDir :: Flag FilePath, flagTestBackupLinkBlobs :: Flag Bool, + flagTestBackupScrubbed :: Flag Bool, flagTestBackupFeatures :: Flag String } @@ -585,6 +613,7 @@ flagTestBackupStaticDir = NoFlag, flagTestBackupTestDir = Flag "test-backup", flagTestBackupLinkBlobs = Flag False, + flagTestBackupScrubbed = Flag False, flagTestBackupFeatures = NoFlag } @@ -613,6 +642,11 @@ ++ "blob files (saves on disk I/O, but less test coverage).") flagTestBackupLinkBlobs (\v flags -> flags { flagTestBackupLinkBlobs = v }) (noArg (Flag True)) + , option [] ["scrubbed-backup"] + ("Generate a scrubbed backup containing no user " ++ + "identifying information (for development use)") + flagTestBackupScrubbed (\v flags -> flags { flagTestBackupScrubbed = v }) + (noArg (Flag True)) , option [] ["features"] ("Only test the specified features") flagTestBackupFeatures (\v flags -> flags { flagTestBackupFeatures = v }) @@ -638,6 +672,8 @@ staticDir = fromFlagOrDefault (confStaticDir defaults) (flagTestBackupStaticDir opts) testDir = fromFlag (flagTestBackupTestDir opts) linkBlobs = fromFlag (flagTestBackupLinkBlobs opts) + scrubbed = fromFlag (flagTestBackupScrubbed opts) + backuptype = if scrubbed then ScrubbedBackup else FullBackup verbosity = fromFlag (flagTestBackupVerbosity opts) config = defaults { confStateDir = stateDir, @@ -681,8 +717,9 @@ -- representation. We start by writing it all out in the external -- representation. -- - dumpServerBackup verbosity dump1Dir (Just tarDumpName) store linkBlobs - (map (second abstractStateBackup) state) + dumpServerBackup verbosity FullBackup dump1Dir (Just tarDumpName) + store linkBlobs + (map (second (\s -> abstractStateBackup s backuptype)) 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 @@ -722,8 +759,9 @@ -- 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') + dumpServerBackup verbosity FullBackup dump2Dir (Just tarDumpName) + store' linkBlobs + (map (second (\s -> abstractStateBackup s backuptype)) 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. @@ -781,7 +819,7 @@ [ optionVerbosity flagRestoreVerbosity (\v flags -> flags { flagRestoreVerbosity = v }) , optionStateDir - flagRestoreStateDir (\v flags -> flags { flagRestoreStateDir = v }) + flagRestoreStateDir (\v flags -> flags { flagRestoreStateDir = v }) , optionStaticDir flagRestoreStaticDir (\v flags -> flags { flagRestoreStaticDir = v }) ] diff --git a/MirrorClient.hs b/MirrorClient.hs --- a/MirrorClient.hs +++ b/MirrorClient.hs @@ -31,6 +31,7 @@ import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BS import qualified Distribution.Server.Util.GZip as GZip +import qualified Codec.Compression.GZip as GZ import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Data.Set as Set @@ -59,12 +60,14 @@ 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 + srcURI :: URI, + dstURI :: URI, + stateDir :: FilePath, + selectedPkgs :: [PackageId], + continuous :: Maybe Int, -- if so, interval in minutes + mo_keepGoing :: Bool, + mirrorUploaders :: Bool, + srcIsOldHackage :: Bool } data MirrorEnv = MirrorEnv { @@ -112,7 +115,7 @@ when (continuous opts == Just 0) $ warn verbosity "A sync interval of zero is a seriously bad idea!" - when (isOldHackageURI (srcURI opts) + when (isHackageURI (srcURI opts) && maybe False (<30) (continuous opts)) $ die $ "Please don't hit the central hackage.haskell.org " ++ "more frequently than every 30 minutes." @@ -201,8 +204,8 @@ mirrorSession (mo_keepGoing opts) $ do - srcIndex <- downloadIndex (srcURI opts) srcCacheDir - dstIndex <- downloadIndex (dstURI opts) dstCacheDir + srcIndex <- downloadIndex (srcIsOldHackage opts) (srcURI opts) srcCacheDir + dstIndex <- downloadIndex (srcIsOldHackage opts) (dstURI opts) dstCacheDir let pkgsMissingFromDest = diffIndex srcIndex dstIndex pkgsToMirror @@ -289,7 +292,7 @@ extractCredentials _ = Nothing mirrorPackage pkginfo@(PkgIndexInfo pkgid _ _ _) = do - let srcPackage = if isOldHackageURI (srcURI opts) + let srcPackage = if srcIsOldHackage opts then "packages" "archive" display (packageName pkgid) display (packageVersion pkgid) @@ -315,19 +318,50 @@ notifyResponse (GetPackageFailed theError pkgid) Nothing -> do notifyResponse GetPackageOk - putPackage dstBase pkginfo locCab locTgz + liftIO $ sanitiseTarball verbosity (stateDir opts) locTgz + putPackage (mirrorUploaders opts) dstBase pkginfo locCab locTgz -putPackage :: URI -> PkgIndexInfo -> FilePath -> FilePath -> MirrorSession () -putPackage baseURI (PkgIndexInfo pkgid mtime muname _muid) locCab locTgz = do +-- Some package tarballs have extraneous stuff in them that causes +-- them to fail the "tarbomb" test in the server. This cleans them +-- up before uploading. +sanitiseTarball :: Verbosity -> FilePath -> FilePath -> IO () +sanitiseTarball verbosity tmpdir tgzpath = do + tgz <- BS.readFile tgzpath + let add _ (Left e) = Left e + add entry (Right entries) = Right (entry:entries) + eallentries = Tar.foldEntries add (Right []) (Left . show) $ + Tar.read (GZip.decompressNamed tgzpath tgz) + case eallentries of + Left e -> warn verbosity e + Right allentries -> do + let okentries = filter dirOK allentries + newtgz = GZ.compress $ Tar.write $ reverse okentries + when (length allentries /= length okentries) $ + warn verbosity $ "sanitising tarball for " ++ tgzpath + (tmpfp, tmph) <- openTempFile tmpdir "tmp.tgz" + hClose tmph + BS.writeFile tmpfp newtgz + renameFile tmpfp tgzpath + where + basedir = dropExtension $ takeBaseName tgzpath + dirOK entry = case splitDirectories (Tar.entryPath entry) of + (d:_) -> d == basedir + _ -> False + +putPackage :: Bool -> URI -> PkgIndexInfo -> FilePath -> FilePath -> MirrorSession () +putPackage doMirrorUploaders baseURI (PkgIndexInfo pkgid mtime muname _muid) locCab locTgz = do cab <- liftIO $ BS.readFile locCab tgz <- liftIO $ BS.readFile locTgz - rsp <- browserActions [ + rsp <- browserActions $ [ requestPUT cabURI "text/plain" cab , requestPUT tgzURI "application/x-gzip" tgz , maybe (return Nothing) putPackageUploadTime mtime - , maybe (return Nothing) putPackageUploader muname - ] + ] ++ + (if doMirrorUploaders + then [maybe (return Nothing) putPackageUploader muname] + else [] + ) case rsp of Just theError -> @@ -538,17 +572,16 @@ -- Fetching info from source and destination servers ---------------------------------------------------- -downloadIndex :: URI -> FilePath -> MirrorSession [PkgIndexInfo] -downloadIndex uri | isOldHackageURI uri = downloadOldIndex uri - | otherwise = downloadNewIndex uri - where +downloadIndex :: Bool -> URI -> FilePath -> MirrorSession [PkgIndexInfo] +downloadIndex isOldHackageURI + | isOldHackageURI = downloadOldIndex + | otherwise = downloadNewIndex -isOldHackageURI :: URI -> Bool -isOldHackageURI uri +isHackageURI :: URI -> Bool +isHackageURI uri | Just auth <- uriAuthority uri = uriRegName auth == "hackage.haskell.org" | otherwise = False - downloadOldIndex :: URI -> FilePath -> MirrorSession [PkgIndexInfo] downloadOldIndex uri cacheDir = do @@ -766,17 +799,27 @@ ------------------------- data MirrorFlags = MirrorFlags { - flagCacheDir :: Maybe FilePath, - flagContinuous:: Bool, - flagInterval :: Maybe String, - flagKeepGoing :: Bool, - flagVerbosity :: Verbosity, - flagHelp :: Bool + flagCacheDir :: Maybe FilePath, + flagContinuous :: Bool, + flagInterval :: Maybe String, + flagKeepGoing :: Bool, + flagMirrorUploaders :: Bool, + flagSrcIsOldHackage :: Bool, + flagVerbosity :: Verbosity, + flagHelp :: Bool } defaultMirrorFlags :: MirrorFlags defaultMirrorFlags = MirrorFlags - Nothing False Nothing False normal False + { flagCacheDir = Nothing + , flagContinuous = False + , flagInterval = Nothing + , flagKeepGoing = False + , flagMirrorUploaders = False + , flagSrcIsOldHackage = False + , flagVerbosity = normal + , flagHelp = False + } mirrorFlagDescrs :: [OptDescr (MirrorFlags -> MirrorFlags)] mirrorFlagDescrs = @@ -803,6 +846,14 @@ , Option [] ["keep-going"] (NoArg (\opts -> opts { flagKeepGoing = True })) "Don't fail on mirroring errors, keep going." + + , Option [] ["mirror-uploaders"] + (NoArg (\opts -> opts { flagMirrorUploaders = True })) + "Mirror the original uploaders which requires that they are already registered on the target hackage." + + , Option [] ["src-is-old-hackage"] + (NoArg (\opts -> opts { flagSrcIsOldHackage = True })) + "Enable this when the source is the old Hackage server so that the correct URLs are used." ] validateOpts :: [String] -> IO (Verbosity, MirrorOpts) @@ -830,7 +881,9 @@ continuous = if flagContinuous flags then Just interval else Nothing, - mo_keepGoing = flagKeepGoing flags + mo_keepGoing = flagKeepGoing flags, + mirrorUploaders = flagMirrorUploaders flags, + srcIsOldHackage = flagSrcIsOldHackage flags } where mpkgs = validatePackageIds pkgstrs diff --git a/datafiles/static/hackage.css b/datafiles/static/hackage.css --- a/datafiles/static/hackage.css +++ b/datafiles/static/hackage.css @@ -67,11 +67,12 @@ } table { + margin: 0.8em 0; font-size:inherit; font:100%; } -pre, code, kbd, samp, tt, .src { +pre, code, kbd, samp, .src { font-family:monospace; *font-size:108%; line-height: 124%; @@ -568,3 +569,73 @@ strong.warning { color: red; } /* @end */ + + +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ +/* Flags table */ + +.flags-table td { + padding-right: 1em; + padding-bottom: 0.25em; +} + +.flags-table .flag-disabled { + color: #888; +} + +p.tip { + font-size: 85%; +} + +.code { + font-family: monospace; +} + +/* Misc admin forms */ + +form.box { + background: #faf9dc; + border: 1px solid #d8d7ad; + padding: 0.5em 1em; + max-width: 35em; + margin: 0.5em 0 1em 1em; +} + +table.simpletable th, table.simpletable td { + padding: 0.2em 1em; +} + +table.properties td, table.properties th { + padding: 1px 0.25em; +} + +table.properties td:first-child, table.properties th:first-child { + padding-left: 0; +} + +table.properties td:last-child, table.properties th:last-child { + padding-right: 0; +} + +table.properties td, table.properties th { + vertical-align: top; + text-align: left; +} + +table.fancy { + border: 1px solid #ddd; + border-collapse: collapse; +} + +table.fancy tr { + border: 1px solid #ddd; + border-width: 1px 0; +} + +table.fancy th { + background: #f0f0f0; +} + +table.fancy td, table.fancy th { + padding: 0.25em 0.5em; +} diff --git a/datafiles/templates/AdminFrontend/account.html.st b/datafiles/templates/AdminFrontend/account.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/AdminFrontend/account.html.st @@ -0,0 +1,234 @@ + + + +$hackageCssTheme()$ +User account $account.name$ | Hackage + + + +$hackagePageHeader()$ + +

+

Admin front-end

+ +

Account information

+ + +
Username:$account.name$ +
User ID:$account.id$ +
Status:$account.status$ +
Legacy password:$if(hasLegacyPassword)$Yes$else$No$endif$ +
Real name:$details.realname$ +
Email:$details.email$ +
Account type:$details.kind$ +
Notes:$details.notes$ +
+ +

Account status

+ +$if(account.enabled)$ +

The account is enabled for login.

+ +
+ + + + + + +
+
+ + + + +
+ +$elseif(account.hasAuth)$ +

The account is disabled, so cannot currently be used for login. +The username is still reserved. +

+

The account still has a password set so it can be re-enabled. +

+ +
+ + + + + + +
+
+ + + + +
+ +$elseif(account.active)$ +

The account is disabled, so cannot currently be used for login. +The username is still reserved. +

+

The account does not have a password set. It will need a password to be set +before it can be re-enabled. (Note that this must be set manually as the +self-service password reset can only be used with enabled accounts.) +

+ +
+ + + + +
+$else$ +

The account has been marked as deleted, so cannot be used for login. +The username is available for reuse. +

+

The account can be undeleted if the username is not in use (and if you want to +enable it then the account will need a password to be set). +

+ +$endif$ + +

Password reset

+ +

+If the account has an associated email address and the account is +already in the enabled state then you can issue a self-service password reset. +

+ +$if(details.canreset)$ +
+ + + + + + +

+
+

The user will be sent an email containing a link to a page where they +can set a new password. +

+$else$ +This account is in a state where the the self-service password reset cannot be +used. The account must be enabled, and the account type must be "real user". +Of course the account also needs a valid email address for it to work. +$endif$ + +$if(first(resetRequests))$ +

+This account has outstanding password reset requests, issued at: +

+
    $resetRequests:{resetRequest|
  • $resetRequest.timestamp$
    • }$
+$else$ +

+This account has no outstanding password reset requests. +

+$endif$ + +

Password set

+

+Alternatively, as an administrator you can set account passwords directly. +

+ +
+ + + + + + + + + + + + +
+ +

+
+ +

Legacy password

+ +

Legacy passwords are to enable a relatively smooth upgrade from +old "htpasswd" style passwords. +

+ +$if(hasLegacyPassword)$ +$if(!account.hasAuth)$ +

This account has a legacy "htpasswd" password set, and no new password set. +It can be upgraded by the user that knows the old password. Alternatively +you can simply delete the legacy "htpasswd" and set a new password. +

+$else$ +

This account has a new password set but still has an legacy "htpasswd" password +too. The legacy one can safely be deleted. Indeed it is better to delete it as +it otherwise prevents the account from being disabled should the need arise +(the account could be reactivated by anyone knowing the legacy "htpasswd".) +

+$endif$ +
+ + + + +
+$else$ +

This account has no legacy password. +

+$endif$ + +

Edit account details

+ +
+ + + + + + + + + + + + + +
+ +

+
+ +
+ + + + + + + + + + + + + +
+ $details.kindenum, ["Not set", "Real user account", "Special account"]: + {enum, label| +
+ +
+ }$ +
+ +

+
+ +
+ + diff --git a/datafiles/templates/AdminFrontend/accounts.html.st b/datafiles/templates/AdminFrontend/accounts.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/AdminFrontend/accounts.html.st @@ -0,0 +1,32 @@ + + + +$hackageCssTheme()$ +Browse user accounts | Hackage + + + +$hackagePageHeader()$ + +
+

Admin front-end

+ +

Browse user accounts

+ +

All user accounts, including disabled and deleted.

+ + + +
+ + diff --git a/datafiles/templates/AdminFrontend/admin.html.st b/datafiles/templates/AdminFrontend/admin.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/AdminFrontend/admin.html.st @@ -0,0 +1,98 @@ + + + +$hackageCssTheme()$ +Admin front-end | Hackage + + + +$hackagePageHeader()$ + +
+

Admin front-end

+ +

User accounts

+ + +

Account signup and reset requests

+ +
    +
  • +
    + + +
    +$if(first(signups))$ +

    Found signup requests:

    + + + + + + + + $signups:{signup| + + + + + + + }$ +
    User nameReal nameEmailTimestamp
    $signup.username$$signup.realname$$signup.email$$signup.timestamp$
    +$elseif(findSignup)$ +

    No matching signup requests found

    +$endif$ +
    • +
  • Browse all signup requests
    • +
  • Browse all reset requests
    • +
+ +

Server status

+ + + +

TODO

+ +

TODO list for this admin interface +

+
    +
  • Account username change
    • +
  • Account undelete
    • +
+ +
+ + diff --git a/datafiles/templates/AdminFrontend/legacy.html.st b/datafiles/templates/AdminFrontend/legacy.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/AdminFrontend/legacy.html.st @@ -0,0 +1,36 @@ + + + +$hackageCssTheme()$ +User accounts with legacy passwords | Hackage + + + +$hackagePageHeader()$ + +
+

Admin front-end

+ +

User accounts with legacy passwords

+ +

All user accounts with legacy "htpasswd" passwords set:

+ +$if(first(accounts))$ +

+$else$ +

None.

+$endif$ + +
+ + diff --git a/datafiles/templates/AdminFrontend/resets.html.st b/datafiles/templates/AdminFrontend/resets.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/AdminFrontend/resets.html.st @@ -0,0 +1,33 @@ + + + +$hackageCssTheme()$ +Browse reset requests | Hackage + + + +$hackagePageHeader()$ + +
+

Admin front-end

+ +

Browse password reset requests

+ +All currently active password reset requests (i.e. excluding expired and completed). + + + + + + + $resets:{reset| + + + + + }$ +
User nameTimestamp
$reset.account.name$$reset.timestamp$
+ +
+ + diff --git a/datafiles/templates/AdminFrontend/signups.html.st b/datafiles/templates/AdminFrontend/signups.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/AdminFrontend/signups.html.st @@ -0,0 +1,38 @@ + + + +$hackageCssTheme()$ +Browse signup requests | Hackage + + + +$hackagePageHeader()$ + +
+

Admin front-end

+ +

Browse account signup requests

+ +All currently active account signup requests (i.e. excluding expired and completed). + + + + + + + + + $signups:{signup| + + + + + + + }$ +
User nameReal nameEmailTimestamp
$signup.username$$signup.realname$$signup.email$$signup.timestamp$
+ + +
+ + diff --git a/datafiles/templates/EditCabalFile/cabalFileEditPage.html.st b/datafiles/templates/EditCabalFile/cabalFileEditPage.html.st --- a/datafiles/templates/EditCabalFile/cabalFileEditPage.html.st +++ b/datafiles/templates/EditCabalFile/cabalFileEditPage.html.st @@ -2,26 +2,24 @@ $hackageCssTheme()$ -Hackage: Edit package metadata for $pkgid$ +Edit package metadata for $pkgid$ | Hackage $hackagePageHeader()$
-

Edit package metadata for $pkgid$ (Tech Preview)

- -

NOTE: This is work in progress. It's not currently actually possible -to publish new revisions (see Issue 52).

+

Edit package metadata for $pkgid$

Package maintainers and Hackage trustees are allowed to edit certain bits of package metadata after a release, without uploading a new tarball. +Note that the tarball itself is never changed, just the metadata that is +stored separately. -

+

- + Reset $if(publish)$ diff --git a/datafiles/templates/EditCabalFile/cabalFilePublished.html.st b/datafiles/templates/EditCabalFile/cabalFilePublished.html.st --- a/datafiles/templates/EditCabalFile/cabalFilePublished.html.st +++ b/datafiles/templates/EditCabalFile/cabalFilePublished.html.st @@ -2,7 +2,7 @@ $hackageCssTheme()$ -Hackage: Published new revision for $pkgid$ +Published new revision for $pkgid$ | Hackage @@ -12,7 +12,7 @@

Published new revision for $pkgid$

The new revision has been published. It will be available to users as soon -as they update their package index (e.g. cabal update). +as they update their package index (e.g. cabal update). 

$cabalfile$
diff --git a/datafiles/templates/Html/distro-monitor.html.st b/datafiles/templates/Html/distro-monitor.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/Html/distro-monitor.html.st @@ -0,0 +1,23 @@ + + + +$hackageCssTheme()$ +Tarballs for $pkgname$ | Hackage + + + +$hackagePageHeader()$ + +
+

Tarballs for $pkgname$

+ +

The following versions of $pkgname$ exist: + +

+ +

+ +
+ diff --git a/datafiles/templates/Html/maintain-candidate.html.st b/datafiles/templates/Html/maintain-candidate.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/Html/maintain-candidate.html.st @@ -0,0 +1,39 @@ + + + +$hackageCssTheme()$ +Maintainers' page for $pkgname$-$pkgversion$ candidate | Hackage + + + +$hackagePageHeader()$ + +
+

Maintainers' page for $pkgname$-$pkgversion$ candidate

+ +

Here, you can delete a candidate, publish it, upload a new one, and +edit the maintainer group. + +

+
Delete candidate
+
Discard this candidate (does not affect published packages). +
+ +
Publish candidate
+
Publish this candidate to make it visible in the main package database. +
+ +
Upload a new candidate
+
If you upload a new candidate with the same version as an + existing candidate, the older will be overwritten. +
+ +
Maintainer group
+
Only these users are allowed to upload new versions of the package. + Existing members can add other users into the maintainer group. +
+ +
+ +
+ diff --git a/datafiles/templates/Html/maintain-docs.html.st b/datafiles/templates/Html/maintain-docs.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/Html/maintain-docs.html.st @@ -0,0 +1,32 @@ + + + +$hackageCssTheme()$ +Hackage: Manage documentation for $pkgid$ + + + +$hackagePageHeader()$ + +
+

Manage documentation for $pkgid$

+ +

Upload documentation

+

Hackage usually builds package documentation automatically. However, if you wish, you may also build and upload the HTML yourself.

+

For more information, see this bug report.

+ + + + + + + +

Delete documentation

+
+ + +
+ +
+ + diff --git a/datafiles/templates/Html/maintain.html.st b/datafiles/templates/Html/maintain.html.st --- a/datafiles/templates/Html/maintain.html.st +++ b/datafiles/templates/Html/maintain.html.st @@ -2,7 +2,7 @@ $hackageCssTheme()$ -Hackage: Maintainers' page for $pkgname$ +Maintainers' page for $pkgname$ | Hackage @@ -19,6 +19,9 @@
Package tags are used to improve search results and related packages to each other.
+ +
Manage documentation for $versions:{pkgid|$pkgid$}; separator=", "$
+
Upload or delete Haddock documentation for this package.
Preferred versions
If you want users to keep using an older version when you release a newer diff --git a/datafiles/templates/Html/report.html.st b/datafiles/templates/Html/report.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/Html/report.html.st @@ -0,0 +1,88 @@ + + + +$hackageCssTheme()$ +Hackage: Build #$report.0$ for $pkgid$ + + + +$hackagePageHeader()$ + +
+

Build #$report.0$ for $pkgid$

+ +

[all reports]

+ + + + + + +
Package$report.1.package$
+ + + + + + + + + + + + + + +
Install$report.1.installOutcome$
Docs$report.1.docsOutcome$
Tests$report.1.testsOutcome$
+ + + + + + + + + + + + + + + + + + + + + + + + + + +
Time submitted + $if(report.1.time)$ + $report.1.time$ + $else$ + unknown + $endif$ +
Compiler$report.1.compiler$
OS$report.1.os$
Arch$report.1.arch$
Dependencies$report.1.dependencies; separator=", "$
Flags + $if(first(report.1.flagAssignment))$ + $report.1.flagAssignment; separator=" "$ + $else$ + none + $endif$ +
+ +

Build log

+ +$if(log)$ +

[view raw]

+
+$log$
+$else$ +

No log was submitted for this report.

+$endif$ + +
+ diff --git a/datafiles/templates/Html/reports.html.st b/datafiles/templates/Html/reports.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/Html/reports.html.st @@ -0,0 +1,55 @@ + + + +$hackageCssTheme()$ +Build reports for $pkgid$ | Hackage + + + +$hackagePageHeader()$ + +
+

Build reports for $pkgid$

+ +$if(first(reports))$ + + + + + + + + + + + + + + + + $reports:{report| + + + + + + + + + + + + }; separator=""$ +
No.OutcomeCompilerOSArchFlagsDetails
InstallDocsTests
#$report.0$$report.1.installOutcome$$report.1.docsOutcome$$report.1.testsOutcome$$report.1.compiler$$report.1.os$$report.1.arch$ + $if(first(report.1.flagAssignment))$ + $report.1.flagAssignment; separator=" "$ + $else$ + none + $endif$ + More details
+$else$ +

No reports available.

+$endif$ + +
+ diff --git a/datafiles/templates/Html/revisions.html.st b/datafiles/templates/Html/revisions.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/Html/revisions.html.st @@ -0,0 +1,44 @@ + + + +$hackageCssTheme()$ +Metadata revisions for $pkgid$ | Hackage + + + +$hackagePageHeader()$ + +
+

Metadata revisions for $pkgid$

+ +

Package maintainers and Hackage trustees are allowed to edit certain bits +of package metadata after a release, without uploading a new tarball. +Note that the tarball itself is never changed, just the metadata that is +stored separately. + + + + + + + + + $revisions:{revision| + + + + + + + }; separator=""$ +
No.TimeUserChanges
#$revision.number$$revision.time$$revision.user$ +
    + $revision.changes:{change|

  • Changed $change.what$ + from 

    $change.from$
    + to 
    $change.to$
    • }$ +
+
+ +

+ + diff --git a/datafiles/templates/LegacyPasswds/htpasswd-upgrade-success.html.st b/datafiles/templates/LegacyPasswds/htpasswd-upgrade-success.html.st --- a/datafiles/templates/LegacyPasswds/htpasswd-upgrade-success.html.st +++ b/datafiles/templates/LegacyPasswds/htpasswd-upgrade-success.html.st @@ -2,7 +2,7 @@ $hackageCssTheme()$ -Hackage: Account upgrade successful +Account upgrade successful | Hackage diff --git a/datafiles/templates/LegacyPasswds/htpasswd-upgrade.html.st b/datafiles/templates/LegacyPasswds/htpasswd-upgrade.html.st --- a/datafiles/templates/LegacyPasswds/htpasswd-upgrade.html.st +++ b/datafiles/templates/LegacyPasswds/htpasswd-upgrade.html.st @@ -2,7 +2,7 @@ $hackageCssTheme()$ -Hackage: Account upgrade +Account upgrade | Hackage @@ -15,7 +15,7 @@ old system need to do a one-time upgrade step.

-
+

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. diff --git a/datafiles/templates/UserSignupReset/ResetConfirm.html.st b/datafiles/templates/UserSignupReset/ResetConfirm.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/UserSignupReset/ResetConfirm.html.st @@ -0,0 +1,34 @@ + + + +$hackageCssTheme()$ +Account recovery | Hackage + + + +$hackagePageHeader()$ + +

+

Account recovery

+ +

Email confirmation done! + +

Now you can set a new password. + + + +
Your name:$realname$ +
Login username:$username$ +
Contact email address:$useremail$ +
+ +
+ +
+ +

+

+ +
+ + diff --git a/datafiles/templates/UserSignupReset/ResetConfirm.st b/datafiles/templates/UserSignupReset/ResetConfirm.st deleted file mode 100644 --- a/datafiles/templates/UserSignupReset/ResetConfirm.st +++ /dev/null @@ -1,34 +0,0 @@ - - - -$hackageCssTheme()$ -Hackage: Account recovery - - - -$hackagePageHeader()$ - -
-

Account recovery

- -

Email confirmation done! - -

Now you can set a new password. - -

- -
Your name:$realname$ -
Login username:$username$ -
Contact email address:$useremail$ -
- -
- -
- -

-

- -
- - diff --git a/datafiles/templates/UserSignupReset/ResetConfirmation.email.st b/datafiles/templates/UserSignupReset/ResetConfirmation.email.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/UserSignupReset/ResetConfirmation.email.st @@ -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. + diff --git a/datafiles/templates/UserSignupReset/ResetConfirmationEmail.st b/datafiles/templates/UserSignupReset/ResetConfirmationEmail.st deleted file mode 100644 --- a/datafiles/templates/UserSignupReset/ResetConfirmationEmail.st +++ /dev/null @@ -1,19 +0,0 @@ -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. - diff --git a/datafiles/templates/UserSignupReset/ResetEmailSent.html.st b/datafiles/templates/UserSignupReset/ResetEmailSent.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/UserSignupReset/ResetEmailSent.html.st @@ -0,0 +1,23 @@ + + + +$hackageCssTheme()$ +Account recovery | Hackage + + + +$hackagePageHeader()$ + +
+

Account recovery email sent

+ +

An email has been sent to $useremail$ + +

The email will contain a link to a page where +you can set a new password. + +

Note that these activation links do eventually expire, +so don't leave it too long! + +

+ diff --git a/datafiles/templates/UserSignupReset/ResetEmailSent.st b/datafiles/templates/UserSignupReset/ResetEmailSent.st deleted file mode 100644 --- a/datafiles/templates/UserSignupReset/ResetEmailSent.st +++ /dev/null @@ -1,23 +0,0 @@ - - - -$hackageCssTheme()$ -Hackage: Account recovery - - - -$hackagePageHeader()$ - -
-

Account recovery email sent

- -

An email has been sent to $useremail$ - -

The email will contain a link to a page where -you can set a new password. - -

Note that these activation links do eventually expire, -so don't leave it too long! - -

- diff --git a/datafiles/templates/UserSignupReset/ResetRequest.html.st b/datafiles/templates/UserSignupReset/ResetRequest.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/UserSignupReset/ResetRequest.html.st @@ -0,0 +1,41 @@ + + + +$hackageCssTheme()$ +Account recovery | Hackage + + + +$hackagePageHeader()$ + +
+

Account recovery for forgotten passwords

+ +

If you have forgotten the password you use to log in to Hackage, you can +recover the account and set a new password. + +

Enter your account name and the email address that you originally +signed up with. The system will send you an email with a link that you can use +to set a new password. + +

+ + + + +
+ + +
+ +This must be the same email address that you registered with originally. +
+ +

+ +

You will be sent an email containing a link to a page where you +can set a new password. +

+ +
+ diff --git a/datafiles/templates/UserSignupReset/ResetRequest.st b/datafiles/templates/UserSignupReset/ResetRequest.st deleted file mode 100644 --- a/datafiles/templates/UserSignupReset/ResetRequest.st +++ /dev/null @@ -1,41 +0,0 @@ - - - -$hackageCssTheme()$ -Hackage: Account recovery - - - -$hackagePageHeader()$ - -
-

Account recovery for forgotten passwords

- -

If you have forgotten the password you use to log in to Hackage, you can -recover the account and set a new password. - -

Enter your account name and the email address that you originally -signed up with. The system will send you an email with a link that you can use -to set a new password. - -

- - - - -
- - -
- -This must be the same email address that you registered with originally. -
- -

- -

You will be sent an email containing a link to a page where you -can set a new password. -

- -
- diff --git a/datafiles/templates/UserSignupReset/SignupConfirm.html.st b/datafiles/templates/UserSignupReset/SignupConfirm.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/UserSignupReset/SignupConfirm.html.st @@ -0,0 +1,34 @@ + + + +$hackageCssTheme()$ +Register a new account | Hackage + + + +$hackagePageHeader()$ + +
+

Register a new account

+ +

Email confirmation done! + +

Now you can set your password and create the account. + +

+ +
Your name:$realname$ +
Login username:$username$ +
Contact email address:$useremail$ +
+ +
+ +
+ +

+

+ +
+ + diff --git a/datafiles/templates/UserSignupReset/SignupConfirm.st b/datafiles/templates/UserSignupReset/SignupConfirm.st deleted file mode 100644 --- a/datafiles/templates/UserSignupReset/SignupConfirm.st +++ /dev/null @@ -1,34 +0,0 @@ - - - -$hackageCssTheme()$ -Hackage: Register a new account - - - -$hackagePageHeader()$ - -
-

Register a new account

- -

Email confirmation done! - -

Now you can set your password and create the account. - -

- -
Your name:$realname$ -
Login username:$username$ -
Contact email address:$useremail$ -
- -
- -
- -

-

- -
- - diff --git a/datafiles/templates/UserSignupReset/SignupConfirmation.email.st b/datafiles/templates/UserSignupReset/SignupConfirmation.email.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/UserSignupReset/SignupConfirmation.email.st @@ -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. + diff --git a/datafiles/templates/UserSignupReset/SignupConfirmationEmail.st b/datafiles/templates/UserSignupReset/SignupConfirmationEmail.st deleted file mode 100644 --- a/datafiles/templates/UserSignupReset/SignupConfirmationEmail.st +++ /dev/null @@ -1,19 +0,0 @@ -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. - diff --git a/datafiles/templates/UserSignupReset/SignupEmailSent.html.st b/datafiles/templates/UserSignupReset/SignupEmailSent.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/UserSignupReset/SignupEmailSent.html.st @@ -0,0 +1,23 @@ + + + +$hackageCssTheme()$ +Register a new account | Hackage + + + +$hackagePageHeader()$ + +
+

Confirmation email sent

+ +

An email has been sent to $useremail$ + +

The email will contain a link to a page where +you can set your password and activate your account. + +

Note that these activation links do eventually expire, +so don't leave it too long! + +

+ diff --git a/datafiles/templates/UserSignupReset/SignupEmailSent.st b/datafiles/templates/UserSignupReset/SignupEmailSent.st deleted file mode 100644 --- a/datafiles/templates/UserSignupReset/SignupEmailSent.st +++ /dev/null @@ -1,23 +0,0 @@ - - - -$hackageCssTheme()$ -Hackage: Register a new account - - - -$hackagePageHeader()$ - -
-

Confirmation email sent

- -

An email has been sent to $useremail$ - -

The email will contain a link to a page where -you can set your password and activate your account. - -

Note that these activation links do eventually expire, -so don't leave it too long! - -

- diff --git a/datafiles/templates/UserSignupReset/SignupRequest.html.st b/datafiles/templates/UserSignupReset/SignupRequest.html.st new file mode 100644 --- /dev/null +++ b/datafiles/templates/UserSignupReset/SignupRequest.html.st @@ -0,0 +1,51 @@ + + + +$hackageCssTheme()$ +Register a new account | Hackage + + + +$hackagePageHeader()$ + +
+

Register a new account

+ +

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. + +

Using the form below you can register an account. + +

+ + + + + +
+ +This is what will be displayed on the site, e.g. Jan Novák + +
+ +This has to be ASCII with no spaces or symbols (except '_'), e.g. JanNovak + +
+ +e.g. jnovak@example.com (but do not use the style "Jan Novák" <jnovak@example.com>) +
+ +

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). + +

+ +

You will be sent an email containing a link to a page where you +can set your password and activate your account. +

+ +
+ diff --git a/datafiles/templates/UserSignupReset/SignupRequest.st b/datafiles/templates/UserSignupReset/SignupRequest.st deleted file mode 100644 --- a/datafiles/templates/UserSignupReset/SignupRequest.st +++ /dev/null @@ -1,52 +0,0 @@ - - - -$hackageCssTheme()$ -Hackage: Register a new account - - - -$hackagePageHeader()$ - -
-

Register a new account

- -

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

Using the form below you can register an account. Note however that getting -permission to upload packages requires an extra step from an administrator. - -

- - - - - -
- -This is what will be displayed on the site, e.g. Jan Novák - -
- -This has to be ASCII with no spaces, e.g. JanNovak - -
- -e.g. jnovak@example.com (but do not use the style "Jan Novák" <jnovak@example.com>) -
- -

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). - -

- -

You will be sent an email containing a link to a page where you -can set your password and activate your account. -

- -
- diff --git a/datafiles/templates/accounts.html.st b/datafiles/templates/accounts.html.st --- a/datafiles/templates/accounts.html.st +++ b/datafiles/templates/accounts.html.st @@ -2,7 +2,7 @@ $hackageCssTheme()$ -Hackage: User accounts +User accounts | Hackage @@ -15,13 +15,8 @@ However, uploading packages requires a Hackage username and password.

-

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.

-

So, you can register a new user account.

+

You can also peruse the list of users.

Passwords are not stored, just the digest.

diff --git a/datafiles/templates/admin.html.st b/datafiles/templates/admin.html.st deleted file mode 100644 --- a/datafiles/templates/admin.html.st +++ /dev/null @@ -1,59 +0,0 @@ - - - -$hackageCssTheme()$ -Hackage: user administartion - - - -$hackagePageHeader()$ - -
-

Admin front-end

- - - - - -
- - diff --git a/datafiles/templates/hackageErrorPage.html.st b/datafiles/templates/hackageErrorPage.html.st --- a/datafiles/templates/hackageErrorPage.html.st +++ b/datafiles/templates/hackageErrorPage.html.st @@ -2,7 +2,7 @@ $hackageCssTheme()$ -Hackage: $errorTitle$ +$errorTitle$ | Hackage diff --git a/datafiles/templates/hackagePageHeader.st b/datafiles/templates/hackagePageHeader.st --- a/datafiles/templates/hackagePageHeader.st +++ b/datafiles/templates/hackagePageHeader.st @@ -1,11 +1,26 @@
+ + +
  • Home
    • + +
  • +
    + + +
    +
    • + +
  • Browse
    • + +
  • What's new
    • + +
  • Upload
    • + +
  • User accounts
    • + + + Hackage :: [Package] +
    diff --git a/datafiles/templates/index.html.st b/datafiles/templates/index.html.st --- a/datafiles/templates/index.html.st +++ b/datafiles/templates/index.html.st @@ -2,7 +2,7 @@ $hackageCssTheme()$ -Hackage: introduction +Introduction | Hackage @@ -71,14 +71,14 @@

    Development

    See the -Hackage wiki page. -There is also a document in progress summarizing the architecture of the new hackage-server. Check out the code yourself: +Hackage wiki. +Check out the code:

    -
    darcs get http://code.haskell.org/hackage-server
    +
    git clone https://github.com/haskell/hackage-server.git

    -We'd like to make it as simple as possible for anyone to set up a Hackage server. +We'd like to make it as simple as possible for anyone to set up a Hackage server.

    diff --git a/datafiles/templates/new-features.html.st b/datafiles/templates/new-features.html.st deleted file mode 100644 --- a/datafiles/templates/new-features.html.st +++ /dev/null @@ -1,107 +0,0 @@ - - - -$hackageCssTheme()$ -New features in Hackage 2 - - - -$hackagePageHeader()$ - -
    - -

    New features in Hackage 2

    -

    Though our main priority has been feature parity so that we can switch over, volunteers have contributed several new features:

    • 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.

    • A new visual theme for the site, using the CSS borrowed from haddock.

    • 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.

    • 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.

    • 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”.

    • Package changelogs, when they are included in the package tarball.

    • The contents of package tarballs can be browsed online.

    • 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.

    • 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.

    • A RESTful API for getting and updating most of the data that the server holds, plus an auto-generated API description / sitemap.

    There are also a number of new features that volunteers have partially implemented or that are in need of improvement.

    • 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 issue #24 and issue #27.

    • 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 issue #40.

    • 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 issue #41.

    • 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 issue #44.

    • All resources in machine readable formats. Many resources have JSON or other machine readable formats, but not yet all. See the api page. This is an easy way to contribute to the development. See issue #42.

    • 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 issue #43.

    - -
    - - diff --git a/datafiles/templates/upload.html.st b/datafiles/templates/upload.html.st --- a/datafiles/templates/upload.html.st +++ b/datafiles/templates/upload.html.st @@ -2,7 +2,7 @@ $hackageCssTheme()$ -Hackage: Uploading packages and package candidates +Uploading packages and package candidates | Hackage @@ -32,15 +32,15 @@

    If there is no maintainer, the uploader can remove themselves from the group, and a package trustee can add anyone who wishes -to assume the responsibility. The Maintainer field of the Cabal file should be -None in this case. If a package is being maintained, any release not approved +to assume the responsibility. The Maintainer field of the Cabal file should be +None 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 Maintainer field as above either to commit to supporting the fork +the Maintainer field as above either to commit to supporting the fork yourself or to mark it as unsupported.

    Note that all of the above is a makeshift upload policy based on the features -available in the newer hackage-server. The Maintainer field has its uses, +available in the newer hackage-server. The Maintainer field has its uses, as does maintainer user groups. The libraries mailing list should probably determine the best approach for this.

    @@ -53,10 +53,10 @@

    Packages must be in the form produced by Cabal's -sdist command: -a gzipped tar file package-version.tar.gz +sdist command: +a gzipped tar file package-version.tar.gz comprising a directory package-version containing a package -of that name and version, including package.cabal. +of that name and version, including package.cabal. See the notes at the bottom of the page.

    @@ -65,23 +65,45 @@

    Notes

      -
    • You should check that your source bundle builds, -including the haddock documentation if it's a library.
      • -
    • Categories are determined by whatever you put in the Category 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.
      • -
    • Documentation for library packages should be generated by a maintainer. -The means of doing this is still up in the air.
      • -
    • We have moved to Haddock 2, and expect some glitches. -If you notice anything broken, please report it on the -Haddock bug tracker.
      • -
    • In GHC 6.8, several modules were split from the base package -into other packages. -See these notes on making packages work with a range of versions of GHC.
      • -
    • While Haddock 2 -accepts GHC features, it is also more picky about comment syntax than -the old version.
      • + +
    • + You should check that your source bundle builds, including the + haddock documentation if it's a library. +
      • + +
    • + Categories are determined by whatever you put in the Category 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. +
      • + +
    • + Documentation for library packages should be generated by a maintainer. + The means of doing this is still up in the air. +
      • + +
    • + We have moved to Haddock 2, and expect some glitches. + + If you notice anything broken, please report it on the + Haddock bug tracker. +
      • + +
    • + In GHC 6.8, several modules were split from the base package + into other packages. + + See these notes + on making packages work with a range of versions of GHC. +
      • + +
    • + While Haddock 2 + accepts GHC features, it is also more picky about comment syntax than + the old version. +
      • +
    diff --git a/dist/build/hackage-server/hackage-server-tmp/Distribution/Server/Pages/Package/HaddockLex.hs b/dist/build/hackage-server/hackage-server-tmp/Distribution/Server/Pages/Package/HaddockLex.hs new file mode 100644 --- /dev/null +++ b/dist/build/hackage-server/hackage-server-tmp/Distribution/Server/Pages/Package/HaddockLex.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE CPP,MagicHash #-} +{-# LINE 7 "Distribution/Server/Pages/Package/HaddockLex.x" #-} + +{-# 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 qualified Data.Bits +import Numeric +import Control.Monad (liftM) +import Distribution.Server.Pages.Package.HaddockTypes (RdrName) + +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Char (ord) +import Data.Array.Base (unsafeAt) +#else +import Array +import Char (ord) +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif +alex_base :: AlexAddr +alex_base = AlexA# "\xf8\xff\xff\xff\xfc\xff\xff\xff\xf2\x00\x00\x00\xfe\xff\xff\xff\x03\x00\x00\x00\xe8\x01\x00\x00\x12\x00\x00\x00\xde\x02\x00\x00\xd4\x03\x00\x00\xd5\x02\x00\x00\x24\x00\x00\x00\xf4\x00\x00\x00\x54\x04\x00\x00\xd4\x04\x00\x00\x54\x05\x00\x00\xd4\x05\x00\x00\x54\x06\x00\x00\xd4\x06\x00\x00\x54\x07\x00\x00\xd4\x07\x00\x00\x54\x08\x00\x00\xd4\x08\x00\x00\x54\x09\x00\x00\xd4\x09\x00\x00\x54\x0a\x00\x00\xd4\x0a\x00\x00\x00\x00\x00\x00\x45\x0b\x00\x00\x00\x00\x00\x00\xb6\x0b\x00\x00\x00\x00\x00\x00\x27\x0c\x00\x00\x00\x00\x00\x00\x98\x0c\x00\x00\x00\x00\x00\x00\x45\x03\x00\x00\x00\x00\x00\x00\x09\x0d\x00\x00\x00\x00\x00\x00\x7a\x0d\x00\x00\x00\x00\x00\x00\xbb\x0d\x00\x00\x00\x00\x00\x00\xfc\x0d\x00\x00\x00\x00\x00\x00\x3d\x0e\x00\x00\x3d\x0f\x00\x00\xfd\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x0f\x00\x00\x00\x00\x00\x00\xaf\x0f\x00\x00\xda\x00\x00\x00\xc3\x01\x00\x00\x00\x00\x00\x00\xf0\x0f\x00\x00\xf0\x10\x00\x00\xb0\x10\x00\x00\x00\x00\x00\x00\xb0\x11\x00\x00\x70\x11\x00\x00\x00\x00\x00\x00\x70\x12\x00\x00\x30\x12\x00\x00\x00\x00\x00\x00\x26\x13\x00\x00\x00\x00\x00\x00\xa6\x12\x00\x00\x30\x00\x00\x00\x26\x14\x00\x00\xe6\x13\x00\x00\x00\x00\x00\x00\xe6\x14\x00\x00\xa6\x14\x00\x00\x00\x00\x00\x00\x9c\x15\x00\x00\xd3\xff\xff\xff\x9c\x16\x00\x00\x1b\x15\x00\x00\x00\x00\x00\x00\xf6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x17\x00\x00\x09\x18\x00\x00\xfd\x17\x00\x00\xef\xff\xff\xff\xff\x18\x00\x00\xf5\x19\x00\x00\x00\x00\x00\x00\xeb\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# "\x00\x00\x04\x00\x52\x00\x04\x00\x04\x00\x04\x00\x59\x00\x51\x00\x58\x00\x51\x00\x51\x00\x51\x00\x04\x00\x52\x00\x04\x00\x04\x00\x04\x00\x5b\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x45\x00\x00\x00\x54\x00\x04\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x54\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x55\x00\x62\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x4f\x00\x0c\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x44\x00\x0f\x00\x31\x00\x31\x00\x31\x00\x32\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\x00\x00\x00\x00\x51\x00\x58\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x5a\x00\x64\x00\x51\x00\x00\x00\x67\x00\x66\x00\x00\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x65\x00\x00\x00\x00\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x69\x00\x63\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x57\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x6c\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x47\x00\x0e\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x34\x00\x14\x00\x24\x00\x24\x00\x24\x00\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x64\x00\x00\x00\x00\x00\x67\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x6d\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x47\x00\x0e\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x34\x00\x14\x00\x24\x00\x24\x00\x24\x00\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x5f\x00\x00\x00\x00\x00\x09\x00\x09\x00\x5d\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x09\x00\x00\x00\x09\x00\x09\x00\x60\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x09\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x11\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2b\x00\x17\x00\x1e\x00\x1e\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3a\x00\x12\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x29\x00\x18\x00\x1c\x00\x1c\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x49\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x46\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x0c\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x3f\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x39\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x0d\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x0e\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x2e\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x10\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x11\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x12\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x15\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x4d\x00\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x2f\x00\x15\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x23\x00\x19\x00\x1a\x00\x1a\x00\x1a\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3f\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x40\x00\x10\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2d\x00\x16\x00\x20\x00\x20\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x09\x00\x09\x00\x09\x00\x09\x00\x5f\x00\x00\x00\x00\x00\x09\x00\x09\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x5d\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x09\x00\x00\x00\x09\x00\x09\x00\x60\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x09\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x11\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2b\x00\x17\x00\x1e\x00\x1e\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x00\x00\x09\x00\x09\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x5e\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x09\x00\x00\x00\x09\x00\x09\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x09\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3a\x00\x12\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x29\x00\x18\x00\x1c\x00\x1c\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4a\x00\x0d\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x38\x00\x13\x00\x26\x00\x26\x00\x26\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3f\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x40\x00\x10\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2d\x00\x16\x00\x20\x00\x20\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x47\x00\x0e\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x34\x00\x14\x00\x24\x00\x24\x00\x24\x00\x25\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_check :: AlexAddr +alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x3e\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x28\x00\xff\xff\x2a\x00\x20\x00\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x29\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5b\x00\x3b\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x22\x00\x23\x00\x20\x00\xff\xff\x26\x00\x27\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x2f\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3c\x00\x3b\x00\xff\xff\xff\xff\x40\x00\xff\xff\x3e\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x23\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x21\x00\x0a\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x23\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x2f\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# "\xff\xff\x01\x00\x6b\x00\xff\xff\xff\xff\x6b\x00\xff\xff\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\x22\x00\x28\x00\x28\x00\x2a\x00\x2a\x00\x2c\x00\x2c\x00\x30\x00\x30\x00\x33\x00\x33\x00\x37\x00\x37\x00\x3b\x00\x3b\x00\x3e\x00\x3e\x00\x41\x00\x41\x00\x42\x00\x42\x00\x42\x00\x43\x00\x43\x00\x48\x00\x48\x00\xff\xff\xff\xff\x4b\x00\x4b\x00\x08\x00\x08\x00\x08\x00\x07\x00\x07\x00\x07\x00\x4c\x00\x4c\x00\x4c\x00\x42\x00\x50\x00\x50\x00\xff\xff\x6b\x00\x6b\x00\x6b\x00\x61\x00\x61\x00\x61\x00\x4c\x00\xff\xff\x01\x00\x01\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\xff\xff\xff\xff\x61\x00\x4c\x00\xff\xff\x6b\x00\xff\xff\xff\xff"# + +alex_accept = listArray (0::Int,109) [AlexAcc (alex_action_5),AlexAcc (alex_action_9),AlexAccNone,AlexAcc (alex_action_8),AlexAcc (alex_action_5),AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccSkip,AlexAcc (alex_action_1),AlexAcc (alex_action_2),AlexAcc (alex_action_3),AlexAcc (alex_action_4),AlexAcc (alex_action_6),AlexAcc (alex_action_7),AlexAcc (alex_action_9),AlexAcc (alex_action_10),AlexAcc (alex_action_11),AlexAcc (alex_action_12),AlexAcc (alex_action_13),AlexAcc (alex_action_14),AlexAcc (alex_action_15),AlexAcc (alex_action_15),AlexAcc (alex_action_16),AlexAcc (alex_action_17),AlexAcc (alex_action_18),AlexAcc (alex_action_19),AlexAcc (alex_action_19),AlexAcc (alex_action_19),AlexAcc (alex_action_19),AlexAcc (alex_action_19),AlexAcc (alex_action_19),AlexAcc (alex_action_20),AlexAcc (alex_action_21),AlexAcc (alex_action_22),AlexAcc (alex_action_23)] +{-# LINE 90 "Distribution/Server/Pages/Package/HaddockLex.x" #-} + +data Token + = TokPara + | TokNumber + | TokBullet + | TokDefStart + | TokDefEnd + | TokSpecial Char + | TokIdent RdrName + | 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 -> Maybe [Token]) -> Maybe [Token] + +--TODO: we ought to switch to ByteString input. +type AlexInput = (Char, [Word8], String) + +-- | For alex >= 3 +-- +-- See also alexGetChar +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte (c,(b:bs),s) = Just (b,(c,bs,s)) +alexGetByte (c,[],[]) = Nothing +alexGetByte (_,[],(c:s)) = case utf8Encode c of + (b:bs) -> Just (b, (c, bs, s)) + +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +utf8Encode :: Char -> [Word8] +utf8Encode = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) + , 0x80 + oc Data.Bits..&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) + , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) + , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) + , 0x80 + oc Data.Bits..&. 0x3f + ] + +-- | 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 -> Maybe [Token] +tokenise str = + go ('\n', [], eofHack str) para + where + go inp@(_,_,str') sc = + case alexScan inp sc of + AlexEOF -> Just [] + AlexError _ -> Nothing + 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, strtokenNL :: (String -> Token) -> Action +strtoken t = \str sc cont -> liftM (t str :) (cont sc) +strtokenNL t = \str sc cont -> liftM (t (filter (/= '\r') str) :) (cont sc) +-- ^ We only want LF line endings in our internal doc string format, so we +-- filter out all CRs. + +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) + + +birdtrack,def,line,para,string :: Int +birdtrack = 1 +def = 2 +line = 3 +para = 4 +string = 5 +alex_action_1 = begin birdtrack +alex_action_2 = token TokBullet `andBegin` string +alex_action_3 = token TokDefStart `andBegin` def +alex_action_4 = token TokNumber `andBegin` string +alex_action_5 = begin string +alex_action_6 = begin birdtrack +alex_action_7 = token TokPara `andBegin` para +alex_action_8 = begin string +alex_action_9 = strtokenNL TokBirdTrack `andBegin` line +alex_action_10 = strtoken $ \s -> TokSpecial (head s) +alex_action_11 = strtoken $ \s -> TokPic (init $ init $ tail $ tail s) +alex_action_12 = strtoken $ \s -> TokURL (init (tail s)) +alex_action_13 = strtoken $ \s -> TokAName (init (tail s)) +alex_action_14 = strtoken $ \s -> TokEmphasis (init (tail s)) +alex_action_15 = ident +alex_action_16 = strtoken (TokString . tail) +alex_action_17 = strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] +alex_action_18 = strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n]; _ -> error "hexParser: Can't happen" +alex_action_19 = strtoken TokString +alex_action_20 = strtokenNL TokString `andBegin` line +alex_action_21 = strtoken TokString +alex_action_22 = token TokDefEnd `andBegin` string +alex_action_23 = strtoken TokString +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +{-# LINE 21 "templates/GenericTemplate.hs" #-} + + + + + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define GTE(n,m) (tagToEnum# (n >=# m)) +#define EQ(n,m) (tagToEnum# (n ==# m)) +#else +#define GTE(n,m) (n >=# m) +#define EQ(n,m) (n ==# m) +#endif +{-# LINE 51 "templates/GenericTemplate.hs" #-} + + +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input (I# (sc)) + = alexScanUser undefined input (I# (sc)) + +alexScanUser user input (I# (sc)) + = case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, input') -> + case alexGetByte input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input' + + (AlexLastSkip input'' len, _) -> + + + + AlexSkip input'' len + + (AlexLastAcc k input''' len, _) -> + + + + AlexToken input''' len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) + in + new_acc `seq` + case alexGetByte input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + case fromIntegral c of { (I# (ord_c)) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if GTE(offset,0#) && EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + -1# -> (new_acc, input) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip) = AlexLastSkip input (I# (len)) +{-# LINE 198 "templates/GenericTemplate.hs" #-} + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +instance Functor AlexLastAcc where + fmap f AlexNone = AlexNone + fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z + fmap f (AlexLastSkip x y) = AlexLastSkip x y + +data AlexAcc a user + = AlexAccNone + | AlexAcc a + | AlexAccSkip +{-# LINE 242 "templates/GenericTemplate.hs" #-} + +-- used by wrappers +iUnbox (I# (i)) = i diff --git a/dist/build/hackage-server/hackage-server-tmp/Distribution/Server/Pages/Package/HaddockParse.hs b/dist/build/hackage-server/hackage-server-tmp/Distribution/Server/Pages/Package/HaddockParse.hs new file mode 100644 --- /dev/null +++ b/dist/build/hackage-server/hackage-server-tmp/Distribution/Server/Pages/Package/HaddockParse.hs @@ -0,0 +1,732 @@ +{-# OPTIONS_GHC -w #-} +{-# OPTIONS -fglasgow-exts -cpp #-} +-- 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 +import Distribution.Server.Pages.Package.HaddockTypes +import Data.Char (isSpace) +import qualified Data.Array as Happy_Data_Array +import qualified GHC.Exts as Happy_GHC_Exts + +-- parser produced by Happy Version 1.19.2 + +newtype HappyAbsSyn = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = Happy_GHC_Exts.Any +#else +type HappyAny = forall a . a +#endif +happyIn5 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: ((Doc RdrName, Doc RdrName)) -> (HappyAbsSyn ) +happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> ((Doc RdrName, Doc RdrName)) +happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: (String) -> (HappyAbsSyn ) +happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> (String) +happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyInTok :: (Token) -> (HappyAbsSyn ) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> (Token) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x01\x00\x27\x00\x0f\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x53\x00\x27\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x1b\x00\x3f\x00\x00\x00\x00\x00\x30\x00\x30\x00\x23\x00\x01\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x26\x00\x17\x00\x21\x00\x1d\x00\x53\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x4c\x00\x79\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x7d\x00\x71\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x67\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\xff\x00\x00\x00\x00\x7b\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xfa\xff\x00\x00\x00\x00\x00\x00\xf9\xff\xf8\xff\xf7\xff\xf6\xff\xf1\xff\xf2\xff\xed\xff\xec\xff\x00\x00\x00\x00\x00\x00\xe5\xff\xe4\xff\xe3\xff\xe6\xff\x00\x00\x00\x00\xef\xff\xe2\xff\xe7\xff\x00\x00\x00\x00\xfb\xff\xfa\xff\xfc\xff\xfa\xff\xf0\xff\xf4\xff\xf5\xff\x00\x00\xe0\xff\x00\x00\x00\x00\xe8\xff\x00\x00\xee\xff\xea\xff\xe9\xff\xeb\xff\x00\x00\xdf\xff\xe1\xff\xfd\xff\xf3\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x0b\x00\x01\x00\x02\x00\x06\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x01\x00\x02\x00\x0b\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x01\x00\x0e\x00\x01\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x03\x00\x0e\x00\x0b\x00\x0c\x00\x01\x00\x0e\x00\x04\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0d\x00\x07\x00\x08\x00\x0c\x00\x0a\x00\x0e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0f\x00\x0a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0b\x00\x0a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0e\x00\x0a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0d\x00\x09\x00\x0a\x00\x0c\x00\x0d\x00\x0e\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x2c\x00\x0d\x00\x0e\x00\x1e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x1c\x00\x18\x00\x0d\x00\x0e\x00\x21\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x0d\x00\x18\x00\x2b\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x2c\x00\x23\x00\x16\x00\x17\x00\x0d\x00\x18\x00\x2e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x1e\x00\x2f\x00\x0a\x00\x17\x00\x0b\x00\x18\x00\x2e\x00\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\x0b\x00\x1c\x00\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x16\x00\x0b\x00\x19\x00\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x23\x00\x0b\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x1e\x00\x28\x00\x25\x00\x17\x00\x27\x00\x18\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x0b\x00\x1f\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x0b\x00\x20\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x0b\x00\x23\x00\x0a\x00\x00\x00\x0b\x00\x27\x00\x0a\x00\x00\x00\x0b\x00\x18\x00\x0a\x00\x00\x00\x0b\x00\x29\x00\x25\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (2, 32) [ + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32) + ] + +happy_n_terms = 16 :: Int +happy_n_nonterms = 12 :: Int + +happyReduce_2 = happySpecReduce_3 0# happyReduction_2 +happyReduction_2 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn5 + (docAppend happy_var_1 happy_var_3 + )}} + +happyReduce_3 = happySpecReduce_2 0# happyReduction_3 +happyReduction_3 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn5 + (happy_var_2 + )} + +happyReduce_4 = happySpecReduce_1 0# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn5 + (happy_var_1 + )} + +happyReduce_5 = happySpecReduce_0 0# happyReduction_5 +happyReduction_5 = happyIn5 + (DocEmpty + ) + +happyReduce_6 = happySpecReduce_1 1# happyReduction_6 +happyReduction_6 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn6 + (DocUnorderedList [happy_var_1] + )} + +happyReduce_7 = happySpecReduce_1 1# happyReduction_7 +happyReduction_7 happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn6 + (DocOrderedList [happy_var_1] + )} + +happyReduce_8 = happySpecReduce_1 1# happyReduction_8 +happyReduction_8 happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn6 + (DocDefList [happy_var_1] + )} + +happyReduce_9 = happySpecReduce_1 1# happyReduction_9 +happyReduction_9 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_10 = happySpecReduce_2 2# happyReduction_10 +happyReduction_10 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn7 + (happy_var_2 + )} + +happyReduce_11 = happySpecReduce_2 3# happyReduction_11 +happyReduction_11 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn8 + (happy_var_2 + )} + +happyReduce_12 = happyReduce 4# 4# happyReduction_12 +happyReduction_12 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut12 happy_x_2 of { happy_var_2 -> + case happyOut12 happy_x_4 of { happy_var_4 -> + happyIn9 + ((happy_var_2, happy_var_4) + ) `HappyStk` happyRest}} + +happyReduce_13 = happySpecReduce_1 5# happyReduction_13 +happyReduction_13 happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + happyIn10 + (docParagraph happy_var_1 + )} + +happyReduce_14 = happySpecReduce_1 5# happyReduction_14 +happyReduction_14 happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn10 + (DocCodeBlock happy_var_1 + )} + +happyReduce_15 = happySpecReduce_2 6# happyReduction_15 +happyReduction_15 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokBirdTrack happy_var_1) -> + case happyOut11 happy_x_2 of { happy_var_2 -> + happyIn11 + (docAppend (DocString happy_var_1) happy_var_2 + )}} + +happyReduce_16 = happySpecReduce_1 6# happyReduction_16 +happyReduction_16 happy_x_1 + = case happyOutTok happy_x_1 of { (TokBirdTrack happy_var_1) -> + happyIn11 + (DocString happy_var_1 + )} + +happyReduce_17 = happySpecReduce_2 7# happyReduction_17 +happyReduction_17 happy_x_2 + happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + case happyOut12 happy_x_2 of { happy_var_2 -> + happyIn12 + (docAppend happy_var_1 happy_var_2 + )}} + +happyReduce_18 = happySpecReduce_1 7# happyReduction_18 +happyReduction_18 happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + happyIn12 + (happy_var_1 + )} + +happyReduce_19 = happySpecReduce_1 8# happyReduction_19 +happyReduction_19 happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn13 + (happy_var_1 + )} + +happyReduce_20 = happySpecReduce_3 8# happyReduction_20 +happyReduction_20 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut14 happy_x_2 of { happy_var_2 -> + happyIn13 + (DocMonospaced happy_var_2 + )} + +happyReduce_21 = happySpecReduce_2 9# happyReduction_21 +happyReduction_21 happy_x_2 + happy_x_1 + = case happyOut14 happy_x_2 of { happy_var_2 -> + happyIn14 + (docAppend (DocString "\n") happy_var_2 + )} + +happyReduce_22 = happySpecReduce_2 9# happyReduction_22 +happyReduction_22 happy_x_2 + happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + case happyOut14 happy_x_2 of { happy_var_2 -> + happyIn14 + (docAppend happy_var_1 happy_var_2 + )}} + +happyReduce_23 = happySpecReduce_1 9# happyReduction_23 +happyReduction_23 happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn14 + (happy_var_1 + )} + +happyReduce_24 = happySpecReduce_1 10# happyReduction_24 +happyReduction_24 happy_x_1 + = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> + happyIn15 + (DocString happy_var_1 + )} + +happyReduce_25 = happySpecReduce_1 10# happyReduction_25 +happyReduction_25 happy_x_1 + = case happyOutTok happy_x_1 of { (TokEmphasis happy_var_1) -> + happyIn15 + (DocEmphasis (DocString happy_var_1) + )} + +happyReduce_26 = happySpecReduce_1 10# happyReduction_26 +happyReduction_26 happy_x_1 + = case happyOutTok happy_x_1 of { (TokURL happy_var_1) -> + happyIn15 + (DocHyperlink (makeHyperlink happy_var_1) + )} + +happyReduce_27 = happySpecReduce_1 10# happyReduction_27 +happyReduction_27 happy_x_1 + = case happyOutTok happy_x_1 of { (TokPic happy_var_1) -> + happyIn15 + (DocPic happy_var_1 + )} + +happyReduce_28 = happySpecReduce_1 10# happyReduction_28 +happyReduction_28 happy_x_1 + = case happyOutTok happy_x_1 of { (TokAName happy_var_1) -> + happyIn15 + (DocAName happy_var_1 + )} + +happyReduce_29 = happySpecReduce_1 10# happyReduction_29 +happyReduction_29 happy_x_1 + = case happyOutTok happy_x_1 of { (TokIdent happy_var_1) -> + happyIn15 + (DocIdentifier happy_var_1 + )} + +happyReduce_30 = happySpecReduce_3 10# happyReduction_30 +happyReduction_30 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut16 happy_x_2 of { happy_var_2 -> + happyIn15 + (DocModule happy_var_2 + )} + +happyReduce_31 = happySpecReduce_1 11# happyReduction_31 +happyReduction_31 happy_x_1 + = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> + happyIn16 + (happy_var_1 + )} + +happyReduce_32 = happySpecReduce_2 11# happyReduction_32 +happyReduction_32 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> + case happyOut16 happy_x_2 of { happy_var_2 -> + happyIn16 + (happy_var_1 ++ happy_var_2 + )}} + +happyNewToken action sts stk [] = + happyDoAction 15# notHappyAtAll action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + TokSpecial '@' -> cont 1#; + TokDefStart -> cont 2#; + TokDefEnd -> cont 3#; + TokSpecial '\"' -> cont 4#; + TokURL happy_dollar_dollar -> cont 5#; + TokPic happy_dollar_dollar -> cont 6#; + TokAName happy_dollar_dollar -> cont 7#; + TokEmphasis happy_dollar_dollar -> cont 8#; + TokBullet -> cont 9#; + TokNumber -> cont 10#; + TokBirdTrack happy_dollar_dollar -> cont 11#; + TokIdent happy_dollar_dollar -> cont 12#; + TokPara -> cont 13#; + TokString happy_dollar_dollar -> cont 14#; + _ -> happyError' (tk:tks) + } + +happyError_ 15# tk tks = happyError' tks +happyError_ _ tk tks = happyError' (tk:tks) + +happyThen :: () => Maybe a -> (a -> Maybe b) -> Maybe b +happyThen = (>>=) +happyReturn :: () => a -> Maybe a +happyReturn = (return) +happyThen1 m k tks = (>>=) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> Maybe a +happyReturn1 = \a tks -> (return) a +happyError' :: () => [(Token)] -> Maybe a +happyError' = happyError + +parseHaddockParagraphs tks = happySomeParser where + happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut5 x)) + +parseHaddockString tks = happySomeParser where + happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut12 x)) + +happySeq = happyDontSeq + + +happyError :: [Token] -> Maybe a +happyError toks = Nothing + +-- | Create a `Hyperlink` from given string. +-- +-- A hyperlink consists of a URL and an optional label. The label is separated +-- from the url by one or more whitespace characters. +makeHyperlink :: String -> Hyperlink +makeHyperlink input = case break isSpace $ strip input of + (url, "") -> Hyperlink url Nothing + (url, label) -> Hyperlink url (Just . dropWhile isSpace $ label) + +-- | Remove all leading and trailing whitespace +strip :: String -> String +strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 13 "templates/GenericTemplate.hs" #-} + + + + + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) +#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) +#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) +#else +#define LT(n,m) (n Happy_GHC_Exts.<# m) +#define GTE(n,m) (n Happy_GHC_Exts.>=# m) +#define EQ(n,m) (n Happy_GHC_Exts.==# m) +#endif +{-# LINE 46 "templates/GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList + + + + + +{-# LINE 67 "templates/GenericTemplate.hs" #-} + +{-# LINE 77 "templates/GenericTemplate.hs" #-} + +{-# LINE 86 "templates/GenericTemplate.hs" #-} + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off Happy_GHC_Exts.+# i) + check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) + then EQ(indexShortOffAddr happyCheck off_i, i) + else False + action + | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + +indexShortOffAddr (HappyA# arr) off = + Happy_GHC_Exts.narrow16Int# i + where + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# + + + + + +data HappyAddr = HappyA# Happy_GHC_Exts.Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 170 "templates/GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk in + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk + + off = indexShortOffAddr happyGotoOffsets st1 + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + in + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk@(x `HappyStk` _) = + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "failing" $ + happyError_ i tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll :: a +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Happy_GHC_Exts.Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/hackage-server.cabal b/hackage-server.cabal --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -1,10 +1,10 @@ name: hackage-server -version: 0.4 +version: 0.5.0 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. @@ -14,8 +14,9 @@ Matthew Gruen maintainer: Duncan Coutts , Matthew Gruen -copyright: 2008-2013 Duncan Coutts, +copyright: 2008-2014 Duncan Coutts, 2012-2013 Edsko de Vries, + 2013 Google Inc., 2010-2011 Matthew Gruen, 2009-2010 Antoine Latter, 2008 David Himmelstrup, @@ -34,7 +35,9 @@ templates/Html/*.html.st templates/LegacyPasswds/*.html.st templates/Search/*.xml.st - templates/UserSignupReset/*.st + templates/UserSignupReset/*.html.st + templates/UserSignupReset/*.email.st + templates/AdminFrontend/*.html.st static/*.css static/*.ico @@ -66,6 +69,15 @@ default: True manual: True +flag build-hackage-import + default: False + manual: True + +-- Requires working local outgoing email +flag test-create-user + default: False + manual: True + executable hackage-server if ! flag(build-hackage-server) buildable: False @@ -93,10 +105,13 @@ Distribution.Server.Framework.Resource Distribution.Server.Framework.RequestContentTypes Distribution.Server.Framework.ResponseContentTypes + Distribution.Server.Framework.CacheControl Distribution.Server.Framework.BackupDump Distribution.Server.Framework.BackupRestore Distribution.Server.Framework.ServerEnv - + Distribution.Server.Framework.Templating + Distribution.Server.Framework.HappstackUtils + Distribution.Server.Packages.Index Distribution.Server.Packages.ModuleForest Distribution.Server.Packages.PackageIndex @@ -105,7 +120,6 @@ Distribution.Server.Packages.Render Distribution.Server.Packages.ChangeLog - Distribution.Server.Pages.BuildReports Distribution.Server.Pages.Distributions Distribution.Server.Pages.Group Distribution.Server.Pages.Index @@ -113,6 +127,7 @@ Distribution.Server.Pages.Package.HaddockHtml Distribution.Server.Pages.Package.HaddockLex Distribution.Server.Pages.Package.HaddockParse + Distribution.Server.Pages.Package.HaddockTypes Distribution.Server.Pages.Recent -- [reverse index disabled] Distribution.Server.Pages.Reverse Distribution.Server.Pages.Template @@ -124,7 +139,6 @@ Distribution.Server.Users.Backup Distribution.Server.Users.Users - Distribution.Server.Util.Happstack Distribution.Server.Util.Histogram Distribution.Server.Util.CountingMap Distribution.Server.Util.Index @@ -132,7 +146,9 @@ Distribution.Server.Util.Parse Distribution.Server.Util.ServeTarball Distribution.Server.Util.TarIndex - Distribution.Server.Util.TextSearch + Distribution.Server.Util.GZip + Distribution.Server.Util.ContentType + Distribution.Server.Util.SigTerm Distribution.Server.Features Distribution.Server.Features.Core @@ -159,11 +175,13 @@ Distribution.Server.Features.BuildReports.BuildReport Distribution.Server.Features.BuildReports.BuildReports Distribution.Server.Features.BuildReports.Backup + Distribution.Server.Features.BuildReports.Render 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.PackageList Distribution.Server.Features.Distro Distribution.Server.Features.Distro.Distributions Distribution.Server.Features.Distro.Backup @@ -173,9 +191,23 @@ Distribution.Server.Features.Documentation.State Distribution.Server.Features.DownloadCount Distribution.Server.Features.DownloadCount.State + Distribution.Server.Features.DownloadCount.Backup Distribution.Server.Features.EditCabalFiles Distribution.Server.Features.Html + Distribution.Server.Features.HoogleData + Distribution.Server.Features.HaskellPlatform + Distribution.Server.Features.HaskellPlatform.State Distribution.Server.Features.Search + Distribution.Server.Features.Search.BM25F + Distribution.Server.Features.Search.DocIdSet + Distribution.Server.Features.Search.DocTermIds + Distribution.Server.Features.Search.DocFeatVals + Distribution.Server.Features.Search.ExtractDescriptionTerms + Distribution.Server.Features.Search.ExtractNameTerms + Distribution.Server.Features.Search.PkgSearch + Distribution.Server.Features.Search.SearchEngine + Distribution.Server.Features.Search.SearchIndex + Distribution.Server.Features.Search.TermBag Distribution.Server.Features.RecentPackages Distribution.Server.Features.PreferredVersions Distribution.Server.Features.PreferredVersions.State @@ -183,10 +215,12 @@ -- [reverse index disabled] Distribution.Server.Features.ReverseDependencies -- [reverse index disabled] Distribution.Server.Features.ReverseDependencies.State Distribution.Server.Features.Tags + Distribution.Server.Features.Tags.Backup Distribution.Server.Features.Tags.State Distribution.Server.Features.UserDetails Distribution.Server.Features.UserSignup Distribution.Server.Features.StaticFiles + Distribution.Server.Features.ServerIntrospect if flag(debug) cpp-options: -DDEBUG @@ -204,7 +238,7 @@ pretty >= 1.0, base64-bytestring ==0.1.* || == 1.0.*, base16-bytestring ==0.1.*, - bytestring >= 0.9, + bytestring >= 0.10.4.1, --TODO: drop blaze builder in favour of bytestring-0.10 builder blaze-builder, text >= 0.11, @@ -216,12 +250,11 @@ mtl >= 2.0, parsec == 3.1.*, network >= 2.1, - unix < 2.7, + 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.*, + cereal >= 0.4, safecopy >= 0.6 && < 0.9, crypto-api >= 0.12 && < 0.13, pureMD5 >= 0.2, @@ -233,16 +266,18 @@ -- client). aeson == 0.6.1.*, unordered-containers >= 0.2.3.0, - rss == 3000.2.*, - Cabal >= 1.16 && < 1.17, + rss >= 3000.2.0.3, + HaXml >= 1.24, + Cabal == 1.20.*, csv == 0.1.*, stm >= 2.2 && < 2.5, - acid-state == 0.8.*, - happstack-server == 7.0.* || ==7.1.* && >= 7.0.6, + acid-state >= 0.12.2, + happstack-server == 7.3.*, hslogger, mime-mail ==0.4.*, HStringTemplate ==0.7.*, - lifted-base >= 0.2.1 && < 0.3 + lifted-base >= 0.2.1 && < 0.3, + QuickCheck >= 2.5 if ! flag(minimal) build-depends: @@ -269,6 +304,8 @@ main-is: MirrorClient.hs other-modules: Distribution.Client + Distribution.Client.Cron + Distribution.Client.UploadLog Distribution.Server.Users.Types Distribution.Server.Util.Index Distribution.Server.Util.Merge @@ -278,10 +315,10 @@ filepath, directory, time, old-locale, random, tar, zlib, - network, HTTP >= 4000.1.3, + network, HTTP >= 4000.2.11, Cabal, safecopy, cereal, binary, mtl, - unix + unix, aeson default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs @@ -315,17 +352,23 @@ ghc-options: -Wall -fwarn-tabs -threaded executable hackage-import - if ! flag(build-hackage-mirror) + if ! flag(build-hackage-import) buildable: False main-is: ImportClient.hs other-modules: + Distribution.Client.DistroMap + Distribution.Client.HtPasswdDb + Distribution.Client.ParseApacheLogs + Distribution.Client.PkgIndex + Distribution.Client.TagsFile + Distribution.Client.UserAddressesDb build-depends: base, containers, array, vector, bytestring, text, pretty, filepath, directory, time, old-locale, random, tar, zlib, - network, HTTP >= 4000.1.3, + network, HTTP >= 4000.2.11, Cabal, safecopy, cereal, binary, mtl, csv, async, attoparsec, @@ -340,7 +383,7 @@ main-is: HighLevelTest.hs hs-source-dirs: tests default-language: Haskell2010 - ghc-options: -threaded + ghc-options: -threaded -Wall build-depends: base, bytestring, base64-bytestring, @@ -352,5 +395,38 @@ process, tar, unix, - zlib + zlib, + unordered-containers, + aeson, + text, + vector, + xml, + random + +Test-Suite CreateUserTest + if ! flag(test-create-user) + buildable: False + type: exitcode-stdio-1.0 + main-is: CreateUserTest.hs + hs-source-dirs: tests + default-language: Haskell2010 + ghc-options: -threaded -Wall + build-depends: base, + bytestring, + base64-bytestring, + Cabal, + directory, + filepath, + HTTP, + network, + process, + tar, + unix, + zlib, + unordered-containers, + aeson, + text, + vector, + xml, + random diff --git a/tests/CreateUserTest.hs b/tests/CreateUserTest.hs new file mode 100644 --- /dev/null +++ b/tests/CreateUserTest.hs @@ -0,0 +1,101 @@ +{- + This a separate part of the high-level test of the hackage server + (see HighLevelTest.hs). This set of tests check that the user self + registration wors. This test needs local outgoing email, which isn't + available on all hosts, so we keep it as a separate test. + + System requirements: + + 1. Port `testPort` (currently 8392) must be available on localhost + 2. You must have sendmail configured so that it can send emails to external + domains (for user registration) -- currently we use mailinator.com accounts + 3. You must allow for outgoing HTTP traffic, as we POST to html5.validator.nu + for HTML validation. +-} + +module Main (main) where + +import Control.Exception +import Control.Monad +import Data.List (isInfixOf) +import Data.String () +import System.Directory +import System.FilePath +import System.IO +import System.Random + +import MailUtils +import Util +import HttpUtils (Authorization(..)) +import HackageClientUtils + +main :: IO () +main = do hSetBuffering stdout LineBuffering + info "Initialising" + root <- getCurrentDirectory + info "Setting up test directory" + exists <- doesDirectoryExist (testDir root) + when exists $ removeDirectoryRecursive (testDir root) + createDirectory (testDir root) + (setCurrentDirectory (testDir root) >> doit root) + `finally` removeDirectoryRecursive (testDir root) + +testName :: FilePath +testName = "CreateUserTestTemp" + +testDir :: FilePath -> FilePath +testDir root = root "tests" testName + +doit :: FilePath -> IO () +doit root + = do info "initialising hackage database" + runServerChecked root ["init"] + withServerRunning root runUserTests + +runUserTests :: IO () +runUserTests = do + do info "Getting user list" + xs <- getUsers + unless (xs == ["admin"]) $ + die ("Bad user list: " ++ show xs) + do info "Getting admin user list" + xs <- getAdmins + unless (groupMembers xs == ["admin"]) $ + die ("Bad admin user list: " ++ show xs) + + testEmail1 <- do + -- Create random test email addresses so that we don't confuse + -- confirmation emails from other sessions + testEmail1 <- mkTestEmail `liftM` randomIO + testEmail2 <- mkTestEmail `liftM` randomIO + createUserSelfRegister "HackageTestUser1" "Test User 1" testEmail1 + createUserSelfRegister "HackageTestUser2" "Test User 2" testEmail2 + confirmUser testEmail1 "testpass1" + confirmUser testEmail2 "testpass2" + return (testEmailAddress testEmail1) + do info "Checking new users are now in user list" + xs <- getUsers + unless (xs == ["admin","HackageTestUser1","HackageTestUser2"]) $ + die ("Bad user list: " ++ show xs) + do info "Checking new users are not in admin list" + xs <- getAdmins + unless (groupMembers xs == ["admin"]) $ + die ("Bad admin user list: " ++ show xs) + do info "Checking new users name & contact info" + ncinf <- getNameContactInfo (Auth "HackageTestUser1" "testpass1") + "/user/HackageTestUser1/name-contact.json" + unless (realName ncinf == "Test User 1") $ + die ("Bad user real name: " ++ realName ncinf) + unless (contactEmailAddress ncinf == testEmail1) $ + die ("Bad user email: " ++ contactEmailAddress ncinf) + do info "Checking new users admin info" + uainf <- getUserAdminInfo (Auth "admin" "admin") "/user/HackageTestUser1/admin-info.json" + unless (accountKind uainf == Just "AccountKindRealUser") $ + die ("Bad user account kind: " ++ show (accountKind uainf)) + unless ("self-registration" `isInfixOf` accountNotes uainf) $ + die ("Bad user notes: " ++ accountNotes uainf) + + where + mkTestEmail :: Int -> String + mkTestEmail n = "HackageTestUser" ++ show n + diff --git a/tests/HighLevelTest.hs b/tests/HighLevelTest.hs --- a/tests/HighLevelTest.hs +++ b/tests/HighLevelTest.hs @@ -1,195 +1,179 @@ - {- -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. + This is a very high-level test of the hackage server. It forks a fresh server + instance, and then uses HTTP to run various requests on that server. + + System requirements: + + 1. Port `testPort` (currently 8392) must be available on localhost + 2. You must allow for outgoing HTTP traffic, as we POST to html5.validator.nu + for HTML validation. -} module Main (main) where import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip -import Control.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 Data.List (isInfixOf) +import Data.String () import System.Directory import System.Exit import System.FilePath import System.IO -import System.IO.Error -import System.Process import Package -import Run +import Util +import HttpUtils ( isOk + , isNoContent + , isForbidden + , Authorization(..) + ) +import HackageClientUtils --- 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) + exists <- doesDirectoryExist (testDir root) + when exists $ removeDirectoryRecursive (testDir root) + createDirectory (testDir root) + (setCurrentDirectory (testDir root) >> doit root) + `finally` removeDirectoryRecursive (testDir root) +testName :: FilePath +testName = "HighLevelTestTemp" + +testDir :: FilePath -> FilePath +testDir root = root "tests" testName + doit :: FilePath -> IO () doit root = do info "initialising hackage database" - runServerChecked True root ["init"] - withServerRunning root $ do validate (mkUrl "/") - validate (mkUrl "/accounts.html") - validate (mkUrl "/admin.html") - validate (mkUrl "/upload.html") + runServerChecked root ["init"] + withServerRunning root $ do void $ validate NoAuth "/" + void $ validate NoAuth "/accounts" + void $ validate (Auth "admin" "admin") "/admin" + void $ validate NoAuth "/upload" runUserTests runPackageUploadTests runPackageTests withServerRunning root $ runPackageTests info "Making database backup" - runServerChecked False root ["backup", "-o", "hlb.tar"] + tarGz1 <- createBackup testName root "1" info "Removing old state" removeDirectoryRecursive "state" info "Checking server doesn't work" - mec <- runServer True root serverRunningArgs + mec <- runServer root serverRunningArgs case mec of Just (ExitFailure 1) -> return () Just (ExitFailure _) -> die "Server failed with wrong exit code" Just ExitSuccess -> die "Server worked unexpectedly" Nothing -> die "Got a signal?" - info "Restoring database" - runServerChecked False root ["restore", "hlb.tar"] + info $ "Restoring database from " ++ tarGz1 + runServerChecked root ["restore", tarGz1] info "Making another database backup" - runServerChecked False root ["backup", "-o", "hlb2.tar"] + tarGz2 <- createBackup testName root "2" info "Checking databases match" - db1 <- LBS.readFile "hlb.tar" - db2 <- LBS.readFile "hlb2.tar" + db1 <- LBS.readFile tarGz1 + db2 <- LBS.readFile tarGz2 unless (db1 == db2) $ die "Databases don't match" info "Checking server still works, and data is intact" withServerRunning root $ runPackageTests -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"]) $ + xs <- fmap (map userName) getUsers + unless (xs == ["admin"]) $ die ("Bad user list: " ++ show xs) do info "Getting admin user list" - xs <- getUrlStrings "/users/admins/" - unless (xs == ["Hackage admins","[","edit","]","admin"]) $ + xs <- getAdmins + unless (map userName (groupMembers xs) == ["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 -- For this test we just create the users directly using the admin + -- interface, there's a separate test that tests the self-signup. + createUserDirect (Auth "admin" "admin") "HackageTestUser1" "testpass1" + createUserDirect (Auth "admin" "admin") "HackageTestUser2" "testpass2" do info "Checking new users are now in user list" - xs <- getUrlStrings "/users/" - unless (xs == ["Hackage users","admin","testuser","testuser2"]) $ + xs <- fmap (map userName) getUsers + unless (xs == ["admin","HackageTestUser1","HackageTestUser2"]) $ die ("Bad user list: " ++ show xs) do info "Checking new users are not in admin list" - xs <- getUrlStrings "/users/admins/" - unless (xs == ["Hackage admins","[","edit","]","admin"]) $ + xs <- getAdmins + unless (map userName (groupMembers xs) == ["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 "Getting password change page for HackageTestUser1" + void $ validate (Auth "HackageTestUser1" "testpass1") "/user/HackageTestUser1/password" + do info "Getting password change page for HackageTestUser1 as an admin" + void $ validate (Auth "admin" "admin") "/user/HackageTestUser1/password" + do info "Getting password change page for HackageTestUser1 as another user" + checkIsForbidden (Auth "HackageTestUser2" "testpass2") "/user/HackageTestUser1/password" + do info "Getting password change page for HackageTestUser1 with bad password" + checkIsUnauthorized (Auth "HackageTestUser1" "badpass") "/user/HackageTestUser1/password" + do info "Getting password change page for HackageTestUser1 with bad username" + checkIsUnauthorized (Auth "baduser" "testpass1") "/user/HackageTestUser1/password" + do info "Changing password for HackageTestUser2" + post (Auth "HackageTestUser2" "testpass2") "/user/HackageTestUser2/password" [ + ("password", "newtestpass2") + , ("repeat-password", "newtestpass2") + , ("_method", "PUT") + ] do info "Checking password has changed" - void $ 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"]) $ + void $ validate (Auth "HackageTestUser2" "newtestpass2") "/user/HackageTestUser2/password" + checkIsUnauthorized (Auth "HackageTestUser2" "testpass2") "/user/HackageTestUser2/password" + do info "Trying to delete HackageTestUser2 as HackageTestUser2" + delete isForbidden (Auth "HackageTestUser2" "newtestpass2") "/user/HackageTestUser2" + xs <- fmap (map userName) getUsers + unless (xs == ["admin","HackageTestUser1","HackageTestUser2"]) $ die ("Bad user list: " ++ show xs) - do info "Deleting testuser2 as admin" - deleteUrlRes ((2, 0, 0) ==) "admin" "admin" "/user/testuser2" - xs <- getUrlStrings "/users/" - unless (xs == ["Hackage users","admin","testuser"]) $ + do info "Deleting HackageTestUser2 as admin" + delete isNoContent (Auth "admin" "admin") "/user/HackageTestUser2" + xs <- fmap (map userName) getUsers + unless (xs == ["admin","HackageTestUser1"]) $ die ("Bad user list: " ++ show xs) - do info "Getting user info for testuser" - xs <- getUrlStrings "/user/testuser" - unless (xs == ["testuser"]) $ + do info "Getting user info for HackageTestUser1" + xs <- validate NoAuth "/user/HackageTestUser1" + --TODO: set the user's real name, and then look for that here + unless ("HackageTestUser1" `isInfixOf` xs) $ die ("Bad user info: " ++ show xs) runPackageUploadTests :: IO () runPackageUploadTests = do do info "Getting package list" - xs <- getUrlStrings "/packages/" - unless (xs == ["Packages by category","Categories:","."]) $ + xs <- map packageName `liftM` getPackages + unless (xs == []) $ 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")] + postFile isForbidden + (Auth "HackageTestUser1" "testpass1") + "/packages/" "package" + (testpackageTarFilename, testpackageTarFileContent) + do info "Adding HackageTestUser1 to uploaders" + post (Auth "admin" "admin") "/packages/uploaders/" [ + ("user", "HackageTestUser1") + ] do info "Uploading testpackage" - void $ postFileAuthToUrlRes ((2, 0, 0) ==) - "testuser" "testpass" "/packages/" "package" - (testpackageTarFilename, testpackageTarFileContent) - where (testpackageTarFilename, testpackageTarFileContent, _, _, _, _) - = testpackage + postFile isOk + (Auth "HackageTestUser1" "testpass1") + "/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"," (1).", - "MyCategory", - "testpackage","library: test package testpackage"]) $ + xs <- map packageName `liftM` getPackages + unless (xs == ["testpackage"]) $ die ("Bad package list: " ++ show xs) do info "Getting package index" - targz <- getUrl "/packages/index.tar.gz" + targz <- getUrl NoAuth "/packages/index.tar.gz" let tar = GZip.decompress $ LBS.pack targz entries = Tar.foldEntries (:) [] (error . show) $ Tar.read tar entryFilenames = map Tar.entryPath entries @@ -202,262 +186,40 @@ return () _ -> die "Bad index contents" + do info "Getting package index with etag" + validateETagHandling "/packages/index.tar.gz" do info "Getting testpackage info" - xs <- getUrlStrings "/package/testpackage" - unless (take 1 xs == ["The testpackage package"]) $ + xs <- validate NoAuth "/package/testpackage" + unless ("The testpackage package" `isInfixOf` xs) $ die ("Bad package info: " ++ show xs) do info "Getting testpackage-1.0.0.0 info" - xs <- getUrlStrings "/package/testpackage-1.0.0.0" - unless (take 1 xs == ["The testpackage package"]) $ + xs <- validate NoAuth "/package/testpackage-1.0.0.0" + unless ("The testpackage package" `isInfixOf` xs) $ die ("Bad package info: " ++ show xs) do info "Getting testpackage Cabal file" - cabalFile <- getUrl "/package/testpackage-1.0.0.0/testpackage.cabal" + cabalFile <- getUrl NoAuth "/package/testpackage-1.0.0.0/testpackage.cabal" unless (cabalFile == testpackageCabalFile) $ die "Bad Cabal file" do info "Getting testpackage tar file" - tarFile <- getUrl "/package/testpackage/testpackage-1.0.0.0.tar.gz" + tarFile <- getUrl NoAuth "/package/testpackage/testpackage-1.0.0.0.tar.gz" unless (tarFile == testpackageTarFileContent) $ die "Bad tar file" do info "Getting testpackage source" - hsFile <- getUrl ("/package/testpackage/src" - testpackageHaskellFilename) + hsFile <- getUrl NoAuth ("/package/testpackage/src" testpackageHaskellFilename) unless (hsFile == testpackageHaskellFileContent) $ die "Bad Haskell file" + do info "Getting testpackage source with etag" + validateETagHandling ("/package/testpackage/src" testpackageHaskellFilename) do info "Getting testpackage maintainer info" - xs <- 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"]) $ + xs <- getGroup "/package/testpackage/maintainers/.json" + unless (map userName (groupMembers xs) == ["HackageTestUser1"]) $ die "Bad maintainers list" - where (_, testpackageTarFileContent, - testpackageCabalIndexFilename, testpackageCabalFile, - testpackageHaskellFilename, testpackageHaskellFileContent) - = testpackage + 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 = ("
    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