git.iko.soy/stackage
on 9f6ede2 help sign in
stackage/Stackage2/ServerBundle.hs
107 lines 3.9 kB history raw
1-- | Create a bundle to be uploaded to Stackage Server.
2{-# LANGUAGE NoImplicitPrelude #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RecordWildCards #-}
5module Stackage2.ServerBundle
6 ( serverBundle
7 , epochTime
8 , bpAllPackages
9 , docsListing
10 ) where
12import qualified Codec.Archive.Tar as Tar
13import qualified Codec.Archive.Tar.Entry as Tar
14import qualified Codec.Compression.GZip as GZip
15import qualified Data.Yaml as Y
16import Foreign.C.Types (CTime (CTime))
17import Stackage2.BuildConstraints
18import Stackage2.BuildPlan
19import Stackage2.Prelude
20import qualified System.PosixCompat.Time as PC
21import qualified Text.XML as X
22import Text.XML.Cursor
23import Filesystem (isFile)
25-- | Get current time
26epochTime :: IO Tar.EpochTime
27epochTime = (\(CTime t) -> t) <$> PC.epochTime
29-- | All package/versions in a build plan, including core packages.
30--
31-- Note that this may include packages not available on Hackage.
32bpAllPackages :: BuildPlan -> Map PackageName Version
33bpAllPackages BuildPlan {..} =
34 siCorePackages bpSystemInfo ++ map ppVersion bpPackages
36serverBundle :: Tar.EpochTime
37 -> Text -- ^ title
38 -> Text -- ^ slug
39 -> BuildPlan
40 -> LByteString
41serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write
42 [ fe "build-plan.yaml" (fromStrict $ Y.encode bp)
43 , fe "hackage" hackage
44 , fe "slug" (fromStrict $ encodeUtf8 slug)
45 , fe "desc" (fromStrict $ encodeUtf8 title)
46 ]
47 where
48 fe name contents =
49 case Tar.toTarPath False name of
50 Left s -> error s
51 Right name' -> (Tar.fileEntry name' contents)
52 { Tar.entryTime = time
53 }
54 hackage = builderToLazy $ foldMap goPair $ mapToList packageMap
56 -- need to remove some packages that don't exist on Hackage
57 packageMap = foldr deleteMap (bpAllPackages bp) $ map PackageName
58 [ "bin-package-db"
59 , "ghc"
60 , "rts"
61 ]
63 goPair (name, version) =
64 toBuilder (display name) ++
65 toBuilder (asText "-") ++
66 toBuilder (display version) ++
67 toBuilder (asText "\n")
69docsListing :: BuildPlan
70 -> FilePath -- ^ docs directory
71 -> IO ByteString
72docsListing bp docsDir =
73 fmap (Y.encode . fold) $ mapM go $ mapToList $ bpAllPackages bp
74 where
75 go :: (PackageName, Version) -> IO (Map Text Y.Value)
76 go (package, version) = do -- handleAny (const $ return mempty) $ do
77 let dirname = fpFromText (concat
78 [ display package
79 , "-"
80 , display version
81 ])
82 indexFP = (docsDir </> dirname </> "index.html")
83 ie <- isFile indexFP
84 if ie
85 then do
86 doc <- flip X.readFile indexFP X.def
87 { X.psDecodeEntities = X.decodeHtmlEntities
88 }
89 let cursor = fromDocument doc
90 getPair x = take 1 $ do
91 href <- attribute "href" x
92 let name = concat $ x $// content
93 guard $ not $ null name
94 return (href, name)
95 pairs = cursor $// attributeIs "class" "module"
96 &/ laxElement "a" >=> getPair
97 m <- fmap fold $ forM pairs $ \(href, name) -> do
98 let suffix = dirname </> fpFromText href
99 e <- isFile $ docsDir </> suffix
100 return $ if e
101 then asMap $ singletonMap name [fpToText dirname, href]
102 else mempty
103 return $ singletonMap (display package) $ Y.object
104 [ "version" Y..= display version
105 , "modules" Y..= m
106 ]
107 else return mempty