diff --git a/Application.hs b/Application.hs index adfde13..767815b 100644 --- a/Application.hs +++ b/Application.hs @@ -12,7 +12,6 @@ import Control.Exception (catch) 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) @@ -56,8 +55,6 @@ import Handler.UploadStackage import Handler.StackageHome import Handler.StackageIndex import Handler.StackageSdist -import Handler.HackageViewIndex -import Handler.HackageViewSdist import Handler.Aliases import Handler.Alias import Handler.Progress @@ -327,18 +324,6 @@ appLoadCabalFiles updateDB forceUpdate env dbconf p = do deleteWhere [DependencyUser ==. metadataName md] insertMany_ $ flip map (metadataDeps md) $ \dep -> Dependency (PackageName dep) (metadataName md) - let views = - [ ("pvp", viewPVP uploadHistory) - , ("no-bounds", viewNoBounds) - , ("unchanged", viewUnchanged) - ] - forM_ views $ \(name, func) -> do - $logInfo $ "Generating view: " ++ toPathPiece name - runResourceT $ createView - name - func - (sourceHistory uploadHistory) - (storeWrite $ HackageViewIndex name) case eres of Left e -> $logError $ tshow e Right () -> return () diff --git a/Data/Hackage.hs b/Data/Hackage.hs index 20e31fd..4c5a466 100644 --- a/Data/Hackage.hs +++ b/Data/Hackage.hs @@ -1,8 +1,6 @@ module Data.Hackage ( loadCabalFiles , sourceHackageSdist - , createView - , sourceHackageViewSdist , sinkUploadHistory , UploadState (..) , UploadHistory @@ -16,17 +14,13 @@ import Data.Conduit.Lazy (MonadActive (..), lazyConsume) import qualified Codec.Archive.Tar as Tar import Control.Monad.Logger (runNoLoggingT) import qualified Data.Text as T -import Data.Conduit.Zlib (ungzip, gzip) -import System.IO.Temp (withSystemTempFile, withSystemTempDirectory) +import Data.Conduit.Zlib (ungzip) +import System.IO.Temp (withSystemTempFile) import System.IO (IOMode (ReadMode), openBinaryFile) import Model (Uploaded (Uploaded), Metadata (..)) -import Filesystem (createTree) import Distribution.PackageDescription.Parse (parsePackageDescription, ParseResult (ParseOk)) -import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) -import Distribution.PackageDescription (GenericPackageDescription) import qualified Distribution.PackageDescription as PD import qualified Distribution.Package as PD -import Control.Exception (throw) import Control.Monad.State.Strict (put, get, execStateT, MonadState) import Crypto.Hash.Conduit (sinkHash) import Crypto.Hash (Digest, SHA256) @@ -433,116 +427,6 @@ sourceHackageSdist name version = do then storeRead key else return Nothing -sourceHackageViewSdist :: ( MonadIO m - , MonadThrow m - , MonadBaseControl IO m - , MonadResource m - , MonadReader env m - , HasHttpManager env - , HasHackageRoot env - , HasBlobStore env StoreKey - , MonadLogger m - , MonadActive m - ) - => HackageView - -> PackageName - -> Version - -> m (Maybe (Source m ByteString)) -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 <- sourceHackageSdist name version - case msrc of - Nothing -> return Nothing - Just src -> do - lbs <- fromChunks <$> lazyConsume (src $= ungzip) - let lbs' = Tar.write $ replaceCabal cabalLBS $ Tar.read lbs - sourceLazy lbs' $$ gzip =$ 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 - , MonadMask m - , MonadReader env m - , HasBlobStore env StoreKey - , MonadBaseControl IO m - , MonadLogger m - ) - => HackageView - -> (PackageName -> Version -> UTCTime -> GenericPackageDescription -> m GenericPackageDescription) - -> Source m Uploaded - -> Sink ByteString m () - -> m () -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 (Uploaded name version time) = do - let relfp = fpFromText (toPathPiece name) - fpFromText (toPathPiece version) - fpFromText (concat - [ toPathPiece name - , "-" - , toPathPiece version - , ".cabal" - ]) - fp = fpFromString dir relfp - key = HackageViewCabal viewName name version - mprev <- storeRead key - case mprev of - Just src' -> do - liftIO $ createTree $ directory fp - src' $$ sinkFile fp - return $ asSet $ singletonSet relfp - Nothing -> do - msrc <- storeRead $ HackageCabal name version - case msrc of - Nothing -> return mempty - Just src' -> do - orig <- src' $$ sinkLazy - new <- - case parsePackageDescription $ unpack $ decodeUtf8 orig of - ParseOk _ gpd -> do - gpd' <- modifyCabal name version time gpd - let str = showGenericPackageDescription gpd' - -- sanity check - case parsePackageDescription str of - ParseOk _ _ -> return $ encodeUtf8 $ pack str - x -> do - $logError $ "Created cabal file that could not be parsed: " ++ tshow (x, str) - return orig - _ -> return orig - sourceLazy new $$ storeWrite key - liftIO $ createTree $ directory fp - writeFile fp new - return $ asSet $ singletonSet relfp - sourceHistory :: Monad m => UploadHistory -> Producer m Uploaded sourceHistory = mapM_ go . mapToList @@ -558,51 +442,3 @@ parMapMC :: (MonadIO m, MonadBaseControl IO m) -> (i -> m o) -> Conduit i m o parMapMC _ = mapMC -{- FIXME -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/Data/Hackage/Views.hs b/Data/Hackage/Views.hs deleted file mode 100644 index e879145..0000000 --- a/Data/Hackage/Views.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -module Data.Hackage.Views where - -import ClassyPrelude.Yesod -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Version (anyVersion, intersectVersionRanges, earlierVersion, Version (..), simplifyVersionRange, VersionRange (..)) -import Distribution.Text (simpleParse) -import Data.NonNull (fromNullable) -- FIXME expose from ClassyPrelude -import Data.Hackage (UploadHistory) -import Data.Time (addUTCTime) -import qualified Types - -viewUnchanged :: Monad m - => packageName -> version -> time - -> GenericPackageDescription - -> m GenericPackageDescription -viewUnchanged _ _ _ = return - -helper :: Monad m - => (Dependency -> m Dependency) - -> GenericPackageDescription - -> m GenericPackageDescription -helper f0 gpd = do - a <- mapM (go f0) $ condLibrary gpd - b <- mapM (go2 f0) $ condExecutables gpd - c <- mapM (go2 f0) $ condTestSuites gpd - d <- mapM (go2 f0) $ condBenchmarks gpd - return gpd - { condLibrary = a - , condExecutables = b - , condTestSuites = c - , condBenchmarks = d - } - where - go2 f (x, y) = do - y' <- go f y - return (x, y') - - go :: Monad m - => (Dependency -> m Dependency) - -> CondTree ConfVar [Dependency] a - -> m (CondTree ConfVar [Dependency] a) - go f (CondNode a constraints comps) = do - constraints' <- mapM f constraints - comps' <- mapM (goComp f) comps - return $ CondNode a constraints' comps' - - goComp :: Monad m - => (Dependency -> m Dependency) - -> (condition, CondTree ConfVar [Dependency] a, Maybe (CondTree ConfVar [Dependency] a)) - -> m (condition, CondTree ConfVar [Dependency] a, Maybe (CondTree ConfVar [Dependency] a)) - goComp f (condition, tree, mtree) = do - tree' <- go f tree - mtree' <- mapM (go f) mtree - return (condition, tree', mtree') - -viewNoBounds :: Monad m - => packageName -> version -> time - -> GenericPackageDescription - -> m GenericPackageDescription -viewNoBounds _ _ _ = - helper go - where - go (Dependency name _range) = return $ Dependency name anyVersion - -getAvailable :: Types.PackageName - -> UTCTime - -> HashMap Types.PackageName (HashMap Types.Version UTCTime) - -> [Types.Version] -getAvailable name maxUploaded = - map fst . filter ((<= maxUploaded) . snd) . mapToList . fromMaybe mempty . lookup name - --- | We want to allow a certain "fuzz factor" between upload dates, so that if, --- for example, foo and bar are released within a few seconds of each other, --- and bar depends on foo, bar can use that new version of foo, even though --- technically it "wasn't available" yet. --- --- The actual value we should use is up for debate. I'm starting with 24 hours. -addFuzz :: UTCTime -> UTCTime -addFuzz = addUTCTime (60 * 60 * 24) - -viewPVP :: Monad m - => UploadHistory - -> packageName -> version -> UTCTime - -> GenericPackageDescription - -> m GenericPackageDescription -viewPVP uploadHistory _ _ uploaded = - helper go - where - toStr (Distribution.Package.PackageName name) = name - - go orig@(Dependency _ range) | hasUpperBound range = return orig - go orig@(Dependency nameO@(toStr -> name) range) = do - let available = getAvailable (fromString name) (addFuzz uploaded) uploadHistory - case fromNullable $ mapMaybe (simpleParse . unpack . toPathPiece) available of - Nothing -> return orig - Just vs -> - case pvpBump $ maximum vs of - Nothing -> return orig - Just v -> return - $ Dependency nameO - $ simplifyVersionRange - $ intersectVersionRanges range - $ earlierVersion v - - pvpBump (Version (x:y:_) _) = Just $ Version [x, y + 1] [] - pvpBump _ = Nothing - - hasUpperBound AnyVersion = False - hasUpperBound ThisVersion{} = True - hasUpperBound LaterVersion{} = False - hasUpperBound EarlierVersion{} = True - hasUpperBound WildcardVersion{} = True - hasUpperBound (UnionVersionRanges x y) = hasUpperBound x && hasUpperBound y - hasUpperBound (IntersectVersionRanges x y) = hasUpperBound x || hasUpperBound y - hasUpperBound (VersionRangeParens x) = hasUpperBound x diff --git a/Handler/HackageViewIndex.hs b/Handler/HackageViewIndex.hs deleted file mode 100644 index 826cef1..0000000 --- a/Handler/HackageViewIndex.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Handler.HackageViewIndex where - -import Import -import Data.BlobStore - -getHackageViewIndexR :: HackageView -> Handler TypedContent -getHackageViewIndexR viewName = do - msrc <- storeRead $ HackageViewIndex viewName - case msrc of - Nothing -> notFound - Just src -> do - addHeader "content-disposition" "attachment; filename=\"00-index.tar.gz\"" - respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src diff --git a/Handler/HackageViewSdist.hs b/Handler/HackageViewSdist.hs deleted file mode 100644 index e5dbb0c..0000000 --- a/Handler/HackageViewSdist.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Handler.HackageViewSdist where - -import Import -import Data.Hackage -import Handler.StackageSdist (addDownload) - -getHackageViewSdistR :: HackageView -> PackageNameVersion -> Handler TypedContent -getHackageViewSdistR viewName (PNVTarball name version) = do - addDownload Nothing (Just viewName) name version - msrc <- sourceHackageViewSdist viewName name version - case msrc of - Nothing -> notFound - Just src -> do - addHeader "content-disposition" $ concat - [ "attachment; filename=\"" - , toPathPiece name - , "-" - , toPathPiece version - , ".tar.gz" - ] - respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src -getHackageViewSdistR _ _ = notFound diff --git a/Handler/StackageSdist.hs b/Handler/StackageSdist.hs index 1c93a23..2e2ab6f 100644 --- a/Handler/StackageSdist.hs +++ b/Handler/StackageSdist.hs @@ -10,7 +10,7 @@ getStackageSdistR :: SnapSlug -> PackageNameVersion -> Handler TypedContent getStackageSdistR slug (PNVTarball name version) = do Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug let ident = stackageIdent stackage - addDownload (Just ident) Nothing name version + addDownload (Just ident) name version msrc1 <- storeRead (CustomSdist ident name version) msrc <- case msrc1 of @@ -56,11 +56,10 @@ getStackageSdistR slug (PNVNameVersion name version) = packagePage ) >>= sendResponse addDownload :: Maybe PackageSetIdent - -> Maybe HackageView -> PackageName -> Version -> Handler () -addDownload downloadIdent downloadView downloadPackage downloadVersion = do +addDownload downloadIdent downloadPackage downloadVersion = do downloadUserAgent <- fmap decodeUtf8 <$> lookupHeader "user-agent" downloadTimestamp <- liftIO getCurrentTime runDB $ insert_ Download {..} diff --git a/Types.hs b/Types.hs index 8072fbd..ed79874 100644 --- a/Types.hs +++ b/Types.hs @@ -18,10 +18,6 @@ newtype PackageSetIdent = PackageSetIdent { unPackageSetIdent :: Text } deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField) instance PersistFieldSql PackageSetIdent where sqlType = sqlType . liftM unPackageSetIdent -newtype HackageView = HackageView { unHackageView :: Text } - deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, IsString) -instance PersistFieldSql HackageView where - sqlType = sqlType . liftM unHackageView data PackageNameVersion = PNVTarball !PackageName !Version | PNVNameVersion !PackageName !Version @@ -53,9 +49,6 @@ data StoreKey = HackageCabal !PackageName !Version | HackageSdist !PackageName !Version | CabalIndex !PackageSetIdent | CustomSdist !PackageSetIdent !PackageName !Version - | HackageViewCabal !HackageView !PackageName !Version - | HackageViewSdist !HackageView !PackageName !Version - | HackageViewIndex !HackageView | SnapshotBundle !PackageSetIdent | HaddockBundle !PackageSetIdent | HoogleDB !PackageSetIdent !HoogleVersion @@ -76,23 +69,6 @@ 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" - ] toPath (SnapshotBundle ident) = [ "bundle" , toPathPiece ident ++ ".tar.gz" @@ -111,9 +87,6 @@ instance BackupToS3 StoreKey where shouldBackup HackageSdist{} = False shouldBackup CabalIndex{} = True shouldBackup CustomSdist{} = True - shouldBackup HackageViewCabal{} = False - shouldBackup HackageViewSdist{} = False - shouldBackup HackageViewIndex{} = False shouldBackup SnapshotBundle{} = True shouldBackup HaddockBundle{} = True shouldBackup HoogleDB{} = True diff --git a/config/models b/config/models index 1c1593f..5544034 100644 --- a/config/models +++ b/config/models @@ -60,7 +60,7 @@ Like Download ident PackageSetIdent Maybe - view HackageView Maybe + view Text Maybe MigrationOnly timestamp UTCTime package PackageName version Version diff --git a/config/routes b/config/routes index 1050d5e..54134e8 100644 --- a/config/routes +++ b/config/routes @@ -27,8 +27,6 @@ /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/#UploadProgressId ProgressR GET diff --git a/stackage-server.cabal b/stackage-server.cabal index 58c8815..1e5e931 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -25,7 +25,6 @@ library Data.BlobStore Data.Hackage Data.Hackage.DeprecationInfo - Data.Hackage.Views Data.WebsiteContent Data.Unpacking Types @@ -38,8 +37,6 @@ library Handler.StackageHome Handler.StackageIndex Handler.StackageSdist - Handler.HackageViewIndex - Handler.HackageViewSdist Handler.Aliases Handler.Alias Handler.Progress