Better create-snapshot

Stackage/ServerFiles.hs

@@ -35,9 +35,9 @@ createHackageFile isInc hp ii ghcVer date hackageH tarballH = do
             , ".stackage"
             ]
     hPutStr tarballH $ concat
-        [ "#!/bin/bash -ex\n\ncp ../build* .\ntar czfv "
+        [ "#!/bin/bash -ex\n\ntar czfv "
         , stackageFP
-        , " hackage desc"
+        , " hackage desc ../build*"
         ]
     indextargz <- getTarballName
     indexLBS <- L.readFile indextargz

stackage-upload.hs

@@ -1,10 +1,19 @@
 {-# LANGUAGE OverloadedStrings #-}
+import           Control.Monad                         (filterM, when)
 import qualified Data.ByteString.Char8                 as S8
+import           Data.List                             (isInfixOf, isPrefixOf,
+                                                        sort)
 import           Network.HTTP.Client
 import           Network.HTTP.Client.MultipartFormData
+import           System.Directory                      (doesDirectoryExist,
+                                                        getDirectoryContents)
 import           System.Environment                    (getArgs, getEnv,
                                                         getProgName)
 import           System.Exit                           (exitFailure)
+import           System.Exit                           (ExitCode (ExitSuccess))
+import           System.FilePath                       (takeDirectory, (</>))
+import           System.Process                        (createProcess, cwd,
+                                                        proc, waitForProcess)
 
 main :: IO ()
 main = withManager defaultManagerSettings $ \m -> do
@@ -22,6 +31,8 @@ main = withManager defaultManagerSettings $ \m -> do
                     ]
                 exitFailure
 
+    let uploadDocs = "exclusive" `isInfixOf` alias
+
     putStrLn $ concat
         [ "Uploading "
         , filepath
@@ -41,5 +52,85 @@ main = withManager defaultManagerSettings $ \m -> do
                 [ ("Authorization", S8.pack token)
                 , ("Accept", "application/json")
                 ] ++ requestHeaders req2
+            , redirectCount = 0
+            , checkStatus = \_ _ _ -> Nothing
             }
-    httpLbs req3 m >>= print
+    res <- httpLbs req3 m
+
+    snapid <-
+        case lookup "x-stackage-ident" $ responseHeaders res of
+            Just snapid -> do
+                putStrLn $ "New ident: " ++ S8.unpack snapid
+                return snapid
+            Nothing -> error $ "An error occurred: " ++ show res
+
+    when uploadDocs $ do
+        putStrLn "Generating index file"
+        let root = takeDirectory filepath </> "haddock"
+        contents <- getDirectoryContents root
+        dirs <- filterM (\n -> doesDirectoryExist $ root </> n)
+              $ filter (not . ("." `isPrefixOf`))
+              $ sort contents
+        writeFile (root </> "index.html") $ mkIndex (S8.unpack snapid) dirs
+        writeFile (root </> "style.css") styleCss
+
+        putStrLn "Creating tarball"
+        (Nothing, Nothing, Nothing, ph) <- createProcess
+            (proc "tar" $ "czf" : "haddock.tar.xz" : "index.html" : "style.css" : dirs)
+                { cwd = Just root
+                }
+        ec <- waitForProcess ph
+        if ec == ExitSuccess
+            then putStrLn "Haddock tarball generated"
+            else error "Error generating Haddock tarball"
+
+        putStrLn "Uploading Haddocks"
+
+        req1 <- parseUrl $ "http://www.stackage.org/upload-haddock/"
+                        ++ S8.unpack snapid
+        let formData =
+                [ partFileSource "tarball" $ root </> "haddock.tar.xz"
+                ]
+        req2 <- formDataBody formData req1
+        let req3 = req2
+                { method = "PUT"
+                , requestHeaders =
+                    [ ("Authorization", S8.pack token)
+                    , ("Accept", "application/json")
+                    ] ++ requestHeaders req2
+                , redirectCount = 0
+                , checkStatus = \_ _ _ -> Nothing
+                }
+        httpLbs req3 m >>= print
+
+mkIndex :: String -> [String] -> String
+mkIndex snapid dirs = concat
+    [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
+    , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"
+    , "<link rel='stylesheet' href='style.css'>"
+    , "</head>"
+    , "<body><div class='container'><h1>Haddock documentation index</h1>"
+    , "<p><a href=\"http://www.stackage.org/stackage/"
+    , snapid
+    , "\">Return to snapshot</a></p><ul>"
+    , concatMap toLI dirs
+    , "</ul></div></body></html>"
+    ]
+  where
+    toLI name = concat
+        [ "<li><a href='"
+        , name
+        , "/index.html'>"
+        , name
+        , "</a></li>"
+        ]
+
+styleCss :: String
+styleCss = concat
+    [ "@media (min-width: 530px) {"
+    , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
+    , "}"
+    , "@media (min-width: 760px) {"
+    , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
+    , "}"
+    ]