Download bundles and metadata

Handler/StackageHome.hs

@@ -1,6 +1,7 @@
 module Handler.StackageHome where
 
 import Import
+import Data.BlobStore (storeExists)
 
 getStackageHomeR :: PackageSetIdent -> Handler Html
 getStackageHomeR ident = do
@@ -8,6 +9,35 @@ getStackageHomeR ident = do
         Entity _ stackage <- getBy404 $ UniqueStackage ident
         user <- get404 $ stackageUser stackage
         return (stackage, user)
+
+    hasBundle <- storeExists $ SnapshotBundle ident
     defaultLayout $ do
         setTitle $ toHtml $ stackageTitle stackage
         $(widgetFile "stackage-home")
+
+getStackageMetadataR :: PackageSetIdent -> Handler TypedContent
+getStackageMetadataR ident = do
+    Entity sid _ <- runDB $ getBy404 $ UniqueStackage ident
+    respondSourceDB typePlain $ do
+        sendChunkBS "Override packages\n"
+        sendChunkBS "=================\n"
+        stream sid True
+        sendChunkBS "\nPackages from Hackage\n"
+        sendChunkBS   "=====================\n"
+        stream sid False
+  where
+    stream sid isOverwrite =
+        selectSource
+            [ PackageStackage ==. sid
+            , PackageOverwrite ==. isOverwrite
+            ]
+            [ Asc PackageName'
+            , Asc PackageVersion
+            ] $= mapC (Chunk . toBuilder . showPackage)
+
+    showPackage (Entity _ (Package _ name version _)) = concat
+        [ toPathPiece name
+        , "-"
+        , toPathPiece version
+        , "\n"
+        ]

Handler/StackageIndex.hs

@@ -11,3 +11,16 @@ getStackageIndexR ident = do
         Just src -> do
             addHeader "content-disposition" "attachment; filename=\"00-index.tar.gz\""
             respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src
+
+getStackageBundleR :: PackageSetIdent -> Handler TypedContent
+getStackageBundleR ident = do
+    msrc <- storeRead $ SnapshotBundle ident
+    case msrc of
+        Nothing -> notFound
+        Just src -> do
+            addHeader "content-disposition" $ mconcat
+                [ "attachment; filename=\"bundle-"
+                , toPathPiece ident
+                , ".tar.gz\""
+                ]
+            respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src

Handler/UploadStackage.hs

@@ -6,7 +6,7 @@ import Crypto.Hash.Conduit (sinkHash)
 import Crypto.Hash (Digest, SHA1)
 import Data.Byteable (toBytes)
 import qualified Data.ByteString.Base16 as B16
-import Data.Conduit.Zlib (ungzip)
+import Data.Conduit.Zlib (gzip, ungzip)
 import qualified Codec.Archive.Tar as Tar
 import qualified Data.Text as T
 import Filesystem.Path (splitExtension)
@@ -96,11 +96,12 @@ putUploadStackageR = do
                 -- Evil lazy I/O thanks to tar package
                 lbs <- readFile $ fpFromString fp
                 withSystemTempDirectory "build00index." $ \dir -> do
-                    LoopState _ stackage files _ <- execStateT (loop update (Tar.read lbs)) LoopState
+                    LoopState _ stackage files _ contents <- execStateT (loop update (Tar.read lbs)) LoopState
                         { lsRoot = fpFromString dir
                         , lsStackage = initial
                         , lsFiles = mempty
                         , lsIdent = ident
+                        , lsContents = []
                         }
                     withSystemTempFile "newindex" $ \fp' h -> do
                         ec <- liftIO $ do
