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