982bcfa · stackage · git.iko.soy

git.iko.soy/stackage

WIP new upload

commit982bcfa2ad233e41e82b4d1319e280623b14a99c authorMichael Snoyman <michael@snoyman.com> dateFri 26 Dec 2014, 13:43 (12 years ago) parent4377dec

6 files changed+243−89

compare with master

unifiedsplit

ChangeLog.md+4 Stackage/PerformBuild.hs−10 Stackage/Prelude.hs+13 Stackage/ServerBundle.hs+165−8 Stackage/Upload.hs+59−70 stackage.cabal+2−1

ChangeLog.md+4

@@ -1,3 +1,7 @@

1+## 0.4.0

3+* Upload bundle V2 stuff

15## 0.3.1

37* Added `justCheck` and `stackage check` command line.

Stackage/PerformBuild.hs−10

@@ -412,16 +412,6 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =

412412renameOrCopy :: FilePath -> FilePath -> IO ()

413413renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest

414414

415−copyDir :: FilePath -> FilePath -> IO ()

416−copyDir src dest =

417− runResourceT $ sourceDirectoryDeep False src $$ mapM_C go

418− where

419− src' = src </> ""

420− go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do

421− let dest' = dest </> suffix

422− liftIO $ createTree $ parent dest'

423− sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())

424−

425415copyBuiltInHaddocks :: FilePath -> IO ()

426416copyBuiltInHaddocks docdir = do

427417 mghc <- findExecutable "ghc"

Stackage/Prelude.hs+13

@@ -20,6 +20,9 @@ import Distribution.Version as X (Version (..),

2020 VersionRange)

2121import Distribution.Version as X (withinRange)

2222import qualified Distribution.Version as C

23+import Filesystem (createTree)

24+import Filesystem.Path (parent)

25+import qualified Filesystem.Path as F

2326

2427unPackageName :: PackageName -> Text

2528unPackageName (PackageName str) = pack str

@@ -101,3 +104,13 @@ topologicalSort toFinal toDeps =

101104data TopologicalSortException key = NoEmptyDeps (Map key (Set key))

102105 deriving (Show, Typeable)

103106instance (Show key, Typeable key) => Exception (TopologicalSortException key)

107+

108+copyDir :: FilePath -> FilePath -> IO ()

109+copyDir src dest =

110+ runResourceT $ sourceDirectoryDeep False src $$ mapM_C go

111+ where

112+ src' = src </> ""

113+ go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do

114+ let dest' = dest </> suffix

115+ liftIO $ createTree $ parent dest'

116+ sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())

Stackage/ServerBundle.hs+165−8

@@ -7,21 +7,31 @@ module Stackage.ServerBundle

77 , epochTime

88 , bpAllPackages

99 , docsListing

10+ , createBundleV2

11+ , CreateBundleV2 (..)

12+ , SnapshotType (..)

13+ , writeIndexStyle

14+ , DocMap

15+ , PackageDocs (..)

1016 ) where

1117

1218import qualified Codec.Archive.Tar as Tar

1319import qualified Codec.Archive.Tar.Entry as Tar

1420import qualified Codec.Compression.GZip as GZip

1521import qualified Data.Map as M

22+import Data.Aeson (ToJSON (..), (.=), object, FromJSON (..), (.:), withObject)

23+import System.IO.Temp (withTempDirectory)

1624import qualified Data.Yaml as Y

17−import Filesystem (isFile)

25+import Filesystem (isFile, getWorkingDirectory, listDirectory, isDirectory, canonicalizePath)

1826import Foreign.C.Types (CTime (CTime))

1927import Stackage.BuildConstraints

2028import Stackage.BuildPlan

2129import Stackage.Prelude

30+import System.IO.Temp (withTempDirectory)

2231import qualified System.PosixCompat.Time as PC

2332import qualified Text.XML as X

2433import Text.XML.Cursor

34+import System.PosixCompat.Files (createSymbolicLink)

2535

2636-- | Get current time

2737epochTime :: IO Tar.EpochTime

@@ -73,13 +83,30 @@ serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write

