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