WIP new upload

2026-01-11 23:08:30 +01:00 · 2014-12-26 13:43:44 +02:00 · 2014-12-26 13:43:44 +02:00 · 982bcfa2ad
commit 982bcfa2ad
parent 4377decd33
6 changed files with 243 additions and 89 deletions
--- a/ChangeLog.md
+++ b/ChangeLog.md
@ -1,3 +1,7 @@
+## 0.4.0
+
+* Upload bundle V2 stuff
+
 ## 0.3.1

 * Added `justCheck` and `stackage check` command line.
--- a/Stackage/PerformBuild.hs
+++ b/Stackage/PerformBuild.hs
@ -412,16 +412,6 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} =
 renameOrCopy :: FilePath -> FilePath -> IO ()
 renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest

-copyDir :: FilePath -> FilePath -> IO ()
-copyDir src dest =
-    runResourceT $ sourceDirectoryDeep False src $$ mapM_C go
-  where
-    src' = src </> ""
-    go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do
-        let dest' = dest </> suffix
-        liftIO $ createTree $ parent dest'
-        sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
-
 copyBuiltInHaddocks :: FilePath -> IO ()
 copyBuiltInHaddocks docdir = do
    mghc <- findExecutable "ghc"
--- a/Stackage/Prelude.hs
+++ b/Stackage/Prelude.hs
@ -20,6 +20,9 @@ import           Distribution.Version            as X (Version (..),
                                                       VersionRange)
 import           Distribution.Version            as X (withinRange)
 import qualified Distribution.Version            as C
+import           Filesystem                      (createTree)
+import           Filesystem.Path                 (parent)
+import qualified Filesystem.Path                 as F

 unPackageName :: PackageName -> Text
 unPackageName (PackageName str) = pack str
@ -101,3 +104,13 @@ topologicalSort toFinal toDeps =
 data TopologicalSortException key = NoEmptyDeps (Map key (Set key))
    deriving (Show, Typeable)
 instance (Show key, Typeable key) => Exception (TopologicalSortException key)
+
+copyDir :: FilePath -> FilePath -> IO ()
+copyDir src dest =
+    runResourceT $ sourceDirectoryDeep False src $$ mapM_C go
+  where
+    src' = src </> ""
+    go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do
+        let dest' = dest </> suffix
+        liftIO $ createTree $ parent dest'
+        sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
--- a/Stackage/ServerBundle.hs
+++ b/Stackage/ServerBundle.hs
@ -7,21 +7,31 @@ module Stackage.ServerBundle
    , epochTime
    , bpAllPackages
    , docsListing
+    , createBundleV2
+    , CreateBundleV2 (..)
+    , SnapshotType (..)
+    , writeIndexStyle
+    , DocMap
+    , PackageDocs (..)
    ) where

 import qualified Codec.Archive.Tar         as Tar
 import qualified Codec.Archive.Tar.Entry   as Tar
 import qualified Codec.Compression.GZip    as GZip
 import qualified Data.Map                  as M
+import           Data.Aeson (ToJSON (..), (.=), object, FromJSON (..), (.:), withObject)
+import System.IO.Temp (withTempDirectory)
 import qualified Data.Yaml                 as Y
-import           Filesystem                (isFile)
+import           Filesystem                (isFile, getWorkingDirectory, listDirectory, isDirectory, canonicalizePath)
 import           Foreign.C.Types           (CTime (CTime))
 import           Stackage.BuildConstraints
 import           Stackage.BuildPlan
 import           Stackage.Prelude
+import           System.IO.Temp (withTempDirectory)
 import qualified System.PosixCompat.Time   as PC
 import qualified Text.XML                  as X
 import           Text.XML.Cursor
+import System.PosixCompat.Files (createSymbolicLink)

 -- | Get current time
 epochTime :: IO Tar.EpochTime
@ -73,13 +83,30 @@ serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write
            map (\(PackageName name) -> name)
                (M.keys $ siCorePackages bpSystemInfo)

+-- | Package name is key
+type DocMap = Map Text PackageDocs
+data PackageDocs = PackageDocs
+    { pdVersion :: Text
+    , pdModules :: Map Text [Text]
+    -- ^ module name, path
+    }
+instance ToJSON PackageDocs where
+    toJSON PackageDocs {..} = object
+        [ "version" .= pdVersion
+        , "modules" .= pdModules
+        ]
+instance FromJSON PackageDocs where
+    parseJSON = withObject "PackageDocs" $ \o -> PackageDocs
+        <$> o .: "version"
+        <*> o .: "modules"
+
 docsListing :: BuildPlan
            -> FilePath -- ^ docs directory
