git.iko.soy/stackage
on fccd62f help sign in
stackage/stackage-upload.hs
176 lines 6.5 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2import Control.Monad (filterM, when)
3import qualified Data.ByteString.Char8 as S8
4import qualified Data.ByteString.Lazy as L
5import qualified Data.ByteString.Lazy.Char8 as L8
6import Data.List (isInfixOf, isPrefixOf,
7 sort)
8import Network.HTTP.Client
9import Network.HTTP.Client.MultipartFormData
10import System.Directory (doesDirectoryExist,
11 getDirectoryContents)
12import System.Environment (getArgs, getEnv,
13 getProgName)
14import System.Exit (exitFailure)
15import System.Exit (ExitCode (ExitSuccess))
16import System.FilePath (takeDirectory, (</>))
17import System.Process (createProcess, cwd,
18 proc, waitForProcess)
20main :: IO ()
21main = withManager defaultManagerSettings $ \m -> do
22 args <- getArgs
23 token <- readFile "/auth-token"
24 (filepath, alias) <-
25 case args of
26 [x, y] -> return (x, y)
27 _ -> do
28 pn <- getProgName
29 putStrLn $ concat
30 [ "Usage: "
31 , pn
32 , " <filepath> <alias name>"
33 ]
34 exitFailure
36 let uploadDocs = "exclusive" `isInfixOf` alias
37 uploadHackageDistro = alias == "unstable-ghc78-exclusive"
39 putStrLn $ concat
40 [ "Uploading "
41 , filepath
42 , " as "
43 , alias
44 ]
46 req1 <- parseUrl "http://www.stackage.org/upload"
47 let formData =
48 [ partBS "alias" $ S8.pack alias
49 , partFileSource "stackage" filepath
50 ]
51 req2 <- formDataBody formData req1
52 let req3 = req2
53 { method = "PUT"
54 , requestHeaders =
55 [ ("Authorization", S8.pack token)
56 , ("Accept", "application/json")
57 ] ++ requestHeaders req2
58 , redirectCount = 0
59 , checkStatus = \_ _ _ -> Nothing
60 }
61 res <- httpLbs req3 m
63 snapid <-
64 case lookup "x-stackage-ident" $ responseHeaders res of
65 Just snapid -> do
66 putStrLn $ "New ident: " ++ S8.unpack snapid
67 return snapid
68 Nothing -> error $ "An error occurred: " ++ show res
70 when uploadDocs $ do
71 putStrLn "Generating index file"
72 let root = takeDirectory filepath </> "haddock"
73 contents <- getDirectoryContents root
74 dirs <- filterM (\n -> doesDirectoryExist $ root </> n)
75 $ filter (not . ("." `isPrefixOf`))
76 $ sort contents
77 writeFile (root </> "index.html") $ mkIndex (S8.unpack snapid) dirs
78 writeFile (root </> "style.css") styleCss
80 putStrLn "Creating tarball"
81 (Nothing, Nothing, Nothing, ph) <- createProcess
82 (proc "tar" $ "cJf" : "haddock.tar.xz" : "index.html" : "style.css" : dirs)
83 { cwd = Just root
84 }
85 ec <- waitForProcess ph
86 if ec == ExitSuccess
87 then putStrLn "Haddock tarball generated"
88 else error "Error generating Haddock tarball"
90 putStrLn "Uploading Haddocks"
92 req1 <- parseUrl $ "http://www.stackage.org/upload-haddock/"
93 ++ S8.unpack snapid
94 let formData =
95 [ partFileSource "tarball" $ root </> "haddock.tar.xz"
96 ]
97 req2 <- formDataBody formData req1
98 let req3 = req2
99 { method = "PUT"
100 , requestHeaders =
101 [ ("Authorization", S8.pack token)
102 , ("Accept", "application/json")
103 ] ++ requestHeaders req2
104 , redirectCount = 0
105 , checkStatus = \_ _ _ -> Nothing
106 }
107 httpLbs req3 m >>= print
109 when uploadHackageDistro $ do
110 lbs <- L.readFile $ takeDirectory filepath </> "build-plan.csv"
111 let req = "http://hackage.haskell.org/distro/Stackage/packages.csv"
112 { requestHeaders = [("Content-Type", "text/csv")]
113 , requestBody = RequestBodyLBS $ L.intercalate "\n" $ L8.lines lbs
114 , checkStatus = \_ _ _ -> Nothing
115 , method = "PUT"
116 }
117 httpLbs req m >>= print
119mkIndex :: String -> [String] -> String
120mkIndex snapid dirs = concat
121 [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
122 , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"
123 , "<link rel='stylesheet' href='style.css'>"
124 , "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"
125 , "</head>"
126 , "<body><div class='container'>"
127 , "<div class='row'><div class='span12 col-md-12'>"
128 , "<h1>Haddock documentation index</h1>"
129 , "<p class='return'><a href=\"http://www.stackage.org/stackage/"
130 , snapid
131 , "\">Return to snapshot</a></p><ul>"
132 , concatMap toLI dirs
133 , "</ul></div></div></div></body></html>"
134 ]
135 where
136 toLI name = concat
137 [ "<li><a href='"
138 , name
139 , "/index.html'>"
140 , name
141 , "</a></li>"
142 ]
144styleCss :: String
145styleCss = concat
146 [ "@media (min-width: 530px) {"
147 , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
148 , "}"
149 , "@media (min-width: 760px) {"
150 , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
151 , "}"
152 , "ul {"
153 , " margin-left: 0;"
154 , " padding-left: 0;"
155 , " list-style-type: none;"
156 , "}"
157 , "body {"
158 , " background: #f0f0f0;"
159 , " font-family: 'Lato', sans-serif;"
160 , " text-shadow: 1px 1px 1px #ffffff;"
161 , " font-size: 20px;"
162 , " line-height: 30px;"
163 , " padding-bottom: 5em;"
164 , "}"
165 , "h1 {"
166 , " font-weight: normal;"
167 , " color: #06537d;"
168 , " font-size: 45px;"
169 , "}"
170 , ".return a {"
171 , " color: #06537d;"
172 , " font-style: italic;"
173 , "}"
174 , ".return {"
175 , " margin-bottom: 1em;"
176 , "}"]