S3 persistence

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'
             }

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

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" .!= ""

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"]