-            -> IO ByteString
+            -> IO DocMap
 docsListing bp docsDir =
-    fmap (Y.encode . fold) $ mapM go $ mapToList $ bpAllPackages bp
+    fmap fold $ mapM go $ mapToList $ bpAllPackages bp
  where
-    go :: (PackageName, Version) -> IO (Map Text Y.Value)
+    go :: (PackageName, Version) -> IO DocMap
    go (package, version) = do -- handleAny (const $ return mempty) $ do
        let dirname = fpFromText (concat
                [ display package
@ -107,8 +134,138 @@ docsListing bp docsDir =
                    return $ if e
                        then asMap $ singletonMap name [fpToText dirname, href]
                        else mempty
-                return $ singletonMap (display package) $ Y.object
-                    [ "version" Y..= display version
-                    , "modules" Y..= m
-                    ]
+                return $ singletonMap (display package) $ PackageDocs
+                    { pdVersion = display version
+                    , pdModules = m
+                    }
            else return mempty
+
+data SnapshotType = STNightly
+                  | STLTS !Int !Int -- ^ major, minor
+    deriving (Show, Read, Eq, Ord)
+
+instance ToJSON SnapshotType where
+    toJSON STNightly = object
+        [ "type" .= asText "nightly"
+        ]
+    toJSON (STLTS major minor) = object
+        [ "type" .= asText "lts"
+        , "major" .= major
+        , "minor" .= minor
+        ]
+instance FromJSON SnapshotType where
+    parseJSON = withObject "SnapshotType" $ \o -> do
+        t <- o .: "type"
+        case asText t of
+            "nightly" -> return STNightly
+            "lts" -> STLTS
+                <$> o .: "major"
+                <*> o .: "minor"
+            _ -> fail $ "Unknown type for SnapshotType: " ++ unpack t
+
+data CreateBundleV2 = CreateBundleV2
+    { cb2Plan :: BuildPlan
+    , cb2Type :: SnapshotType
+    , cb2DocsDir :: FilePath
+    , cb2Dest :: FilePath
+    }
+
+-- | Create a V2 bundle, which contains the build plan, metadata, docs, and doc
+-- map.
+createBundleV2 :: CreateBundleV2 -> IO ()
+createBundleV2 CreateBundleV2 {..} = do
+    docsDir <- canonicalizePath cb2DocsDir
+    docMap <- docsListing cb2Plan cb2DocsDir
+
+    Y.encodeFile (fpToString $ docsDir </> "build-plan.yaml") cb2Plan
+    Y.encodeFile (fpToString $ docsDir </> "build-type.yaml") cb2Type
+    Y.encodeFile (fpToString $ docsDir </> "docs-map.yaml") docMap
+    void $ writeIndexStyle Nothing cb2DocsDir
+
+    currentDir <- getWorkingDirectory
+    files <- listDirectory docsDir
+
+    let args = "cfJ"
+             : fpToString (currentDir </> cb2Dest)
+             : "--dereference"
+             : map (fpToString . filename) files
+        cp = (proc "tar" args) { cwd = Just $ fpToString docsDir }
+    withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return ()
+
+writeIndexStyle :: Maybe Text -- ^ snapshot id
+                -> FilePath -- ^ docs dir
+                -> IO [String]
+writeIndexStyle msnapid dir = do
+    dirs <- fmap sort
+          $ runResourceT
+          $ sourceDirectory dir
+         $$ filterMC (liftIO . isDirectory)
+         =$ mapC (fpToString . filename)
+         =$ sinkList
+    writeFile (dir </> "index.html") $ mkIndex
+        (unpack <$> msnapid)
+        dirs
+    writeFile (dir </> "style.css") styleCss
+    return dirs
+
+mkIndex :: Maybe String -> [String] -> String
+mkIndex msnapid dirs = concat
+    [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
+    , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"
+    , "<link rel='stylesheet' href='style.css'>"
+    , "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"
+    , "</head>"
+    , "<body><div class='container'>"
+    , "<div class='row'><div class='span12 col-md-12'>"
+    , "<h1>Haddock documentation index</h1>"
+    , flip foldMap msnapid $ \snapid -> concat
+        [ "<p class='return'><a href=\"http://www.stackage.org/stackage/"
+        , snapid
+        , "\">Return to snapshot</a></p>"
+        ]
+    , "<ul>"
+    , concatMap toLI dirs
+    , "</ul></div></div></div></body></html>"
+    ]
+  where
+    toLI name = concat
+        [ "<li><a href='"
+        , name
+        , "/index.html'>"
+        , name
+        , "</a></li>"
+        ]
+
+styleCss :: String
+styleCss = concat
+    [ "@media (min-width: 530px) {"
+    , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
+    , "}"
+    , "@media (min-width: 760px) {"
+    , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
+    , "}"
+    , "ul {"
+    , "  margin-left: 0;"
+    , "  padding-left: 0;"
+    , "  list-style-type: none;"
+    , "}"
+    , "body {"
+    , "  background: #f0f0f0;"
+    , "  font-family: 'Lato', sans-serif;"
+    , "  text-shadow: 1px 1px 1px #ffffff;"
+    , "  font-size: 20px;"
+    , "  line-height: 30px;"
+    , "  padding-bottom: 5em;"
+    , "}"
+    , "h1 {"
+    , "  font-weight: normal;"
+    , "  color: #06537d;"
+    , "  font-size: 45px;"
+    , "}"
+    , ".return a {"
+    , "  color: #06537d;"
+    , "  font-style: italic;"
+    , "}"
+    , ".return {"
+    , "  margin-bottom: 1em;"
+    , "}"]
--- a/Stackage/Upload.hs
+++ b/Stackage/Upload.hs
@ -13,17 +13,23 @@ module Stackage.Upload
    , uploadHackageDistro
    , UploadDocMap (..)
    , uploadDocMap
+    , uploadBundleV2
+    , UploadBundleV2 (..)
    ) where

 import Control.Monad.Writer.Strict           (execWriter, tell)
 import Data.Default.Class                    (Default (..))
+import Data.Function                         (fix)
 import Filesystem                            (isDirectory, isFile)
 import Network.HTTP.Client
+import qualified Network.HTTP.Client.Conduit as HCC
 import Network.HTTP.Client.MultipartFormData
 import Stackage.BuildPlan                    (BuildPlan)
 import Stackage.Prelude
-import Stackage.ServerBundle                 (bpAllPackages, docsListing)
+import Stackage.ServerBundle                 (bpAllPackages, docsListing, writeIndexStyle)
 import System.IO.Temp                        (withSystemTempFile)
+import qualified System.IO as IO
+import qualified Data.Yaml as Y

 newtype StackageServer = StackageServer { unStackageServer :: Text }
    deriving (Show, Eq, Ord, Hashable, IsString)
@ -106,17 +112,7 @@ uploadDocs (UploadDocs (StackageServer host) fp0 token ident) man = do
  where
    uploadDocsDir = withSystemTempFile "haddocks.tar.xz" $ \fp h -> do
        hClose h
-        dirs <- fmap sort
-              $ runResourceT
-              $ sourceDirectory fp0
-             $$ filterMC (liftIO . isDirectory)
-             =$ mapC (fpToString . filename)
-             =$ sinkList
-        writeFile (fp0 </> "index.html") $ mkIndex
-            (unpack $ unSnapshotIdent ident)
-            dirs
-        writeFile (fp0 </> "style.css") styleCss
-        -- FIXME write index.html, style.css
+        dirs <- writeIndexStyle (Just $ unSnapshotIdent ident) fp0
        let cp = (proc "tar" $ "cJf" : fp : "index.html" : "style.css" : dirs)
                { cwd = Just $ fpToString fp0
                }
@ -187,7 +183,7 @@ uploadDocMap :: UploadDocMap -> Manager -> IO (Response LByteString)
 uploadDocMap UploadDocMap {..} man = do
    docmap <- docsListing udmPlan udmDocDir
    req1 <- parseUrl $ unpack $ unStackageServer udmServer ++ "/upload-doc-map"
-    req2 <- formDataBody (formData docmap) req1
+    req2 <- formDataBody (formData $ Y.encode docmap) req1
    let req3 = req2
            { method = "PUT"
            , requestHeaders =
@ -205,61 +201,54 @@ uploadDocMap UploadDocMap {..} man = do
        , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap
        ]

-mkIndex :: String -> [String] -> String
-mkIndex snapid dirs = concat
-    [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
-    , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"
-    , "<link rel='stylesheet' href='style.css'>"
-    , "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"
-    , "</head>"
-    , "<body><div class='container'>"
-    , "<div class='row'><div class='span12 col-md-12'>"
-    , "<h1>Haddock documentation index</h1>"
-    , "<p class='return'><a href=\"http://www.stackage.org/stackage/"
-    , snapid
-    , "\">Return to snapshot</a></p><ul>"
-    , concatMap toLI dirs
-    , "</ul></div></div></div></body></html>"
-    ]
-  where
-    toLI name = concat
-        [ "<li><a href='"
-        , name
-        , "/index.html'>"
-        , name
-        , "</a></li>"
-        ]
+data UploadBundleV2 = UploadBundleV2
+    { ub2Server :: StackageServer
+    , ub2AuthToken :: Text
+    , ub2Bundle :: FilePath
+    }

-styleCss :: String
-styleCss = concat
-    [ "@media (min-width: 530px) {"
-    , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
-    , "}"
-    , "@media (min-width: 760px) {"
-    , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
-    , "}"
-    , "ul {"
-    , "  margin-left: 0;"
-    , "  padding-left: 0;"
-    , "  list-style-type: none;"
-    , "}"
-    , "body {"
-    , "  background: #f0f0f0;"
-    , "  font-family: 'Lato', sans-serif;"
-    , "  text-shadow: 1px 1px 1px #ffffff;"
-    , "  font-size: 20px;"
-    , "  line-height: 30px;"
-    , "  padding-bottom: 5em;"
-    , "}"
-    , "h1 {"
-    , "  font-weight: normal;"
-    , "  color: #06537d;"
-    , "  font-size: 45px;"
-    , "}"
-    , ".return a {"
-    , "  color: #06537d;"
-    , "  font-style: italic;"
-    , "}"
-    , ".return {"
-    , "  margin-bottom: 1em;"
-    , "}"]
+uploadBundleV2 :: UploadBundleV2 -> Manager -> IO Text
+uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile (fpToString ub2Bundle) IO.ReadMode $ \h -> do
+    size <- IO.hFileSize h
+    req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2"
+    let req2 = req1
+            { method = "PUT"
+            , requestHeaders =
+                [ ("Authorization", encodeUtf8 ub2AuthToken)
+                , ("Accept", "application/json")
+                , ("Content-Type", "application/x-tar")
+                ]
+            , requestBody = HCC.requestBodySource (fromIntegral size)
+                          $ sourceHandle h $= printProgress size
+            }
+        sink = decodeUtf8C =$ fix (\loop -> do
+            mx <- peekC
+            case mx of
+                Nothing -> error $ "uploadBundleV2: premature end of stream"
+                Just _ -> do
+                    l <- lineC $ takeCE 4096 =$ foldC
+                    let (cmd, msg') = break (== ':') l
+                        msg = dropWhile (== ' ') $ dropWhile (== ':') msg'
+                    case cmd of
+                        "CONT" -> do
+                            putStrLn msg
+                            loop
+                        "FAILURE" -> error $ "uploadBundleV2 failed: " ++ unpack msg
+                        "SUCCESS" -> return msg
+                        _ -> error $ "uploadBundleV2: unknown command " ++ unpack cmd
+            )
+    withResponse req2 man $ \res -> HCC.bodyReaderSource (responseBody res) $$ sink
+  where
+    printProgress total =
+        loop 0 0
+      where
+        loop sent lastPercent =
+            await >>= maybe (putStrLn "Upload complete") go
+          where
+            go bs = do
+                yield bs
+                let sent' = sent + fromIntegral (length bs)
+                    percent = sent' * 100 `div` total
+                when (percent /= lastPercent)
+                    $ putStrLn $ "Upload progress: " ++ tshow percent ++ "%"
+                loop sent' percent
--- a/stackage.cabal
+++ b/stackage.cabal
@ -1,5 +1,5 @@
 name:                stackage
-version:             0.3.1
+version:             0.4.0
 synopsis:            "Stable Hackage," tools for creating a vetted set of packages from Hackage.
 description:         Please see <http://www.stackage.org/package/stackage> for a description and documentation.
 homepage:            https://github.com/fpco/stackage
@ -52,6 +52,7 @@ library
                     , yaml
                     , unix-compat
                     , http-client
+                     , http-conduit
                     , http-client-tls
                     , temporary
                     , data-default-class