diff --git a/Application.hs b/Application.hs index 4edd93a..adfde13 100644 --- a/Application.hs +++ b/Application.hs @@ -13,6 +13,7 @@ import Control.Monad.Logger (runLoggingT, LoggingT, defaultLogStr) import Data.BlobStore (fileStore, storeWrite, cachedS3Store) import Data.Hackage import Data.Hackage.Views +import Data.Unpacking (newDocUnpacker, createHoogleDatabases) import Data.WebsiteContent import Data.Slug (SnapSlug (..), safeMakeSlug, HasGenIO) import Data.Time (diffUTCTime) @@ -69,6 +70,9 @@ import Handler.Tag import Handler.BannedTags import Handler.RefreshDeprecated import Handler.UploadV2 +import Handler.Hoogle +import Handler.BuildVersion +import Handler.PackageCounts -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the @@ -148,17 +152,12 @@ makeFoundation useEcho conf = do (getter, _) <- clockDateCacher gen <- MWC.createSystemRandom - progressMap' <- newIORef mempty - nextProgressKey' <- newIORef 0 blobStore' <- loadBlobStore manager conf let haddockRootDir' = "/tmp/stackage-server-haddocks2" - (statusRef, unpacker) <- createHaddockUnpacker haddockRootDir' blobStore' - (flip (Database.Persist.runPool dbconf) p) widgetCache' <- newIORef mempty -#if MIN_VERSION_yesod_gitrepo(0,1,1) websiteContent' <- if development then do void $ rawSystem "git" @@ -170,23 +169,12 @@ makeFoundation useEcho conf = do "https://github.com/fpco/stackage-content.git" "master" loadWebsiteContent -#else - websiteContent' <- if development - then do - void $ rawSystem "git" - [ "clone" - , "https://github.com/fpco/stackage-content.git" - ] - tmp <- gitRepo "stackage-content" "master" loadWebsiteContent - return tmp - { grRefresh = return () - , grContent = loadWebsiteContent "stackage-content" - } - else gitRepo - "https://github.com/fpco/stackage-content.git" - "master" - loadWebsiteContent -#endif + + env <- getEnvironment + + let runDB' :: (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a + runDB' = flip (Database.Persist.runPool dbconf) p + docUnpacker <- newDocUnpacker haddockRootDir' blobStore' runDB' snapshotInfoCache' <- newIORef mempty @@ -200,17 +188,14 @@ makeFoundation useEcho conf = do , appLogger = logger , genIO = gen , blobStore = blobStore' - , progressMap = progressMap' - , nextProgressKey = nextProgressKey' , haddockRootDir = haddockRootDir' - , haddockUnpacker = unpacker + , appDocUnpacker = docUnpacker , widgetCache = widgetCache' - , compressorStatus = statusRef , websiteContent = websiteContent' , snapshotInfoCache = snapshotInfoCache' } - env <- getEnvironment + let urlRender' = yesodRender foundation (appRoot conf) -- Perform database migration using our application's logging settings. when (lookup "STACKAGE_SKIP_MIGRATION" env /= Just "1") $ @@ -224,6 +209,7 @@ makeFoundation useEcho conf = do let updateDB = lookup "STACKAGE_CABAL_LOADER" env /= Just "0" + hoogleGen = lookup "STACKAGE_HOOGLE_GEN" env /= Just "0" forceUpdate = lookup "STACKAGE_FORCE_UPDATE" env == Just "1" loadCabalFiles' = appLoadCabalFiles updateDB forceUpdate foundation dbconf p @@ -236,6 +222,8 @@ makeFoundation useEcho conf = do loadCabalFiles' + when hoogleGen $ liftIO $ createHoogleDatabases blobStore' runDB' putStrLn urlRender' + liftIO $ threadDelay $ 30 * 60 * 1000000 return foundation where ifRunCabalLoader m = @@ -276,6 +264,26 @@ cabalLoaderMain = do } dbconf pool + + let foundation = App + { settings = conf + , getStatic = error "getStatic" + , connPool = pool + , httpManager = manager + , persistConfig = dbconf + , appLogger = error "appLogger" + , genIO = error "genIO" + , blobStore = bs + , haddockRootDir = error "haddockRootDir" + , appDocUnpacker = error "appDocUnpacker" + , widgetCache = error "widgetCache" + , websiteContent = error "websiteContent" + } + createHoogleDatabases + bs + (flip (Database.Persist.runPool dbconf) pool) + putStrLn + (yesodRender foundation (appRoot conf)) where logFunc loc src level str | level > LevelDebug = S.hPutStr stdout $ fromLogStr $ defaultLogStr loc src level str diff --git a/Data/Hackage/DeprecationInfo.hs b/Data/Hackage/DeprecationInfo.hs index 9bdbd90..238a4f5 100644 --- a/Data/Hackage/DeprecationInfo.hs +++ b/Data/Hackage/DeprecationInfo.hs @@ -23,8 +23,8 @@ instance FromJSON HackageDeprecationInfo where } data DeprecationRecord = DeprecationRecord { - deprecatedPackage :: PackageName, - deprecatedInFavourOf :: [PackageName] + _deprecatedPackage :: PackageName, + _deprecatedInFavourOf :: [PackageName] } instance FromJSON DeprecationRecord where diff --git a/Data/Slug.hs b/Data/Slug.hs index a3fc74a..d517cfa 100644 --- a/Data/Slug.hs +++ b/Data/Slug.hs @@ -18,7 +18,7 @@ import GHC.Prim (RealWorld) import Text.Blaze (ToMarkup) newtype Slug = Slug { unSlug :: Text } - deriving (Show, Read, Eq, Typeable, PersistField, ToMarkup) + deriving (Show, Read, Eq, Typeable, PersistField, ToMarkup, Ord, Hashable) instance PersistFieldSql Slug where sqlType = sqlType . liftM unSlug @@ -101,6 +101,6 @@ slugField = -- | Unique identifier for a snapshot. newtype SnapSlug = SnapSlug { unSnapSlug :: Slug } - deriving (Show, Read, Eq, Typeable, PersistField, ToMarkup, PathPiece) + deriving (Show, Read, Eq, Typeable, PersistField, ToMarkup, PathPiece, Ord, Hashable) instance PersistFieldSql SnapSlug where sqlType = sqlType . liftM unSnapSlug diff --git a/Data/Unpacking.hs b/Data/Unpacking.hs new file mode 100644 index 0000000..d505720 --- /dev/null +++ b/Data/Unpacking.hs @@ -0,0 +1,494 @@ +-- | Code for unpacking documentation bundles, building the Hoogle databases, +-- and compressing/deduping contents. +module Data.Unpacking + ( newDocUnpacker + , getHoogleDB + , makeHoogle + , createHoogleDatabases + ) where + +import Import hiding (runDB) +import Data.BlobStore +import Handler.Haddock +import Filesystem (createTree, isFile, removeTree, isDirectory, listDirectory, removeDirectory, removeFile, rename) +import System.Posix.Files (createLink) +import Crypto.Hash.Conduit (sinkHash) +import Control.Concurrent (forkIO) +import Control.Monad.Trans.Resource (allocate, release) +import Data.Char (isAlpha) +import qualified Hoogle +import qualified Data.Text as T +import qualified Data.Yaml as Y +import System.IO (IOMode (ReadMode), withBinaryFile, openBinaryFile) +import System.IO.Temp (withSystemTempFile, withTempFile, withSystemTempDirectory) +import System.Exit (ExitCode (ExitSuccess)) +import System.Process (createProcess, proc, cwd, waitForProcess) +import qualified Filesystem.Path.CurrentOS as F +import Data.Conduit.Zlib (gzip, ungzip) +import qualified Data.ByteString.Base16 as B16 +import Data.Byteable (toBytes) +import Crypto.Hash (Digest, SHA1) + +newDocUnpacker + :: FilePath -- ^ haddock root + -> BlobStore StoreKey + -> (forall a m. (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a) + -> IO DocUnpacker +newDocUnpacker root store runDB = do + createDirs dirs + + statusMapVar <- newTVarIO $ asMap mempty + messageVar <- newTVarIO "Inactive" + workChan <- atomically newTChan + + let requestDocs forceUnpack ent = atomically $ do + var <- newTVar USBusy + modifyTVar statusMapVar + $ insertMap (stackageSlug $ entityVal ent) var + writeTChan workChan (forceUnpack, ent, var) + + forkForever $ unpackWorker dirs runDB store messageVar workChan + + return DocUnpacker + { duRequestDocs = \ent -> do + m <- readTVarIO statusMapVar + case lookup (stackageSlug $ entityVal ent) m of + Nothing -> do + b <- isUnpacked dirs (entityVal ent) + if b + then return USReady + else do + requestDocs False ent + return USBusy + Just us -> readTVarIO us + , duGetStatus = readTVarIO messageVar + , duForceReload = \ent -> do + atomically $ modifyTVar statusMapVar + $ deleteMap (stackageSlug $ entityVal ent) + requestDocs True ent + } + where + dirs = mkDirs root + +createDirs :: Dirs -> IO () +createDirs dirs = do + createTree $ dirCacheRoot dirs + createTree $ dirRawRoot dirs + createTree $ dirGzRoot dirs + createTree $ dirHoogleRoot dirs + +-- | Check for the presence of file system artifacts indicating that the docs +-- have been unpacked. +isUnpacked :: Dirs -> Stackage -> IO Bool +isUnpacked dirs stackage = isFile $ completeUnpackFile dirs stackage + +defaultHooDest :: Dirs -> Stackage -> FilePath +defaultHooDest dirs stackage = dirHoogleFp dirs (stackageIdent stackage) + ["default-" ++ VERSION_hoogle ++ ".hoo"] + +forkForever :: IO () -> IO () +forkForever inner = mask $ \restore -> + void $ forkIO $ forever $ handleAny print $ restore $ forever inner + +unpackWorker + :: Dirs + -> (forall a m. (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a) + -> BlobStore StoreKey + -> TVar Text + -> TChan (Bool, Entity Stackage, TVar UnpackStatus) + -> IO () +unpackWorker dirs runDB store messageVar workChan = do + let say' = atomically . writeTVar messageVar + say' "Running the compressor" + let shouldStop = fmap not $ atomically $ isEmptyTChan workChan + handleAny print $ runCompressor shouldStop say' dirs + + say' "Waiting for new work item" + (forceUnpack, ent, resVar) <- atomically $ readTChan workChan + shouldUnpack <- + if forceUnpack + then return True + else not <$> isUnpacked dirs (entityVal ent) + + let say msg = atomically $ writeTVar messageVar $ concat + [ toPathPiece (stackageSlug $ entityVal ent) + , ": " + , msg + ] + + when shouldUnpack $ do + say "Beginning of processing" + + -- As soon as the raw unpack is complete, start serving docs + let onRawComplete = atomically $ writeTVar resVar USReady + + eres <- tryAny $ unpacker dirs runDB store say onRawComplete ent + atomically $ writeTVar resVar $ case eres of + Left e -> USFailed $ tshow e + Right () -> USReady + +removeTreeIfExists :: FilePath -> IO () +removeTreeIfExists fp = whenM (isDirectory fp) (removeTree fp) + +unpackRawDocsTo + :: BlobStore StoreKey + -> PackageSetIdent + -> (Text -> IO ()) + -> FilePath + -> IO () +unpackRawDocsTo store ident say destdir = + withSystemTempFile "haddock-bundle.tar.xz" $ \tempfp temph -> do + say "Downloading raw doc tarball" + withAcquire (storeRead' store (HaddockBundle ident)) $ \msrc -> + case msrc of + Nothing -> error "No haddocks exist for that snapshot" + Just src -> src $$ sinkHandle temph + hClose temph + + createTree destdir + say "Unpacking tarball" + (Nothing, Nothing, Nothing, ph) <- createProcess + (proc "tar" ["xf", tempfp]) + { cwd = Just $ fpToString destdir + } + ec <- waitForProcess ph + if ec == ExitSuccess then return () else throwM ec + + +unpacker + :: Dirs + -> (forall a m. (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a) + -> BlobStore StoreKey + -> (Text -> IO ()) + -> IO () -- ^ onRawComplete + -> Entity Stackage + -> IO () +unpacker dirs runDB store say onRawComplete (Entity sid stackage@Stackage {..}) = do + say "Removing old directories, if they exist" + removeTreeIfExists $ dirRawIdent dirs stackageIdent + removeTreeIfExists $ dirGzIdent dirs stackageIdent + removeTreeIfExists $ dirHoogleIdent dirs stackageIdent + + let destdir = dirRawIdent dirs stackageIdent + unpackRawDocsTo store stackageIdent say destdir + onRawComplete + + createTree $ dirHoogleIdent dirs stackageIdent + + -- Determine which packages have documentation and update the + -- database appropriately + say "Updating database for available documentation" + runResourceT $ runDB $ do + updateWhere + [PackageStackage ==. sid] + [PackageHasHaddocks =. False] + sourceDirectory destdir $$ mapM_C (\fp -> do + let mnv = nameAndVersionFromPath fp + forM_ mnv $ \(name, version) -> updateWhere + [ PackageStackage ==. sid + , PackageName' ==. PackageName name + , PackageVersion ==. Version version + ] + [PackageHasHaddocks =. True] + ) + + say "Unpack complete" + let completeFP = completeUnpackFile dirs stackage + liftIO $ do + createTree $ F.parent completeFP + writeFile completeFP ("Complete" :: ByteString) + +completeUnpackFile :: Dirs -> Stackage -> FilePath +completeUnpackFile dirs stackage = + dirGzIdent dirs (stackageIdent stackage) "unpack-complete" + +-- | Get the path to the Hoogle database, downloading from persistent storage +-- if necessary. This function will /not/ generate a new database, and +-- therefore is safe to run on a live web server. +getHoogleDB :: Dirs + -> Stackage + -> Handler (Maybe FilePath) +getHoogleDB dirs stackage = do + exists <- liftIO $ isFile fp + if exists + then return $ Just fp + else do + msrc <- storeRead key + case msrc of + Nothing -> return Nothing + Just src -> do + liftIO $ createTree $ F.parent fp + let tmpfp = fp <.> "tmp" -- FIXME add something random + src $$ ungzip =$ sinkFile tmpfp + liftIO $ rename tmpfp fp + return $ Just fp + where + fp = defaultHooDest dirs stackage + key = HoogleDB (stackageIdent stackage) $ HoogleVersion VERSION_hoogle + +-- | Make sure that the last 5 LTS and last 5 Nightly releases all have Hoogle +-- databases available. +createHoogleDatabases + :: BlobStore StoreKey + -> (forall a m. (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a) + -> (Text -> IO ()) + -> (Route App -> [(Text, Text)] -> Text) + -> IO () +createHoogleDatabases store runDB say urlRender = do + stackages <- runDB $ do + sids <- (++) + <$> fmap (map $ ltsStackage . entityVal) + (selectList [] [Desc LtsMajor, Desc LtsMinor, LimitTo 5]) + <*> fmap (map $ nightlyStackage . entityVal) + (selectList [] [Desc NightlyDay, LimitTo 5]) + catMaybes <$> mapM get sids + forM_ stackages $ \stackage -> do + let say' x = say $ concat + [ toPathPiece $ stackageSlug stackage + , ": " + , x + ] + handleAny (say' . tshow) $ makeHoogle store say' urlRender stackage + +-- | Either download the Hoogle database from persistent storage, or create it. +makeHoogle + :: BlobStore StoreKey + -> (Text -> IO ()) + -> (Route App -> [(Text, Text)] -> Text) + -> Stackage + -> IO () +makeHoogle store say urlRender stackage = do + say "Making hoogle database" + exists <- storeExists' store hoogleKey + if exists + then say "Hoogle database already exists, skipping" + else do + say "Generating Hoogle database" + generate + where + ident = stackageIdent stackage + hoogleKey = HoogleDB ident $ HoogleVersion VERSION_hoogle + + generate = withSystemTempDirectory "hoogle-database-gen" $ \hoogletemp' -> do + let hoogletemp = fpFromString hoogletemp' + rawdocs = hoogletemp "rawdocs" + + unpackRawDocsTo store ident say rawdocs + + say "Copying Hoogle text files to temp directory" + runResourceT $ copyHoogleTextFiles say rawdocs hoogletemp + say "Creating Hoogle database" + withSystemTempFile "default.hoo" $ \dstFP' dstH -> do + let dstFP = fpFromString dstFP' + hClose dstH + createHoogleDb say dstFP stackage hoogletemp urlRender + say "Uploading database to persistent storage" + withAcquire (storeWrite' store hoogleKey) $ \sink -> + runResourceT $ sourceFile dstFP $$ gzip =$ sink + +runCompressor :: IO Bool -- ^ should stop early? + -> (Text -> IO ()) -> Dirs -> IO () +runCompressor shouldStop say dirs = + handle (\EarlyStop -> return ()) $ runResourceT $ goDir $ dirRawRoot dirs + where + goDir dir = do + liftIO $ whenM shouldStop $ do + say "Stopping compressor early" + throwIO EarlyStop + liftIO $ say $ "Compressing directory: " ++ fpToText dir + sourceDirectory dir $$ mapM_C goFP + liftIO $ void $ tryIO $ removeDirectory dir + + goFP fp = do + e <- liftIO $ isFile fp + if e + then liftIO $ do + liftIO $ say $ "Compressing file: " ++ fpToText fp + handle (print . asSomeException) + $ gzipHash dirs suffix + else goDir fp + where + Just suffix = F.stripPrefix (dirRawRoot dirs "") fp + +data EarlyStop = EarlyStop + deriving (Show, Typeable) +instance Exception EarlyStop + +-- Procedure is to: +-- +-- * Gzip the src file to a temp file, and get a hash of the gzipped contents +-- * If that hash doesn't exist in the cache, move the new file to the cache +-- * Create a hard link from dst to the file in the cache +-- * Delete src +gzipHash :: Dirs + -> FilePath -- ^ suffix + -> IO () +gzipHash dirs suffix = do + withTempFile (fpToString $ dirCacheRoot dirs) "haddock-file.gz" $ \tempfp temph -> do + digest <- withBinaryFile (fpToString src) ReadMode $ \inh -> + sourceHandle inh + $= gzip + $$ (getZipSink $ + ZipSink (sinkHandle temph) *> + ZipSink sinkHash) + hClose temph + let fpcache = dirCacheFp dirs digest + unlessM (isFile fpcache) $ do + createTree $ F.parent fpcache + rename (fpFromString tempfp) fpcache + createTree $ F.parent dst + createLink (fpToString fpcache) (fpToString dst) + removeFile src + where + src = dirRawRoot dirs suffix + dst = dirGzRoot dirs suffix + +dirCacheFp :: Dirs -> Digest SHA1 -> FilePath +dirCacheFp dirs digest = + dirCacheRoot dirs fpFromText x fpFromText y <.> "gz" + where + name = decodeUtf8 $ B16.encode $ toBytes digest + (x, y) = splitAt 2 name + +copyHoogleTextFiles :: (Text -> IO ()) -- ^ log + -> FilePath -- ^ raw unpacked Haddock files + -> FilePath -- ^ temporary work directory + -> ResourceT IO () +copyHoogleTextFiles say raw tmp = do + let tmptext = tmp "text" + liftIO $ createTree tmptext + sourceDirectory raw $$ mapM_C (\fp -> + forM_ (nameAndVersionFromPath fp) $ \(name, version) -> do + let src = fp fpFromText name <.> "txt" + dst = tmptext fpFromText (name ++ "-" ++ version) + exists <- liftIO $ isFile src + if exists + then sourceFile src $$ (sinkFile dst :: Sink ByteString (ResourceT IO) ()) + else liftIO $ appendHoogleErrors say $ HoogleErrors + { packageName = name + , packageVersion = version + , errors = ["No textual Hoogle DB (use \"cabal haddock --hoogle\")"] + } + ) + +createHoogleDb :: (Text -> IO ()) + -> FilePath -- ^ default.hoo output location + -> Stackage + -> FilePath -- ^ temp directory + -> (Route App -> [(Text, Text)] -> Text) + -> IO () +createHoogleDb say dstDefaultHoo stackage tmpdir urlRender = do + let tmpbin = tmpdir "binary" + createTree tmpbin + eres <- tryAny $ runResourceT $ do + -- Create hoogle binary databases for each package. + sourceDirectory (tmpdir "text") $$ mapM_C + ( \fp -> do + (releaseKey, srcH) <- allocate (openBinaryFile (fpToString fp) ReadMode) hClose + forM_ (nameAndVersionFromPath fp) $ \(name, version) -> liftIO $ do + say $ concat + [ "Creating Hoogle database for: " + , name + , "-" + , version + ] + src <- unpack . decodeUtf8 . asLByteString <$> hGetContents srcH + let -- Preprocess the haddock-generated manifest file. + src' = unlines $ haddockHacks (Just (unpack docsUrl)) $ lines src + docsUrl = urlRender (HaddockR (stackageSlug stackage) urlPieces) [] + urlPieces = [name <> "-" <> version, "index.html"] + -- Compute the filepath of the resulting hoogle + -- database. + out = fpToString $ tmpbin fpFromText base + base = name <> "-" <> version <> ".hoo" + errs <- Hoogle.createDatabase "" Hoogle.Haskell [] src' out + when (not $ null errs) $ do + -- TODO: remove this printing once errors are yielded + -- to the user. + putStrLn $ concat + [ base + , " Hoogle errors: " + , tshow errs + ] + appendHoogleErrors say $ HoogleErrors + { packageName = name + , packageVersion = version + , errors = map show errs + } + release releaseKey + ) + -- Merge the individual binary databases into one big database. + liftIO $ do + say "Merging all Hoogle databases" + dbs <- listDirectory tmpbin + Hoogle.mergeDatabase + (map fpToString dbs) + (fpToString dstDefaultHoo) + case eres of + Right () -> return () + Left err -> liftIO $ appendHoogleErrors say $ HoogleErrors + { packageName = "Exception thrown while building hoogle DB" + , packageVersion = "" + , errors = [show err] + } + +data HoogleErrors = HoogleErrors + { packageName :: Text + , packageVersion :: Text + , errors :: [String] + } deriving (Generic) + +instance ToJSON HoogleErrors where +instance FromJSON HoogleErrors where + +-- Appends hoogle errors to a log file. By encoding within a single +-- list, the resulting file can be decoded as [HoogleErrors]. +appendHoogleErrors :: (Text -> IO ()) -> HoogleErrors -> IO () +appendHoogleErrors say errs = say $ decodeUtf8 $ Y.encode [errs] + +nameAndVersionFromPath :: FilePath -> Maybe (Text, Text) +nameAndVersionFromPath fp = + (\name -> (name, version)) <$> stripSuffix "-" name' + where + (name', version) = T.breakOnEnd "-" $ fpToText $ filename fp + +--------------------------------------------------------------------- +-- HADDOCK HACKS +-- (Copied from hoogle-4.2.36/src/Recipe/Haddock.hs) +-- Modifications: +-- 1) Some name qualification +-- 2) Explicit type sig due to polymorphic elem +-- 3) Fixed an unused binding warning + +-- Eliminate @version +-- Change :*: to (:*:), Haddock bug +-- Change !!Int to !Int, Haddock bug +-- Change instance [overlap ok] to instance, Haddock bug +-- Change instance [incoherent] to instance, Haddock bug +-- Change instance [safe] to instance, Haddock bug +-- Change !Int to Int, HSE bug +-- Drop {-# UNPACK #-}, Haddock bug +-- Drop everything after where, Haddock bug + +haddockHacks :: Maybe Hoogle.URL -> [String] -> [String] +haddockHacks loc src = maybe id haddockPackageUrl loc (translate src) + where + translate :: [String] -> [String] + translate = map (unwords . g . map f . words) . filter (not . isPrefixOf "@version ") + + f "::" = "::" + f (':':xs) = "(:" ++ xs ++ ")" + f ('!':'!':x:xs) | isAlpha x = xs + f ('!':x:xs) | isAlpha x || x `elem` ("[(" :: String) = x:xs + f x | x `elem` ["[overlap","ok]","[incoherent]","[safe]"] = "" + f x | x `elem` ["{-#","UNPACK","#-}"] = "" + f x = x + + g ("where":_) = [] + g (x:xs) = x : g xs + g [] = [] + +haddockPackageUrl :: Hoogle.URL -> [String] -> [String] +haddockPackageUrl x = concatMap f + where f y | "@package " `isPrefixOf` y = ["@url " ++ x, y] + | otherwise = [y] diff --git a/Foundation.hs b/Foundation.hs index e93fa37..3f5635d 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -5,6 +5,7 @@ import Data.BlobStore import Data.Slug (safeMakeSlug, HasGenIO (getGenIO), randomSlug, Slug, SnapSlug) import Data.WebsiteContent import qualified Database.Persist +import Database.Persist.Sql (PersistentSqlException (Couldn'tGetSQLConnection)) import Model import qualified Settings import Settings (widgetFile, Extra (..), GoogleAuth (..)) @@ -36,18 +37,15 @@ data App = App , httpManager :: Manager , persistConfig :: Settings.PersistConf , appLogger :: Logger - , genIO :: !MWC.GenIO - , blobStore :: !(BlobStore StoreKey) - , progressMap :: !(IORef (IntMap Progress)) - , nextProgressKey :: !(IORef Int) - , haddockRootDir :: !FilePath - , haddockUnpacker :: !(ForceUnpack -> PackageSetIdent -> IO ()) + , genIO :: MWC.GenIO + , blobStore :: BlobStore StoreKey + , haddockRootDir :: FilePath + , appDocUnpacker :: DocUnpacker -- ^ We have a dedicated thread so that (1) we don't try to unpack too many -- things at once, (2) we never unpack the same thing twice at the same -- time, and (3) so that even if the client connection dies, we finish the -- unpack job. - , widgetCache :: !(IORef (HashMap Text (UTCTime, GWData (Route App)))) - , compressorStatus :: !(IORef Text) + , widgetCache :: IORef (HashMap Text (UTCTime, GWData (Route App))) , websiteContent :: GitRepo WebsiteContent , snapshotInfoCache :: !(IORef (HashMap PackageSetIdent SnapshotInfo)) } @@ -58,7 +56,11 @@ data SnapshotInfo = SnapshotInfo , siDocMap :: !DocMap } -type ForceUnpack = Bool +data DocUnpacker = DocUnpacker + { duRequestDocs :: Entity Stackage -> IO UnpackStatus + , duGetStatus :: IO Text + , duForceReload :: Entity Stackage -> IO () + } data Progress = ProgressWorking !Text | ProgressDone !Text !(Route App) @@ -101,7 +103,9 @@ instance Yesod App where defaultLayout widget = do mmsg <- getMessage - muser <- maybeAuth + muser <- catch maybeAuth $ \e -> case e of + Couldn'tGetSQLConnection -> return Nothing + _ -> throwM e -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and @@ -136,6 +140,7 @@ instance Yesod App where -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR + {- Temporarily disable to allow for horizontal scaling -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows -- expiration dates to be set far in the future without worry of @@ -147,6 +152,7 @@ instance Yesod App where genFileName lbs | development = "autogen-" ++ base64md5 lbs | otherwise = base64md5 lbs + -} -- Place Javascript at bottom of the body tag so the rest of the page loads first jsLoader _ = BottomOfBody diff --git a/Handler/Alias.hs b/Handler/Alias.hs index c73016e..c3657ec 100644 --- a/Handler/Alias.hs +++ b/Handler/Alias.hs @@ -9,6 +9,7 @@ import Data.Slug (Slug) import Handler.StackageHome (getStackageHomeR, getStackageMetadataR, getStackageCabalConfigR, getSnapshotPackagesR, getDocsR) import Handler.StackageIndex (getStackageIndexR, getStackageBundleR) import Handler.StackageSdist (getStackageSdistR) +import Handler.Hoogle (getHoogleR) handleAliasR :: Slug -> Slug -> [Text] -> Handler () handleAliasR user name pieces = do @@ -77,4 +78,5 @@ goSid sid pieces = do StackageSdistR pnv -> getStackageSdistR slug pnv >>= sendResponse SnapshotPackagesR -> getSnapshotPackagesR slug >>= sendResponse DocsR -> getDocsR slug >>= sendResponse + HoogleR -> getHoogleR slug >>= sendResponse _ -> notFound diff --git a/Handler/BuildVersion.hs b/Handler/BuildVersion.hs new file mode 100644 index 0000000..9e302a8 --- /dev/null +++ b/Handler/BuildVersion.hs @@ -0,0 +1,29 @@ +module Handler.BuildVersion where + +import Import hiding (lift) +import Language.Haskell.TH.Syntax +import System.Process (rawSystem) +import System.Exit + +getBuildVersionR :: Handler Text +getBuildVersionR = return $ pack $(do + let headFile = ".git/HEAD" + qAddDependentFile headFile + ehead <- qRunIO $ tryIO $ readFile $ fpFromString headFile + case decodeUtf8 <$> ehead of + Left e -> lift $ ".git/HEAD not read: " ++ show e + Right raw -> + case takeWhile (/= '\n') <$> stripPrefix "ref: " raw of + Nothing -> lift $ ".git/HEAD not in expected format: " ++ show raw + Just fp' -> do + let fp = ".git" fpFromText fp' + qAddDependentFile $ fpToString fp + bs <- qRunIO $ readFile fp + isDirty <- qRunIO + $ (/= ExitSuccess) + <$> rawSystem "git" ["diff-files", "--quiet"] + lift $ unpack $ unlines + [ "Most recent commit: " ++ asText (decodeUtf8 bs) + , "Working tree is " ++ (if isDirty then "dirty" else "clean") + ] + ) diff --git a/Handler/CompressorStatus.hs b/Handler/CompressorStatus.hs index 62ac54b..c26a25a 100644 --- a/Handler/CompressorStatus.hs +++ b/Handler/CompressorStatus.hs @@ -4,7 +4,7 @@ import Import getCompressorStatusR :: Handler Html getCompressorStatusR = do - status <- getYesod >>= readIORef . compressorStatus + status <- getYesod >>= liftIO . duGetStatus . appDocUnpacker defaultLayout $ do setTitle "Compressor thread status" [whamlet| diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index ebfe746..81f37a9 100644 --- a/Handler/Haddock.hs +++ b/Handler/Haddock.hs @@ -1,26 +1,35 @@ -module Handler.Haddock where +module Handler.Haddock + ( getUploadHaddockR + , putUploadHaddockR + , getHaddockR + , getUploadDocMapR + , putUploadDocMapR + -- Exported for use in Handler.Hoogle + , Dirs (..), getDirs, dirHoogleFp, mkDirs + , dirRawIdent + , dirGzIdent + , dirHoogleIdent + , createCompressor + ) where -import Import -import Data.BlobStore -import Filesystem (removeTree, isDirectory, createTree, isFile, rename, removeFile, removeDirectory) -import Control.Concurrent (forkIO) -import System.IO.Temp (withSystemTempFile, withTempFile) -import System.Process (createProcess, proc, cwd, waitForProcess) -import System.Exit (ExitCode (ExitSuccess)) -import Network.Mime (defaultMimeLookup) -import Crypto.Hash.Conduit (sinkHash) -import System.IO (IOMode (ReadMode), withBinaryFile) -import Data.Conduit.Zlib (gzip) -import System.Posix.Files (createLink) +import Control.Concurrent (forkIO) +import Crypto.Hash (Digest, SHA1) +import Crypto.Hash.Conduit (sinkHash) +import Data.Aeson (withObject) +import Data.BlobStore import qualified Data.ByteString.Base16 as B16 -import Data.Byteable (toBytes) -import Crypto.Hash (Digest, SHA1) -import qualified Filesystem.Path.CurrentOS as F -import Data.Slug (SnapSlug) +import Data.Byteable (toBytes) +import Data.Conduit.Zlib (gzip) +import Data.Slug (SnapSlug, unSlug) import qualified Data.Text as T -import Data.Slug (unSlug) import qualified Data.Yaml as Y -import Data.Aeson (withObject) +import Filesystem (isDirectory, createTree, isFile, rename, removeFile, removeDirectory) +import qualified Filesystem.Path.CurrentOS as F +import Import +import Network.Mime (defaultMimeLookup) +import System.IO (IOMode (ReadMode), withBinaryFile) +import System.IO.Temp (withTempFile) +import System.Posix.Files (createLink) form :: Form FileInfo form = renderDivs $ areq fileField "tarball containing docs" @@ -30,7 +39,7 @@ form = renderDivs $ areq fileField "tarball containing docs" getUploadHaddockR, putUploadHaddockR :: Text -> Handler Html getUploadHaddockR slug0 = do uid <- requireAuthIdOrToken - Entity sid Stackage {..} <- runDB $ do + stackageEnt@(Entity sid Stackage {..}) <- runDB $ do -- Provide fallback for old URLs ment <- getBy $ UniqueStackage $ PackageSetIdent slug0 case ment of @@ -47,7 +56,7 @@ getUploadHaddockR slug0 = do fileSource fileInfo $$ storeWrite (HaddockBundle ident) runDB $ update sid [StackageHasHaddocks =. True] master <- getYesod - void $ liftIO $ forkIO $ haddockUnpacker master True ident + liftIO $ duForceReload (appDocUnpacker master) stackageEnt setMessage "Haddocks uploaded" redirect $ SnapshotR slug StackageHomeR _ -> defaultLayout $ do @@ -58,7 +67,7 @@ putUploadHaddockR = getUploadHaddockR getHaddockR :: SnapSlug -> [Text] -> Handler () getHaddockR slug rest = do - ident <- runDB $ do + stackageEnt <- runDB $ do ment <- getBy $ UniqueSnapshot slug case ment of Just ent -> do @@ -66,7 +75,7 @@ getHaddockR slug rest = do [pkgver] -> tryContentsRedirect ent pkgver [pkgver, "index.html"] -> tryContentsRedirect ent pkgver _ -> return () - return $ stackageIdent $ entityVal ent + return ent Nothing -> do Entity _ stackage <- getBy404 $ UniqueStackage @@ -74,11 +83,11 @@ getHaddockR slug rest = do $ toPathPiece slug redirectWith status301 $ HaddockR (stackageSlug stackage) rest mapM_ sanitize rest - dirs <- getDirs -- (gzdir, rawdir) <- getHaddockDir ident - master <- getYesod - liftIO $ haddockUnpacker master False ident + dirs <- getDirs + requireDocs stackageEnt - let rawfp = dirRawFp dirs ident rest + let ident = stackageIdent (entityVal stackageEnt) + rawfp = dirRawFp dirs ident rest gzfp = dirGzFp dirs ident rest mime = defaultMimeLookup $ fpToText $ filename rawfp @@ -124,19 +133,6 @@ tryContentsRedirect (Entity sid Stackage {..}) pkgver = do dropDash :: Text -> Text dropDash t = fromMaybe t $ stripSuffix "-" t -getHaddockDir :: PackageSetIdent -> Handler (FilePath, FilePath) -getHaddockDir ident = do - master <- getYesod - return $ mkDirPair (haddockRootDir master) ident - -mkDirPair :: FilePath -- ^ root - -> PackageSetIdent - -> (FilePath, FilePath) -- ^ compressed, uncompressed -mkDirPair root ident = - ( root "idents-raw" fpFromText (toPathPiece ident) - , root "idents-gz" fpFromText (toPathPiece ident) - ) - createCompressor :: Dirs -> IO (IORef Text, IO ()) -- ^ action to kick off compressor again @@ -209,93 +205,6 @@ dirCacheFp dirs digest = name = decodeUtf8 $ B16.encode $ toBytes digest (x, y) = splitAt 2 name --- Should have two threads: one to unpack, one to convert. Never serve the --- uncompressed files, only the compressed files. When serving, convert on --- demand. -createHaddockUnpacker :: FilePath -- ^ haddock root - -> BlobStore StoreKey - -> (forall a m. (MonadIO m, MonadBaseControl IO m) - => SqlPersistT m a -> m a) - -> IO (IORef Text, ForceUnpack -> PackageSetIdent -> IO ()) -createHaddockUnpacker root store runDB' = do - createTree $ dirCacheRoot dirs - createTree $ dirRawRoot dirs - createTree $ dirGzRoot dirs - - chan <- newChan - (statusRef, compressor) <- createCompressor dirs - - mask $ \restore -> void $ forkIO $ forever $ do - (forceUnpack, ident, res) <- readChan chan - try (restore $ go forceUnpack ident) >>= putMVar res - compressor - return (statusRef, \forceUnpack ident -> do - shouldAct <- - if forceUnpack - then return True - else not <$> doDirsExist ident - if shouldAct - then do - res <- newEmptyMVar - writeChan chan (forceUnpack, ident, res) - takeMVar res >>= either (throwM . asSomeException) return - else return ()) - where - dirs = mkDirs root - - removeTreeIfExists fp = whenM (isDirectory fp) (removeTree fp) - - doDirsExist ident = do - e1 <- isDirectory $ dirGzIdent dirs ident - if e1 - then return True - else isDirectory $ dirRawIdent dirs ident - go forceUnpack ident = do - toRun <- - if forceUnpack - then do - removeTreeIfExists $ dirRawIdent dirs ident - removeTreeIfExists $ dirGzIdent dirs ident - return True - else not <$> doDirsExist ident - when toRun $ do - withSystemTempFile "haddock-bundle.tar.xz" $ \tempfp temph -> do - withAcquire (storeRead' store (HaddockBundle ident)) $ \msrc -> - case msrc of - Nothing -> error "No haddocks exist for that snapshot" - Just src -> src $$ sinkHandle temph - hClose temph - createTree $ dirRawIdent dirs ident - let destdir = dirRawIdent dirs ident - (Nothing, Nothing, Nothing, ph) <- createProcess - (proc "tar" ["xf", tempfp]) - { cwd = Just $ fpToString destdir - } - ec <- waitForProcess ph - if ec == ExitSuccess then return () else throwM ec - - -- Determine which packages have documentation and update the - -- database appropriately - runResourceT $ runDB' $ do - ment <- getBy $ UniqueStackage ident - forM_ ment $ \(Entity sid _) -> do - updateWhere - [PackageStackage ==. sid] - [PackageHasHaddocks =. False] - sourceDirectory destdir $$ mapM_C (\fp -> do - let (name', version) = - T.breakOnEnd "-" - $ fpToText - $ filename fp - mname = stripSuffix "-" name' - forM_ mname $ \name -> updateWhere - [ PackageStackage ==. sid - , PackageName' ==. PackageName name - , PackageVersion ==. Version version - ] - [PackageHasHaddocks =. True] - ) - data DocInfo = DocInfo Version (Map Text [Text]) instance FromJSON DocInfo where parseJSON = withObject "DocInfo" $ \o -> DocInfo diff --git a/Handler/Hoogle.hs b/Handler/Hoogle.hs new file mode 100644 index 0000000..98868f2 --- /dev/null +++ b/Handler/Hoogle.hs @@ -0,0 +1,157 @@ +module Handler.Hoogle where + +import Control.DeepSeq (NFData(..)) +import Control.DeepSeq.Generics (genericRnf) +import Control.Spoon (spoon) +import Data.Data (Data (..)) +import Data.Slug (SnapSlug) +import Data.Text.Read (decimal) +import Data.Unpacking (getHoogleDB) +import Handler.Haddock (getDirs) +import qualified Hoogle +import Import +import Text.Blaze.Html (preEscapedToHtml) + +getHoogleR :: SnapSlug -> Handler Html +getHoogleR slug = do + dirs <- getDirs + mquery <- lookupGetParam "q" + mpage <- lookupGetParam "page" + exact <- maybe False (const True) <$> lookupGetParam "exact" + mresults' <- lookupGetParam "results" + let count' = + case decimal <$> mresults' of + Just (Right (i, "")) -> min perPage i + _ -> perPage + page = + case decimal <$> mpage of + Just (Right (i, "")) -> i + _ -> 1 + offset = (page - 1) * perPage + Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug + mdatabasePath <- getHoogleDB dirs stackage + heDatabase <- case mdatabasePath of + Just x -> return $ liftIO $ Hoogle.loadDatabase $ fpToString x + Nothing -> (>>= sendResponse) $ defaultLayout $ do + setTitle "Hoogle database not available" + [whamlet| +
+

