mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-12 15:28:29 +01:00
108 lines
3.9 KiB
Haskell
108 lines
3.9 KiB
Haskell
-- | Create a bundle to be uploaded to Stackage Server.
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
module Stackage.ServerBundle
|
|
( serverBundle
|
|
, epochTime
|
|
, bpAllPackages
|
|
, docsListing
|
|
) where
|
|
|
|
import qualified Codec.Archive.Tar as Tar
|
|
import qualified Codec.Archive.Tar.Entry as Tar
|
|
import qualified Codec.Compression.GZip as GZip
|
|
import qualified Data.Yaml as Y
|
|
import Filesystem (isFile)
|
|
import Foreign.C.Types (CTime (CTime))
|
|
import Stackage.BuildConstraints
|
|
import Stackage.BuildPlan
|
|
import Stackage.Prelude
|
|
import qualified System.PosixCompat.Time as PC
|
|
import qualified Text.XML as X
|
|
import Text.XML.Cursor
|
|
|
|
-- | Get current time
|
|
epochTime :: IO Tar.EpochTime
|
|
epochTime = (\(CTime t) -> fromIntegral t) <$> PC.epochTime
|
|
|
|
-- | All package/versions in a build plan, including core packages.
|
|
--
|
|
-- Note that this may include packages not available on Hackage.
|
|
bpAllPackages :: BuildPlan -> Map PackageName Version
|
|
bpAllPackages BuildPlan {..} =
|
|
siCorePackages bpSystemInfo ++ map ppVersion bpPackages
|
|
|
|
serverBundle :: Tar.EpochTime
|
|
-> Text -- ^ title
|
|
-> Text -- ^ slug
|
|
-> BuildPlan
|
|
-> LByteString
|
|
serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write
|
|
[ fe "build-plan.yaml" (fromStrict $ Y.encode bp)
|
|
, fe "hackage" hackage
|
|
, fe "slug" (fromStrict $ encodeUtf8 slug)
|
|
, fe "desc" (fromStrict $ encodeUtf8 title)
|
|
]
|
|
where
|
|
fe name contents =
|
|
case Tar.toTarPath False name of
|
|
Left s -> error s
|
|
Right name' -> (Tar.fileEntry name' contents)
|
|
{ Tar.entryTime = time
|
|
}
|
|
hackage = builderToLazy $ foldMap goPair $ mapToList packageMap
|
|
|
|
-- need to remove some packages that don't exist on Hackage
|
|
packageMap = foldr deleteMap (bpAllPackages bp) $ map PackageName
|
|
[ "bin-package-db"
|
|
, "ghc"
|
|
, "rts"
|
|
]
|
|
|
|
goPair (name, version) =
|
|
toBuilder (display name) ++
|
|
toBuilder (asText "-") ++
|
|
toBuilder (display version) ++
|
|
toBuilder (asText "\n")
|
|
|
|
docsListing :: BuildPlan
|
|
-> FilePath -- ^ docs directory
|
|
-> IO ByteString
|
|
docsListing bp docsDir =
|
|
fmap (Y.encode . fold) $ mapM go $ mapToList $ bpAllPackages bp
|
|
where
|
|
go :: (PackageName, Version) -> IO (Map Text Y.Value)
|
|
go (package, version) = do -- handleAny (const $ return mempty) $ do
|
|
let dirname = fpFromText (concat
|
|
[ display package
|
|
, "-"
|
|
, display version
|
|
])
|
|
indexFP = (docsDir </> dirname </> "index.html")
|
|
ie <- isFile indexFP
|
|
if ie
|
|
then do
|
|
doc <- flip X.readFile indexFP X.def
|
|
{ X.psDecodeEntities = X.decodeHtmlEntities
|
|
}
|
|
let cursor = fromDocument doc
|
|
getPair x = take 1 $ do
|
|
href <- attribute "href" x
|
|
let name = concat $ x $// content
|
|
guard $ not $ null name
|
|
return (href, name)
|
|
pairs = cursor $// attributeIs "class" "module"
|
|
&/ laxElement "a" >=> getPair
|
|
m <- fmap fold $ forM pairs $ \(href, name) -> do
|
|
let suffix = dirname </> fpFromText href
|
|
e <- isFile $ docsDir </> suffix
|
|
return $ if e
|
|
then asMap $ singletonMap name [fpToText dirname, href]
|
|
else mempty
|
|
return $ singletonMap (display package) $ Y.object
|
|
[ "version" Y..= display version
|
|
, "modules" Y..= m
|
|
]
|
|
else return mempty
|