From 95250c5b0904837f916c99c8785dca6a67dc9afe Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 10 Apr 2014 10:59:58 +0300 Subject: [PATCH] Blob storage and downloading from Hackage --- .gitignore | 1 + Application.hs | 19 +++++++- Data/BlobStore.hs | 94 ++++++++++++++++++++++++++++++++++++ Data/Hackage.hs | 103 ++++++++++++++++++++++++++++++++++++++++ Foundation.hs | 9 ++++ Handler/HackageSdist.hs | 19 ++++++++ Import.hs | 1 + Settings.hs | 19 +++++++- Types.hs | 36 ++++++++++++++ config/routes | 1 + config/settings.yml | 2 + stackage-server.cabal | 13 ++++- 12 files changed, 314 insertions(+), 3 deletions(-) create mode 100644 Data/BlobStore.hs create mode 100644 Data/Hackage.hs create mode 100644 Handler/HackageSdist.hs create mode 100644 Types.hs diff --git a/.gitignore b/.gitignore index 5c48818..97e85ef 100644 --- a/.gitignore +++ b/.gitignore @@ -12,3 +12,4 @@ yesod-devel/ cabal.sandbox.config .DS_Store *.swp +/dev-blob-store/ diff --git a/Application.hs b/Application.hs index 73fdd9a..daadee9 100644 --- a/Application.hs +++ b/Application.hs @@ -16,13 +16,16 @@ import Network.Wai.Middleware.RequestLogger import qualified Network.Wai.Middleware.RequestLogger as RequestLogger import qualified Database.Persist import Control.Monad.Logger (runLoggingT) +import Control.Monad.Reader (runReaderT) import Control.Concurrent (forkIO, threadDelay) -import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize) +import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr) import Network.Wai.Logger (clockDateCacher) import Yesod.Core.Types (loggerSet, Logger (Logger)) import qualified System.Random.MWC as MWC import qualified Network.Wai as Wai import Network.Wai.Middleware.MethodOverride (methodOverride) +import Data.BlobStore (fileStore) +import Data.Hackage -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! @@ -30,6 +33,7 @@ import Handler.Home import Handler.Profile import Handler.Email import Handler.ResetToken +import Handler.HackageSdist -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the @@ -83,6 +87,7 @@ makeFoundation conf = do let updateLoop = do threadDelay 1000000 updater + flushLogStr loggerSet' -- FIXME include upstream! updateLoop _ <- forkIO updateLoop @@ -97,6 +102,9 @@ makeFoundation conf = do , persistConfig = dbconf , appLogger = logger , genIO = gen + , blobStore = + case storeConfig $ appExtra conf of + BSCFile root -> fileStore root } -- Perform database migration using our application's logging settings. @@ -104,6 +112,15 @@ makeFoundation conf = do (Database.Persist.runPool dbconf (runMigration migrateAll) p) (messageLoggerSource foundation logger) + -- Start the cabal file loader + void $ forkIO $ forever $ flip runLoggingT (messageLoggerSource foundation logger) $ do + when development $ liftIO $ threadDelay $ 5 * 60 * 1000000 + eres <- tryAny $ runReaderT loadCabalFiles foundation + case eres of + Left e -> $logError $ tshow e + Right () -> return () + liftIO $ threadDelay $ 30 * 60 * 1000000 + return foundation -- for yesod devel diff --git a/Data/BlobStore.hs b/Data/BlobStore.hs new file mode 100644 index 0000000..544865e --- /dev/null +++ b/Data/BlobStore.hs @@ -0,0 +1,94 @@ +module Data.BlobStore + ( BlobStore (..) + , ToPath (..) + , fileStore + , HasBlobStore (..) + , storeWrite + , storeRead + , storeExists + ) where + +import ClassyPrelude.Yesod +import qualified Filesystem as F +import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.Trans.Resource (release) +import qualified Aws + +data BlobStore key = BlobStore + { storeWrite' :: !(forall m. MonadIO m => key -> Acquire (Sink ByteString m ())) + , storeRead' :: !(forall m. MonadIO m => key -> Acquire (Maybe (Source m ByteString))) + , storeExists' :: !(forall m. MonadIO m => key -> m Bool) + } + +class HasBlobStore a key | a -> key where + getBlobStore :: a -> BlobStore key +instance HasBlobStore (BlobStore key) key where + getBlobStore = id + +storeWrite :: (MonadResource m, MonadReader env m, HasBlobStore env key) + => key + -> Consumer ByteString m () +storeWrite key = do + store <- liftM getBlobStore ask + (releaseKey, sink) <- allocateAcquire $ storeWrite' store key + toConsumer sink + release releaseKey + +storeRead :: (MonadResource m, MonadReader env m, HasBlobStore env key) + => key + -> m (Maybe (Source m ByteString)) +storeRead key = do + store <- liftM getBlobStore ask + (releaseKey, msrc) <- allocateAcquire $ storeRead' store key + case msrc of + Nothing -> do + release releaseKey + return Nothing + Just src -> return $ Just $ src >> release releaseKey + +storeExists :: (MonadIO m, MonadReader env m, HasBlobStore env key) + => key + -> m Bool +storeExists key = do + store <- liftM getBlobStore ask + storeExists' store key + +class ToPath a where + toPath :: a -> [Text] + +fileStore :: ToPath key + => FilePath -- ^ root + -> BlobStore key +fileStore root = BlobStore + { storeWrite' = \key -> sinkHandle <$> mkAcquire + (do + let fp = toFP key + F.createTree $ directory fp + F.openFile fp F.WriteMode) + hClose + , storeRead' = \key -> (fmap sourceHandle) <$> mkAcquire + ((Just <$> F.openFile (toFP key) F.ReadMode) + `catch` \e -> + if isDoesNotExistError e + then return Nothing + else throwIO e) + (maybe (return ()) hClose) + , storeExists' = liftIO . F.isFile . toFP + } + where + toFP key = foldl' (\x y -> x fpFromText y) root (toPath key) + +{- +-- | Note: Only use with data which will never be modified! +cachedS3Store :: (BackupToS3 key, ToPath key) + => FilePath -- ^ cache directory + -> Aws.Bucket + -> Text -- ^ prefix within bucket + -> BlobStore key +cachedS3Store cache bucket prefix = BlobStore + { storeWrite' = \key -> + } + +class BackupToS3 key where + shouldBackup :: key -> Bool +-} diff --git a/Data/Hackage.hs b/Data/Hackage.hs new file mode 100644 index 0000000..dbff17a --- /dev/null +++ b/Data/Hackage.hs @@ -0,0 +1,103 @@ +module Data.Hackage + ( loadCabalFiles + , sourceHackageSdist + ) where + +import ClassyPrelude.Yesod +import Types +import Data.BlobStore +import Data.Conduit.Lazy (MonadActive (..), lazyConsume) +import Control.Monad.Logger (LoggingT) +import qualified Codec.Archive.Tar as Tar +import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.Trans.Resource (release) +import qualified Data.Text as T +import Data.Conduit.Zlib (ungzip) + +loadCabalFiles :: ( MonadActive m + , MonadBaseControl IO m + , MonadThrow m + , MonadIO m + , MonadReader env m + , HasHttpManager env + , HasBlobStore env StoreKey + , HasHackageRoot env + , MonadLogger m + ) + => m () +loadCabalFiles = do + HackageRoot root <- liftM getHackageRoot ask + $logDebug $ "Entering loadCabalFiles, root == " ++ root + req <- parseUrl $ unpack $ root ++ "/00-index.tar.gz" + withResponse req $ \res -> do + $logDebug $ "Got a response, processing" + bss <- lazyConsume $ responseBody res $= ungzip + loop $ Tar.read $ fromChunks bss + where + loop (Tar.Next entry entries) = go entry >> loop entries + loop Tar.Done = return () + loop (Tar.Fail e) = throwM e + + go entry = do + case Tar.entryContent entry of + Tar.NormalFile lbs _ + | Just (name, version) <- parseFilePath (Tar.entryPath entry) -> do + let key = HackageCabal name version + exists <- storeExists key + store <- liftM getBlobStore ask + unless exists $ withAcquire (storeWrite' store key) $ \sink -> + sourceLazy lbs $$ sink + _ -> return () + +parseFilePath :: String -> Maybe (PackageName, Version) +parseFilePath s = + case filter (not . null) $ T.split (== '/') $ pack s of + (name:version:_) -> Just (PackageName name, Version version) + _ -> Nothing + +sourceHackageSdist :: ( MonadIO m + , MonadThrow m + , MonadBaseControl IO m + , MonadResource m + , MonadReader env m + , HasHttpManager env + , HasHackageRoot env + , HasBlobStore env StoreKey + ) + => PackageName + -> Version + -> m (Maybe (Source m ByteString)) +sourceHackageSdist name version = do + let key = HackageSdist name version + msrc1 <- storeRead key + case msrc1 of + Just src -> return $ Just src + Nothing -> do + HackageRoot root <- liftM getHackageRoot ask + let url = concat + [ root + , "/" + , toPathPiece name + , "/" + , toPathPiece version + , "/" + , toPathPiece name + , "-" + , toPathPiece version + , ".tar.gz" + ] + req' <- parseUrl $ unpack url + let req = req' { checkStatus = \_ _ _ -> Nothing } + exists <- withResponse req $ \res -> + if responseStatus res == status200 + then do + responseBody res $$ storeWrite key + return True + else return False + if exists + then storeRead key + else return Nothing + +-- FIXME orphan +instance MonadActive m => MonadActive (LoggingT m) where + monadActive = lift monadActive diff --git a/Foundation.hs b/Foundation.hs index 37f0249..2cc8555 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -17,6 +17,8 @@ import Text.Hamlet (hamletFile) import Yesod.Core.Types (Logger) import Data.Slug (safeMakeSlug, HasGenIO (getGenIO), randomSlug, Slug) import qualified System.Random.MWC as MWC +import Data.BlobStore +import Types -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -30,14 +32,21 @@ data App = App , persistConfig :: Settings.PersistConf , appLogger :: Logger , genIO :: !MWC.GenIO + , blobStore :: !(BlobStore StoreKey) } +instance HasBlobStore App StoreKey where + getBlobStore = blobStore + instance HasGenIO App where getGenIO = genIO instance HasHttpManager App where getHttpManager = httpManager +instance HasHackageRoot App where + getHackageRoot = hackageRoot . appExtra . settings + -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: -- http://www.yesodweb.com/book/routing-and-handlers diff --git a/Handler/HackageSdist.hs b/Handler/HackageSdist.hs new file mode 100644 index 0000000..d20da2f --- /dev/null +++ b/Handler/HackageSdist.hs @@ -0,0 +1,19 @@ +module Handler.HackageSdist where + +import Import +import Data.Hackage + +getHackageSdistR :: PackageName -> Version -> Handler TypedContent +getHackageSdistR name version = do + msrc <- sourceHackageSdist name version + case msrc of + Nothing -> notFound + Just src -> do + addHeader "content-disposition" $ concat + [ "attachment; filename=\"" + , toPathPiece name + , "-" + , toPathPiece version + , ".tar.gz" + ] + respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src diff --git a/Import.hs b/Import.hs index f55b4ad..89398c5 100644 --- a/Import.hs +++ b/Import.hs @@ -5,6 +5,7 @@ module Import import ClassyPrelude.Yesod as Import import Foundation as Import import Model as Import +import Types as Import import Settings as Import import Settings.Development as Import import Settings.StaticFiles as Import diff --git a/Settings.hs b/Settings.hs index 38b0540..2ef86a5 100644 --- a/Settings.hs +++ b/Settings.hs @@ -14,6 +14,8 @@ import Yesod.Default.Util import Data.Yaml import Settings.Development import Text.Hamlet +import Data.Aeson (withText) +import Types -- | Which Persistent backend this site is using. type PersistConf = PostgresConf @@ -63,7 +65,22 @@ widgetFile = (if development then widgetFileReload widgetFileSettings data Extra = Extra + { storeConfig :: !BlobStoreConfig + , hackageRoot :: !HackageRoot + } deriving Show parseExtra :: DefaultEnv -> Object -> Parser Extra -parseExtra _ _o = return Extra +parseExtra _ o = Extra + <$> o .: "blob-store" + <*> (HackageRoot <$> o .: "hackage-root") + +data BlobStoreConfig = BSCFile !FilePath + deriving Show + +instance FromJSON BlobStoreConfig where + parseJSON = withText "BlobStoreConfig" $ \t -> + case () of + () + | Just root <- stripPrefix "file:" t -> return $ BSCFile $ fpFromText root + | otherwise -> fail $ "Invalid BlobStoreConfig: " ++ show t diff --git a/Types.hs b/Types.hs new file mode 100644 index 0000000..4475b4c --- /dev/null +++ b/Types.hs @@ -0,0 +1,36 @@ +module Types where + +import ClassyPrelude.Yesod +import Data.BlobStore (ToPath (..)) +import Text.Blaze (ToMarkup) + +newtype PackageName = PackageName { unPackageName :: Text } + deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup) +newtype Version = Version { unVersion :: Text } + deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup) +newtype PackageSetIdent = PackageSetIdent { unPackageSetIdent :: Text } + deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup) + +data StoreKey = HackageCabal !PackageName !Version + | HackageSdist !PackageName !Version + | CabalIndex !PackageSetIdent + | CustomSdist !PackageSetIdent !PackageName !Version + +instance ToPath StoreKey where + toPath (HackageCabal name version) = ["hackage", toPathPiece name, toPathPiece version ++ ".cabal"] + toPath (HackageSdist name version) = ["hackage", toPathPiece name, toPathPiece version ++ ".tar.gz"] + toPath (CabalIndex ident) = ["cabal-index", toPathPiece ident ++ ".tar.gz"] + toPath (CustomSdist ident name version) = + [ "custom-tarball" + , toPathPiece ident + , toPathPiece name + , toPathPiece version ++ ".tar.gz" + ] + +newtype HackageRoot = HackageRoot { unHackageRoot :: Text } + deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup) + +class HasHackageRoot a where + getHackageRoot :: a -> HackageRoot +instance HasHackageRoot HackageRoot where + getHackageRoot = id diff --git a/config/routes b/config/routes index b8be2cd..3bda7b4 100644 --- a/config/routes +++ b/config/routes @@ -8,3 +8,4 @@ /profile ProfileR GET PUT /email/#EmailId EmailR DELETE /reset-token ResetTokenR POST +/hackage/#PackageName/#Version HackageSdistR GET diff --git a/config/settings.yml b/config/settings.yml index 828a5cc..4bf37a5 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -2,9 +2,11 @@ Default: &defaults host: "*4" # any IPv4 host port: 3000 approot: "http://localhost:3000" + hackage-root: http://hackage.haskell.org/packages/archive Development: <<: *defaults + blob-store: file:dev-blob-store Testing: <<: *defaults diff --git a/stackage-server.cabal b/stackage-server.cabal index 9f6274d..7df4fee 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -20,10 +20,14 @@ library Settings.StaticFiles Settings.Development Data.Slug + Data.BlobStore + Data.Hackage + Types Handler.Home Handler.Profile Handler.Email Handler.ResetToken + Handler.HackageSdist if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT @@ -47,6 +51,9 @@ library ViewPatterns TypeSynonymInstances FlexibleInstances + RankNTypes + FunctionalDependencies + PatternGuards build-depends: base >= 4 && < 5 , yesod >= 1.2.5 && < 1.3 @@ -80,7 +87,11 @@ library , mtl >= 2.1 && < 2.2 , blaze-markup >= 0.6 && < 0.7 , ghc-prim - , ghc-prim + , system-fileio + , resourcet + , aws >= 0.9 && < 0.10 + , conduit-extra + , tar >= 0.4 && < 0.5 executable stackage-server if flag(library-only)