The given Hoogle database is not available. +

+ Return to snapshot homepage + |] + + mresults <- case mquery of + Just query -> runHoogleQuery heDatabase HoogleQueryInput + { hqiQueryInput = query + , hqiExactSearch = if exact then Just query else Nothing + , hqiLimitTo = count' + , hqiOffsetBy = offset + } + Nothing -> return $ HoogleQueryOutput "" [] Nothing + let queryText = fromMaybe "" mquery + pageLink p = (SnapshotR slug HoogleR + , (if exact then (("exact", "true"):) else id) + $ (maybe id (\q' -> (("q", q'):)) mquery) + [("page", tshow p)]) + snapshotLink = SnapshotR slug StackageHomeR + hoogleForm = $(widgetFile "hoogle-form") + defaultLayout $ do + setTitle "Hoogle Search" + $(widgetFile "hoogle") + +getPageCount :: Int -> Int +getPageCount totalCount = 1 + div totalCount perPage + +perPage :: Int +perPage = 10 + +data HoogleQueryInput = HoogleQueryInput + { hqiQueryInput :: Text + , hqiExactSearch :: Maybe Text + , hqiLimitTo :: Int + , hqiOffsetBy :: Int + } + deriving (Eq, Read, Show, Data, Typeable, Ord, Generic) + +data HoogleQueryOutput = HoogleQueryBad Text + | HoogleQueryOutput Text [HoogleResult] (Maybe Int) -- ^ Text == HTML version of query, Int == total count + deriving (Read, Typeable, Data, Show, Eq) + +data HoogleResult = HoogleResult + { hrURL :: String + , hrSources :: [(PackageLink, [ModuleLink])] + , hrTitle :: String -- ^ HTML + , hrBody :: String -- ^ plain text + } + deriving (Eq, Read, Show, Data, Typeable, Ord, Generic) + +data PackageLink = PackageLink + { plName :: String + , plURL :: String + } + deriving (Eq, Read, Show, Data, Typeable, Ord, Generic) + +data ModuleLink = ModuleLink + { mlName :: String + , mlURL :: String + } + deriving (Eq, Read, Show, Data, Typeable, Ord, Generic) + +instance NFData HoogleResult where rnf = genericRnf +instance NFData PackageLink where rnf = genericRnf +instance NFData ModuleLink where rnf = genericRnf + +runHoogleQuery :: Monad m + => m Hoogle.Database + -> HoogleQueryInput + -> m HoogleQueryOutput +runHoogleQuery heDatabase HoogleQueryInput {..} = + runQuery $ Hoogle.parseQuery Hoogle.Haskell query + where + query = unpack hqiQueryInput + + runQuery (Left err) = return $ HoogleQueryBad (tshow err) + runQuery (Right query') = do + hoogledb <- heDatabase + let query'' = Hoogle.queryExact classifier query' + rawRes = concatMap fixResult + $ Hoogle.search hoogledb query'' + mres = spoon + $ take (min 100 hqiLimitTo) + $ drop hqiOffsetBy rawRes + mcount = spoon $ limitedLength 0 rawRes + limitedLength x [] = Just x + limitedLength x (_:rest) + | x >= 100 = Nothing + | otherwise = limitedLength (x + 1) rest + rendered = pack $ Hoogle.showTagHTML $ Hoogle.renderQuery query'' + return $ case (,) <$> mres <*> mcount of + Nothing -> + HoogleQueryOutput rendered [] (Just 0) + Just (results, mcount') -> + HoogleQueryOutput rendered (take hqiLimitTo results) mcount' + + classifier = maybe Nothing + (const (Just Hoogle.UnclassifiedItem)) + hqiExactSearch + + fixResult (_, Hoogle.Result locs self docs) = do + (loc, _) <- take 1 locs + let sources' = unionsWith (++) $ + mapMaybe (getPkgModPair . snd) locs + return HoogleResult + { hrURL = loc + , hrSources = mapToList sources' + , hrTitle = Hoogle.showTagHTML self + , hrBody = fromMaybe "Problem loading documentation" $ + spoon $ Hoogle.showTagText docs + } + + getPkgModPair :: [(String, String)] + -> Maybe (Map PackageLink [ModuleLink]) + getPkgModPair [(pkg, pkgname), (modu, moduname)] = do + let pkg' = PackageLink pkgname pkg + modu' = ModuleLink moduname modu + return $ asMap $ singletonMap pkg' [modu'] + getPkgModPair _ = Nothing diff --git a/Handler/PackageCounts.hs b/Handler/PackageCounts.hs new file mode 100644 index 0000000..4e91655 --- /dev/null +++ b/Handler/PackageCounts.hs @@ -0,0 +1,39 @@ +module Handler.PackageCounts + ( getPackageCountsR + ) where + +import Import hiding (Value (..), groupBy, (==.)) +import Data.Slug (mkSlug) +import Database.Esqueleto + +data Count = Count + { name :: Text + , date :: Day + , packages :: Int + } + +toCount :: (Value Text, Value UTCTime, Value Int) -> Count +toCount (Value x, Value y, Value z) = + Count x (utctDay y) z + +getPackageCountsR :: Handler Html +getPackageCountsR = do + admins <- adminUsers <$> getExtra + counts <- runDB $ do + let slugs = mapMaybe mkSlug $ setToList admins + adminUids <- selectKeysList [UserHandle <-. slugs] [] + fmap (map toCount) $ select $ from $ \(s, p) -> do + where_ $ + (not_ $ s ^. StackageTitle `like` val "%inclusive") &&. + (s ^. StackageId ==. p ^. PackageStackage) &&. + (s ^. StackageUser `in_` valList adminUids) + groupBy (s ^. StackageTitle, s ^. StackageUploaded) + orderBy [desc $ s ^. StackageUploaded] + return + ( s ^. StackageTitle + , s ^. StackageUploaded + , countRows + ) + defaultLayout $ do + setTitle "Package counts" + $(widgetFile "package-counts") diff --git a/Handler/PackageList.hs b/Handler/PackageList.hs index fbfe44a..aab68ce 100644 --- a/Handler/PackageList.hs +++ b/Handler/PackageList.hs @@ -1,10 +1,10 @@ module Handler.PackageList where import qualified Data.HashMap.Strict as M -import Data.Time (NominalDiffTime, addUTCTime) +import Data.Time (NominalDiffTime) import qualified Database.Esqueleto as E import Import -import Yesod.Core.Types (WidgetT (WidgetT), unWidgetT) + -- FIXME maybe just redirect to the LTS or nightly package list getPackageListR :: Handler Html @@ -29,7 +29,10 @@ getPackageListR = defaultLayout $ do -- FIXME move somewhere else, maybe even yesod-core cachedWidget :: NominalDiffTime -> Text -> Widget -> Widget -cachedWidget diff key widget = do +cachedWidget _diff _key widget = do + -- Temporarily disabled, seems to be eating up too much memory + widget + {- ref <- widgetCache <$> getYesod now <- liftIO getCurrentTime mpair <- lookup key <$> readIORef ref @@ -44,3 +47,4 @@ cachedWidget diff key widget = do -- FIXME render the builders in gw for more efficiency atomicModifyIORef' ref $ \m -> (insertMap key (addUTCTime diff now, gw) m, ()) return ((), gw) + -} diff --git a/Handler/Progress.hs b/Handler/Progress.hs index fcbde35..a59f85b 100644 --- a/Handler/Progress.hs +++ b/Handler/Progress.hs @@ -2,16 +2,14 @@ module Handler.Progress where import Import -getProgressR :: Int -> Handler Html +getProgressR :: UploadProgressId -> Handler Html getProgressR key = do - app <- getYesod - m <- readIORef $ progressMap app - case lookup key m of - Nothing -> notFound - Just (ProgressWorking text) -> defaultLayout $ do + UploadProgress text mdest <- runDB $ get404 key + case mdest of + Nothing -> defaultLayout $ do addHeader "Refresh" "1" setTitle "Working..." [whamlet|

#{text}|] - Just (ProgressDone text url) -> do + Just url -> do setMessage $ toHtml text redirect url diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index 5964296..36cc64d 100644 --- a/Handler/StackageHome.hs +++ b/Handler/StackageHome.hs @@ -31,6 +31,12 @@ getStackageHomeR slug = do else Nothing base = maybe 0 (const 1) minclusive :: Int + hoogleForm = + let queryText = "" :: Text + exact = False + in $(widgetFile "hoogle-form") + Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug + defaultLayout $ do setTitle $ toHtml $ stackageTitle stackage cachedWidget (20 * 60) ("package-list-" ++ toPathPiece slug) $ do diff --git a/Handler/UploadStackage.hs b/Handler/UploadStackage.hs index 6897a3c..176d8f1 100644 --- a/Handler/UploadStackage.hs +++ b/Handler/UploadStackage.hs @@ -20,6 +20,7 @@ import System.Directory (removeFile, getTemporaryDirectory) import System.Process (runProcess, waitForProcess) import System.Exit (ExitCode (ExitSuccess)) import Data.Slug (mkSlug, SnapSlug (..), safeMakeSlug, unSlug) +import Control.Debounce fileKey :: Text fileKey = "stackage" @@ -78,12 +79,28 @@ putUploadStackageR = do when (isJust mstackage) $ invalidArgs ["Stackage already exists"] app <- getYesod - key <- atomicModifyIORef (nextProgressKey app) $ \i -> (i + 1, i + 1) - let updateHelper :: MonadBase IO m => Progress -> m () - updateHelper p = atomicModifyIORef (progressMap app) $ \m -> (insertMap key p m, ()) + let initProgress = UploadProgress "Upload starting" Nothing + key <- runDB $ insert initProgress + + -- We don't want to be writing progress updates to the database too + -- frequently, so let's just do it once per second at most. + -- Debounce to the rescue! + statusRef <- newIORef initProgress + writeToDB <- liftIO $ mkDebounce defaultDebounceSettings + { debounceAction = do + up <- readIORef statusRef + runPool (persistConfig app) (replace key up) (connPool app) + } + + let updateHelper :: MonadBase IO m => UploadProgress -> m () + updateHelper p = do + writeIORef statusRef p + liftBase writeToDB update :: MonadBase IO m => Text -> m () - update msg = updateHelper (ProgressWorking msg) - done msg url = updateHelper (ProgressDone msg url) + update msg = updateHelper (UploadProgress msg Nothing) + done msg route = do + render <- getUrlRender + updateHelper (UploadProgress msg $ Just $ render route) onExc e = done ("Exception occurred: " ++ tshow e) ProfileR setAlias = do forM_ (malias >>= mkSlug) $ \alias -> do @@ -167,8 +184,7 @@ putUploadStackageR = do return slug done "Stackage created" $ SnapshotR slug StackageHomeR - else do - done "Error creating index file" ProfileR + else done "Error creating index file" ProfileR addHeader "X-Stackage-Ident" $ toPathPiece ident redirect $ ProgressR key diff --git a/Import.hs b/Import.hs index 0e41481..de05411 100644 --- a/Import.hs +++ b/Import.hs @@ -86,11 +86,11 @@ getSnapshotInfoByIdent ident = withCache $ do atomicModifyIORef' cacheRef $ \m -> (insertMap ident x m, x) - data Dirs = Dirs { dirRawRoot :: !FilePath , dirGzRoot :: !FilePath , dirCacheRoot :: !FilePath + , dirHoogleRoot :: !FilePath } getDirs :: Handler Dirs @@ -101,12 +101,35 @@ mkDirs dir = Dirs { dirRawRoot = dir "idents-raw" , dirGzRoot = dir "idents-gz" , dirCacheRoot = dir "cachedir" + , dirHoogleRoot = dir "hoogle" } -dirGzIdent, dirRawIdent :: Dirs -> PackageSetIdent -> FilePath +dirGzIdent, dirRawIdent, dirHoogleIdent :: Dirs -> PackageSetIdent -> FilePath dirGzIdent dirs ident = dirGzRoot dirs fpFromText (toPathPiece ident) dirRawIdent dirs ident = dirRawRoot dirs fpFromText (toPathPiece ident) +dirHoogleIdent dirs ident = dirHoogleRoot dirs fpFromText (toPathPiece ident) -dirGzFp, dirRawFp :: Dirs -> PackageSetIdent -> [Text] -> FilePath +dirGzFp, dirRawFp, dirHoogleFp :: Dirs -> PackageSetIdent -> [Text] -> FilePath dirGzFp dirs ident rest = dirGzIdent dirs ident mconcat (map fpFromText rest) dirRawFp dirs ident rest = dirRawIdent dirs ident mconcat (map fpFromText rest) +dirHoogleFp dirs ident rest = dirHoogleIdent dirs ident mconcat (map fpFromText rest) + +requireDocs :: Entity Stackage -> Handler () +requireDocs stackageEnt = do + master <- getYesod + status <- liftIO $ duRequestDocs (appDocUnpacker master) stackageEnt + case status of + USReady -> return () + USBusy -> (>>= sendResponse) $ defaultLayout $ do + setTitle "Docs unpacking, please wait" + addHeader "Refresh" "1" + msg <- liftIO $ duGetStatus $ appDocUnpacker master + [whamlet| +

+

Docs are currently being unpacked, please wait. +

This page will automatically reload every second. +

Current status: #{msg} + |] + USFailed e -> invalidArgs + [ "Docs not available: " ++ e + ] diff --git a/Types.hs b/Types.hs index ea3f58a..8072fbd 100644 --- a/Types.hs +++ b/Types.hs @@ -58,8 +58,14 @@ data StoreKey = HackageCabal !PackageName !Version | HackageViewIndex !HackageView | SnapshotBundle !PackageSetIdent | HaddockBundle !PackageSetIdent + | HoogleDB !PackageSetIdent !HoogleVersion deriving (Show, Eq, Ord, Typeable) +newtype HoogleVersion = HoogleVersion Text + deriving (Show, Eq, Ord, Typeable, PathPiece) +currentHoogleVersion :: HoogleVersion +currentHoogleVersion = HoogleVersion VERSION_hoogle + instance ToPath StoreKey where toPath (HackageCabal name version) = ["hackage", toPathPiece name, toPathPiece version ++ ".cabal"] toPath (HackageSdist name version) = ["hackage", toPathPiece name, toPathPiece version ++ ".tar.gz"] @@ -95,6 +101,11 @@ instance ToPath StoreKey where [ "haddock" , toPathPiece ident ++ ".tar.xz" ] + toPath (HoogleDB ident ver) = + [ "hoogle" + , toPathPiece ver + , toPathPiece ident ++ ".hoo.gz" + ] instance BackupToS3 StoreKey where shouldBackup HackageCabal{} = False shouldBackup HackageSdist{} = False @@ -105,6 +116,7 @@ instance BackupToS3 StoreKey where shouldBackup HackageViewIndex{} = False shouldBackup SnapshotBundle{} = True shouldBackup HaddockBundle{} = True + shouldBackup HoogleDB{} = True newtype HackageRoot = HackageRoot { unHackageRoot :: Text } deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup) @@ -113,3 +125,7 @@ class HasHackageRoot a where getHackageRoot :: a -> HackageRoot instance HasHackageRoot HackageRoot where getHackageRoot = id + +data UnpackStatus = USReady + | USBusy + | USFailed !Text diff --git a/cabal.config b/cabal.config index e266890..9b1d059 100644 --- a/cabal.config +++ b/cabal.config @@ -1,7 +1,7 @@ --- Stackage snapshot from: http://www.stackage.org/snapshot/nightly-2014-12-22 +-- Stackage snapshot from: http://www.stackage.org/snapshot/lts-1.0 -- Please place this file next to your .cabal file as cabal.config -- To only use tested packages, uncomment the following line: --- remote-repo: stackage-nightly-2014-12-22:http://www.stackage.org/snapshot/nightly-2014-12-22 +-- remote-repo: stackage-lts-1.0:http://www.stackage.org/snapshot/lts-1.0 constraints: abstract-deque ==0.3, abstract-par ==0.3.3, accelerate ==0.15.0.0, @@ -15,6 +15,7 @@ constraints: abstract-deque ==0.3, aeson-pretty ==0.7.2, aeson-qq ==0.7.4, aeson-utils ==0.2.2.1, + alarmclock ==0.2.0.5, alex ==3.1.3, amqp ==0.10.1, ansi-terminal ==0.6.2.1, @@ -29,7 +30,7 @@ constraints: abstract-deque ==0.3, asn1-encoding ==0.9.0, asn1-parse ==0.9.0, asn1-types ==0.3.0, - async ==2.0.1.6, + async ==2.0.2, atto-lisp ==0.2.2, attoparsec ==0.12.1.2, attoparsec-conduit ==1.1.0, @@ -39,16 +40,18 @@ constraints: abstract-deque ==0.3, auto-update ==0.1.2.1, aws ==0.11, bake ==0.2, + bank-holidays-england ==0.1.0.2, barecheck ==0.2.0.6, base installed, base16-bytestring ==0.1.1.6, base64-bytestring ==1.0.0.1, base-compat ==0.5.0, - base-prelude ==0.1.8, + base-prelude ==0.1.11, base-unicode-symbols ==0.2.2.4, basic-prelude ==0.3.10, bifunctors ==4.2, binary installed, + binary-conduit ==1.2.3, binary-list ==1.0.1.0, bindings-DSL ==1.0.21, bioace ==0.0.1, @@ -65,7 +68,7 @@ constraints: abstract-deque ==0.3, blaze-builder ==0.3.3.4, blaze-builder-enumerator ==0.2.0.6, blaze-html ==0.7.0.3, - blaze-markup ==0.6.1.1, + blaze-markup ==0.6.2.0, blaze-svg ==0.3.4, blaze-textual ==0.2.0.9, BlogLiterately ==0.7.1.7, @@ -76,6 +79,7 @@ constraints: abstract-deque ==0.3, bool-extras ==0.4.0, bound ==1.0.4, BoundedChan ==1.0.3.0, + broadcast-chan ==0.1.0, bson ==0.3.1, bumper ==0.6.0.2, byteable ==0.1.1, @@ -87,17 +91,18 @@ constraints: abstract-deque ==0.3, bytestring-lexing ==0.4.3.2, bytestring-mmap ==0.2.2, bytestring-progress ==1.0.3, + bytestring-show ==0.3.5.6, bytestring-trie ==0.2.4, bzlib ==0.5.0.4, bzlib-conduit ==0.2.1.3, c2hs ==0.20.1, Cabal installed, - cabal-install ==1.18.0.6, + cabal-install ==1.18.0.7, cabal-src ==0.2.5, - cairo ==0.13.0.5, + cairo ==0.13.0.6, case-insensitive ==1.2.0.3, cases ==0.1.2, - cassava ==0.4.2.0, + cassava ==0.4.2.1, cautious-file ==1.0.2, cereal ==0.4.1.0, cereal-conduit ==0.7.2.3, @@ -105,7 +110,7 @@ constraints: abstract-deque ==0.3, charset ==0.3.7, Chart ==1.3.2, Chart-diagrams ==1.3.2, - ChasingBottoms ==1.3.0.8, + ChasingBottoms ==1.3.0.9, check-email ==1.0, checkers ==0.4.1, chell ==0.4, @@ -116,7 +121,7 @@ constraints: abstract-deque ==0.3, cipher-camellia ==0.0.2, cipher-des ==0.0.6, cipher-rc4 ==0.1.4, - circle-packing ==0.1.0.3, + circle-packing ==0.1.0.4, classy-prelude ==0.10.2, classy-prelude-conduit ==0.10.2, classy-prelude-yesod ==0.10.2, @@ -137,14 +142,14 @@ constraints: abstract-deque ==0.3, concurrent-supply ==0.1.7, cond ==0.4.1.1, conduit ==1.2.3.1, - conduit-combinators ==0.3.0.4, - conduit-extra ==1.1.5.1, + conduit-combinators ==0.3.0.5, + conduit-extra ==1.1.6, configurator ==0.3.0.0, connection ==0.2.3, - constraints ==0.4.1.1, + constraints ==0.4.1.2, containers installed, containers-unicode-symbols ==0.3.1.1, - contravariant ==1.2, + contravariant ==1.2.0.1, control-monad-free ==0.5.3, control-monad-loop ==0.1, convertible ==1.1.0.0, @@ -161,8 +166,8 @@ constraints: abstract-deque ==0.3, cryptohash ==0.11.6, cryptohash-conduit ==0.1.1, cryptohash-cryptoapi ==0.1.3, - crypto-numbers ==0.2.3, - crypto-pubkey ==0.2.6, + crypto-numbers ==0.2.7, + crypto-pubkey ==0.2.7, crypto-pubkey-types ==0.4.2.3, crypto-random ==0.0.8, crypto-random-api ==0.2.0, @@ -184,12 +189,13 @@ constraints: abstract-deque ==0.3, data-memocombinators ==0.5.1, data-reify ==0.6, DAV ==1.0.3, + Decimal ==0.4.2, deepseq installed, deepseq-generics ==0.1.1.2, derive ==2.5.18, diagrams ==1.2, diagrams-builder ==0.6.0.2, - diagrams-cairo ==1.2.0.4, + diagrams-cairo ==1.2.0.5, diagrams-contrib ==1.1.2.4, diagrams-core ==1.2.0.4, diagrams-haddock ==0.2.2.12, @@ -198,13 +204,19 @@ constraints: abstract-deque ==0.3, diagrams-svg ==1.1.0.3, Diff ==0.3.0, digest ==0.0.1.2, - digestive-functors ==0.7.1.1, + digestive-functors ==0.7.1.3, dimensional ==0.13.0.1, directory installed, directory-tree ==0.12.0, direct-sqlite ==2.3.14, distributed-process ==0.5.3, + distributed-process-async ==0.2.1, + distributed-process-client-server ==0.1.2, + distributed-process-execution ==0.1.1, + distributed-process-extras ==0.2.0, distributed-process-simplelocalnet ==0.2.2.0, + distributed-process-supervisor ==0.1.2, + distributed-process-task ==0.1.1, distributed-static ==0.3.1.0, distributive ==0.4.4, djinn-ghc ==0.0.2.2, @@ -219,6 +231,7 @@ constraints: abstract-deque ==0.3, elm-build-lib ==0.14.0.0, elm-compiler ==0.14, elm-core-sources ==1.0.0, + elm-package ==0.2.2, email-validate ==2.0.1, enclosed-exceptions ==1.0.1, entropy ==0.3.4.1, @@ -232,7 +245,6 @@ constraints: abstract-deque ==0.3, exceptions ==0.6.1, exception-transformers ==0.3.0.4, executable-path ==0.0.3, - ex-pool ==0.2, extensible-exceptions ==0.1.1.4, extra ==1.0, failure ==0.2.0.3, @@ -247,7 +259,7 @@ constraints: abstract-deque ==0.3, fb ==1.0.7, fb-persistent ==0.3.4, fclabels ==2.0.2, - FenwickTree ==0.1.1, + FenwickTree ==0.1.2, fgl ==5.5.0.1, file-embed ==0.0.7, file-location ==0.4.5.3, @@ -259,6 +271,7 @@ constraints: abstract-deque ==0.3, flexible-defaults ==0.0.1.1, focus ==0.1.3, foldl ==1.0.7, + FontyFruity ==0.4, force-layout ==0.3.0.8, foreign-store ==0.1, formatting ==6.0.0, @@ -271,24 +284,24 @@ constraints: abstract-deque ==0.3, gd ==3000.7.3, generic-aeson ==0.2.0.2, generic-deriving ==1.6.3, + GenericPretty ==1.2.1, generics-sop ==0.1.0.4, ghc-heap-view ==0.5.3, - ghcid ==0.3.3, - ghc-mod ==5.2.1.1, + ghcid ==0.3.4, + ghc-mod ==5.2.1.2, ghc-mtl ==1.2.1.0, ghc-paths ==0.1.0.9, ghc-prim installed, ghc-syb-utils ==0.2.2, - gio ==0.13.0.3, + gio ==0.13.0.4, git-embed ==0.1.0, gl ==0.6.2, - glib ==0.13.0.6, + glib ==0.13.0.7, Glob ==0.7.5, GLURaw ==1.4.0.1, GLUT ==2.5.1.1, graph-core ==0.2.1.0, graphs ==0.5.0.1, - graphviz ==2999.17.0.1, gravatar ==0.6, groundhog ==0.7.0.1, groundhog-mysql ==0.7.0.1, @@ -297,15 +310,15 @@ constraints: abstract-deque ==0.3, groundhog-th ==0.7.0, groupoids ==4.0, groups ==0.4.0.0, - gtk ==0.13.3, + gtk ==0.13.4, gtk2hs-buildtools ==0.13.0.3, - haddock-api ==2.15.0, + haddock-api ==2.15.0.2, haddock-library ==1.1.1, half ==0.2.0.1, HandsomeSoup ==0.3.5, happstack-server ==7.3.9, happy ==1.19.4, - hashable ==1.2.3.0, + hashable ==1.2.3.1, hashable-extras ==0.2.0.1, hashmap ==1.3.0.1, hashtables ==1.2.0.1, @@ -318,12 +331,12 @@ constraints: abstract-deque ==0.3, haskell-src ==1.0.1.6, haskell-src-exts ==1.16.0.1, haskell-src-meta ==0.6.0.8, - hasql ==0.4.1, - hasql-backend ==0.2.2, - hasql-postgres ==0.9.0, - hastache ==0.6.0, + hasql ==0.7.1, + hasql-backend ==0.4.0, + hasql-postgres ==0.10.1, + hastache ==0.6.1, HaTeX ==3.16.0.0, - HaXml ==1.24.1, + HaXml ==1.25, haxr ==3000.10.3.1, HCodecs ==0.5, hdaemonize ==0.5.0.0, @@ -333,29 +346,30 @@ constraints: abstract-deque ==0.3, heist ==0.14.0.1, here ==1.2.6, heredoc ==0.2.0.0, + hflags ==0.4, highlighting-kate ==0.5.11.1, hinotify ==0.3.7, hint ==0.4.2.1, histogram-fill ==0.8.3.0, hit ==0.6.2, hjsmin ==0.1.4.7, - hledger ==0.23.3, - hledger-lib ==0.23.3, + hledger ==0.24, + hledger-lib ==0.24, hlibgit2 ==0.18.0.13, - hlint ==1.9.13, - hmatrix ==0.16.1.2, + hlint ==1.9.14, + hmatrix ==0.16.1.3, hmatrix-gsl ==0.16.0.2, + hoauth2 ==0.4.3, holy-project ==0.1.1.1, hoogle ==4.2.36, hoopl installed, hOpenPGP ==1.11, - hopenpgp-tools ==0.13, hostname ==1.0, hostname-validate ==1.0.0, hourglass ==0.2.6, hpc installed, - hPDB ==1.2.0, - hPDB-examples ==1.1.2, + hPDB ==1.2.0.2, + hPDB-examples ==1.2.0.1, hs-bibutils ==5.5, hscolour ==1.20.3, hse-cpp ==0.1, @@ -365,7 +379,7 @@ constraints: abstract-deque ==0.3, hspec2 ==0.6.1, hspec-core ==2.1.2, hspec-discover ==2.1.2, - hspec-expectations ==0.6.1, + hspec-expectations ==0.6.1.1, hspec-meta ==2.0.0, hspec-wai ==0.6.2, hspec-wai-json ==0.6.0, @@ -383,7 +397,7 @@ constraints: abstract-deque ==0.3, http-types ==0.8.5, HUnit ==1.2.5.2, hweblib ==0.6.3, - hxt ==9.3.1.7, + hxt ==9.3.1.10, hxt-charproperties ==9.2.0.0, hxt-http ==9.1.5, hxt-pickle-utils ==0.1.0.2, @@ -394,11 +408,12 @@ constraints: abstract-deque ==0.3, hyphenation ==0.4, idna ==0.3.0, ieee754 ==0.7.4, + IfElse ==0.85, imagesize-conduit ==1.0.0.4, immortal ==0.2, incremental-parser ==0.2.3.3, indents ==0.3.3, - ini ==0.2.2, + ini ==0.3.0, integer-gmp installed, integration ==0.2.0.1, interpolate ==0.1.0, @@ -411,15 +426,16 @@ constraints: abstract-deque ==0.3, iterable ==3.0, ixset ==1.0.6, js-flot ==0.8.3, - js-jquery ==1.11.1, + js-jquery ==1.11.2, + json-autotype ==0.2.5.4, json-schema ==0.7.3.0, - JuicyPixels ==3.1.7.1, + JuicyPixels ==3.2.1, JuicyPixels-repa ==0.7, - kan-extensions ==4.1.1, + kan-extensions ==4.2, kdt ==0.2.2, keter ==1.3.7.1, keys ==3.10.1, - kure ==2.4.10, + kure ==2.16.4, language-c ==0.4.7, language-ecmascript ==0.16.2, language-glsl ==0.1.1, @@ -438,13 +454,14 @@ constraints: abstract-deque ==0.3, lifted-base ==0.2.3.3, linear ==1.15.5, linear-accelerate ==0.2, - list-t ==0.3.1, + list-t ==0.4.2, loch-th ==0.2.1, log-domain ==0.9.3, logfloat ==0.12.1, logict ==0.6.0.2, loop ==0.2.0, lucid ==2.5, + lzma-conduit ==1.1.1, machines ==0.4.1, mandrill ==0.1.1.0, map-syntax ==0.2, @@ -464,13 +481,13 @@ constraints: abstract-deque ==0.3, MissingH ==1.3.0.1, mmap ==0.5.9, mmorph ==1.0.4, - MonadCatchIO-transformers ==0.3.1.2, + MonadCatchIO-transformers ==0.3.1.3, monad-control ==0.3.3.0, monad-coroutine ==0.8.0.1, monadcryptorandom ==0.6.1, monad-extras ==0.5.9, monadic-arrays ==0.2.1.3, - monad-journal ==0.6.0.1, + monad-journal ==0.6.0.2, monad-logger ==0.3.11.1, monad-loops ==0.4.2.1, monad-par ==0.3.4.7, @@ -488,7 +505,7 @@ constraints: abstract-deque ==0.3, mono-traversable ==0.7.0, mtl ==2.1.3.1, mtlparse ==0.1.2, - mtl-prelude ==1.0.1, + mtl-prelude ==1.0.2, multimap ==1.2.1, multipart ==0.1.2, MusicBrainz ==0.2.2, @@ -506,7 +523,7 @@ constraints: abstract-deque ==0.3, network-simple ==0.4.0.2, network-transport ==0.4.1.0, network-transport-tcp ==0.4.1, - network-transport-tests ==0.2.1.0, + network-transport-tests ==0.2.2.0, network-uri ==2.6.0.1, newtype ==0.2, nsis ==0.2.4, @@ -514,7 +531,7 @@ constraints: abstract-deque ==0.3, numeric-extras ==0.0.3, NumInstances ==1.4, numtype ==1.1, - Octree ==0.5.3, + Octree ==0.5.4.2, old-locale installed, old-time installed, OneTuple ==0.2.1, @@ -529,8 +546,8 @@ constraints: abstract-deque ==0.3, pandoc ==1.13.2, pandoc-citeproc ==0.6, pandoc-types ==1.12.4.1, - pango ==0.13.0.4, - parallel ==3.2.0.5, + pango ==0.13.0.5, + parallel ==3.2.0.6, parallel-io ==0.3.3, parseargs ==0.1.5.2, parsec ==3.1.7, @@ -541,23 +558,23 @@ constraints: abstract-deque ==0.3, pcre-light ==0.4.0.3, pdfinfo ==1.5.1, pem ==0.2.2, - persistent ==2.1.1.2, + persistent ==2.1.1.3, persistent-mongoDB ==2.1.2, persistent-mysql ==2.1.2, persistent-postgresql ==2.1.2, - persistent-sqlite ==2.1.1.1, + persistent-sqlite ==2.1.1.2, persistent-template ==2.1.0.1, phantom-state ==0.2.0.2, pipes ==4.1.4, pipes-concurrency ==2.0.2, pipes-parse ==3.0.2, placeholders ==0.1, - pointed ==4.1.1, - polyparse ==1.9, + pointed ==4.2, + polyparse ==1.10, pool-conduit ==0.1.2.3, postgresql-binary ==0.5.0, postgresql-libpq ==0.9.0.1, - postgresql-simple ==0.4.8.0, + postgresql-simple ==0.4.9.0, pqueue ==1.2.1, prefix-units ==0.1.0.2, prelude-extras ==0.4, @@ -584,8 +601,9 @@ constraints: abstract-deque ==0.3, QuasiText ==0.1.2.5, QuickCheck ==2.7.6, quickcheck-assertions ==0.1.1, - quickcheck-instances ==0.3.9, + quickcheck-instances ==0.3.10, quickcheck-io ==0.1.1, + quickcheck-unicode ==1.0.0.0, quickpull ==0.4.0.0, rainbow ==0.20.0.4, rainbow-tests ==0.20.0.4, @@ -594,6 +612,7 @@ constraints: abstract-deque ==0.3, random-shuffle ==0.0.4, random-source ==0.3.0.6, rank1dynamic ==0.2.0.1, + Rasterific ==0.4, raw-strings-qq ==1.0.2, ReadArgs ==1.2.2, reducers ==3.10.3, @@ -606,8 +625,9 @@ constraints: abstract-deque ==0.3, regexpr ==0.5.4, regex-tdfa ==1.2.0, regex-tdfa-rc ==1.1.8.3, - regular ==0.3.4.3, + regular ==0.3.4.4, regular-xmlpickler ==0.2, + rematch ==0.2.0.0, repa ==3.3.1.2, repa-algorithms ==3.3.1.2, repa-devil ==0.3.2.2, @@ -615,7 +635,7 @@ constraints: abstract-deque ==0.3, reroute ==0.2.2.1, resource-pool ==0.2.3.2, resourcet ==1.1.3.3, - rest-client ==0.4.0.1, + rest-client ==0.4.0.2, rest-core ==0.33.1.2, rest-gen ==0.16.1.3, rest-happstack ==0.2.10.3, @@ -641,12 +661,12 @@ constraints: abstract-deque ==0.3, setenv ==0.1.1.1, SHA ==1.6.4.1, shake ==0.14.2, - shake-language-c ==0.6.2, + shake-language-c ==0.6.3, shakespeare ==2.0.2.1, shakespeare-i18n ==1.1.0, shakespeare-text ==1.1.0, shell-conduit ==4.5, - shelly ==1.5.6, + shelly ==1.5.7, silently ==1.2.4.1, simple-reflect ==0.3.2, simple-sendfile ==0.2.18, @@ -657,16 +677,18 @@ constraints: abstract-deque ==0.3, smallcheck ==1.1.1, smtLib ==1.0.7, snap ==0.13.3.2, - snap-core ==0.9.6.3, + snap-core ==0.9.6.4, snaplet-fay ==0.3.3.8, - snap-server ==0.9.4.5, + snap-server ==0.9.4.6, socks ==0.5.4, - sodium ==0.11.0.2, + sodium ==0.11.0.3, sourcemap ==0.1.3.0, speculation ==1.5.0.1, sphinx ==0.6.0.1, split ==0.2.2, - Spock ==0.7.5.1, + Spock ==0.7.6.0, + Spock-digestive ==0.1.0.0, + Spock-worker ==0.2.1.3, spoon ==0.3.1, sqlite-simple ==0.4.8.0, stateref ==0.3, @@ -675,7 +697,7 @@ constraints: abstract-deque ==0.3, statistics-linreg ==0.3, stm ==2.4.4, stm-chans ==3.0.0.2, - stm-conduit ==2.5.2, + stm-conduit ==2.5.3, stm-containers ==0.2.7, stm-stats ==0.2.0.0, storable-complex ==0.2.1, @@ -689,11 +711,11 @@ constraints: abstract-deque ==0.3, stringsearch ==0.3.6.5, stylish-haskell ==0.5.11.0, SVGFonts ==1.4.0.3, - syb ==0.4.2, + syb ==0.4.3, syb-with-class ==0.6.1.5, system-canonicalpath ==0.2.0.0, system-fileio ==0.3.16, - system-filepath ==0.4.13, + system-filepath ==0.4.13.1, system-posix-redirect ==1.1.0.1, tabular ==0.2.2.5, tagged ==0.7.3, @@ -722,7 +744,7 @@ constraints: abstract-deque ==0.3, testing-feat ==0.4.0.2, testpack ==2.1.3.0, texmath ==0.8.0.1, - text ==1.1.1.3, + text ==1.2.0.3, text-binary ==0.1.0, text-format ==0.3.1.1, text-icu ==0.7.0.0, @@ -731,7 +753,7 @@ constraints: abstract-deque ==0.3, th-expand-syns ==0.3.0.4, th-extras ==0.0.0.2, th-lift ==0.7, - th-orphans ==0.8.2, + th-orphans ==0.8.3, threads ==0.5.1.2, th-reify-many ==0.1.2, thyme ==0.3.5.5, @@ -752,7 +774,7 @@ constraints: abstract-deque ==0.3, type-eq ==0.4.2, type-list ==0.0.0.0, udbus ==0.2.1, - unbounded-delays ==0.1.0.8, + unbounded-delays ==0.1.0.9, union-find ==0.2, uniplate ==1.6.12, unix installed, @@ -763,7 +785,7 @@ constraints: abstract-deque ==0.3, url ==2.1.3, utf8-light ==0.4.2, utf8-string ==0.3.8, - uuid ==1.3.7, + uuid ==1.3.8, vault ==0.3.0.4, vector ==0.10.12.2, vector-algorithms ==0.6.0.3, @@ -778,21 +800,22 @@ constraints: abstract-deque ==0.3, wai-app-static ==3.0.0.5, wai-conduit ==3.0.0.2, wai-eventsource ==3.0.0, - wai-extra ==3.0.3.1, + wai-extra ==3.0.3.2, wai-logger ==2.2.3, wai-middleware-static ==0.6.0.1, wai-websockets ==3.0.0.3, - warp ==3.0.4.1, + warp ==3.0.5, warp-tls ==3.0.1.1, webdriver ==0.6.0.3, web-fpco ==0.1.1.0, - websockets ==0.9.2.1, + websockets ==0.9.2.2, wizards ==1.0.1, wl-pprint ==1.1, wl-pprint-extras ==3.5.0.3, wl-pprint-terminfo ==3.7.1.3, - wl-pprint-text ==1.1.0.2, + wl-pprint-text ==1.1.0.3, word8 ==0.1.1, + wordpass ==1.0.0.2, X11 ==1.6.1.2, x509 ==1.5.0.1, x509-store ==1.5.0, @@ -804,7 +827,7 @@ constraints: abstract-deque ==0.3, xml-conduit ==1.2.3.1, xmlgen ==0.6.2.1, xml-hamlet ==0.4.0.9, - xmlhtml ==0.2.3.3, + xmlhtml ==0.2.3.4, xml-types ==0.3.4, xss-sanitize ==0.3.5.4, yackage ==0.7.0.6, @@ -812,11 +835,12 @@ constraints: abstract-deque ==0.3, Yampa ==0.9.6, YampaSynth ==0.2, yesod ==1.4.1.3, - yesod-auth ==1.4.1.1, + yesod-auth ==1.4.1.2, yesod-auth-deskcom ==1.4.0, yesod-auth-fb ==1.6.6, - yesod-auth-hashdb ==1.4.1.1, - yesod-bin ==1.4.3.1, + yesod-auth-hashdb ==1.4.1.2, + yesod-auth-oauth2 ==0.0.11, + yesod-bin ==1.4.3.2, yesod-core ==1.4.7.1, yesod-eventsource ==1.4.0.1, yesod-fay ==0.7.0, @@ -827,7 +851,7 @@ constraints: abstract-deque ==0.3, yesod-persistent ==1.4.0.2, yesod-sitemap ==1.4.0.1, yesod-static ==1.4.0.4, - yesod-test ==1.4.2.1, + yesod-test ==1.4.2.2, yesod-text-markdown ==0.1.7, yesod-websockets ==0.2.1.1, zeromq4-haskell ==0.6.2, diff --git a/config/keter.yaml b/config/keter.yaml index be96820..18e6c7b 100644 --- a/config/keter.yaml +++ b/config/keter.yaml @@ -5,5 +5,5 @@ stanzas: - production env: STACKAGE_CABAL_LOADER: "0" + STACKAGE_HOOGLE_GEN: "0" host: www.stackage.org -copy-to: fpuser@www.stackage.org:/var/opt/keter/incoming diff --git a/config/models b/config/models index 260db48..1c1593f 100644 --- a/config/models +++ b/config/models @@ -134,3 +134,7 @@ Suggested package PackageName insteadOf PackageName UniqueSuggested package insteadOf + +UploadProgress + message Text + dest Text Maybe diff --git a/config/robots.txt b/config/robots.txt index 7d329b1..f10713e 100644 --- a/config/robots.txt +++ b/config/robots.txt @@ -1 +1,2 @@ User-agent: * +Disallow: /haddock/ diff --git a/config/routes b/config/routes index 3bad7df..1050d5e 100644 --- a/config/routes +++ b/config/routes @@ -25,12 +25,13 @@ /package/#PackageNameVersion StackageSdistR GET /packages SnapshotPackagesR GET /docs DocsR GET + /hoogle HoogleR GET /hackage-view/#HackageView/00-index.tar.gz HackageViewIndexR GET /hackage-view/#HackageView/package/#PackageNameVersion HackageViewSdistR GET /aliases AliasesR PUT /alias/#Slug/#Slug/*Texts AliasR -/progress/#Int ProgressR GET +/progress/#UploadProgressId ProgressR GET /system SystemR GET /haddock/#SnapSlug/*Texts HaddockR GET /package/#PackageName PackageR GET @@ -54,3 +55,5 @@ /refresh-deprecated RefreshDeprecatedR GET /upload2 UploadV2R PUT +/build-version BuildVersionR GET +/package-counts PackageCountsR GET diff --git a/fpbuild.config b/fpbuild.config new file mode 100644 index 0000000..99fe986 --- /dev/null +++ b/fpbuild.config @@ -0,0 +1,8 @@ +docker: + repo-suffix: "_ghc-7.8.4.20141229_stackage-lts-1.0" + image-tag: "20150101" + # For fpbuild <= 0.1.0 + registry-username: "dummy" + registry-password: "no-auth-required" +packages: + - "." diff --git a/stackage-server.cabal b/stackage-server.cabal index 4c96283..58c8815 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -27,6 +27,7 @@ library Data.Hackage.DeprecationInfo Data.Hackage.Views Data.WebsiteContent + Data.Unpacking Types Handler.Home Handler.Snapshots @@ -44,6 +45,7 @@ library Handler.Progress Handler.System Handler.Haddock + Handler.Hoogle Handler.Package Handler.PackageList Handler.CompressorStatus @@ -51,6 +53,8 @@ library Handler.BannedTags Handler.RefreshDeprecated Handler.UploadV2 + Handler.BuildVersion + Handler.PackageCounts if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT @@ -83,6 +87,7 @@ library ScopedTypeVariables BangPatterns TupleSections + DeriveGeneric build-depends: base >= 4 @@ -150,9 +155,14 @@ library , formatting , blaze-html , haddock-library - , yesod-gitrepo , async , stackage >= 0.4 + , yesod-gitrepo >= 0.1.1 + , hoogle + , spoon + , deepseq + , deepseq-generics + , auto-update executable stackage-server if flag(library-only) diff --git a/templates/doc-list.hamlet b/templates/doc-list.hamlet index 2b13d13..8ea7c84 100644 --- a/templates/doc-list.hamlet +++ b/templates/doc-list.hamlet @@ -1,8 +1,9 @@ -

Module listing for #{toPathPiece slug} -

- Return to snapshot -