From 8825105005abfaf641cb7947b4c98363d69ff34a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 20 Nov 2012 14:01:43 +0200 Subject: [PATCH] Initial code --- .gitignore | 1 + .gitmodules | 3 ++ LICENSE | 20 ++++++++ README.md | 7 ++- Setup.hs | 2 + Stackage/HaskellPlatform.hs | 53 +++++++++++++++++++++ Stackage/LoadDatabase.hs | 92 +++++++++++++++++++++++++++++++++++++ Stackage/NarrowDatabase.hs | 30 ++++++++++++ Stackage/PackageList.hs | 31 +++++++++++++ Stackage/Types.hs | 40 ++++++++++++++++ Stackage/Util.hs | 12 +++++ app/gen-install-line.hs | 19 ++++++++ haskell-platform | 1 + package-list.txt | 8 ++++ stackage.cabal | 37 +++++++++++++++ 15 files changed, 355 insertions(+), 1 deletion(-) create mode 100644 .gitmodules create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 Stackage/HaskellPlatform.hs create mode 100644 Stackage/LoadDatabase.hs create mode 100644 Stackage/NarrowDatabase.hs create mode 100644 Stackage/PackageList.hs create mode 100644 Stackage/Types.hs create mode 100644 Stackage/Util.hs create mode 100644 app/gen-install-line.hs create mode 160000 haskell-platform create mode 100644 package-list.txt create mode 100644 stackage.cabal diff --git a/.gitignore b/.gitignore index 477a3533..803badb3 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,4 @@ cabal-dev *.chi *.chs.h .virthualenv +*.swp diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 00000000..c41f65d1 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "haskell-platform"] + path = haskell-platform + url = https://github.com/haskell/haskell-platform.git diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..d9f04179 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md index bd7e9df2..7da6894f 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,9 @@ stackage ======== -"Stable Hackage," tools for creating a vetted set of packages from Hackage. \ No newline at end of file +"Stable Hackage," tools for creating a vetted set of packages from Hackage. + +A note about the codebase: the goal is to minimize dependencies and have +the maximum range of supported compiler versions. Therefore, we avoid +anything "complicated." For example, instead of using the text package, +we use Strings everywhere. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Stackage/HaskellPlatform.hs b/Stackage/HaskellPlatform.hs new file mode 100644 index 00000000..cc08ff60 --- /dev/null +++ b/Stackage/HaskellPlatform.hs @@ -0,0 +1,53 @@ +module Stackage.HaskellPlatform + ( loadHaskellPlatform + ) where + +import Control.Monad (guard) +import Data.Char (isSpace) +import Data.List (foldl', isInfixOf, isPrefixOf, stripPrefix) +import Data.Maybe (mapMaybe) +import Data.Monoid (Monoid (..)) +import Data.Set (singleton) +import Distribution.Text (simpleParse) +import Stackage.Types + +loadHaskellPlatform :: IO HaskellPlatform +loadHaskellPlatform = fmap parseHP $ readFile "haskell-platform/haskell-platform.cabal" + +data HPLine = HPLPackage PackageIdentifier + | HPLBeginCore + | HPLEndCore + | HPLBeginPlatform + | HPLEndPlatform + deriving Show + +toHPLine :: String -> Maybe HPLine +toHPLine s + | "begin core packages" `isInfixOf` s = Just HPLBeginCore + | "end core packages" `isInfixOf` s = Just HPLEndCore + | "begin platform packages" `isInfixOf` s = Just HPLBeginPlatform + | "end platform packages" `isInfixOf` s = Just HPLEndPlatform + | otherwise = do + let s1 = dropWhile isSpace s + guard $ not $ "--" `isPrefixOf` s1 + guard $ not $ null s1 + guard $ "==" `isInfixOf` s1 + let (package', s2) = break (== '=') s1 + package = takeWhile (not . isSpace) package' + s3 <- stripPrefix "==" s2 + version <- simpleParse $ takeWhile (/= ',') s3 + Just $ HPLPackage $ PackageIdentifier (PackageName package) version + +parseHP :: String -> HaskellPlatform +parseHP = + snd . foldl' addLine (notInBlock, mempty) . mapMaybe toHPLine . lines + where + notInBlock _ = mempty + inCore x = HaskellPlatform (singleton x) mempty + inPlatform x = HaskellPlatform mempty (singleton x) + + addLine (fromPackage, hp) (HPLPackage vp) = (fromPackage, fromPackage vp `mappend` hp) + addLine (_, hp) HPLBeginCore = (inCore, hp) + addLine (_, hp) HPLEndCore = (notInBlock, hp) + addLine (_, hp) HPLBeginPlatform = (inPlatform, hp) + addLine (_, hp) HPLEndPlatform = (notInBlock, hp) diff --git a/Stackage/LoadDatabase.hs b/Stackage/LoadDatabase.hs new file mode 100644 index 00000000..8947a401 --- /dev/null +++ b/Stackage/LoadDatabase.hs @@ -0,0 +1,92 @@ +module Stackage.LoadDatabase where + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as TarEntry +import Control.Exception (throwIO) +import Control.Monad (guard) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.List (stripPrefix) +import qualified Data.Map as Map +import Data.Monoid (Monoid (..)) +import Data.Set (member) +import qualified Data.Set as Set +import Distribution.Package (Dependency (Dependency)) +import Distribution.PackageDescription (condBenchmarks, + condExecutables, + condLibrary, + condTestSuites, + condTreeConstraints) +import Distribution.PackageDescription.Parse (ParseResult (ParseOk), + parsePackageDescription) +import Distribution.Text (simpleParse) +import Distribution.Version (withinRange) +import Stackage.Types +import System.Directory (getAppUserDataDirectory) +import System.FilePath (()) + +-- | Load the raw package database. +-- +-- We want to put in some restrictions: +-- +-- * Drop all core packages. We never want to install a new version of +-- those, nor include them in the package list. +-- +-- * For packages with a specific version bound, find the maximum matching +-- version. +-- +-- * For other packages, select the maximum version number. +loadPackageDB :: Set PackageName -- ^ core packages + -> Map PackageName VersionRange -- ^ additional deps + -> IO PackageDB +loadPackageDB core deps = do + c <- getAppUserDataDirectory "cabal" + let tarName = c "packages" "hackage.haskell.org" "00-index.tar" + lbs <- L.readFile tarName + addEntries mempty $ Tar.read lbs + where + addEntries :: PackageDB -> Tar.Entries Tar.FormatError -> IO PackageDB + addEntries _ (Tar.Fail e) = throwIO e + addEntries db Tar.Done = return db + addEntries db (Tar.Next e es) = addEntry db e >>= flip addEntries es + + addEntry :: PackageDB -> Tar.Entry -> IO PackageDB + addEntry pdb e = + case getPackageVersion $ TarEntry.fromTarPathToPosixPath (TarEntry.entryTarPath e) of + Nothing -> return pdb + Just (p, v) + | p `member` core -> return pdb + | otherwise -> + case Map.lookup p deps of + Just vrange + | not $ withinRange v vrange -> return pdb + _ -> + case Tar.entryContent e of + Tar.NormalFile bs _ -> return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo + { piVersion = v + , piDeps = parseDeps bs + } + _ -> return pdb + + parseDeps lbs = + case parsePackageDescription $ L8.unpack lbs of + ParseOk _ gpd -> mconcat + [ maybe mempty go $ condLibrary gpd + , mconcat $ map (go . snd) $ condExecutables gpd + , mconcat $ map (go . snd) $ condTestSuites gpd + , mconcat $ map (go . snd) $ condBenchmarks gpd + ] + _ -> mempty + where + go = Set.fromList . map (\(Dependency p _) -> p) . condTreeConstraints + + getPackageVersion :: FilePath -> Maybe (PackageName, Version) + getPackageVersion fp = do + let (package', s1) = break (== '/') fp + package = PackageName package' + s2 <- stripPrefix "/" s1 + let (version', s3) = break (== '/') s2 + version <- simpleParse version' + s4 <- stripPrefix "/" s3 + guard $ s4 == package' ++ ".cabal" + Just (package, version) diff --git a/Stackage/NarrowDatabase.hs b/Stackage/NarrowDatabase.hs new file mode 100644 index 00000000..66d929f0 --- /dev/null +++ b/Stackage/NarrowDatabase.hs @@ -0,0 +1,30 @@ +module Stackage.NarrowDatabase where + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Prelude hiding (pi) +import Stackage.Types + +-- | Narrow down the database to only the specified packages and all of +-- their dependencies. +narrowPackageDB :: PackageDB + -> Set PackageName + -> IO (Map PackageName Version) +narrowPackageDB (PackageDB pdb) = + loop Map.empty . Set.map ((,) True) + where + loop result toProcess = + case Set.minView toProcess of + Nothing -> return result + Just ((isOrig, p), toProcess') -> + case Map.lookup p pdb of + Nothing + | isOrig -> error $ "Unknown package: " ++ show p + | otherwise -> loop result toProcess' + Just pi -> do + let result' = Map.insert p (piVersion pi) result + loop result' $ Set.foldl' (addDep result') toProcess' $ piDeps pi + addDep result toProcess p = + case Map.lookup p result of + Nothing -> Set.insert (False, p) toProcess + Just{} -> toProcess diff --git a/Stackage/PackageList.hs b/Stackage/PackageList.hs new file mode 100644 index 00000000..5e782f03 --- /dev/null +++ b/Stackage/PackageList.hs @@ -0,0 +1,31 @@ +module Stackage.PackageList where + +import Control.Monad (foldM) +import Data.Char (isSpace) +import qualified Data.Map as Map +import Distribution.Text (simpleParse) +import Distribution.Version (anyVersion) +import Stackage.Types + +loadPackageList :: FilePath -> IO (Map PackageName VersionRange) +loadPackageList fp = + readFile fp >>= foldM addLine Map.empty . lines + where + addLine ps l' + | null l = return ps + | otherwise = + case parseVersionRange v' of + Nothing -> error $ "Invalid version range: " ++ show (p, v') + Just v -> return $ Map.insert (PackageName p) v ps + where + l = cleanup l' + (p, v') = break isSpace l + cleanup = dropWhile isSpace . reverse . dropWhile isSpace . reverse . stripComments + + parseVersionRange l + | null $ cleanup l = Just anyVersion + | otherwise = simpleParse l + + stripComments "" = "" + stripComments ('-':'-':_) = "" + stripComments (c:cs) = c : stripComments cs diff --git a/Stackage/Types.hs b/Stackage/Types.hs new file mode 100644 index 00000000..ac2ba5d7 --- /dev/null +++ b/Stackage/Types.hs @@ -0,0 +1,40 @@ +module Stackage.Types + ( module X + , module Stackage.Types + ) where + +import Data.Map as X (Map) +import Data.Map (unionWith) +import Data.Monoid (Monoid (..)) +import Data.Set as X (Set) +import Data.Version as X (Version) +import Distribution.Package as X (PackageIdentifier (..), + PackageName (..)) +import Distribution.Version as X (VersionRange (..)) + +newtype PackageDB = PackageDB (Map PackageName PackageInfo) + deriving (Show, Eq, Ord) + +instance Monoid PackageDB where + mempty = PackageDB mempty + PackageDB x `mappend` PackageDB y = + PackageDB $ unionWith newest x y + where + newest pi1 pi2 + | piVersion pi1 > piVersion pi2 = pi1 + | otherwise = pi2 + +data PackageInfo = PackageInfo + { piVersion :: Version + , piDeps :: Set PackageName + } + deriving (Show, Eq, Ord) + +data HaskellPlatform = HaskellPlatform + { hpcore :: Set PackageIdentifier + , hplibs :: Set PackageIdentifier + } + deriving (Show, Eq, Ord) +instance Monoid HaskellPlatform where + mempty = HaskellPlatform mempty mempty + HaskellPlatform a x `mappend` HaskellPlatform b y = HaskellPlatform (mappend a b) (mappend x y) diff --git a/Stackage/Util.hs b/Stackage/Util.hs new file mode 100644 index 00000000..970b9fc3 --- /dev/null +++ b/Stackage/Util.hs @@ -0,0 +1,12 @@ +module Stackage.Util where + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Distribution.Version (thisVersion) +import Stackage.Types + +identsToRanges :: Set PackageIdentifier -> Map PackageName VersionRange +identsToRanges = + Map.unions . map go . Set.toList + where + go (PackageIdentifier package version) = Map.singleton package $ thisVersion version diff --git a/app/gen-install-line.hs b/app/gen-install-line.hs new file mode 100644 index 00000000..929f12f6 --- /dev/null +++ b/app/gen-install-line.hs @@ -0,0 +1,19 @@ +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Version (showVersion) +import Stackage.HaskellPlatform +import Stackage.LoadDatabase +import Stackage.NarrowDatabase +import Stackage.PackageList +import Stackage.Types +import Stackage.Util + +main :: IO () +main = do + userPackages <- loadPackageList "package-list.txt" + hp <- loadHaskellPlatform + let allPackages = Map.union userPackages $ identsToRanges (hplibs hp) + pdb <- loadPackageDB (Set.map (\(PackageIdentifier p _) -> p) (hpcore hp)) allPackages + final <- narrowPackageDB pdb $ Set.fromList $ Map.keys allPackages + putStr "cabal-dev install -fnetwork23 --enable-tests " + mapM_ (\(PackageName p, v) -> putStr $ p ++ "-" ++ showVersion v ++ " ") $ Map.toList final diff --git a/haskell-platform b/haskell-platform new file mode 160000 index 00000000..73a58050 --- /dev/null +++ b/haskell-platform @@ -0,0 +1 @@ +Subproject commit 73a58050d86cef941fc82a82d52e70c906785b7f diff --git a/package-list.txt b/package-list.txt new file mode 100644 index 00000000..64b0990f --- /dev/null +++ b/package-list.txt @@ -0,0 +1,8 @@ +-- Michael Snoyman michael@snoyman.com +yesod < 1.4 +yesod-newsfeed +yesod-sitemap +yesod-static + +-- Constraints +binary == 0.5.1.0 diff --git a/stackage.cabal b/stackage.cabal new file mode 100644 index 00000000..607e0207 --- /dev/null +++ b/stackage.cabal @@ -0,0 +1,37 @@ +-- Initial stackage.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: stackage +version: 0.1.0.0 +synopsis: "Stable Hackage," tools for creating a vetted set of packages from Hackage. +-- description: +homepage: https://github.com/snoyberg/stackage +license: MIT +license-file: LICENSE +author: Michael Snoyman +maintainer: michael@snoyman.com +category: Distribution +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: Stackage.PackageList + Stackage.NarrowDatabase + Stackage.LoadDatabase + Stackage.HaskellPlatform + Stackage.Util + Stackage.Types + build-depends: base >= 4 && < 5 + , containers + , Cabal + , tar >= 0.4 + , bytestring + , directory + , filepath + +executable stackage-gen-install-line + hs-source-dirs: app + main-is: gen-install-line.hs + build-depends: base + , stackage + , containers