haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-30 21:00:24 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Better dependency grabbing

Browse Source
This commit is contained in:
Michael Snoyman 2014-10-28 15:44:51 +02:00
parent 6ba9b3d36b
commit e1dcab25e7
1 changed files with 18 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
Data/Hackage.hs
View File

@ -34,6 +34,7 @@ import Crypto.Hash (Digest, SHA256)
import Data.Byteable (toBytes) import Data.Byteable (toBytes)
import Distribution.Text (display) import Distribution.Text (display)
import Text.Markdown (Markdown (Markdown)) import Text.Markdown (Markdown (Markdown))
import Data.Foldable (foldMap)
sinkUploadHistory :: Monad m => Consumer (Entity Uploaded) m UploadHistory sinkUploadHistory :: Monad m => Consumer (Entity Uploaded) m UploadHistory
sinkUploadHistory = sinkUploadHistory =
@ -181,7 +182,7 @@ setMetadata name version hash' gpdRes = do
if toUpdate if toUpdate
then case gpdRes of then case gpdRes of
ParseOk _ gpd -> do ParseOk _ gpd -> do
!md <- getMetadata name version hash' $ PD.packageDescription gpd !md <- getMetadata name version hash' gpd
put $! UploadState us1 us2 put $! UploadState us1 us2
(insertMap name (version, hash') mdMap) (insertMap name (version, hash') mdMap)
(insertMap name md mdChanges) (insertMap name md mdChanges)
@ -201,16 +202,22 @@ getMetadata :: ( MonadActive m
=> PackageName => PackageName
-> Version -> Version
-> ByteString -> ByteString
-> PD.PackageDescription -> PD.GenericPackageDescription
-> m Metadata -> m Metadata
getMetadata name version hash' pd = do getMetadata name version hash' gpd = do
let pd = PD.packageDescription gpd
(mreadme, mchangelog, mlicenseContent) <- (mreadme, mchangelog, mlicenseContent) <-
grabExtraFiles name version $ PD.licenseFiles pd grabExtraFiles name version $ PD.licenseFiles pd
return Metadata return Metadata
{ metadataName = name { metadataName = name
, metadataVersion = version , metadataVersion = version
, metadataHash = hash' , metadataHash = hash'
, metadataDeps = [pack n | PD.Dependency (PD.PackageName n) _ <- PD.buildDepends pd] , metadataDeps = setToList
$ asSet
$ concat
[ foldMap goTree $ PD.condLibrary gpd
, foldMap (goTree . snd) $ PD.condExecutables gpd
]
, metadataAuthor = pack $ PD.author pd , metadataAuthor = pack $ PD.author pd
, metadataMaintainer = pack $ PD.maintainer pd , metadataMaintainer = pack $ PD.maintainer pd
, metadataLicenseName = pack $ display $ PD.license pd , metadataLicenseName = pack $ display $ PD.license pd
@ -227,6 +234,10 @@ getMetadata name version hash' pd = do
, metadataChangelog = mchangelog , metadataChangelog = mchangelog
, metadataLicenseContent = mlicenseContent , metadataLicenseContent = mlicenseContent
} }
where
goTree (PD.CondNode _ deps comps) = concatMap goDep deps ++ concatMap goComp comps
goDep (PD.Dependency (PD.PackageName n) _) = singletonSet $ pack n
goComp (_, tree, mtree) = goTree tree ++ maybe mempty goTree mtree
showSourceRepo :: PD.SourceRepo -> Maybe Text showSourceRepo :: PD.SourceRepo -> Maybe Text
showSourceRepo = fmap pack . PD.repoLocation showSourceRepo = fmap pack . PD.repoLocation
@ -256,15 +267,15 @@ grabExtraFiles name version lfiles = runResourceT $ do
go trip@(mreadme, mchangelog, mlicense) entry = go trip@(mreadme, mchangelog, mlicense) entry =
case Tar.entryContent entry of case Tar.entryContent entry of
Tar.NormalFile lbs _ -> Tar.NormalFile lbs _ ->
let name = drop 1 $ dropWhile (/= '/') $ Tar.entryPath entry in let name' = drop 1 $ dropWhile (/= '/') $ Tar.entryPath entry in
case toLower name of case toLower name' of
"readme.md" -> (md lbs, mchangelog, mlicense) "readme.md" -> (md lbs, mchangelog, mlicense)
"readme" -> (txt lbs, mchangelog, mlicense) "readme" -> (txt lbs, mchangelog, mlicense)
"readme.txt" -> (txt lbs, mchangelog, mlicense) "readme.txt" -> (txt lbs, mchangelog, mlicense)
"changelog.md" -> (mreadme, md lbs, mlicense) "changelog.md" -> (mreadme, md lbs, mlicense)
"changelog" -> (mreadme, txt lbs, mlicense) "changelog" -> (mreadme, txt lbs, mlicense)
"changelog.txt" -> (mreadme, txt lbs, mlicense) "changelog.txt" -> (mreadme, txt lbs, mlicense)
_ | name `elem` lfiles -> (mreadme, mchangelog, txt lbs) _ | name' `elem` lfiles -> (mreadme, mchangelog, txt lbs)
_ -> trip _ -> trip
_ -> trip _ -> trip