@@ -113,7 +114,15 @@ putUploadStackageR = do
                         if ec == ExitSuccess
                             then do
                                 sourceFile (fpFromString fp') $$ storeWrite (CabalIndex ident)
-                                runDB $ insert_ stackage
+                                sourceFile (fpFromString fp) $$ gzip =$ storeWrite (SnapshotBundle ident)
+                                runDB $ do
+                                    sid <- insert stackage
+                                    forM_ contents $ \(name, version, overwrite) -> insert_ Package
+                                        { packageStackage = sid
+                                        , packageName' = name
+                                        , packageVersion = version
+                                        , packageOverwrite = overwrite
+                                        }
 
                                 setAlias
 
@@ -184,7 +193,12 @@ putUploadStackageR = do
                 let fp' = lsRoot ls </> fp
                 liftIO $ createTree $ directory fp'
                 src $$ sinkFile fp'
-                put ls { lsFiles = insertSet fp $ lsFiles ls }
+                put ls
+                    { lsFiles = insertSet fp $ lsFiles ls
+                    , lsContents
+                        = (name, version, isOverride)
+                        : lsContents ls
+                    }
           where
             fp = mkFP name version
 
@@ -209,8 +223,12 @@ data LoopState = LoopState
     , lsStackage :: !Stackage
     , lsFiles :: !(Set FilePath)
     , lsIdent :: !PackageSetIdent
+
+    , lsContents :: ![(PackageName, Version, IsOverride)] -- FIXME use SnocVector when ready
     }
 
+type IsOverride = Bool
+
 extractCabal :: (MonadLogger m, MonadThrow m)
              => LByteString
              -> PackageName -- ^ name

Types.hs

@@ -42,6 +42,7 @@ data StoreKey = HackageCabal !PackageName !Version
               | HackageViewCabal !HackageView !PackageName !Version
               | HackageViewSdist !HackageView !PackageName !Version
               | HackageViewIndex !HackageView
+              | SnapshotBundle !PackageSetIdent
     deriving (Show, Eq, Ord, Typeable)
 
 instance ToPath StoreKey where
@@ -71,6 +72,10 @@ instance ToPath StoreKey where
         , toPathPiece viewName
         , "00-index.tar.gz"
         ]
+    toPath (SnapshotBundle ident) =
+        [ "bundle"
+        , toPathPiece ident ++ ".tar.gz"
+        ]
 instance BackupToS3 StoreKey where
     shouldBackup HackageCabal{} = False
     shouldBackup HackageSdist{} = False
@@ -79,6 +84,7 @@ instance BackupToS3 StoreKey where
     shouldBackup HackageViewCabal{} = False
     shouldBackup HackageViewSdist{} = False
     shouldBackup HackageViewIndex{} = False
+    shouldBackup SnapshotBundle{} = True
 
 newtype HackageRoot = HackageRoot { unHackageRoot :: Text }
     deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup)

config/models

@@ -33,3 +33,9 @@ Alias
     name Slug
     target PackageSetIdent
     UniqueAlias user name
+
+Package
+    stackage StackageId
+    name' PackageName sql=name
+    version Version
+    overwrite Bool

config/routes

@@ -11,7 +11,9 @@
 /reset-token ResetTokenR POST
 /upload UploadStackageR GET PUT
 /stackage/#PackageSetIdent StackageHomeR GET
+/stackage/#PackageSetIdent/metadata StackageMetadataR GET
 /stackage/#PackageSetIdent/00-index.tar.gz StackageIndexR GET
+/stackage/#PackageSetIdent/bundle StackageBundleR GET
 /stackage/#PackageSetIdent/package/#PackageNameVersion StackageSdistR GET
 /hackage-view/#HackageView/00-index.tar.gz HackageViewIndexR GET
 /hackage-view/#HackageView/package/#PackageNameVersion HackageViewSdistR GET

templates/stackage-home.hamlet

@@ -26,3 +26,12 @@ $newline never
     <pre>
         <code>
             \$ cabal update
+
+    $if hasBundle
+        <p>
+            <a href=@{StackageMetadataR ident}>View metadata on this snapshot
+            , such as package versions.
+        <p>
+            <a href=@{StackageBundleR ident}>Download the original bundle file.
+            \ #
+            <i>This is useful for making modifications to an existing snapshot.