stackage-metadata-0.1.0.0: app/all-cabal-metadata-tool.hs
{-# 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'