From 4f122f6282d32681eb24cafc873f28f02908bd3c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 13 Apr 2014 08:48:58 +0300 Subject: [PATCH] Untested Hackage views --- Application.hs | 40 +++++++++++-- Data/Hackage.hs | 133 +++++++++++++++++++++++++++++++++++------- Types.hs | 24 +++++++- config/routes | 2 + stackage-server.cabal | 7 +++ 5 files changed, 180 insertions(+), 26 deletions(-) diff --git a/Application.hs b/Application.hs index 22887a2..adb4601 100644 --- a/Application.hs +++ b/Application.hs @@ -5,7 +5,7 @@ module Application , makeFoundation ) where -import Import +import Import hiding (catch) import Settings import Yesod.Default.Config import Yesod.Default.Main @@ -22,8 +22,14 @@ import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr) import Network.Wai.Logger (clockDateCacher) import Yesod.Core.Types (loggerSet, Logger (Logger)) import qualified System.Random.MWC as MWC -import Data.BlobStore (fileStore) +import Data.BlobStore (fileStore, storeWrite) import Data.Hackage +import Data.Hackage.Views +import Data.Conduit.Lazy (MonadActive, monadActive) +import Control.Monad.Catch (MonadCatch (..)) +import Database.Persist.Sql (SqlPersistT (..)) +import Control.Monad.Trans.Resource.Internal (ResourceT (..)) +import Control.Monad.Reader (MonadReader (..)) -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! @@ -35,6 +41,8 @@ import Handler.UploadStackage import Handler.StackageHome import Handler.StackageIndex import Handler.StackageSdist +import Handler.HackageViewIndex +import Handler.HackageViewSdist -- 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 @@ -113,8 +121,8 @@ makeFoundation conf = do -- Start the cabal file loader void $ forkIO $ forever $ flip runLoggingT (messageLoggerSource foundation logger) $ do when development $ liftIO $ threadDelay $ 5 * 60 * 1000000 - eres <- tryAny $ flip runReaderT foundation $ loadCabalFiles - $ \name version mmtime -> + eres <- tryAny $ flip runReaderT foundation $ do + loadCabalFiles $ \name version mmtime -> runResourceT $ flip (Database.Persist.runPool dbconf) p $ do mx <- getBy $ UniqueUploaded name version case mx of @@ -122,6 +130,17 @@ makeFoundation conf = do Nothing -> do mtime <- lift $ lift mmtime forM_ mtime $ void . insertBy . Uploaded name version + let views = + [ ("pvp", viewPVP) + , ("no-bounds", viewNoBounds) + , ("unchanged", viewUnchanged) + ] + forM_ views $ \(name, func) -> + runResourceT $ flip (Database.Persist.runPool dbconf) p $ createView + name + func + (selectSource [] []) + (storeWrite $ HackageViewIndex name) case eres of Left e -> $logError $ tshow e Right () -> return () @@ -129,6 +148,19 @@ makeFoundation conf = do return foundation +instance MonadActive m => MonadActive (SqlPersistT m) where -- FIXME orphan upstream + monadActive = lift monadActive +deriving instance MonadCatch m => MonadCatch (SqlPersistT m) +instance MonadCatch m => MonadCatch (ResourceT m) where + catch (ResourceT m) c = ResourceT $ \r -> m r `catch` \e -> unResourceT (c e) r + mask a = ResourceT $ \e -> mask $ \u -> unResourceT (a $ q u) e + where q u (ResourceT b) = ResourceT (u . b) + uninterruptibleMask a = + ResourceT $ \e -> uninterruptibleMask $ \u -> unResourceT (a $ q u) e + where q u (ResourceT b) = ResourceT (u . b) +instance MonadReader env m => MonadReader env (SqlPersistT m) where + ask = lift ask + -- for yesod devel getApplicationDev :: IO (Int, Application) getApplicationDev = diff --git a/Data/Hackage.hs b/Data/Hackage.hs index ed9cdf4..c773e64 100644 --- a/Data/Hackage.hs +++ b/Data/Hackage.hs @@ -1,9 +1,10 @@ module Data.Hackage ( loadCabalFiles , sourceHackageSdist + , createView ) where -import ClassyPrelude.Yesod +import ClassyPrelude.Yesod hiding (get) import Types import Data.BlobStore import Data.Conduit.Lazy (MonadActive (..), lazyConsume) @@ -12,7 +13,7 @@ import qualified Codec.Archive.Tar as Tar import Control.Monad.Reader (MonadReader, ask) import Control.Monad.Trans.Resource (release) import qualified Data.Text as T -import Data.Conduit.Zlib (ungzip) +import Data.Conduit.Zlib (ungzip, gzip) import Text.XML.Cursor (($//), (&/), content, fromDocument, element, followingSibling) import Text.HTML.DOM (sinkDoc) import System.IO.Temp (withSystemTempFile, withSystemTempDirectory) @@ -20,8 +21,12 @@ import System.IO (IOMode (ReadMode), openBinaryFile) import Control.Monad.Catch (MonadCatch) import Model (Uploaded (Uploaded)) import Filesystem (createTree) -import Distribution.PackageDescription.Parse (showPackageDescription, parsePackageDescription, ParseResult (ParseOk)) -import Distribution.PackageDescription (GenericPackageDescription, PackageDescription) +import Distribution.PackageDescription.Parse (parsePackageDescription, ParseResult (ParseOk)) +import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) +import Distribution.PackageDescription (GenericPackageDescription, PackageDescription, packageDescription) +import Control.Exception (throw) +import Control.Monad.State (modify, put, get) +import Control.Concurrent.Lifted (fork) loadCabalFiles :: ( MonadActive m , MonadBaseControl IO m @@ -46,14 +51,10 @@ loadCabalFiles addUpload = do liftIO $ hClose handleOut withBinaryFile tempIndex ReadMode $ \handleIn -> do bss <- lazyConsume $ sourceHandle handleIn $= ungzip - loop $ Tar.read $ fromChunks bss + tarSource (Tar.read $ fromChunks bss) $$ parMapMC 32 go =$ sinkNull -- FIXME parMapM_C where withBinaryFile fp mode = bracket (liftIO $ openBinaryFile fp mode) (liftIO . hClose) - loop (Tar.Next entry entries) = go entry >> loop entries - loop Tar.Done = return () - loop (Tar.Fail e) = throwM e - go entry = do case Tar.entryContent entry of Tar.NormalFile lbs _ @@ -66,6 +67,10 @@ loadCabalFiles addUpload = do setUploadDate name version addUpload _ -> return () +tarSource Tar.Done = return () +tarSource (Tar.Fail e) = throwM e +tarSource (Tar.Next e es) = yield e >> tarSource es + setUploadDate :: ( MonadBaseControl IO m , MonadThrow m , MonadIO m @@ -148,17 +153,62 @@ sourceHackageSdist name version = do then storeRead key else return Nothing +sourceHackageViewSdist viewName name version = do + let key = HackageViewSdist viewName name version + msrc1 <- storeRead key + case msrc1 of + Just src -> return $ Just src + Nothing -> do + mcabalSrc <- storeRead $ HackageViewCabal viewName name version + case mcabalSrc of + Nothing -> return Nothing + Just cabalSrc -> do + cabalLBS <- cabalSrc $$ sinkLazy + msrc <- storeRead $ HackageSdist name version + case msrc of + Nothing -> return Nothing + Just src -> do + lbs <- fromChunks <$> lazyConsume src + let lbs' = Tar.write $ replaceCabal cabalLBS $ Tar.read lbs + sourceLazy lbs' $$ storeWrite key + storeRead key + where + cabalName = unpack $ concat + [ toPathPiece name + , "-" + , toPathPiece version + , "/" + , toPathPiece name + , ".cabal" + ] + + replaceCabal _ Tar.Done = [] + replaceCabal _ (Tar.Fail e) = throw e -- עבירה גוררת עבירה + replaceCabal lbs (Tar.Next e es) = replaceCabal' lbs e : replaceCabal lbs es + + replaceCabal' lbs e + | Tar.entryPath e == cabalName = e { Tar.entryContent = Tar.NormalFile lbs (olength64 lbs) } + | otherwise = e + createView :: ( MonadResource m , MonadCatch m , MonadReader env m , HasBlobStore env StoreKey + , MonadBaseControl IO m + , MonadLogger m ) - => (PackageName -> Version -> UTCTime -> GenericPackageDescription -> m PackageDescription) + => HackageView + -> (PackageName -> Version -> UTCTime -> GenericPackageDescription -> m GenericPackageDescription) -> Source m (Entity Uploaded) -> Sink ByteString m () -> m () -createView modifyCabal src sink = withSystemTempDirectory "createview" $ \dir -> do - rels <- src $$ mapMC (\(Entity _ (Uploaded name version time)) -> do +createView viewName modifyCabal src sink = withSystemTempDirectory "createview" $ \dir -> do + $logDebug $ "Creating view: " ++ tshow viewName + rels <- src $$ parMapMC 32 (uploadedConduit dir) =$ foldC + entries <- liftIO $ Tar.pack dir (map fpToString $ setToList rels) + sourceLazy (Tar.write entries) $$ gzip =$ sink + where + uploadedConduit dir (Entity _ (Uploaded name version time)) = do let relfp = fpFromText (toPathPiece name) fpFromText (toPathPiece version) fpFromText (concat @@ -176,18 +226,59 @@ createView modifyCabal src sink = withSystemTempDirectory "createview" $ \dir -> case parsePackageDescription $ unpack $ decodeUtf8 orig of ParseOk _ gpd -> do gpd' <- modifyCabal name version time gpd - return $ encodeUtf8 $ pack $ showPackageDescription gpd' + return $ encodeUtf8 $ pack $ showGenericPackageDescription gpd' _ -> return orig + sourceLazy new $$ storeWrite (HackageViewCabal viewName name version) let fp = fpFromString dir relfp liftIO $ createTree $ directory fp writeFile fp new return $ asSet $ singletonSet relfp - ) =$ foldC - entries <- liftIO $ Tar.pack dir (map fpToString $ setToList rels) - sourceLazy (Tar.write entries) $$ sink -viewNoBounds :: Monad m - => packageName -> version -> time - -> GenericPackageDescription - -> m GenericPackageDescription -viewNoBounds gpd = undefined +-- FIXME put in conduit-combinators +parMapMC :: (MonadIO m, MonadBaseControl IO m) + => Int + -> (i -> m o) + -> Conduit i m o +parMapMC threads f = evalStateC 0 $ do + incoming <- liftIO $ newTBQueueIO $ threads * 8 + outgoing <- liftIO newTChanIO + lift $ lift $ replicateM_ threads (addWorker incoming outgoing) + awaitForever $ \x -> do + cnt <- get + ys <- atomically $ do + writeTBQueue incoming (Just x) + readWholeTChan outgoing + put $ cnt + 1 - length ys + yieldMany ys + atomically $ writeTBQueue incoming Nothing + let loop = do + togo <- get + when (togo > 0) $ do + y <- atomically $ readTChan outgoing + put $ togo - 1 + yield y + loop + where + addWorker incoming outgoing = + fork loop + where + loop = join $ atomically $ do + mx <- readTBQueue incoming + case mx of + Nothing -> do + writeTBQueue incoming Nothing + return $ return () + Just x -> return $ do + y <- f x + atomically $ writeTChan outgoing y + loop + + readWholeTChan chan = + go id + where + go front = do + mx <- tryReadTChan chan + case mx of + Nothing -> return $ front [] + Just x -> go $ front . (x:) + diff --git a/Types.hs b/Types.hs index 08b9e50..fb27346 100644 --- a/Types.hs +++ b/Types.hs @@ -7,11 +7,13 @@ import Database.Persist.Sql (PersistFieldSql) import qualified Data.Text as T newtype PackageName = PackageName { unPackageName :: Text } - deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, PersistFieldSql) + deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, PersistFieldSql, IsString) newtype Version = Version { unVersion :: Text } deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, PersistFieldSql) newtype PackageSetIdent = PackageSetIdent { unPackageSetIdent :: Text } deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, PersistFieldSql) +newtype HackageView = HackageView { unHackageView :: Text } + deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, PersistFieldSql, IsString) data PackageNameVersion = PackageNameVersion !PackageName !Version deriving (Show, Read, Typeable, Eq, Ord) @@ -29,6 +31,9 @@ data StoreKey = HackageCabal !PackageName !Version | HackageSdist !PackageName !Version | CabalIndex !PackageSetIdent | CustomSdist !PackageSetIdent !PackageName !Version + | HackageViewCabal !HackageView !PackageName !Version + | HackageViewSdist !HackageView !PackageName !Version + | HackageViewIndex !HackageView instance ToPath StoreKey where toPath (HackageCabal name version) = ["hackage", toPathPiece name, toPathPiece version ++ ".cabal"] @@ -40,6 +45,23 @@ instance ToPath StoreKey where , toPathPiece name , toPathPiece version ++ ".tar.gz" ] + toPath (HackageViewCabal viewName name version) = + [ "hackage-view" + , toPathPiece viewName + , toPathPiece name + , toPathPiece version ++ ".cabal" + ] + toPath (HackageViewSdist viewName name version) = + [ "hackage-view" + , toPathPiece viewName + , toPathPiece name + , toPathPiece version ++ ".tar.gz" + ] + toPath (HackageViewIndex viewName) = + [ "hackage-view" + , toPathPiece viewName + , "00-index.tar.gz" + ] newtype HackageRoot = HackageRoot { unHackageRoot :: Text } deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup) diff --git a/config/routes b/config/routes index ec762d5..7232bcd 100644 --- a/config/routes +++ b/config/routes @@ -12,3 +12,5 @@ /stackage/#PackageSetIdent StackageHomeR GET /stackage/#PackageSetIdent/00-index.tar.gz StackageIndexR GET /stackage/#PackageSetIdent/package/#PackageNameVersion StackageSdistR GET +/hackage-view/#HackageView/00-index.tar.gz HackageViewIndexR GET +/hackage-view/#HackageView/package/#PackageNameVersion HackageViewSdistR GET diff --git a/stackage-server.cabal b/stackage-server.cabal index 33c5ced..8c20a19 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -22,6 +22,7 @@ library Data.Slug Data.BlobStore Data.Hackage + Data.Hackage.Views Types Handler.Home Handler.Profile @@ -31,6 +32,8 @@ library Handler.StackageHome Handler.StackageIndex Handler.StackageSdist + Handler.HackageViewIndex + Handler.HackageViewSdist if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT @@ -57,6 +60,8 @@ library RankNTypes FunctionalDependencies PatternGuards + StandaloneDeriving + UndecidableInstances build-depends: base >= 4 && < 5 , yesod >= 1.2.5 && < 1.3 @@ -107,6 +112,8 @@ library , xml-conduit , html-conduit , Cabal + , lifted-base + , mono-traversable executable stackage-server if flag(library-only)