git.iko.soy/stackage
on master help sign in
Better create-snapshot
755bef0Michael Snoyman
Stackage/ServerFiles.hs+2−2
compare with master
unifiedsplit
@@ -35,9 +35,9 @@ createHackageFile isInc hp ii ghcVer date hackageH tarballH = do
35 , ".stackage"
35 , ".stackage"
36 ]
36 ]
37 hPutStr tarballH $ concat
37 hPutStr tarballH $ concat
38− [ "#!/bin/bash -ex\n\ncp ../build* .\ntar czfv "
38+ [ "#!/bin/bash -ex\n\ntar czfv "
39 , stackageFP
39 , stackageFP
40− , " hackage desc"
40+ , " hackage desc ../build*"
41 ]
41 ]
42 indextargz <- getTarballName
42 indextargz <- getTarballName
43 indexLBS <- L.readFile indextargz
43 indexLBS <- L.readFile indextargz
stackage-upload.hs+92−1
@@ -1,10 +1,19 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2+import Control.Monad (filterM, when)
2import qualified Data.ByteString.Char8 as S8
3import qualified Data.ByteString.Char8 as S8
4+import Data.List (isInfixOf, isPrefixOf,
5+ sort)
3import Network.HTTP.Client
6import Network.HTTP.Client
4import Network.HTTP.Client.MultipartFormData
7import Network.HTTP.Client.MultipartFormData
8+import System.Directory (doesDirectoryExist,
9+ getDirectoryContents)
5import System.Environment (getArgs, getEnv,
10import System.Environment (getArgs, getEnv,
6 getProgName)
11 getProgName)
7import System.Exit (exitFailure)
12import System.Exit (exitFailure)
13+import System.Exit (ExitCode (ExitSuccess))
14+import System.FilePath (takeDirectory, (</>))
15+import System.Process (createProcess, cwd,
16+ proc, waitForProcess)
8
17
9main :: IO ()
18main :: IO ()
10main = withManager defaultManagerSettings $ \m -> do
19main = withManager defaultManagerSettings $ \m -> do
@@ -22,6 +31,8 @@ main = withManager defaultManagerSettings $ \m -> do
22 ]
31 ]
23 exitFailure
32 exitFailure
24
33
34+ let uploadDocs = "exclusive" `isInfixOf` alias
35+
25 putStrLn $ concat
36 putStrLn $ concat
26 [ "Uploading "
37 [ "Uploading "
27 , filepath
38 , filepath
@@ -41,5 +52,85 @@ main = withManager defaultManagerSettings $ \m -> do
41 [ ("Authorization", S8.pack token)
52 [ ("Authorization", S8.pack token)
42 , ("Accept", "application/json")
53 , ("Accept", "application/json")
43 ] ++ requestHeaders req2
54 ] ++ requestHeaders req2
55+ , redirectCount = 0
56+ , checkStatus = \_ _ _ -> Nothing
44 }
57 }
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+ }
45− httpLbs req3 m >>= print
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+ ]