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