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