git.iko.soy/stackage
on master help sign in
Upload docs map
8651984Michael Snoyman
Stackage2/CompleteBuild.hs+9
compare with master
unifiedsplit
@@ -178,4 +178,13 @@ completeBuild buildType = withManager defaultManagerSettings $ \man -> do
178 putStrLn $ "Distro upload response: " ++ tshow res2
178 putStrLn $ "Distro upload response: " ++ tshow res2
179 _ -> putStrLn "No creds found, skipping Hackage distro upload"
179 _ -> putStrLn "No creds found, skipping Hackage distro upload"
180
180
181+ putStrLn "Uploading doc map"
182+ uploadDocMap UploadDocMap
183+ { udmServer = def
184+ , udmAuthToken = decodeUtf8 token
185+ , udmSnapshot = ident
186+ , udmDocDir = pbDocDir pb
187+ , udmPlan = plan
188+ } man >>= print
189+
181 postBuild
190 postBuild
Stackage2/ServerBundle.hs+44
@@ -6,6 +6,7 @@ module Stackage2.ServerBundle
6 ( serverBundle
6 ( serverBundle
7 , epochTime
7 , epochTime
8 , bpAllPackages
8 , bpAllPackages
9+ , docsListing
9 ) where
10 ) where
10
11
11import qualified Codec.Archive.Tar as Tar
12import qualified Codec.Archive.Tar as Tar
@@ -17,6 +18,9 @@ import Stackage2.BuildConstraints
17import Stackage2.BuildPlan
18import Stackage2.BuildPlan
18import Stackage2.Prelude
19import Stackage2.Prelude
19import qualified System.PosixCompat.Time as PC
20import qualified System.PosixCompat.Time as PC
21+import qualified Text.XML as X
22+import Text.XML.Cursor
23+import Filesystem (isFile)
20
24
21-- | Get current time
25-- | Get current time
22epochTime :: IO Tar.EpochTime
26epochTime :: IO Tar.EpochTime
@@ -61,3 +65,43 @@ serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write
61 toBuilder (asText "-") ++
65 toBuilder (asText "-") ++
62 toBuilder (display version) ++
66 toBuilder (display version) ++
63 toBuilder (asText "\n")
67 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
Stackage2/Upload.hs+32−1
@@ -11,6 +11,8 @@ module Stackage2.Upload
11 , UploadDocs (..)
11 , UploadDocs (..)
12 , uploadDocs
12 , uploadDocs
13 , uploadHackageDistro
13 , uploadHackageDistro
14+ , UploadDocMap (..)
15+ , uploadDocMap
14 ) where
16 ) where
15
17
16import Control.Monad.Writer.Strict (execWriter, tell)
18import Control.Monad.Writer.Strict (execWriter, tell)
@@ -20,7 +22,7 @@ import Network.HTTP.Client
20import Network.HTTP.Client.MultipartFormData
22import Network.HTTP.Client.MultipartFormData
21import Stackage2.BuildPlan (BuildPlan)
23import Stackage2.BuildPlan (BuildPlan)
22import Stackage2.Prelude
24import Stackage2.Prelude
23−import Stackage2.ServerBundle (bpAllPackages)
25+import Stackage2.ServerBundle (bpAllPackages, docsListing)
24import System.IO.Temp (withSystemTempFile)
26import System.IO.Temp (withSystemTempFile)
25
27
26newtype StackageServer = StackageServer { unStackageServer :: Text }
28newtype StackageServer = StackageServer { unStackageServer :: Text }
@@ -169,6 +171,35 @@ uploadHackageDistro bp username password =
169 , method = "PUT"
171 , method = "PUT"
170 }
172 }
171
173
174+data UploadDocMap = UploadDocMap
175+ { udmServer :: StackageServer
176+ , udmAuthToken :: Text
177+ , udmSnapshot :: SnapshotIdent
178+ , udmDocDir :: FilePath
179+ , udmPlan :: BuildPlan
180+ }
181+
182+uploadDocMap UploadDocMap {..} man = do
183+ docmap <- docsListing udmPlan udmDocDir
184+ req1 <- parseUrl $ unpack $ unStackageServer udmServer ++ "/upload-doc-map"
185+ req2 <- formDataBody (formData docmap) req1
186+ let req3 = req2
187+ { method = "PUT"
188+ , requestHeaders =
189+ [ ("Authorization", encodeUtf8 udmAuthToken)
190+ , ("Accept", "application/json")
191+ ] ++ requestHeaders req2
192+ , redirectCount = 0
193+ , checkStatus = \_ _ _ -> Nothing
194+ , responseTimeout = Just 300000000
195+ }
196+ httpLbs req3 man
197+ where
198+ formData docmap =
199+ [ partBS "snapshot" (encodeUtf8 $ unSnapshotIdent udmSnapshot)
200+ , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap
201+ ]
202+
172mkIndex :: String -> [String] -> String
203mkIndex :: String -> [String] -> String
173mkIndex snapid dirs = concat
204mkIndex snapid dirs = concat
174 [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
205 [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
stackage.cabal+1
@@ -75,6 +75,7 @@ library
75 , async
75 , async
76 , streaming-commons >= 0.1.7.1
76 , streaming-commons >= 0.1.7.1
77 , semigroups
77 , semigroups
78+ , xml-conduit
78
79
79executable stackage
80executable stackage
80 default-language: Haskell2010
81 default-language: Haskell2010