7383 map (\(PackageName name) -> name)

7484 (M.keys $ siCorePackages bpSystemInfo)

7585

86+-- | Package name is key

87+type DocMap = Map Text PackageDocs

88+data PackageDocs = PackageDocs

89+ { pdVersion :: Text

90+ , pdModules :: Map Text [Text]

91+ -- ^ module name, path

92+ }

93+instance ToJSON PackageDocs where

94+ toJSON PackageDocs {..} = object

95+ [ "version" .= pdVersion

96+ , "modules" .= pdModules

97+ ]

98+instance FromJSON PackageDocs where

99+ parseJSON = withObject "PackageDocs" $ \o -> PackageDocs

100+ <$> o .: "version"

101+ <*> o .: "modules"

102+

76103docsListing :: BuildPlan

77104 -> FilePath -- ^ docs directory

78− -> IO ByteString

105+ -> IO DocMap

79106docsListing bp docsDir =

80− fmap (Y.encode . fold) $ mapM go $ mapToList $ bpAllPackages bp

107+ fmap fold $ mapM go $ mapToList $ bpAllPackages bp

81108 where

82− go :: (PackageName, Version) -> IO (Map Text Y.Value)

109+ go :: (PackageName, Version) -> IO DocMap

83110 go (package, version) = do -- handleAny (const $ return mempty) $ do

