982bcfa · stackage · git.iko.soy

git.iko.soy/stackage

on master help sign in

WIP new upload

982bcfaMichael Snoyman12 years ago

ChangeLog.md+4

compare with master

unifiedsplit

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

1+## 0.4.0

3+* Upload bundle V2 stuff

1## 0.3.1

5## 0.3.1

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

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

Stackage/PerformBuild.hs−10

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

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

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

414

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−

425copyBuiltInHaddocks :: FilePath -> IO ()

415copyBuiltInHaddocks :: FilePath -> IO ()

426copyBuiltInHaddocks docdir = do

416copyBuiltInHaddocks docdir = do

427 mghc <- findExecutable "ghc"

417 mghc <- findExecutable "ghc"

Stackage/Prelude.hs+13

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

20 VersionRange)

21import Distribution.Version as X (withinRange)

22import qualified Distribution.Version as C

23+import Filesystem (createTree)

24+import Filesystem.Path (parent)

25+import qualified Filesystem.Path as F

24unPackageName :: PackageName -> Text

27unPackageName :: PackageName -> Text

25unPackageName (PackageName str) = pack str

28unPackageName (PackageName str) = pack str

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

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

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

102 deriving (Show, Typeable)

105 deriving (Show, Typeable)

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

106instance (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

7 , epochTime

8 , bpAllPackages

9 , docsListing

10+ , createBundleV2

11+ , CreateBundleV2 (..)

12+ , SnapshotType (..)

13+ , writeIndexStyle

14+ , DocMap

15+ , PackageDocs (..)

10 ) where

16 ) where

12import qualified Codec.Archive.Tar as Tar

18import qualified Codec.Archive.Tar as Tar

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

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

14import qualified Codec.Compression.GZip as GZip

20import qualified Codec.Compression.GZip as GZip

15import qualified Data.Map as M

21import qualified Data.Map as M

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

23+import System.IO.Temp (withTempDirectory)

16import qualified Data.Yaml as Y

24import qualified Data.Yaml as Y

17−import Filesystem (isFile)

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

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

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

19import Stackage.BuildConstraints

27import Stackage.BuildConstraints

20import Stackage.BuildPlan

28import Stackage.BuildPlan

21import Stackage.Prelude

29import Stackage.Prelude

30+import System.IO.Temp (withTempDirectory)

22import qualified System.PosixCompat.Time as PC

31import qualified System.PosixCompat.Time as PC

23import qualified Text.XML as X

32import qualified Text.XML as X

24import Text.XML.Cursor

33import Text.XML.Cursor

34+import System.PosixCompat.Files (createSymbolicLink)

26-- | Get current time

36-- | Get current time

27epochTime :: IO Tar.EpochTime

37epochTime :: IO Tar.EpochTime

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

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

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

74 (M.keys $ siCorePackages bpSystemInfo)

84 (M.keys $ siCorePackages bpSystemInfo)

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+

76docsListing :: BuildPlan

103docsListing :: BuildPlan

77 -> FilePath -- ^ docs directory

104 -> FilePath -- ^ docs directory

78− -> IO ByteString

105+ -> IO DocMap

79docsListing bp docsDir =

106docsListing bp docsDir =

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

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

81 where

108 where

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

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

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

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

