From 8651984bf3d59ee38c42705f1d35bb0c5fe706ef Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Sat, 13 Dec 2014 20:42:49 +0200
Subject: [PATCH] Upload docs map

---
 Stackage2/CompleteBuild.hs |  9 ++++++++
 Stackage2/ServerBundle.hs  | 44 ++++++++++++++++++++++++++++++++++++++
 Stackage2/Upload.hs        | 33 +++++++++++++++++++++++++++-
 stackage.cabal             |  1 +
 4 files changed, 86 insertions(+), 1 deletion(-)

diff --git a/Stackage2/CompleteBuild.hs b/Stackage2/CompleteBuild.hs
index 8a5908ca..ec13527c 100644
--- a/Stackage2/CompleteBuild.hs
+++ b/Stackage2/CompleteBuild.hs
@@ -178,4 +178,13 @@ completeBuild buildType = withManager defaultManagerSettings $ \man -> do
             putStrLn $ "Distro upload response: " ++ tshow res2
         _ -> putStrLn "No creds found, skipping Hackage distro upload"
 
+    putStrLn "Uploading doc map"
+    uploadDocMap UploadDocMap
+        { udmServer = def
+        , udmAuthToken = decodeUtf8 token
+        , udmSnapshot = ident
+        , udmDocDir = pbDocDir pb
+        , udmPlan = plan
+        } man >>= print
+
     postBuild
diff --git a/Stackage2/ServerBundle.hs b/Stackage2/ServerBundle.hs
index ea8bdac7..c572f299 100644
--- a/Stackage2/ServerBundle.hs
+++ b/Stackage2/ServerBundle.hs
@@ -6,6 +6,7 @@ module Stackage2.ServerBundle
     ( serverBundle
     , epochTime
     , bpAllPackages
+    , docsListing
     ) where
 
 import qualified Codec.Archive.Tar          as Tar
@@ -17,6 +18,9 @@ import           Stackage2.BuildConstraints
 import           Stackage2.BuildPlan
 import           Stackage2.Prelude
 import qualified System.PosixCompat.Time    as PC
+import qualified Text.XML as X
+import Text.XML.Cursor
+import Filesystem (isFile)
 
 -- | Get current time
 epochTime :: IO Tar.EpochTime
@@ -61,3 +65,43 @@ serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write
         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
diff --git a/Stackage2/Upload.hs b/Stackage2/Upload.hs
index 07686578..39eee631 100644
--- a/Stackage2/Upload.hs
+++ b/Stackage2/Upload.hs
@@ -11,6 +11,8 @@ module Stackage2.Upload
     , UploadDocs (..)
     , uploadDocs
     , uploadHackageDistro
+    , UploadDocMap (..)
+    , uploadDocMap
     ) where
 
 import Control.Monad.Writer.Strict           (execWriter, tell)
@@ -20,7 +22,7 @@ import Network.HTTP.Client
 import Network.HTTP.Client.MultipartFormData
 import Stackage2.BuildPlan                   (BuildPlan)
 import Stackage2.Prelude
-import Stackage2.ServerBundle                (bpAllPackages)
+import Stackage2.ServerBundle                (bpAllPackages, docsListing)
 import System.IO.Temp                        (withSystemTempFile)
 
 newtype StackageServer = StackageServer { unStackageServer :: Text }
@@ -169,6 +171,35 @@ uploadHackageDistro bp username password =
         , method = "PUT"
         }
 
+data UploadDocMap = UploadDocMap
+    { udmServer :: StackageServer
+    , udmAuthToken :: Text
+    , udmSnapshot :: SnapshotIdent
+    , udmDocDir :: FilePath
+    , udmPlan :: BuildPlan
+    }
+
+uploadDocMap UploadDocMap {..} man = do
+    docmap <- docsListing udmPlan udmDocDir
+    req1 <- parseUrl $ unpack $ unStackageServer udmServer ++ "/upload-doc-map"
+    req2 <- formDataBody (formData docmap) req1
+    let req3 = req2
+            { method = "PUT"
+            , requestHeaders =
+                [ ("Authorization", encodeUtf8 udmAuthToken)
+                , ("Accept", "application/json")
+                ] ++ requestHeaders req2
+            , redirectCount = 0
+            , checkStatus = \_ _ _ -> Nothing
+            , responseTimeout = Just 300000000
+            }
+    httpLbs req3 man
+  where
+    formData docmap =
+        [ partBS "snapshot" (encodeUtf8 $ unSnapshotIdent udmSnapshot)
+        , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap
+        ]
+
 mkIndex :: String -> [String] -> String
 mkIndex snapid dirs = concat
     [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
diff --git a/stackage.cabal b/stackage.cabal
index 68b1892d..a597a3cd 100644
--- a/stackage.cabal
+++ b/stackage.cabal
@@ -75,6 +75,7 @@ library
                      , async
                      , streaming-commons >= 0.1.7.1
                      , semigroups
+                     , xml-conduit
 
 executable stackage
   default-language:    Haskell2010