84111 let dirname = fpFromText (concat

85112 [ display package

@@ -107,8 +134,138 @@ docsListing bp docsDir =

107134 return $ if e

108135 then asMap $ singletonMap name [fpToText dirname, href]

109136 else mempty

110− return $ singletonMap (display package) $ Y.object

111− [ "version" Y..= display version

112− , "modules" Y..= m

113− ]

137+ return $ singletonMap (display package) $ PackageDocs

138+ { pdVersion = display version

139+ , pdModules = m

140+ }

114141 else return mempty

142+

143+data SnapshotType = STNightly

144+ | STLTS !Int !Int -- ^ major, minor

145+ deriving (Show, Read, Eq, Ord)

146+

147+instance ToJSON SnapshotType where

148+ toJSON STNightly = object

149+ [ "type" .= asText "nightly"

150+ ]

151+ toJSON (STLTS major minor) = object

152+ [ "type" .= asText "lts"

153+ , "major" .= major

154+ , "minor" .= minor

155+ ]

156+instance FromJSON SnapshotType where

157+ parseJSON = withObject "SnapshotType" $ \o -> do

158+ t <- o .: "type"

159+ case asText t of

160+ "nightly" -> return STNightly

161+ "lts" -> STLTS

162+ <$> o .: "major"

163+ <*> o .: "minor"

164+ _ -> fail $ "Unknown type for SnapshotType: " ++ unpack t

165+

166+data CreateBundleV2 = CreateBundleV2

167+ { cb2Plan :: BuildPlan

168+ , cb2Type :: SnapshotType

169+ , cb2DocsDir :: FilePath

170+ , cb2Dest :: FilePath

171+ }

172+

173+-- | Create a V2 bundle, which contains the build plan, metadata, docs, and doc

174+-- map.

175+createBundleV2 :: CreateBundleV2 -> IO ()

176+createBundleV2 CreateBundleV2 {..} = do

177+ docsDir <- canonicalizePath cb2DocsDir

178+ docMap <- docsListing cb2Plan cb2DocsDir

179+

180+ Y.encodeFile (fpToString $ docsDir </> "build-plan.yaml") cb2Plan

181+ Y.encodeFile (fpToString $ docsDir </> "build-type.yaml") cb2Type

182+ Y.encodeFile (fpToString $ docsDir </> "docs-map.yaml") docMap

183+ void $ writeIndexStyle Nothing cb2DocsDir

184+

185+ currentDir <- getWorkingDirectory

186+ files <- listDirectory docsDir

187+

188+ let args = "cfJ"

189+ : fpToString (currentDir </> cb2Dest)

190+ : "--dereference"

191+ : map (fpToString . filename) files

192+ cp = (proc "tar" args) { cwd = Just $ fpToString docsDir }

193+ withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return ()

194+

195+writeIndexStyle :: Maybe Text -- ^ snapshot id

196+ -> FilePath -- ^ docs dir

197+ -> IO [String]

198+writeIndexStyle msnapid dir = do

199+ dirs <- fmap sort

200+ $ runResourceT

201+ $ sourceDirectory dir

202+ $$ filterMC (liftIO . isDirectory)

203+ =$ mapC (fpToString . filename)

204+ =$ sinkList

205+ writeFile (dir </> "index.html") $ mkIndex

206+ (unpack <$> msnapid)

207+ dirs

208+ writeFile (dir </> "style.css") styleCss

209+ return dirs

210+

211+mkIndex :: Maybe String -> [String] -> String

212+mkIndex msnapid dirs = concat

213+ [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"

214+ , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"

215+ , "<link rel='stylesheet' href='style.css'>"

216+ , "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"

217+ , "</head>"

218+ , "<body><div class='container'>"

219+ , "<div class='row'><div class='span12 col-md-12'>"

220+ , "<h1>Haddock documentation index</h1>"

221+ , flip foldMap msnapid $ \snapid -> concat

222+ [ "<p class='return'><a href=\"http://www.stackage.org/stackage/"

223+ , snapid

224+ , "\">Return to snapshot</a></p>"

225+ ]

226+ , "<ul>"

227+ , concatMap toLI dirs

228+ , "</ul></div></div></div></body></html>"

229+ ]

230+ where

231+ toLI name = concat

232+ [ "<li><a href='"

233+ , name

234+ , "/index.html'>"

235+ , name

236+ , "</a></li>"

237+ ]

238+

239+styleCss :: String

240+styleCss = concat

241+ [ "@media (min-width: 530px) {"

242+ , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"

243+ , "}"

244+ , "@media (min-width: 760px) {"

245+ , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"

246+ , "}"

247+ , "ul {"

248+ , " margin-left: 0;"

249+ , " padding-left: 0;"

250+ , " list-style-type: none;"

251+ , "}"

252+ , "body {"

253+ , " background: #f0f0f0;"

254+ , " font-family: 'Lato', sans-serif;"

255+ , " text-shadow: 1px 1px 1px #ffffff;"

256+ , " font-size: 20px;"

257+ , " line-height: 30px;"

258+ , " padding-bottom: 5em;"

259+ , "}"

260+ , "h1 {"

261+ , " font-weight: normal;"

262+ , " color: #06537d;"

263+ , " font-size: 45px;"

264+ , "}"

265+ , ".return a {"

266+ , " color: #06537d;"

267+ , " font-style: italic;"

268+ , "}"

269+ , ".return {"

270+ , " margin-bottom: 1em;"

271+ , "}"]

Stackage/Upload.hs+59−70

@@ -13,17 +13,23 @@ module Stackage.Upload

1313 , uploadHackageDistro

1414 , UploadDocMap (..)

1515 , uploadDocMap

16+ , uploadBundleV2

17+ , UploadBundleV2 (..)

1618 ) where

1719

1820import Control.Monad.Writer.Strict (execWriter, tell)

1921import Data.Default.Class (Default (..))

22+import Data.Function (fix)

2023import Filesystem (isDirectory, isFile)

2124import Network.HTTP.Client

25+import qualified Network.HTTP.Client.Conduit as HCC

2226import Network.HTTP.Client.MultipartFormData

2327import Stackage.BuildPlan (BuildPlan)

2428import Stackage.Prelude

25−import Stackage.ServerBundle (bpAllPackages, docsListing)

29+import Stackage.ServerBundle (bpAllPackages, docsListing, writeIndexStyle)

2630import System.IO.Temp (withSystemTempFile)

31+import qualified System.IO as IO

32+import qualified Data.Yaml as Y

2733

2834newtype StackageServer = StackageServer { unStackageServer :: Text }

2935 deriving (Show, Eq, Ord, Hashable, IsString)

@@ -106,17 +112,7 @@ uploadDocs (UploadDocs (StackageServer host) fp0 token ident) man = do

106112 where

107113 uploadDocsDir = withSystemTempFile "haddocks.tar.xz" $ \fp h -> do

108114 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

115+ dirs <- writeIndexStyle (Just $ unSnapshotIdent ident) fp0

120116 let cp = (proc "tar" $ "cJf" : fp : "index.html" : "style.css" : dirs)

121117 { cwd = Just $ fpToString fp0

122118 }

@@ -187,7 +183,7 @@ uploadDocMap :: UploadDocMap -> Manager -> IO (Response LByteString)

187183uploadDocMap UploadDocMap {..} man = do

188184 docmap <- docsListing udmPlan udmDocDir

189185 req1 <- parseUrl $ unpack $ unStackageServer udmServer ++ "/upload-doc-map"

190− req2 <- formDataBody (formData docmap) req1

186+ req2 <- formDataBody (formData $ Y.encode docmap) req1

191187 let req3 = req2

192188 { method = "PUT"

193189 , requestHeaders =

@@ -205,61 +201,54 @@ uploadDocMap UploadDocMap {..} man = do

205201 , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap

206202 ]

207203

208−mkIndex :: String -> [String] -> String

209−mkIndex 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− ]

