Get rid of blob store

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
 

Data/BlobStore.hs

@@ -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

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
 

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)

Handler/StackageIndex.hs

@@ -1,7 +1,6 @@
 module Handler.StackageIndex where
 
 import Import
-import Data.BlobStore
 import Stackage.Database
 
 getStackageIndexR :: SnapName -> Handler TypedContent

Handler/StackageSdist.hs

@@ -3,7 +3,6 @@ module Handler.StackageSdist
     ) where
 
 import Import
-import Data.BlobStore
 import Stackage.Database
 import Handler.Package (packagePage)
 

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)
 

stackage-server.cabal

@@ -22,7 +22,6 @@ library
                      Settings.Development
                      Data.Slug
                      Data.Tag
-                     Data.BlobStore
                      Data.GhcLinks
                      Data.WebsiteContent
                      Types