Merge branch 'master' into new-upload

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

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 Data.Conduit.Zlib (ungzip)
-import System.IO.Temp (withSystemTempFile, withSystemTempDirectory)
+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:)
--}

Data/Hackage/Views.hs

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

Handler/HackageViewIndex.hs

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

Handler/HackageViewSdist.hs

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

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

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

config/models

@@ -60,7 +60,7 @@ Like
 
 Download
     ident PackageSetIdent Maybe
-    view HackageView Maybe
+    view Text Maybe MigrationOnly
     timestamp UTCTime
     package PackageName
     version Version

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

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