diff --git a/Application.hs b/Application.hs index ffafe82..cdfdfa2 100644 --- a/Application.hs +++ b/Application.hs @@ -10,7 +10,6 @@ import qualified Aws import Control.Concurrent (forkIO, threadDelay) import Control.Exception (catch) import Control.Monad.Logger (runLoggingT, LoggingT, defaultLogStr) -import Data.BlobStore (fileStore, cachedS3Store) import Data.WebsiteContent import Data.Streaming.Network (bindPortTCP) import Data.Time (diffUTCTime) @@ -34,7 +33,6 @@ import Yesod.Default.Handlers import Yesod.Default.Main import Yesod.GitRepo import System.Environment (getEnvironment) -import Data.BlobStore (HasBlobStore (..), BlobStore) import System.IO (hSetBuffering, BufferMode (LineBuffering)) import qualified Data.ByteString as S import qualified Data.Text as T @@ -117,18 +115,6 @@ getDbConf conf = Database.Persist.loadConfig >>= Database.Persist.applyEnv -loadBlobStore :: Manager -> AppConfig DefaultEnv Extra -> IO (BlobStore StoreKey) -loadBlobStore manager conf = - 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 [] - <*> pure Nothing - return $ cachedS3Store root creds bucket prefix manager - -- | Loads up any necessary settings, creates your foundation datatype, and -- performs some initialization. makeFoundation :: Bool -> AppConfig DefaultEnv Extra -> IO App @@ -145,8 +131,6 @@ makeFoundation useEcho conf = do gen <- MWC.createSystemRandom - blobStore' <- loadBlobStore manager conf - websiteContent' <- if development then do void $ rawSystem "git" @@ -183,7 +167,6 @@ makeFoundation useEcho conf = do , persistConfig = dbconf , appLogger = logger , genIO = gen - , blobStore = blobStore' , websiteContent = websiteContent' , stackageDatabase = stackageDatabase' } @@ -215,14 +198,11 @@ makeFoundation useEcho conf = do data CabalLoaderEnv = CabalLoaderEnv { cleSettings :: !(AppConfig DefaultEnv Extra) - , cleBlobStore :: !(BlobStore StoreKey) , cleManager :: !Manager } instance HasHackageRoot CabalLoaderEnv where getHackageRoot = hackageRoot . appExtra . cleSettings -instance HasBlobStore CabalLoaderEnv StoreKey where - getBlobStore = cleBlobStore instance HasHttpManager CabalLoaderEnv where getHttpManager = cleManager diff --git a/Data/BlobStore.hs b/Data/BlobStore.hs deleted file mode 100644 index 65ee779..0000000 --- a/Data/BlobStore.hs +++ /dev/null @@ -1,178 +0,0 @@ -module Data.BlobStore - ( BlobStore (..) - , ToPath (..) - , fileStore - , HasBlobStore (..) - , storeWrite - , storeRead - , storeExists - , BackupToS3 (..) - , cachedS3Store - ) where - -import ClassyPrelude.Yesod -import qualified Filesystem as F -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))) - , 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 . snd) <$> mkAcquireType - (do - let fp = toFP root key - F.createTree $ directory fp - IO.openBinaryTempFile - (fpToString $ directory fp) - (fpToString $ filename fp)) - (\(fp, h) rt -> - case rt of - ReleaseException -> do - hClose h `finally` F.removeFile (fpFromString fp) - _ -> do - hClose h - F.rename (fpFromString fp) (toFP root key)) - , storeRead' = \key -> (fmap sourceHandle) <$> mkAcquire - ((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 root - } - -toFP :: ToPath a => FilePath -> a -> FilePath -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.Credentials - -> Text -- bucket FIXME Aws.Bucket - -> Text -- ^ prefix within bucket - -> Manager - -> BlobStore 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 - -- FIXME the need for this separate manager - -- indicates a serious bug in either aws or (more - -- likely) http-client, must investigate! - manager' <- newManager - 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 - liftIO $ IO.withFile fp IO.ReadMode $ \inH -> withAcquire - (storeWrite' (fileStore cache) key) - (sourceHandle inH $$) - 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 - join $ liftIO $ handle (\S3Error{} -> return $ return Nothing) $ 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 - liftIO $ F.createTree $ directory fp - 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 - return $ 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/Foundation.hs b/Foundation.hs index f4c43bd..e61bef3 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -1,7 +1,6 @@ module Foundation where import ClassyPrelude.Yesod -import Data.BlobStore import Data.Slug (safeMakeSlug, HasGenIO (getGenIO), randomSlug, Slug) import Data.WebsiteContent import qualified Database.Persist @@ -35,14 +34,10 @@ data App = App , persistConfig :: Settings.PersistConf , appLogger :: Logger , genIO :: MWC.GenIO - , blobStore :: BlobStore StoreKey , websiteContent :: GitRepo WebsiteContent , stackageDatabase :: StackageDatabase } -instance HasBlobStore App StoreKey where - getBlobStore = blobStore - instance HasGenIO App where getGenIO = genIO diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index 3dd3896..85b0988 100644 --- a/Handler/Haddock.hs +++ b/Handler/Haddock.hs @@ -6,7 +6,6 @@ import Control.Concurrent (forkIO) import Crypto.Hash (Digest, SHA1) import Crypto.Hash.Conduit (sinkHash) import Data.Aeson (withObject) -import Data.BlobStore import qualified Data.ByteString.Base16 as B16 import Data.Byteable (toBytes) import Data.Conduit.Zlib (gzip) diff --git a/Handler/StackageIndex.hs b/Handler/StackageIndex.hs index c6d85bc..be5c5e6 100644 --- a/Handler/StackageIndex.hs +++ b/Handler/StackageIndex.hs @@ -1,7 +1,6 @@ module Handler.StackageIndex where import Import -import Data.BlobStore import Stackage.Database getStackageIndexR :: SnapName -> Handler TypedContent diff --git a/Handler/StackageSdist.hs b/Handler/StackageSdist.hs index ddcf68d..4e8f132 100644 --- a/Handler/StackageSdist.hs +++ b/Handler/StackageSdist.hs @@ -3,7 +3,6 @@ module Handler.StackageSdist ) where import Import -import Data.BlobStore import Stackage.Database import Handler.Package (packagePage) diff --git a/Types.hs b/Types.hs index 3fc98fc..f770c56 100644 --- a/Types.hs +++ b/Types.hs @@ -2,7 +2,6 @@ module Types where import ClassyPrelude.Yesod import Data.Aeson -import Data.BlobStore (ToPath (..), BackupToS3 (..)) import Data.Hashable (hashUsing) import Text.Blaze (ToMarkup) import Database.Persist.Sql (PersistFieldSql (sqlType)) @@ -60,52 +59,11 @@ instance PathPiece PackageNameVersion where where f c = (c == '.') || ('0' <= c && c <= '9') -data StoreKey = HackageCabal !PackageName !Version - | HackageSdist !PackageName !Version - | CabalIndex !PackageSetIdent - | CustomSdist !PackageSetIdent !PackageName !Version - | SnapshotBundle !PackageSetIdent - | HaddockBundle !PackageSetIdent - | HoogleDB !PackageSetIdent !HoogleVersion - deriving (Show, Eq, Ord, Typeable) - newtype HoogleVersion = HoogleVersion Text deriving (Show, Eq, Ord, Typeable, PathPiece) currentHoogleVersion :: HoogleVersion currentHoogleVersion = HoogleVersion VERSION_hoogle -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" - ] - toPath (SnapshotBundle ident) = - [ "bundle" - , toPathPiece ident ++ ".tar.gz" - ] - toPath (HaddockBundle ident) = - [ "haddock" - , toPathPiece ident ++ ".tar.xz" - ] - toPath (HoogleDB ident ver) = - [ "hoogle" - , toPathPiece ver - , toPathPiece ident ++ ".hoo.gz" - ] -instance BackupToS3 StoreKey where - shouldBackup HackageCabal{} = False - shouldBackup HackageSdist{} = False - shouldBackup CabalIndex{} = True - shouldBackup CustomSdist{} = True - shouldBackup SnapshotBundle{} = True - shouldBackup HaddockBundle{} = True - shouldBackup HoogleDB{} = True - newtype HackageRoot = HackageRoot { unHackageRoot :: Text } deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup) diff --git a/stackage-server.cabal b/stackage-server.cabal index 504e612..763a0c7 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -22,7 +22,6 @@ library Settings.Development Data.Slug Data.Tag - Data.BlobStore Data.GhcLinks Data.WebsiteContent Types