diff --git a/Data/Hackage/Views.hs b/Data/Hackage/Views.hs new file mode 100644 index 0000000..f6675d1 --- /dev/null +++ b/Data/Hackage/Views.hs @@ -0,0 +1,105 @@ +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 Types hiding (Version (..)) +import qualified Types +import Model +import Data.NonNull (fromNullable) -- FIXME expose from ClassyPrelude + +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 + +viewPVP :: ( Monad m + , PersistMonadBackend m ~ SqlBackend + , PersistQuery m + ) + => packageName -> version -> UTCTime + -> GenericPackageDescription + -> m GenericPackageDescription +viewPVP _ _ uploaded = + helper go + where + wiredIn = asSet $ setFromList $ words "base ghc template-haskell" + + toStr (Distribution.Package.PackageName name) = name + + go (Dependency name _) | toStr name `member` wiredIn = return $ Dependency name anyVersion + go orig@(Dependency _ range) | hasUpperBound range = return orig + go orig@(Dependency nameO@(toStr -> name) range) = do + available <- selectList [UploadedName ==. fromString name, UploadedUploaded <=. uploaded] [] + case fromNullable $ mapMaybe (simpleParse . unpack . toPathPiece . uploadedVersion . entityVal) 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 new file mode 100644 index 0000000..826cef1 --- /dev/null +++ b/Handler/HackageViewIndex.hs @@ -0,0 +1,13 @@ +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 new file mode 100644 index 0000000..f2afe51 --- /dev/null +++ b/Handler/HackageViewSdist.hs @@ -0,0 +1,24 @@ +module Handler.HackageViewSdist where + +import Import +import Data.BlobStore +import Data.Hackage +import Data.Conduit.Lazy (MonadActive (..)) + +getHackageViewSdistR :: HackageView -> PackageNameVersion -> Handler TypedContent +getHackageViewSdistR viewName (PackageNameVersion name version) = do + 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 + +instance MonadActive m => MonadActive (HandlerT site m) where -- FIXME upstream + monadActive = lift monadActive