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