diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +## 0.1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +The MIT License (MIT) + +Copyright (c) 2015 commercialhaskell + +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 new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# stackage-metadata + +[![Build Status](https://travis-ci.org/commercialhaskell/all-cabal-metadata-tool.svg?branch=master)](https://travis-ci.org/commercialhaskell/all-cabal-metadata-tool) + +Tool for extracting metadata on all packages. Mostly used for +[all-cabal-metadata](https://github.com/commercialhaskell/all-cabal-metadata) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Stackage/Metadata.hs b/Stackage/Metadata.hs new file mode 100644 --- /dev/null +++ b/Stackage/Metadata.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +module Stackage.Metadata + ( PackageInfo (..) + , Deprecation (..) + ) where + +import Control.Applicative ((<$>), (<*>)) +import Data.Aeson (FromJSON (..), ToJSON (..), + object, withObject, (.:), (.=)) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import Data.Typeable (Typeable) +import Data.Version (Version) +import Distribution.Package (PackageName) +import Distribution.Version (VersionRange) +import Prelude hiding (pi) +import Stackage.PackageIndex.Conduit (parseDistText, renderDistText) + +data PackageInfo = PackageInfo + { piLatest :: !Version + , piHash :: !Text + , piAllVersions :: !(Set Version) + , piSynopsis :: !Text + , piDescription :: !Text + , piDescriptionType :: !Text + , piChangeLog :: !Text + , piChangeLogType :: !Text + , piBasicDeps :: !(Map PackageName VersionRange) + , piTestBenchDeps :: !(Map PackageName VersionRange) + } + deriving (Show, Eq, Typeable) +instance ToJSON PackageInfo where + toJSON pi = object + [ "latest" .= renderDistText (piLatest pi) + , "hash" .= piHash pi + , "all-versions" .= map renderDistText (Set.toList $ piAllVersions pi) + , "synopsis" .= piSynopsis pi + , "description" .= piDescription pi + , "description-type" .= piDescriptionType pi + , "changelog" .= piChangeLog pi + , "changelog-type" .= piChangeLogType pi + , "basic-deps" .= showM (piBasicDeps pi) + , "test-bench-deps" .= showM (piTestBenchDeps pi) + ] + where + showM = Map.mapKeysWith const renderDistText . Map.map renderDistText +instance FromJSON PackageInfo where + parseJSON = withObject "PackageInfo" $ \o -> PackageInfo + <$> (o .: "latest" >>= parseDistText) + <*> o .: "hash" + <*> (o .: "all-versions" >>= fmap Set.fromList . mapM parseDistText) + <*> o .: "synopsis" + <*> o .: "description" + <*> o .: "description-type" + <*> o .: "changelog" + <*> o .: "changelog-type" + <*> (o .: "basic-deps" >>= parseM) + <*> (o .: "test-bench-deps" >>= parseM) + where + parseM = fmap Map.fromList . mapM go . Map.toList + go (name, range) = do + name' <- parseDistText name + range' <- parseDistText range + return (name', range') + +data Deprecation = Deprecation + { depPackage :: !Text + , depInFavourOf :: !(Set Text) + } +instance ToJSON Deprecation where + toJSON d = object + [ "deprecated-package" .= depPackage d + , "in-favour-of" .= depInFavourOf d + ] +instance FromJSON Deprecation where + parseJSON = withObject "Deprecation" $ \o -> Deprecation + <$> o .: "deprecated-package" + <*> o .: "in-favour-of" diff --git a/Stackage/PackageIndex/Conduit.hs b/Stackage/PackageIndex/Conduit.hs new file mode 100644 --- /dev/null +++ b/Stackage/PackageIndex/Conduit.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE RankNTypes #-} +module Stackage.PackageIndex.Conduit + ( sourceTarFile + , sourceAllCabalFiles + , parseDistText + , renderDistText + , CabalFileEntry (..) + ) where + +import qualified Codec.Archive.Tar as Tar +import Codec.Compression.GZip (decompress) +import Control.Monad (guard) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (MonadResource, throwM) +import qualified Data.ByteString.Lazy as L +import Data.Conduit (Producer, bracketP, + yield, (=$=)) +import qualified Data.Conduit.List as CL +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.Lazy as TL +import Data.Text.Lazy.Encoding (decodeUtf8With) +import Data.Version (Version) +import Distribution.Compat.ReadP (readP_to_S) +import Distribution.Package (PackageName) +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription.Parse (ParseResult, + parsePackageDescription) +import Distribution.Text (disp, parse) +import qualified Distribution.Text +import System.IO (IOMode (ReadMode), + hClose, openBinaryFile) +import Text.PrettyPrint (render) + +sourceTarFile :: MonadResource m + => Bool -- ^ ungzip? + -> FilePath + -> Producer m Tar.Entry +sourceTarFile toUngzip fp = do + bracketP (openBinaryFile fp ReadMode) hClose $ \h -> do + lbs <- liftIO $ L.hGetContents h + loop $ Tar.read $ ungzip' lbs + where + ungzip' + | toUngzip = decompress + | otherwise = id + loop Tar.Done = return () + loop (Tar.Fail e) = throwM e + loop (Tar.Next e es) = yield e >> loop es + +data CabalFileEntry = CabalFileEntry + { cfeName :: !PackageName + , cfeVersion :: !Version + , cfeRaw :: L.ByteString + , cfeParsed :: ParseResult GenericPackageDescription + } + +sourceAllCabalFiles + :: MonadResource m + => IO FilePath + -> Producer m CabalFileEntry +sourceAllCabalFiles getIndexTar = do + tarball <- liftIO $ getIndexTar + sourceTarFile False tarball =$= CL.mapMaybe go + where + go e = + case (toPkgVer $ Tar.entryPath e, Tar.entryContent e) of + (Just (name, version), Tar.NormalFile lbs _) -> Just CabalFileEntry + { cfeName = name + , cfeVersion = version + , cfeRaw = lbs + , cfeParsed = parsePackageDescription $ TL.unpack $ decodeUtf8With lenientDecode lbs + } + _ -> Nothing + + toPkgVer s0 = do + (name', '/':s1) <- Just $ break (== '/') s0 + (version', '/':s2) <- Just $ break (== '/') s1 + guard $ s2 == (name' ++ ".cabal") + name <- parseDistText name' + version <- parseDistText version' + Just (name, version) + +parseDistText :: (Monad m, Distribution.Text.Text t) => String -> m t +parseDistText s = + case map fst $ filter (null . snd) $ readP_to_S parse s of + [x] -> return x + _ -> fail $ "Could not parse: " ++ s + +renderDistText :: Distribution.Text.Text t => t -> String +renderDistText = render . disp diff --git a/app/all-cabal-metadata-tool.hs b/app/all-cabal-metadata-tool.hs new file mode 100644 --- /dev/null +++ b/app/all-cabal-metadata-tool.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +import qualified Codec.Archive.Tar as Tar +import Control.Exception (assert) +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (MonadResource, + runResourceT, throwM) +import Crypto.Hash.SHA256 (hashlazy) +import qualified Data.ByteString as S +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Lazy as L +import Data.Conduit (($$), (=$)) +import qualified Data.Conduit.List as CL +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text, pack, toLower, + unpack) +import Data.Text.Encoding (decodeUtf8With) +import qualified Data.Text.Encoding as TE +import Data.Text.Encoding.Error (lenientDecode) +import Data.Version (Version) +import Data.Yaml (decodeEither', + decodeFileEither, + encodeFile) +import Distribution.Package (Dependency (..), + PackageIdentifier (..), + PackageName) +import Distribution.PackageDescription (CondTree (..), + Condition (..), + ConfVar (..), + condBenchmarks, + condExecutables, + condLibrary, + condTestSuites, + description, package, + packageDescription, + synopsis) +import Distribution.PackageDescription.Parse (ParseResult (..)) +import Distribution.Version (VersionRange, + intersectVersionRanges, + simplifyVersionRange) +import Network.HTTP.Client (Manager, brConsume, + newManager, + responseBody, + withResponse) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Prelude hiding (pi) +import Stackage.Install +import Stackage.Metadata +import Stackage.PackageIndex.Conduit +import Stackage.Update +import System.Directory (createDirectoryIfMissing) +import System.FilePath (splitExtension, + takeDirectory, + takeFileName, (<.>), + ()) + +data Pair x y = Pair !x !y + +main :: IO () +main = do + stackageUpdate $ setVerify False defaultStackageUpdateSettings + + man <- newManager tlsManagerSettings + packageLocation <- defaultPackageLocation + indexLocation <- defaultIndexLocation + let set = setGetManager (return man) + $ setPackageLocation (return packageLocation) + $ setIndexLocation (return indexLocation) + defaultSettings + + newest <- runResourceT $ sourceAllCabalFiles (return indexLocation) + $$ flip CL.fold Map.empty + (\m cfe -> + let name = cfeName cfe + version = cfeVersion cfe + in flip (Map.insert name) m $ case Map.lookup (cfeName cfe) m of + Nothing -> Pair version (Set.singleton version) + Just (Pair version' s) -> Pair (max version version') (Set.insert version s)) + + let onlyNewest cfe = + case Map.lookup (cfeName cfe) newest of + Nothing -> assert False Nothing + Just (Pair latest allVersions) + | cfeVersion cfe == latest -> Just (cfe, allVersions) + | otherwise -> Nothing + + runResourceT + $ sourceAllCabalFiles (return indexLocation) + $$ CL.mapMaybe onlyNewest + =$ (do + CL.mapMaybeM (updatePackage set packageLocation) + liftIO $ saveDeprecated man + ) + =$ CL.isolate 500 + =$ CL.sinkNull + +saveDeprecated :: Manager -> IO () +saveDeprecated man = do + bss <- withResponse "https://hackage.haskell.org/packages/deprecated.json" man + $ \res -> brConsume $ responseBody res + deps <- either throwM return $ decodeEither' $ S.concat bss + encodeFile "deprecated.yaml" (deps :: [Deprecation]) + +updatePackage :: MonadResource m + => Settings + -> (String -> String -> FilePath) + -> (CabalFileEntry, Set Version) + -> m (Maybe ()) +updatePackage set packageLocation (cfe, allVersions) = do + epi <- liftIO $ decodeFileEither fp + case epi of + Right pi + | version == piLatest pi + && thehash == piHash pi + -> return Nothing + _ -> do + liftIO $ putStrLn $ concat + [ "Loading " + , renderDistText name + , "-" + , renderDistText version + ] + gpd <- + case mgpd of + ParseFailed pe -> error $ show (name, version, pe) + ParseOk _ gpd -> return gpd + + let pd = packageDescription gpd + when (package pd /= PackageIdentifier name version) $ + error $ show ("mismatch" :: String, name, version, package pd) + + let name'' = renderDistText name + version' = renderDistText version + liftIO $ download set [(name'', version')] + let tarball = packageLocation name'' version' + + (desc, desct, cl, clt) <- + sourceTarFile True tarball $$ CL.fold goEntry + (pack $ description pd, "haddock", "", "") + + liftIO $ do + createDirectoryIfMissing True $ takeDirectory fp + let checkCond = const True -- FIXME do something intelligent + getDeps' = getDeps checkCond + encodeFile fp PackageInfo + { piLatest = version + , piHash = thehash + , piAllVersions = allVersions + , piSynopsis = pack $ synopsis pd + , piDescription = desc + , piDescriptionType = desct + , piChangeLog = cl + , piChangeLogType = clt + , piBasicDeps = combineDeps + $ maybe id ((:) . getDeps') (condLibrary gpd) + $ map (getDeps' . snd) (condExecutables gpd) + , piTestBenchDeps = combineDeps + $ map (getDeps' . snd) (condTestSuites gpd) + ++ map (getDeps' . snd) (condBenchmarks gpd) + } + return $ Just () + where + name = cfeName cfe + version = cfeVersion cfe + lbs = cfeRaw cfe + mgpd = cfeParsed cfe + + fp = "packages" (unpack $ toLower $ pack $ take 2 $ name' ++ "XX") name' <.> "yaml" + name' = renderDistText name + + thehash = TE.decodeUtf8 $ B16.encode $ hashlazy lbs + + goEntry :: (Text, Text, Text, Text) -> Tar.Entry -> (Text, Text, Text, Text) + goEntry orig@(desc, desct, cl, clt) e = + case (toEntryType $ Tar.entryPath e, toText $ Tar.entryContent e) of + (ChangeLog clt', Just cl') -> (desc, desct, cl', clt') + (Desc desct', Just desc') -> (desc', desct', cl, clt) + _ -> orig + + toText (Tar.NormalFile lbs' _) = Just $ decodeUtf8With lenientDecode $ L.toStrict lbs' + toText _ = Nothing + +data EntryType = Ignored | ChangeLog Text | Desc Text + deriving Show + +toEntryType :: FilePath -> EntryType +toEntryType fp + -- Only take things in the root directory of the tarball + | length (filter (== '/') fp) /= 1 = Ignored + + | name == "changelog" = ChangeLog t + | name == "changes" = ChangeLog t + | name == "readme" = Desc t + | otherwise = Ignored + where + (name', ext) = splitExtension fp + name = unpack $ toLower $ pack $ takeFileName name' + t = + case ext of + ".md" -> "markdown" + ".markdown" -> "markdown" + _ -> "text" + +-- | FIXME this function should get cleaned up and merged into stackage-common +getDeps :: (Condition ConfVar -> Bool) + -> CondTree ConfVar [Dependency] a + -> Map PackageName VersionRange +getDeps checkCond = + goTree + where + goTree (CondNode _data deps comps) = combineDeps + $ map (\(Dependency name range) -> Map.singleton name range) deps + ++ map goComp comps + + goComp (cond, yes, no) + | checkCond cond = goTree yes + | otherwise = maybe Map.empty goTree no + +combineDeps :: [Map PackageName VersionRange] -> Map PackageName VersionRange +combineDeps = + Map.unionsWith (\x y -> normalize . simplifyVersionRange $ intersectVersionRanges x y) + where + normalize vr = + case parseDistText $ renderDistText vr of + Nothing -> vr + Just vr' -> vr' diff --git a/stackage-metadata.cabal b/stackage-metadata.cabal new file mode 100644 --- /dev/null +++ b/stackage-metadata.cabal @@ -0,0 +1,60 @@ +name: stackage-metadata +version: 0.1.0.0 +synopsis: Grab current metadata for all packages +description: See README.md +homepage: https://github.com/commercialhaskell/all-cabal-metadata-tool +license: MIT +license-file: LICENSE +author: Michael Snoyman +maintainer: michael@snoyman.com +category: Distribution +build-type: Simple +extra-source-files: README.md ChangeLog.md +cabal-version: >=1.10 + +library + exposed-modules: Stackage.Metadata + Stackage.PackageIndex.Conduit + build-depends: base >=4.7 && < 5 + , text + , containers + , aeson >= 0.8 + , conduit >= 1.2 && < 1.3 + , resourcet >= 1.1 + , tar >=0.4 + , bytestring >= 0.10 + , Cabal + , pretty + , filepath + , directory + , transformers + , zlib + default-language: Haskell2010 + +executable all-cabal-metadata-tool + main-is: all-cabal-metadata-tool.hs + hs-source-dirs: app + build-depends: base + , stackage-metadata + , filepath + , directory + , stackage-install >= 0.1.1 + , http-client + , http-client-tls + , Cabal + , yaml + , text + , containers + , conduit + , bytestring + , base16-bytestring + , cryptohash + , transformers + , resourcet + , tar + , stackage-update >= 0.1.2 + default-language: Haskell2010 + +source-repository head + type: git + location: git://github.com/commercialhaskell/all-cabal-metadata-tool