84 let dirname = fpFromText (concat

111 let dirname = fpFromText (concat

85 [ display package

112 [ display package

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

107 return $ if e

134 return $ if e

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

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

109 else mempty

136 else mempty

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

137+ return $ singletonMap (display package) $ PackageDocs

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

138+ { pdVersion = display version

112− , "modules" Y..= m

139+ , pdModules = m

113− ]

140+ }

114 else return mempty

141 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

13 , uploadHackageDistro

14 , UploadDocMap (..)

15 , uploadDocMap

16+ , uploadBundleV2

17+ , UploadBundleV2 (..)

16 ) where

18 ) where

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

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

19import Data.Default.Class (Default (..))

21import Data.Default.Class (Default (..))

22+import Data.Function (fix)

20import Filesystem (isDirectory, isFile)

23import Filesystem (isDirectory, isFile)

21import Network.HTTP.Client

24import Network.HTTP.Client

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

22import Network.HTTP.Client.MultipartFormData

26import Network.HTTP.Client.MultipartFormData

23import Stackage.BuildPlan (BuildPlan)

27import Stackage.BuildPlan (BuildPlan)

24import Stackage.Prelude

28import Stackage.Prelude

25−import Stackage.ServerBundle (bpAllPackages, docsListing)

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

26import System.IO.Temp (withSystemTempFile)

30import System.IO.Temp (withSystemTempFile)

31+import qualified System.IO as IO

32+import qualified Data.Yaml as Y

28newtype StackageServer = StackageServer { unStackageServer :: Text }

34newtype StackageServer = StackageServer { unStackageServer :: Text }

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

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

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

106 where

112 where

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

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

108 hClose h

114 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)

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

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)

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

121 { cwd = Just $ fpToString fp0

117 { cwd = Just $ fpToString fp0

122 }

118 }

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

187uploadDocMap UploadDocMap {..} man = do

183uploadDocMap UploadDocMap {..} man = do

188 docmap <- docsListing udmPlan udmDocDir

184 docmap <- docsListing udmPlan udmDocDir

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

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

190− req2 <- formDataBody (formData docmap) req1

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

191 let req3 = req2

187 let req3 = req2

192 { method = "PUT"

188 { method = "PUT"

193 , requestHeaders =

189 , requestHeaders =

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

205 , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap

201 , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap

206 ]

202 ]

207

203

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

204+data UploadBundleV2 = UploadBundleV2

209−mkIndex snapid dirs = concat

205+ { ub2Server :: StackageServer

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

206+ , ub2AuthToken :: Text

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

207+ , ub2Bundle :: FilePath

212− , "<link rel='stylesheet' href='style.css'>"

208+ }

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

232

209

233−styleCss :: String

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

234−styleCss = concat

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

235− [ "@media (min-width: 530px) {"

212+ size <- IO.hFileSize h

236− , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"

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

237− , "}"

214+ let req2 = req1

238− , "@media (min-width: 760px) {"

215+ { method = "PUT"

239− , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"

216+ , requestHeaders =

240− , "}"

217+ [ ("Authorization", encodeUtf8 ub2AuthToken)

241− , "ul {"

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

242− , " margin-left: 0;"

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

243− , " padding-left: 0;"

220+ ]

244− , " list-style-type: none;"

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

245− , "}"

222+ $ sourceHandle h $= printProgress size

246− , "body {"

223+ }

247− , " background: #f0f0f0;"

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

248− , " font-family: 'Lato', sans-serif;"

225+ mx <- peekC

249− , " text-shadow: 1px 1px 1px #ffffff;"

226+ case mx of

250− , " font-size: 20px;"

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

251− , " line-height: 30px;"

228+ Just _ -> do

252− , " padding-bottom: 5em;"

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

253− , "}"

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

254− , "h1 {"

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

255− , " font-weight: normal;"

232+ case cmd of

256− , " color: #06537d;"

233+ "CONT" -> do

257− , " font-size: 45px;"

234+ putStrLn msg

258− , "}"

235+ loop

259− , ".return a {"

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

260− , " color: #06537d;"

237+ "SUCCESS" -> return msg

261− , " font-style: italic;"

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

262− , "}"

239+ )

263− , ".return {"

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

264− , " margin-bottom: 1em;"

241+ where

265− , "}"]

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 @@

1name: stackage

2−version: 0.3.1

2+version: 0.4.0

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

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

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

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

52 , yaml

53 , unix-compat

54 , http-client

55+ , http-conduit

55 , http-client-tls

56 , http-client-tls

56 , temporary

57 , temporary

57 , data-default-class

58 , data-default-class