diff --git a/Application.hs b/Application.hs index eace2ff..ac40aa7 100644 --- a/Application.hs +++ b/Application.hs @@ -22,7 +22,7 @@ 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 Data.BlobStore (fileStore, storeWrite) +import Data.BlobStore (fileStore, storeWrite, cachedS3Store) import Data.Hackage import Data.Hackage.Views import Data.Conduit.Lazy (MonadActive, monadActive) @@ -32,6 +32,7 @@ import Control.Monad.Trans.Resource.Internal (ResourceT (..)) import Control.Monad.Reader (MonadReader (..)) import Filesystem (getModified, removeTree) import Data.Time (diffUTCTime) +import qualified Aws -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! @@ -107,6 +108,16 @@ makeFoundation conf = do progressMap' <- newIORef mempty nextProgressKey' <- newIORef 0 + blobStore' <- + case storeConfig $ appExtra conf of + BSCFile root -> return $ fileStore root + BSCAWS root access secret bucket prefix -> do + creds <- Aws.Credentials + <$> pure (encodeUtf8 access) + <*> pure (encodeUtf8 secret) + <*> newIORef [] + return $ cachedS3Store root creds bucket prefix manager + let logger = Yesod.Core.Types.Logger loggerSet' getter foundation = App { settings = conf @@ -116,9 +127,7 @@ makeFoundation conf = do , persistConfig = dbconf , appLogger = logger , genIO = gen - , blobStore = - case storeConfig $ appExtra conf of - BSCFile root -> fileStore root + , blobStore = blobStore' , progressMap = progressMap' , nextProgressKey = nextProgressKey' } diff --git a/Data/BlobStore.hs b/Data/BlobStore.hs index b923588..df1d250 100644 --- a/Data/BlobStore.hs +++ b/Data/BlobStore.hs @@ -7,15 +7,20 @@ module Data.BlobStore , storeRead , storeExists , BackupToS3 (..) + , cachedS3Store ) where import ClassyPrelude.Yesod +import Control.Exception.Lifted (bracketOnError) import qualified Filesystem as F import Control.Monad.Reader (MonadReader, ask) import Control.Monad.Trans.Resource (release) import qualified Aws +import Aws.S3 as Aws import qualified System.IO as IO +import System.Directory (getTemporaryDirectory) +-- FIXME add a sendfile optimization 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))) @@ -64,7 +69,7 @@ fileStore :: ToPath key fileStore root = BlobStore { storeWrite' = \key -> (sinkHandle . snd) <$> mkAcquireType (do - let fp = toFP key + let fp = toFP root key F.createTree $ directory fp IO.openBinaryTempFile (fpToString $ directory fp) @@ -75,30 +80,92 @@ fileStore root = BlobStore hClose h `finally` F.removeFile (fpFromString fp) _ -> do hClose h - F.rename (fpFromString fp) (toFP key)) + F.rename (fpFromString fp) (toFP root key)) , storeRead' = \key -> (fmap sourceHandle) <$> mkAcquire - ((Just <$> F.openFile (toFP key) F.ReadMode) + ((Just <$> F.openFile (toFP root key) F.ReadMode) `catch` \e -> if isDoesNotExistError e then return Nothing else throwIO e) (maybe (return ()) hClose) - , storeExists' = liftIO . F.isFile . toFP + , storeExists' = liftIO . F.isFile . toFP root } - where - toFP key = foldl' (\x y -> x fpFromText y) root (toPath key) -{- +toFP root 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 + -> Aws.Credentials + -> Text -- bucket FIXME Aws.Bucket -> Text -- ^ prefix within bucket + -> Manager -> BlobStore key -cachedS3Store cache bucket prefix = BlobStore - { storeWrite' = \key -> - } --} +cachedS3Store cache creds bucket prefix manager = + self + where + self = BlobStore + { storeWrite' = \key -> + if shouldBackup key + then do + tempDir <- liftIO getTemporaryDirectory + (fp, h) <- mkAcquire + (IO.openBinaryTempFile tempDir "store-write-cache") + (\(fp, h) -> hClose h >> F.removeFile (fpFromString fp)) + return $ do + len <- getZipSink $ ZipSink (sinkHandle h) *> ZipSink lengthCE + liftIO $ hClose h + liftIO $ IO.withFile fp IO.ReadMode $ \inH -> runResourceT $ do + res <- Aws.aws + (Aws.Configuration Aws.Timestamp creds + $ Aws.defaultLog Aws.Error) + Aws.defServiceConfig + manager + (Aws.putObject bucket (toS3Path key) + $ requestBodySource len + $ sourceHandle inH) + void $ Aws.readResponseIO res + else storeWrite' (fileStore cache) key + , storeRead' = \key -> + if shouldBackup key + then do + msrc <- storeRead' (fileStore cache) key + case msrc of + Just src -> return $ Just src + Nothing -> do + liftIO $ runResourceT $ do + res <- Aws.aws + (Aws.Configuration Aws.Timestamp creds + $ Aws.defaultLog Aws.Error) + Aws.defServiceConfig + manager + (Aws.getObject bucket (toS3Path key)) + gor <- Aws.readResponseIO res + let fp = toFP cache key + bracketOnError + (liftIO $ IO.openBinaryTempFile + (fpToString $ directory fp) + (fpToString $ filename fp)) + (\(fpTmp, h) -> liftIO $ do + hClose h + F.removeFile (fpFromString fpTmp)) + $ \(fpTmp, h) -> do + responseBody (Aws.gorResponse gor) $$+- sinkHandle h + liftIO $ do + hClose h + F.rename (fpFromString fpTmp) fp + storeRead' (fileStore cache) key -- FIXME optimize? + else storeRead' (fileStore cache) key + , storeExists' = \key -> + if shouldBackup key + then liftIO $ withAcquire (storeRead' self key) + $ \msrc -> return + $ maybe False (const True) + (msrc :: Maybe (Source IO ByteString)) + else storeExists' (fileStore cache) key + } + + toS3Path key = intercalate "/" $ filter (not . null) $ prefix : toPath key class BackupToS3 key where shouldBackup :: key -> Bool diff --git a/Settings.hs b/Settings.hs index 2ef86a5..68b1ff3 100644 --- a/Settings.hs +++ b/Settings.hs @@ -14,7 +14,7 @@ import Yesod.Default.Util import Data.Yaml import Settings.Development import Text.Hamlet -import Data.Aeson (withText) +import Data.Aeson (withText, withObject) import Types -- | Which Persistent backend this site is using. @@ -76,11 +76,20 @@ parseExtra _ o = Extra <*> (HackageRoot <$> o .: "hackage-root") data BlobStoreConfig = BSCFile !FilePath + | BSCAWS !FilePath !Text !Text !Text !Text 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 + parseJSON v = file v <|> aws v + where + file = withText "BlobStoreConfig" $ \t -> + case () of + () + | Just root <- stripPrefix "file:" t -> return $ BSCFile $ fpFromText root + | otherwise -> fail $ "Invalid BlobStoreConfig: " ++ show t + aws = withObject "BlobStoreConfig" $ \o -> BSCAWS + <$> (fpFromText <$> (o .: "local")) + <*> o .: "access" + <*> o .: "secret" + <*> o .: "bucket" + <*> o .:? "prefix" .!= "" diff --git a/Types.hs b/Types.hs index a853be8..9a06d9c 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 + deriving (Show, Eq, Ord, Typeable) instance ToPath StoreKey where toPath (HackageCabal name version) = ["hackage", toPathPiece name, toPathPiece version ++ ".cabal"]