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