git.iko.soy/stackage
on 7d0b22b help sign in
stackage/stackage-upload.hs
163 lines 5.8 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2import Control.Monad (filterM, when)
3import qualified Data.ByteString.Char8 as S8
4import Data.List (isInfixOf, isPrefixOf,
5 sort)
6import Network.HTTP.Client
7import Network.HTTP.Client.MultipartFormData
8import System.Directory (doesDirectoryExist,
9 getDirectoryContents)
10import System.Environment (getArgs, getEnv,
11 getProgName)
12import System.Exit (exitFailure)
13import System.Exit (ExitCode (ExitSuccess))
14import System.FilePath (takeDirectory, (</>))
15import System.Process (createProcess, cwd,
16 proc, waitForProcess)
18main :: IO ()
19main = withManager defaultManagerSettings $ \m -> do
20 args <- getArgs
21 token <- readFile "/auth-token"
22 (filepath, alias) <-
23 case args of
24 [x, y] -> return (x, y)
25 _ -> do
26 pn <- getProgName
27 putStrLn $ concat
28 [ "Usage: "
29 , pn
30 , " <filepath> <alias name>"
31 ]
32 exitFailure
34 let uploadDocs = "exclusive" `isInfixOf` alias
36 putStrLn $ concat
37 [ "Uploading "
38 , filepath
39 , " as "
40 , alias
41 ]
43 req1 <- parseUrl "http://www.stackage.org/upload"
44 let formData =
45 [ partBS "alias" $ S8.pack alias
46 , partFileSource "stackage" filepath
47 ]
48 req2 <- formDataBody formData req1
49 let req3 = req2
50 { method = "PUT"
51 , requestHeaders =
52 [ ("Authorization", S8.pack token)
53 , ("Accept", "application/json")
54 ] ++ requestHeaders req2
55 , redirectCount = 0
56 , checkStatus = \_ _ _ -> Nothing
57 }
58 res <- httpLbs req3 m
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
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
77 putStrLn "Creating tarball"
78 (Nothing, Nothing, Nothing, ph) <- createProcess
79 (proc "tar" $ "cJf" : "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"
87 putStrLn "Uploading Haddocks"
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
106mkIndex :: String -> [String] -> String
107mkIndex 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 , "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"
112 , "</head>"
113 , "<body><div class='container'>"
114 , "<div class='row'><div class='span12 col-md-12'>"
115 , "<h1>Haddock documentation index</h1>"
116 , "<p class='return'><a href=\"http://www.stackage.org/stackage/"
117 , snapid
118 , "\">Return to snapshot</a></p><ul>"
119 , concatMap toLI dirs
120 , "</ul></div></div></div></body></html>"
121 ]
122 where
123 toLI name = concat
124 [ "<li><a href='"
125 , name
126 , "/index.html'>"
127 , name
128 , "</a></li>"
129 ]
131styleCss :: String
132styleCss = concat
133 [ "@media (min-width: 530px) {"
134 , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
135 , "}"
136 , "@media (min-width: 760px) {"
137 , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
138 , "}"
139 , "ul {"
140 , " margin-left: 0;"
141 , " padding-left: 0;"
142 , " list-style-type: none;"
143 , "}"
144 , "body {"
145 , " background: #f0f0f0;"
146 , " font-family: 'Lato', sans-serif;"
147 , " text-shadow: 1px 1px 1px #ffffff;"
148 , " font-size: 20px;"
149 , " line-height: 30px;"
150 , " padding-bottom: 5em;"
151 , "}"
152 , "h1 {"
153 , " font-weight: normal;"
154 , " color: #06537d;"
155 , " font-size: 45px;"
156 , "}"
157 , ".return a {"
158 , " color: #06537d;"
159 , " font-style: italic;"
160 , "}"
161 , ".return {"
162 , " margin-bottom: 1em;"
163 , "}"]