@@ -6,6 +6,7 @@ module Stackage2.ServerBundle
66 ( serverBundle
77 , epochTime
88 , bpAllPackages
9+ , docsListing
910 ) where
1011
1112import qualified Codec.Archive.Tar as Tar
@@ -17,6 +18,9 @@ import Stackage2.BuildConstraints
1718import Stackage2.BuildPlan
1819import Stackage2.Prelude
1920import qualified System.PosixCompat.Time as PC
21+import qualified Text.XML as X
22+import Text.XML.Cursor
23+import Filesystem (isFile)
2024
2125-- | Get current time
2226epochTime :: IO Tar.EpochTime
@@ -61,3 +65,43 @@ serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write
6165 toBuilder (asText "-") ++
6266 toBuilder (display version) ++
6367 toBuilder (asText "\n")
68+
69+docsListing :: BuildPlan
70+ -> FilePath -- ^ docs directory
71+ -> IO ByteString
72+docsListing 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