From 92042ed193bccf0a6a80594089bd582add602e4b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 30 Jul 2014 16:57:52 +0300 Subject: [PATCH] Download bundles and metadata --- Handler/StackageHome.hs | 30 ++++++++++++++++++++++++++++++ Handler/StackageIndex.hs | 13 +++++++++++++ Handler/UploadStackage.hs | 26 ++++++++++++++++++++++---- Types.hs | 6 ++++++ config/models | 6 ++++++ config/routes | 2 ++ templates/stackage-home.hamlet | 9 +++++++++ 7 files changed, 88 insertions(+), 4 deletions(-) diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index fde0d03..216f0fd 100644 --- a/Handler/StackageHome.hs +++ b/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" + ] diff --git a/Handler/StackageIndex.hs b/Handler/StackageIndex.hs index 02a4a6c..8dca5fa 100644 --- a/Handler/StackageIndex.hs +++ b/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 diff --git a/Handler/UploadStackage.hs b/Handler/UploadStackage.hs index 8bfcc8b..9faf402 100644 --- a/Handler/UploadStackage.hs +++ b/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 diff --git a/Types.hs b/Types.hs index 9a06d9c..3d442f9 100644 --- a/Types.hs +++ b/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) diff --git a/config/models b/config/models index 97a30f4..f6d2f10 100644 --- a/config/models +++ b/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 diff --git a/config/routes b/config/routes index 64dafa0..d15243b 100644 --- a/config/routes +++ b/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 diff --git a/templates/stackage-home.hamlet b/templates/stackage-home.hamlet index 3676fea..90dc7ec 100644 --- a/templates/stackage-home.hamlet +++ b/templates/stackage-home.hamlet @@ -26,3 +26,12 @@ $newline never 
         
             \$ cabal update
+
+    $if hasBundle
+        

+            View metadata on this snapshot
+            , such as package versions.
+        

+            Download the original bundle file.
+            \ #
+            This is useful for making modifications to an existing snapshot.