git.iko.soy/stackage
on 96ff559 help sign in
stackage/Stackage/Upload.hs
279 lines 9.4 kB history raw
1-- | Upload to Stackage and Hackage
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE NoImplicitPrelude #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE TupleSections #-}
7module Stackage.Upload
8 ( UploadBundle (..)
9 , SnapshotIdent (..)
10 , uploadBundle
11 , UploadDocs (..)
12 , uploadDocs
13 , uploadHackageDistro
14 , uploadHackageDistroNamed
15 , UploadDocMap (..)
16 , uploadDocMap
17 ) where
19import Control.Monad.Writer.Strict (execWriter, tell)
20import Data.Default.Class (Default (..))
21import Filesystem (isDirectory, isFile)
22import Network.HTTP.Client
23import Network.HTTP.Client.MultipartFormData
24import Stackage.BuildPlan (BuildPlan)
25import Stackage.Prelude
26import Stackage.ServerBundle (bpAllPackages, docsListing)
27import System.IO.Temp (withSystemTempFile)
29newtype StackageServer = StackageServer { unStackageServer :: Text }
30 deriving (Show, Eq, Ord, Hashable, IsString)
31instance Default StackageServer where
32 def = "http://www.stackage.org"
34data UploadBundle = UploadBundle
35 { ubServer :: StackageServer
36 , ubContents :: LByteString
37 , ubAlias :: Maybe Text
38 , ubNightly :: Maybe Text -- ^ should be GHC version
39 , ubLTS :: Maybe Text -- ^ e.g. 2.3
40 , ubAuthToken :: Text
41 }
42instance Default UploadBundle where
43 def = UploadBundle
44 { ubServer = def
45 , ubContents = mempty
46 , ubAlias = Nothing
47 , ubNightly = Nothing
48 , ubLTS = Nothing
49 , ubAuthToken = "no-auth-token-provided"
50 }
52newtype SnapshotIdent = SnapshotIdent { unSnapshotIdent :: Text }
53 deriving (Show, Eq, Ord, Hashable, IsString)
55uploadBundle :: UploadBundle -> Manager -> IO (SnapshotIdent, Maybe Text)
56uploadBundle UploadBundle {..} man = do
57 req1 <- parseUrl $ unpack $ unStackageServer ubServer ++ "/upload"
58 req2 <- formDataBody formData req1
59 let req3 = req2
60 { method = "PUT"
61 , requestHeaders =
62 [ ("Authorization", encodeUtf8 ubAuthToken)
63 , ("Accept", "application/json")
64 ] ++ requestHeaders req2
65 , redirectCount = 0
66 , checkStatus = \_ _ _ -> Nothing
67 , responseTimeout = Just 300000000
68 }
69 res <- httpLbs req3 man
70 case lookup "x-stackage-ident" $ responseHeaders res of
71 Just snapid -> return
72 ( SnapshotIdent $ decodeUtf8 snapid
73 , decodeUtf8 <$> lookup "location" (responseHeaders res)
74 )
75 Nothing -> error $ "An error occurred: " ++ show res
76 where
77 params = mapMaybe (\(x, y) -> (x, ) <$> y)
78 [ ("alias", ubAlias)
79 , ("nightly", ubNightly)
80 , ("lts", ubLTS)
81 ]
82 formData = ($ []) $ execWriter $ do
83 forM_ params $ \(key, value) ->
84 tell' $ partBS key $ encodeUtf8 value
85 tell' $ partFileRequestBody "stackage" "stackage"
86 $ RequestBodyLBS ubContents
88 tell' x = tell (x:)
90data UploadDocs = UploadDocs
91 { udServer :: StackageServer
92 , udDocs :: FilePath -- ^ may be a directory or a tarball
93 , udAuthToken :: Text
94 , udSnapshot :: SnapshotIdent
95 }
97uploadDocs :: UploadDocs -> Manager -> IO (Response LByteString)
98uploadDocs (UploadDocs (StackageServer host) fp0 token ident) man = do
99 fe <- isFile fp0
100 if fe
101 then uploadDocsFile $ fpToString fp0
102 else do
103 de <- isDirectory fp0
104 if de
105 then uploadDocsDir
106 else error $ "Path not found: " ++ fpToString fp0
107 where
108 uploadDocsDir = withSystemTempFile "haddocks.tar.xz" $ \fp h -> do
109 hClose h
110 dirs <- fmap sort
111 $ runResourceT
112 $ sourceDirectory fp0
113 $$ filterMC (liftIO . isDirectory)
114 =$ mapC (fpToString . filename)
115 =$ sinkList
116 writeFile (fp0 </> "index.html") $ mkIndex
117 (unpack $ unSnapshotIdent ident)
118 dirs
119 writeFile (fp0 </> "style.css") styleCss
120 -- FIXME write index.html, style.css
121 let cp = (proc "tar" $ "cJf" : fp : "index.html" : "style.css" : dirs)
122 { cwd = Just $ fpToString fp0
123 }
124 withCheckedProcess cp $ \Inherited Inherited Inherited -> return ()
125 uploadDocsFile fp
126 uploadDocsFile fp = do
127 req1 <- parseUrl $ unpack $ concat
128 [ host
129 , "/upload-haddock/"
130 , unSnapshotIdent ident
131 ]
132 let formData =
133 [ partFileSource "tarball" fp
134 ]
135 req2 <- formDataBody formData req1
136 let req3 = req2
137 { method = "PUT"
138 , requestHeaders =
139 [ ("Authorization", encodeUtf8 token)
140 , ("Accept", "application/json")
141 ] ++ requestHeaders req2
142 , redirectCount = 0
143 , checkStatus = \_ _ _ -> Nothing
144 , responseTimeout = Just 300000000
145 }
146 httpLbs req3 man
148uploadHackageDistro :: BuildPlan
149 -> ByteString -- ^ Hackage username
150 -> ByteString -- ^ Hackage password
151 -> Manager
152 -> IO (Response LByteString)
153uploadHackageDistro = uploadHackageDistroNamed "Stackage"
155uploadHackageDistroNamed
156 :: Text -- ^ distro name
157 -> BuildPlan
158 -> ByteString -- ^ Hackage username
159 -> ByteString -- ^ Hackage password
160 -> Manager
161 -> IO (Response LByteString)
162uploadHackageDistroNamed name bp username password manager = do
163 req1 <- parseUrl $ concat
164 [ "http://hackage.haskell.org/distro/"
165 , unpack name
166 , "/packages.csv"
167 ]
168 let req2 = req1
169 { requestHeaders = [("Content-Type", "text/csv")]
170 , requestBody = RequestBodyLBS csv
171 , checkStatus = \_ _ _ -> Nothing
172 , method = "PUT"
173 }
174 httpLbs (applyBasicAuth username password req2) manager
175 where
176 csv = encodeUtf8
177 $ builderToLazy
178 $ mconcat
179 $ intersperse "\n"
180 $ map go
181 $ mapToList
182 $ bpAllPackages bp
183 go (name, version) =
184 "\"" ++
185 (toBuilder $ display name) ++
186 "\",\"" ++
187 (toBuilder $ display version) ++
188 "\",\"http://www.stackage.org/package/" ++
189 (toBuilder $ display name) ++
190 "\""
192data UploadDocMap = UploadDocMap
193 { udmServer :: StackageServer
194 , udmAuthToken :: Text
195 , udmSnapshot :: SnapshotIdent
196 , udmDocDir :: FilePath
197 , udmPlan :: BuildPlan
198 }
200uploadDocMap :: UploadDocMap -> Manager -> IO (Response LByteString)
201uploadDocMap UploadDocMap {..} man = do
202 docmap <- docsListing udmPlan udmDocDir
203 req1 <- parseUrl $ unpack $ unStackageServer udmServer ++ "/upload-doc-map"
204 req2 <- formDataBody (formData docmap) req1
205 let req3 = req2
206 { method = "PUT"
207 , requestHeaders =
208 [ ("Authorization", encodeUtf8 udmAuthToken)
209 , ("Accept", "application/json")
210 ] ++ requestHeaders req2
211 , redirectCount = 0
212 , checkStatus = \_ _ _ -> Nothing
213 , responseTimeout = Just 300000000
214 }
215 httpLbs req3 man
216 where
217 formData docmap =
218 [ partBS "snapshot" (encodeUtf8 $ unSnapshotIdent udmSnapshot)
219 , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap
220 ]
222mkIndex :: String -> [String] -> String
223mkIndex snapid dirs = concat
224 [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
225 , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"
226 , "<link rel='stylesheet' href='style.css'>"
227 , "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"
228 , "</head>"
229 , "<body><div class='container'>"
230 , "<div class='row'><div class='span12 col-md-12'>"
231 , "<h1>Haddock documentation index</h1>"
232 , "<p class='return'><a href=\"http://www.stackage.org/stackage/"
233 , snapid
234 , "\">Return to snapshot</a></p><ul>"
235 , concatMap toLI dirs
236 , "</ul></div></div></div></body></html>"
237 ]
238 where
239 toLI name = concat
240 [ "<li><a href='"
241 , name
242 , "/index.html'>"
243 , name
244 , "</a></li>"
245 ]
247styleCss :: String
248styleCss = concat
249 [ "@media (min-width: 530px) {"
250 , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
251 , "}"
252 , "@media (min-width: 760px) {"
253 , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
254 , "}"
255 , "ul {"
256 , " margin-left: 0;"
257 , " padding-left: 0;"
258 , " list-style-type: none;"
259 , "}"
260 , "body {"
261 , " background: #f0f0f0;"
262 , " font-family: 'Lato', sans-serif;"
263 , " text-shadow: 1px 1px 1px #ffffff;"
264 , " font-size: 20px;"
265 , " line-height: 30px;"
266 , " padding-bottom: 5em;"
267 , "}"
268 , "h1 {"
269 , " font-weight: normal;"
270 , " color: #06537d;"
271 , " font-size: 45px;"
272 , "}"
273 , ".return a {"
274 , " color: #06537d;"
275 , " font-style: italic;"
276 , "}"
277 , ".return {"
278 , " margin-bottom: 1em;"
279 , "}"]