WIP new upload

ChangeLog.md

@@ -1,3 +1,7 @@
+## 0.4.0
+
+* Upload bundle V2 stuff
+
 ## 0.3.1
 
 * Added `justCheck` and `stackage check` command line.

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"

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

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
+                return $ singletonMap (display package) $ PackageDocs
-                    [ "version" Y..= display version
+                    { pdVersion = display version
-                    , "modules" Y..= m
+                    , 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;"
+    , "}"]

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
+        dirs <- writeIndexStyle (Just $ unSnapshotIdent ident) fp0
-              $ 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
         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
+data UploadBundleV2 = UploadBundleV2
-mkIndex snapid dirs = concat
+    { ub2Server :: StackageServer
-    [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"
+    , ub2AuthToken :: Text
-    , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"
+    , ub2Bundle :: FilePath
-    , "<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>"
-        ]
 
-styleCss :: String
+uploadBundleV2 :: UploadBundleV2 -> Manager -> IO Text
-styleCss = concat
+uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile (fpToString ub2Bundle) IO.ReadMode $ \h -> do
-    [ "@media (min-width: 530px) {"
+    size <- IO.hFileSize h
-    , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"
+    req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2"
-    , "}"
+    let req2 = req1
-    , "@media (min-width: 760px) {"
+            { method = "PUT"
-    , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"
+            , requestHeaders =
-    , "}"
+                [ ("Authorization", encodeUtf8 ub2AuthToken)
-    , "ul {"
+                , ("Accept", "application/json")
-    , "  margin-left: 0;"
+                , ("Content-Type", "application/x-tar")
-    , "  padding-left: 0;"
+                ]
-    , "  list-style-type: none;"
+            , requestBody = HCC.requestBodySource (fromIntegral size)
-    , "}"
+                          $ sourceHandle h $= printProgress size
-    , "body {"
+            }
-    , "  background: #f0f0f0;"
+        sink = decodeUtf8C =$ fix (\loop -> do
-    , "  font-family: 'Lato', sans-serif;"
+            mx <- peekC
-    , "  text-shadow: 1px 1px 1px #ffffff;"
+            case mx of
-    , "  font-size: 20px;"
+                Nothing -> error $ "uploadBundleV2: premature end of stream"
-    , "  line-height: 30px;"
+                Just _ -> do
-    , "  padding-bottom: 5em;"
+                    l <- lineC $ takeCE 4096 =$ foldC
-    , "}"
+                    let (cmd, msg') = break (== ':') l
-    , "h1 {"
+                        msg = dropWhile (== ' ') $ dropWhile (== ':') msg'
-    , "  font-weight: normal;"
+                    case cmd of
-    , "  color: #06537d;"
+                        "CONT" -> do
-    , "  font-size: 45px;"
+                            putStrLn msg
-    , "}"
+                            loop
-    , ".return a {"
+                        "FAILURE" -> error $ "uploadBundleV2 failed: " ++ unpack msg
-    , "  color: #06537d;"
+                        "SUCCESS" -> return msg
-    , "  font-style: italic;"
+                        _ -> error $ "uploadBundleV2: unknown command " ++ unpack cmd
-    , "}"
+            )
-    , ".return {"
+    withResponse req2 man $ \res -> HCC.bodyReaderSource (responseBody res) $$ sink
-    , "  margin-bottom: 1em;"
+  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

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