@@ -1,10 +1,19 @@
11{-# LANGUAGE OverloadedStrings #-}
2+import Control.Monad (filterM, when)
23import qualified Data.ByteString.Char8 as S8
4+import Data.List (isInfixOf, isPrefixOf,
5+ sort)
36import Network.HTTP.Client
47import Network.HTTP.Client.MultipartFormData
8+import System.Directory (doesDirectoryExist,
9+ getDirectoryContents)
510import System.Environment (getArgs, getEnv,
611 getProgName)
712import System.Exit (exitFailure)
13+import System.Exit (ExitCode (ExitSuccess))
14+import System.FilePath (takeDirectory, (</>))
15+import System.Process (createProcess, cwd,
16+ proc, waitForProcess)
817
918main :: IO ()
1019main = withManager defaultManagerSettings $ \m -> do
@@ -22,6 +31,8 @@ main = withManager defaultManagerSettings $ \m -> do
2231 ]
2332 exitFailure
2433
34+ let uploadDocs = "exclusive" `isInfixOf` alias
35+
2536 putStrLn $ concat
2637 [ "Uploading "
2738 , filepath
@@ -41,5 +52,85 @@ main = withManager defaultManagerSettings $ \m -> do
4152 [ ("Authorization", S8.pack token)
4253 , ("Accept", "application/json")
4354 ] ++ requestHeaders req2
55+ , redirectCount = 0
56+ , checkStatus = \_ _ _ -> Nothing
4457 }
45− httpLbs req3 m >>= print
58+ res <- httpLbs req3 m
59+
60+ snapid <-
61+ case lookup "x-stackage-ident" $ responseHeaders res of
62+ Just snapid -> do
63+ putStrLn $ "New ident: " ++ S8.unpack snapid
64+ return snapid
65+ Nothing -> error $ "An error occurred: " ++ show res
66+
67+ when uploadDocs $ do
68+ putStrLn "Generating index file"
69+ let root = takeDirectory filepath </> "haddock"
70+ contents <- getDirectoryContents root
71+ dirs <- filterM (\n -> doesDirectoryExist $ root </> n)
72+ $ filter (not . ("." `isPrefixOf`))
73+ $ sort contents
74+ writeFile (root </> "index.html") $ mkIndex (S8.unpack snapid) dirs
75+ writeFile (root </> "style.css") styleCss
76+
77+ putStrLn "Creating tarball"
78+ (Nothing, Nothing, Nothing, ph) <- createProcess
79+ (proc "tar" $ "czf" : "haddock.tar.xz" : "index.html" : "style.css" : dirs)
80+ { cwd = Just root
81+ }
82+ ec <- waitForProcess ph
83+ if ec == ExitSuccess
84+ then putStrLn "Haddock tarball generated"
85+ else error "Error generating Haddock tarball"
86+
87+ putStrLn "Uploading Haddocks"
88+
89+ req1 <- parseUrl $ "http://www.stackage.org/upload-haddock/"
90+ ++ S8.unpack snapid
91+ let formData =
92+ [ partFileSource "tarball" $ root </> "haddock.tar.xz"
93+ ]
94+ req2 <- formDataBody formData req1
95+ let req3 = req2
96+ { method = "PUT"
97+ , requestHeaders =
98+ [ ("Authorization", S8.pack token)
99+ , ("Accept", "application/json")
100+ ] ++ requestHeaders req2
101+ , redirectCount = 0
102+ , checkStatus = \_ _ _ -> Nothing
103+ }
104+ httpLbs req3 m >>= print
105+
106+mkIndex :: String -> [String] -> String
107+mkIndex snapid dirs = concat
108+ [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
109+ , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"
110+ , "<link rel='stylesheet' href='style.css'>"
111+ , "</head>"
112+ , "<body><div class='container'><h1>Haddock documentation index</h1>"
113+ , "<p><a href=\"http://www.stackage.org/stackage/"
114+ , snapid
115+ , "\">Return to snapshot</a></p><ul>"
116+ , concatMap toLI dirs
117+ , "</ul></div></body></html>"
118+ ]
119+ where
120+ toLI name = concat
121+ [ "<li><a href='"
122+ , name
123+ , "/index.html'>"
124+ , name
125+ , "</a></li>"
126+ ]
127+
128+styleCss :: String
129+styleCss = concat
130+ [ "@media (min-width: 530px) {"
131+ , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
132+ , "}"
133+ , "@media (min-width: 760px) {"
134+ , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
135+ , "}"
136+ ]