204+data UploadBundleV2 = UploadBundleV2

205+ { ub2Server :: StackageServer

206+ , ub2AuthToken :: Text

207+ , ub2Bundle :: FilePath

208+ }

232209

233−styleCss :: String

234−styleCss = 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− , "}"]

210+uploadBundleV2 :: UploadBundleV2 -> Manager -> IO Text

211+uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile (fpToString ub2Bundle) IO.ReadMode $ \h -> do

212+ size <- IO.hFileSize h

213+ req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2"

214+ let req2 = req1

215+ { method = "PUT"

216+ , requestHeaders =

217+ [ ("Authorization", encodeUtf8 ub2AuthToken)

218+ , ("Accept", "application/json")

219+ , ("Content-Type", "application/x-tar")

220+ ]

221+ , requestBody = HCC.requestBodySource (fromIntegral size)

222+ $ sourceHandle h $= printProgress size

223+ }

224+ sink = decodeUtf8C =$ fix (\loop -> do

225+ mx <- peekC

226+ case mx of

227+ Nothing -> error $ "uploadBundleV2: premature end of stream"

228+ Just _ -> do

229+ l <- lineC $ takeCE 4096 =$ foldC

230+ let (cmd, msg') = break (== ':') l

231+ msg = dropWhile (== ' ') $ dropWhile (== ':') msg'

232+ case cmd of

233+ "CONT" -> do

234+ putStrLn msg

235+ loop

236+ "FAILURE" -> error $ "uploadBundleV2 failed: " ++ unpack msg

237+ "SUCCESS" -> return msg

238+ _ -> error $ "uploadBundleV2: unknown command " ++ unpack cmd

239+ )

240+ withResponse req2 man $ \res -> HCC.bodyReaderSource (responseBody res) $$ sink

241+ where

242+ printProgress total =

243+ loop 0 0

244+ where

245+ loop sent lastPercent =

246+ await >>= maybe (putStrLn "Upload complete") go

247+ where

248+ go bs = do

249+ yield bs

250+ let sent' = sent + fromIntegral (length bs)

251+ percent = sent' * 100 `div` total

252+ when (percent /= lastPercent)

253+ $ putStrLn $ "Upload progress: " ++ tshow percent ++ "%"

254+ loop sent' percent

stackage.cabal+2−1

@@ -1,5 +1,5 @@

11name: stackage

2−version: 0.3.1

2+version: 0.4.0

33synopsis: "Stable Hackage," tools for creating a vetted set of packages from Hackage.

44description: Please see <http://www.stackage.org/package/stackage> for a description and documentation.

55homepage: https://github.com/fpco/stackage

@@ -52,6 +52,7 @@ library

5252 , yaml

5353 , unix-compat

5454 , http-client

55+ , http-conduit

5556 , http-client-tls

5657 , temporary

5758 , data-default-class