{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-orphans #-} module Git.S3 ( s3Factory, odbS3Backend, addS3Backend , ObjectStatus(..), BackendCallbacks(..) , ObjectType(..), ObjectLength(..), QuotaStatus(..) , S3MockService(), s3MockService , mockGetBucket, mockHeadObject, mockGetObject, mockPutObject ) where import Aws import Aws.Core import qualified Aws.S3 as Aws import Bindings.Libgit2 import Conduit import Control.Applicative import Control.Concurrent.STM hiding (orElse) import Control.Exception (assert) import Control.Lens ((??), under, reversed, has, _Left) import Control.Monad import Control.Monad.Catch import Control.Monad.Logger hiding (LogLevel) import Control.Monad.Trans.Control import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource.Internal import Control.Retry import Data.Aeson as A import Data.Bifunctor import Data.Binary as Bin import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Unsafe as BU import Data.Conduit.Internal hiding (yield) import Data.Default import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.IORef import Data.Int (Int64) import qualified Data.List as L import qualified Data.List.Split as L import Data.Maybe import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time.Clock import Data.Traversable (for) import Foreign.C.String import Foreign.C.Types import Foreign.ForeignPtr import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.StablePtr import Foreign.Storable import GHC.Generics import qualified Git import Git (SHA(..), shaToText) import Git.Libgit2 import Git.Libgit2.Backend import Git.Libgit2.Internal import Git.Libgit2.Types import Network.HTTP.Conduit hiding (Response) import Prelude hiding (mapM_, catch) import System.Directory import System.FilePath.Posix import System.IO.Unsafe newtype ObjectLength = ObjectLength { getObjectLength :: Int64 } deriving (Eq, Show, Generic) newtype ObjectType = ObjectType { getObjectType :: Int } deriving (Eq, Show, Generic) instance Bin.Binary ObjectLength where put (ObjectLength x) = Bin.put x get = ObjectLength <$> Bin.get instance Bin.Binary ObjectType where put (ObjectType x) = Bin.put x get = ObjectType <$> Bin.get plainFile :: ObjectType plainFile = ObjectType 0 data ObjectInfo = ObjectInfo { infoLength :: ObjectLength , infoType :: ObjectType , infoPath :: Maybe FilePath , infoData :: Maybe BL.ByteString } deriving Eq instance Show ObjectInfo where show ObjectInfo {..} = "ObjectInfo {" ++ "infoLength = " ++ show infoLength ++ ", infoType = " ++ show infoType ++ ", infoPath = " ++ show infoPath ++ ", infoData = " ++ show (isJust infoData) ++ "}" fromSha :: SHA -> FilePath fromSha = T.unpack . shaToText data ObjectStatus = ObjectLoose | ObjectLooseMetaKnown ObjectLength ObjectType | ObjectInPack Text deriving (Eq, Show, Generic) instance A.ToJSON ObjectLength; instance A.FromJSON ObjectLength instance A.ToJSON ObjectType; instance A.FromJSON ObjectType instance A.ToJSON ObjectStatus; instance A.FromJSON ObjectStatus data QuotaStatus = QuotaCheckSuccess | QuotaSoftLimitExceeded { quotaStatusAmount :: Int64 , quotaStatusLimit :: Int64 } | QuotaHardLimitExceeded { quotaStatusAmount :: Int64 , quotaStatusLimit :: Int64 } deriving (Eq, Show, Generic) type MonadS3 m = (MonadExcept m, MonadIO m, MonadBaseControl IO m, MonadLogger m) data BackendCallbacks = BackendCallbacks { checkQuota :: ObjectLength -> IO (Maybe QuotaStatus) -- 'checkQuota' gives the backend a chance to reject the upload of -- objects that may exceed per-user quotas. , registerObject :: SHA -> Maybe (ObjectLength, ObjectType) -> IO () -- 'registerObject' reports that a SHA has been written as a loose -- object to the S3 repository. The for tracking it is that sometimes -- calling 'locateObject' can be much faster than querying Amazon. , registerPackFile :: Text -> [SHA] -> IO () -- 'registerPackFile' takes the basename of a pack file, and a list of -- SHAs which are contained with the pack. It must register this in an -- index, for the sake of the next function. , lookupObject :: SHA -> IO (Maybe ObjectStatus) -- 'locateObject' takes a SHA, and returns: Nothing if the object is -- "loose", or Just SHA identifying the basename of the packfile that -- the object is located within. , getBucket :: MonadS3 m => Text -> Text -> ResourceT m (Maybe [Text]) , headObject :: MonadS3 m => Text -> Text -> ResourceT m (Maybe Bool) , getObject :: MonadS3 m => Text -> Text -> Maybe (Int64, Int64) -> ResourceT m (Maybe (Either Text BL.ByteString)) , putObject :: MonadS3 m => Text -> Text -> ObjectLength -> BL.ByteString -> ResourceT m (Maybe (Either Text ())) -- These four methods allow mocking of S3. -- -- - 'getBucket' takes the bucket and a prefix, and returns Just [xs] to -- indicate the list of files in the bucket, or else Nothing if the -- method is not mocked. -- -- - 'headObject' takes the bucket and path, and returns Just True if an -- object exists at that path, Just False if not, and Nothing if the -- method is not mocked. -- -- - 'getObject' takes the bucket, path and an optional range of bytes -- (see the S3 API for deatils), and returns a Just Right bytestring -- to represent the contents, a Just Left error, or Nothing if the -- method is not mocked. -- -- - 'putObject' takes the bucket, path, length and a bytestring source, -- and stores the contents at that location. It returns Just Right () -- if it succeeds, a Just Left on error, or Nothing if the method is not -- mocked. , updateRef :: Git.RefName -> Text -> IO () , resolveRef :: Git.RefName -> IO (Maybe Text) , acquireLock :: Text -> IO Text , releaseLock :: Text -> IO () , shuttingDown :: IO () -- 'shuttingDown' informs whoever registered with this backend that we -- are about to disappear, and as such any resources which they acquired -- on behalf of this backend should be released. , setException :: Git.GitException -> IO () -- 'setException' is used to indicate to gitlib that a more meaningful -- exception has occurred, from the one that will be raised by libgit2 -- upon exiting this backend with an error status. } instance Default BackendCallbacks where def = BackendCallbacks { checkQuota = \_ -> return Nothing , registerObject = \_ _ -> return () , registerPackFile = \_ _ -> return () , lookupObject = \_ -> return Nothing , getBucket = \_ _ -> return Nothing , headObject = \_ _ -> return Nothing , getObject = \_ _ _ -> return Nothing , putObject = \_ _ _ _ -> return Nothing , updateRef = \_ _ -> return () , resolveRef = \_ -> return Nothing , acquireLock = \_ -> return "" , releaseLock = \_ -> return () , shuttingDown = return () , setException = \_ -> return () } data CacheEntry = DoesNotExist | LooseRemote | LooseRemoteMetaKnown { objectLength :: ObjectLength , objectType :: ObjectType } | LooseCached { objectLength :: ObjectLength , objectType :: ObjectType , objectCached :: UTCTime , objectPath :: FilePath } | PackedRemote { objectPackSha :: Text } | PackedCached { objectCached :: UTCTime , objectPackSha :: Text , objectPackPath :: FilePath , objectIndexPath :: FilePath } | PackedCachedMetaKnown { objectLength :: ObjectLength , objectType :: ObjectType , objectCached :: UTCTime -- Must always be a PackedCached value , objectPackSha :: Text , objectPackPath :: FilePath , objectIndexPath :: FilePath } deriving (Eq, Show) data OdbS3Details = OdbS3Details { httpManager :: Manager , bucketName :: Text , objectPrefix :: Text , configuration :: Configuration , s3configuration :: Aws.S3Configuration NormalQuery , callbacks :: BackendCallbacks -- In the 'knownObjects' map, if the object is not present, we must query -- via the 'lookupObject' callback above. If it is present, it can be -- one of the CacheEntry's possible states. , knownObjects :: TVar (HashMap SHA CacheEntry) , knownPackFiles :: TVar (HashMap FilePath (Ptr C'git_odb, [SHA])) , tempDirectory :: FilePath } data OdbS3Backend = OdbS3Backend { odbS3Parent :: C'git_odb_backend , packWriter :: Ptr C'git_odb_writepack , details :: StablePtr OdbS3Details } instance Storable OdbS3Backend where alignment _ = alignment (undefined :: Ptr C'git_odb_backend) sizeOf _ = sizeOf (undefined :: C'git_odb_backend) + sizeOf (undefined :: Ptr C'git_odb_writepack) + sizeOf (undefined :: StablePtr OdbS3Details) peek p = do v0 <- peekByteOff p 0 let sizev1 = sizeOf (undefined :: C'git_odb_backend) v1 <- peekByteOff p sizev1 let sizev2 = sizev1 + sizeOf (undefined :: Ptr C'git_odb_writepack) v2 <- peekByteOff p sizev2 return (OdbS3Backend v0 v1 v2) poke p (OdbS3Backend v0 v1 v2) = do pokeByteOff p 0 v0 let sizev1 = sizeOf (undefined :: C'git_odb_backend) pokeByteOff p sizev1 v1 let sizev2 = sizev1 + sizeOf (undefined :: Ptr C'git_odb_writepack) pokeByteOff p sizev2 v2 return () toType :: ObjectType -> C'git_otype toType (ObjectType t) = fromIntegral t toLength :: ObjectLength -> CSize toLength (ObjectLength l) = fromIntegral l fromType :: C'git_otype -> ObjectType fromType = ObjectType . fromIntegral fromLength :: CSize -> ObjectLength fromLength = ObjectLength . fromIntegral wrap :: (Show a, MonadS3 m) => String -> m a -> m a -> m a wrap msg f g = catch (do lgDebug $ msg ++ "..." r <- f lgDebug $ msg ++ "...done, result = " ++ show r return r) $ \e -> do lgWarn $ msg ++ "...FAILED" lgWarn $ show (e :: SomeException) g wrap' :: MonadS3 m => String -> m a -> m a -> m a wrap' msg f g = catch (do lgDebug $ msg ++ "..." r <- f lgDebug $ msg ++ "...done" return r) $ \e -> do lgWarn $ msg ++ "...FAILED" lgWarn $ show (e :: SomeException) g orElse :: MonadS3 m => m a -> m a -> m a orElse f g = catch f $ \e -> do lgWarn "A callback operation failed" lgWarn $ show (e :: SomeException) g coidToJSON :: ForeignPtr C'git_oid -> A.Value coidToJSON coid = unsafePerformIO $ withForeignPtr coid $ fmap A.toJSON . flip oidToStr 40 unpackDetails :: Ptr C'git_odb_backend -> Ptr C'git_oid -> IO (OdbS3Details, SHA) unpackDetails be oid = do odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) dets <- deRefStablePtr (details odbS3) sha <- oidToSha oid return (dets, sha) wrapCheckQuota :: MonadS3 m => (ObjectLength -> IO (Maybe QuotaStatus)) -> ObjectLength -> m (Maybe QuotaStatus) wrapCheckQuota f len = wrap ("checkQuota " ++ show len) (liftIO $ f len) (return Nothing) wrapRegisterObject :: MonadS3 m => (SHA -> Maybe (ObjectLength, ObjectType) -> IO ()) -> SHA -> Maybe (ObjectLength, ObjectType) -> m () wrapRegisterObject f name metadata = wrap ("registerObject " ++ show (shaToText name) ++ " " ++ show metadata) (liftIO $ f name metadata) (return ()) wrapRegisterPackFile :: MonadS3 m => (Text -> [SHA] -> IO ()) -> Text -> [SHA] -> m () wrapRegisterPackFile f name shas = wrap ("registerPackFile: " ++ show name) (liftIO $ f name shas) (return ()) wrapLookupObject :: MonadS3 m => (SHA -> IO (Maybe ObjectStatus)) -> SHA -> m (Maybe ObjectStatus) wrapLookupObject f name = wrap ("lookupObject: " ++ show (shaToText name)) (liftIO $ f name) (return Nothing) wrapGetBucket :: MonadS3 m => (Text -> Text -> ResourceT m (Maybe [Text])) -> Text -> Text -> ResourceT m (Maybe [Text]) wrapGetBucket f bucket prefix = wrap ("getBucket: " ++ show bucket ++ " " ++ show prefix) (f bucket prefix) (return Nothing) wrapHeadObject :: MonadS3 m => (Text -> Text -> ResourceT m (Maybe Bool)) -> Text -> Text -> ResourceT m (Maybe Bool) wrapHeadObject f bucket path = wrap ("headObject: " ++ show bucket ++ "/" ++ show path) (f bucket path) (return Nothing) wrapGetObject :: MonadS3 m => (Text -> Text -> Maybe (Int64, Int64) -> ResourceT m (Maybe (Either Text BL.ByteString))) -> Text -> Text -> Maybe (Int64, Int64) -> ResourceT m (Maybe (Either Text BL.ByteString)) wrapGetObject f bucket path range = wrap' ("getObject: " ++ show bucket ++ "/" ++ show path ++ " " ++ show range) (f bucket path range) (return Nothing) wrapPutObject :: MonadS3 m => (Text -> Text -> ObjectLength -> BL.ByteString -> ResourceT m (Maybe (Either Text ()))) -> Text -> Text -> ObjectLength -> BL.ByteString -> ResourceT m (Maybe (Either Text ())) wrapPutObject f bucket path len bytes = wrap ("putObject: " ++ show bucket ++ "/" ++ show path ++ " length " ++ show len) (f bucket path len bytes) (return Nothing) wrapUpdateRef :: MonadS3 m => (Text -> Text -> IO ()) -> Text -> Text -> m () wrapUpdateRef f name sha = wrap ("updateRef: " ++ show name ++ " " ++ show sha) (liftIO $ f name sha) (return ()) wrapResolveRef :: MonadS3 m => (Text -> IO (Maybe Text)) -> Text -> m (Maybe Text) wrapResolveRef f name = wrap ("resolveRef: " ++ show name) (liftIO $ f name) (return Nothing) wrapAcquireLock :: MonadS3 m => (Text -> IO Text) -> Text -> m Text wrapAcquireLock f name = wrap ("acquireLock: " ++ show name) (liftIO $ f name) (return "") wrapReleaseLock :: MonadS3 m => (Text -> IO ()) -> Text -> m () wrapReleaseLock f name = wrap ("releaseLock: " ++ show name) (liftIO $ f name) (return ()) wrapShuttingDown :: MonadS3 m => IO () -> m () wrapShuttingDown f = wrap "shuttingDown..." (liftIO f) (return ()) wrapSetException :: MonadS3 m => (Git.GitException -> IO ()) -> Git.GitException -> m () wrapSetException f e = wrap ("setException: " ++ show e) (liftIO $ f e) (return ()) awsRetry :: (MonadIO m, Transaction r a) => Configuration -> ServiceConfiguration r NormalQuery -> Manager -> r -> ResourceT m (Response (ResponseMetadata a) a) awsRetry cfg svcfg mgr r = transResourceT liftIO $ retrying def (has _Left . responseResult) $ aws cfg svcfg mgr r listBucketS3 :: MonadS3 m => OdbS3Details -> ResourceT m [Text] listBucketS3 dets = do lgDebug "listBucketS3" let bucket = bucketName dets prefix = objectPrefix dets cbResult <- wrapGetBucket (getBucket (callbacks dets)) bucket prefix `orElse` return Nothing case cbResult of Just r -> return r Nothing -> makeRequest bucket prefix Nothing True where makeRequest _ _ _ False = return [] makeRequest bucket prefix mmarker True = do lgDebug "Aws.getBucket" res <- awsRetry (configuration dets) (s3configuration dets) (httpManager dets) ((Aws.getBucket bucket) { Aws.gbPrefix = Just prefix , Aws.gbMarker = mmarker }) gbr <- readResponseIO res let contents = map Aws.objectKey (Aws.gbrContents gbr) case contents of [] -> return [] _ -> (++) <$> pure contents <*> makeRequest bucket prefix (Just (Prelude.last contents)) (Aws.gbrIsTruncated gbr) testFileS3 :: MonadS3 m => OdbS3Details -> Text -> ResourceT m Bool testFileS3 dets filepath = do lgDebug $ "testFileS3: " ++ show filepath let bucket = bucketName dets path = T.append (objectPrefix dets) filepath cbResult <- wrapHeadObject (headObject (callbacks dets)) bucket path `orElse` return (Just False) case cbResult of Just r -> return r Nothing -> do lgDebug $ "Aws.headObject: " ++ show filepath resp <- awsRetry (configuration dets) (s3configuration dets) (httpManager dets) (Aws.headObject bucket path) _hor <- readResponseIO resp -- If we reach this point, it means the answer was 200 OK, which -- means the object exists. return True getFileS3 :: MonadS3 m => OdbS3Details -> FilePath -> Maybe (Int64,Int64) -> ResourceT m (ResumableSource (ResourceT IO) ByteString) getFileS3 dets filepath range = do lgDebug $ "getFileS3: " ++ filepath let bucket = bucketName dets path = T.unpack (objectPrefix dets) <> filepath cbResult <- wrapGetObject (getObject (callbacks dets)) bucket (T.pack path) range `orElse` return (Just (Left "Failed to get object from callback")) case cbResult of Just (Left e) -> throwM $ Git.BackendError e Just (Right r) -> transResourceT liftIO $ return $ ResumableSource (sourceLazy r) (return ()) _ -> do lgDebug $ "Aws.getObject: " ++ show filepath ++ " " ++ show range res <- awsRetry (configuration dets) (s3configuration dets) (httpManager dets) (Aws.getObject bucket (T.pack path)) { Aws.goResponseContentRange = bimap fromIntegral fromIntegral <$> range } gor <- readResponseIO res return (responseBody (Aws.gorResponse gor)) putFileS3 :: MonadS3 m => OdbS3Details -> Text -> Source (ResourceT m) ByteString -> ResourceT m () putFileS3 dets filepath src = do lgDebug $ "putFileS3: " ++ show filepath let bucket = bucketName dets path = T.append (objectPrefix dets) filepath lbs <- src $$ sinkLazy cbResult <- wrapPutObject (putObject (callbacks dets)) bucket path (ObjectLength (BL.length lbs)) lbs `orElse` return (Just (Left "Failed to get object from callback")) case cbResult of Just (Left e) -> throwM $ Git.BackendError e Just (Right r) -> return r _ -> do lgDebug $ "Aws.putObject: " ++ show filepath ++ " len " ++ show (BL.length lbs) res <- awsRetry (configuration dets) (s3configuration dets) (httpManager dets) (Aws.putObject (bucketName dets) (T.append (objectPrefix dets) filepath) (RequestBodyLBS lbs)) void $ readResponseIO res type RefMap m = M.HashMap Text (Maybe (Git.RefTarget LgRepo)) -- jww (2013-04-26): Split these off into a gitlib-aeson library. instance A.FromJSON RefTarget where parseJSON j = do o <- A.parseJSON j case L.lookup "symbolic" (M.toList (o :: A.Object)) of Just _ -> Git.RefSymbolic <$> o .: "symbolic-target" Nothing -> Git.RefObj . go <$> o .: "oid-target" where go = mkOid . unsafePerformIO . strToOid strToOid :: String -> IO (ForeignPtr C'git_oid) strToOid oidStr = do ptr <- mallocForeignPtr withCString oidStr $ \cstr -> withForeignPtr ptr $ \ptr' -> do r <- c'git_oid_fromstr ptr' cstr when (r < 0) $ throwM Git.OidCopyFailed return ptr instance A.ToJSON RefTarget where toJSON (Git.RefSymbolic target) = object [ "symbolic-target" .= target ] toJSON (Git.RefObj oid) = object [ "oid-target" .= coidToJSON (getOid oid) ] observePackObjects :: MonadS3 m => OdbS3Details -> Text -> FilePath -> Bool -> Ptr C'git_odb -> m [SHA] observePackObjects dets packSha idxFile _alsoWithRemote odbPtr = do lgDebug $ "observePackObjects: " ++ show idxFile -- Iterate the "database", which gives us a list of all the oids contained -- within it mshas <- liftIO $ newIORef [] r <- liftIO $ flip (lgForEachObject odbPtr) nullPtr $ \oid _ -> do sha <- oidToSha oid modifyIORef mshas (sha:) return c'GIT_OK checkResult r "lgForEachObject failed" -- Update the known objects map with the fact that we've got a local cache -- of the pack file. lgDebug "observePackObjects: update known objects map" now <- liftIO getCurrentTime shas <- liftIO $ readIORef mshas let obj = PackedCached now packSha (replaceExtension idxFile "pack") idxFile liftIO $ atomically $ modifyTVar (knownObjects dets) $ \objs -> foldr (`M.insert` obj) objs shas lgDebug $ "observePackObjects: observed " ++ show (Prelude.length shas) ++ " objects" return shas catalogPackFile :: MonadS3 m => OdbS3Details -> Text -> FilePath -> m [SHA] catalogPackFile dets packSha idxPath = do -- Load the pack file, and iterate over the objects within it to determine -- what it contains. When 'withPackFile' returns, the pack file will be -- closed and any associated resources freed. lgDebug $ "catalogPackFile: " ++ show packSha m <- liftIO $ atomically $ readTVar (knownPackFiles dets) case M.lookup idxPath m of Nothing -> bracketOnError (lgOpenPackFile idxPath) lgClosePackFile $ \odbPtr -> do shas <- observePackObjects dets packSha idxPath True odbPtr liftIO $ atomically $ modifyTVar (knownPackFiles dets) $ M.insert idxPath (odbPtr, shas) return shas Just (_, shas) -> return shas observeCacheObjects :: OdbS3Details -> IO () observeCacheObjects dets = do now <- getCurrentTime let dir = tempDirectory dets contents <- getDirectoryContents dir forM_ contents $ \entry -> do let fname = dir entry if "pack-" `L.isPrefixOf` entry then if ".pack" `L.isSuffixOf` entry then do let sha = under reversed (drop 5) $ drop 5 entry psha <- packSha sha atomically $ modifyTVar (knownObjects dets) $ M.insert psha $ PackedCached now (T.pack sha) fname (replaceExtension fname "idx") else return () else case L.splitOn "-" entry of [sha, typs, lens] -> do sha' <- packSha sha atomically $ modifyTVar (knownObjects dets) $ M.insert sha' $ LooseCached (ObjectLength (read lens)) (ObjectType (read typs)) now fname _ -> return () where packSha = Git.textToSha . T.pack mapPair f (x,y) = (f x, f y) cacheLookupEntry :: MonadS3 m => OdbS3Details -> SHA -> m (Maybe CacheEntry) cacheLookupEntry dets sha = wrap ("cacheLookupEntry " ++ show (shaToText sha)) (go True) (return Nothing) where go recurse = do objs <- liftIO $ readTVarIO (knownObjects dets) case M.lookup sha objs of Nothing | M.null objs && recurse -> do lgDebug "observeCacheObjects" liftIO $ observeCacheObjects dets go False mres -> return mres cacheUpdateEntry :: MonadS3 m => OdbS3Details -> SHA -> CacheEntry -> m () cacheUpdateEntry dets sha ce = do lgDebug $ "cacheUpdateEntry " ++ show (shaToText sha) ++ " " ++ show ce liftIO $ atomically $ modifyTVar (knownObjects dets) $ M.insert sha ce cacheLoadObject :: MonadS3 m => OdbS3Details -> SHA -> CacheEntry -> Bool -> m (Maybe ObjectInfo) cacheLoadObject dets sha ce metadataOnly = do lgDebug $ "cacheLoadObject " ++ show sha ++ " " ++ show metadataOnly minfo <- go ce case ce of LooseCached {} -> return () -- refresh the cache's knowledge if it wasn't already cached _ -> for_ minfo $ cacheStoreObject dets sha return minfo where go DoesNotExist = return Nothing go LooseRemote = runResourceT $ remoteLoadObject dets sha go (LooseRemoteMetaKnown len typ) = if metadataOnly then return . Just $ ObjectInfo len typ Nothing Nothing else runResourceT $ remoteLoadObject dets sha go (LooseCached len typ _ path) | metadataOnly = return . Just $ ObjectInfo len typ (Just path) Nothing | otherwise = do exists <- liftIO $ doesFileExist path if exists then Just <$> (ObjectInfo <$> pure len <*> pure typ <*> pure (Just path) <*> (Just <$> liftIO (BL.readFile path))) else go LooseRemote go (PackedRemote packSha) = do mpaths <- runResourceT $ remoteReadPackFile dets packSha True join <$> for mpaths (\(packPath,idxPath) -> do void $ catalogPackFile dets packSha idxPath packLoadObject dets sha packSha packPath idxPath metadataOnly) go (PackedCached _ packSha packPath idxPath) = packLoadObject dets sha packSha packPath idxPath metadataOnly go (PackedCachedMetaKnown len typ _ packSha packPath idxPath) | metadataOnly = return . Just $ ObjectInfo len typ Nothing Nothing | otherwise = packLoadObject dets sha packSha packPath idxPath metadataOnly packLoadObject _dets sha packSha packPath idxPath metadataOnly = do bothExist <- liftIO $ (&&) <$> doesFileExist packPath <*> doesFileExist idxPath if bothExist then do lgDebug $ "getObjectFromPack " ++ show packPath ++ " " ++ show sha m <- liftIO $ atomically $ readTVar (knownPackFiles dets) mresult <- case M.lookup idxPath m of Nothing -> throwM $ Git.BackendError $ "Accessing unknown pack file " <> T.pack idxPath Just (ptr, _) -> lgReadFromPack ptr sha metadataOnly for mresult $ \(typ, len, bytes) -> return $ ObjectInfo (fromLength len) (fromType typ) Nothing (Just (BL.fromChunks [bytes])) else go (PackedRemote packSha) cacheStoreObject :: MonadS3 m => OdbS3Details -> SHA -> ObjectInfo -> m () cacheStoreObject dets sha info@ObjectInfo {..} = do lgDebug $ "cacheStoreObject " ++ show sha ++ " " ++ show info liftIO go >>= cacheUpdateEntry dets sha where go | Just bytes <- infoData = do let path = tempDirectory dets (fromSha sha ++ "-" ++ show (getObjectType infoType) ++ "-" ++ show (getObjectLength infoLength)) BL.writeFile path bytes now <- getCurrentTime return $ LooseCached infoLength infoType now path | otherwise = return $ LooseRemoteMetaKnown infoLength infoType callbackLocateObject :: MonadS3 m => OdbS3Details -> SHA -> m (Maybe CacheEntry) callbackLocateObject dets sha = do location <- wrapLookupObject (lookupObject (callbacks dets)) sha `orElse` return Nothing lgDebug $ "callbackLocateObject lookup: " ++ show location return $ case location of Just (ObjectInPack base) -> Just (PackedRemote base) Just ObjectLoose -> Just LooseRemote _ -> Nothing callbackRegisterObject :: MonadS3 m => OdbS3Details -> SHA -> ObjectInfo -> m () callbackRegisterObject dets sha info@ObjectInfo {..} = do lgDebug $ "callbackRegisterObject " ++ show sha ++ " " ++ show info wrapRegisterObject (registerObject (callbacks dets)) sha (Just (infoLength, infoType))`orElse` return () callbackRegisterPackFile :: MonadS3 m => OdbS3Details -> Text -> [SHA] -> m () callbackRegisterPackFile dets packSha shas = do lgDebug $ "callbackRegisterPackFile " ++ show packSha -- Let whoever is listening know about this pack files and its contained -- objects wrapRegisterPackFile (registerPackFile (callbacks dets)) packSha shas `orElse` return () callbackRegisterCacheEntry :: MonadS3 m => OdbS3Details -> SHA -> CacheEntry -> m () callbackRegisterCacheEntry dets sha ce = wrap ("callbackRegisterCacheEntry " ++ show (shaToText sha) ++ " " ++ show ce) (go ce) (return ()) where go DoesNotExist = return () go LooseRemote = regObj Nothing go LooseRemoteMetaKnown {..} = regObj (Just (objectLength, objectType)) go LooseCached {..} = regObj (Just (objectLength, objectType)) go PackedRemote {..} = err go PackedCached {..} = err go PackedCachedMetaKnown {..} = err regObj = wrapRegisterObject (registerObject (callbacks dets)) sha err = throwM (Git.BackendError $ "callbackRecordInfo called with " <> T.pack (show ce)) remoteObjectExists :: MonadS3 m => OdbS3Details -> SHA -> ResourceT m Bool remoteObjectExists dets sha = wrap "remoteObjectExists" (testFileS3 dets (shaToText sha)) (return False) remoteReadFile :: MonadS3 m => OdbS3Details -> FilePath -> ResourceT m (Maybe ObjectInfo) remoteReadFile dets path = do lgDebug $ "remoteReadFile " ++ show path exists <- liftIO $ doesFileExist path when exists $ do lgDebug $ "remoteReadFile: removing " ++ show path liftIO $ removeFile path blocks <- do result <- getFileS3 dets (takeFileName path) Nothing transResourceT liftIO $ result $$+- sinkList lgDebug $ "remoteReadFile: downloaded " ++ show path case blocks of [] -> return Nothing bs -> Just <$> processData bs where processData bs = do let hdrLen = sizeOf (undefined :: Int64) * 2 (len,typ) = mapPair fromIntegral (Bin.decode (BL.fromChunks [L.head bs]) :: (Int64,Int64)) lgDebug $ "downloadFile: length from header is " ++ show len bytes <- liftIO $ allocaBytes len $ \content -> do foldM_ (readData hdrLen content) 0 bs curry B.packCStringLen (castPtr content) (fromIntegral len) return ObjectInfo { infoLength = ObjectLength (fromIntegral len) , infoType = ObjectType (fromIntegral typ) , infoPath = Just path , infoData = Just (BL.fromChunks [bytes]) } readData hdrLen content offset x = liftIO $ do let xOffset = if offset == 0 then hdrLen else 0 innerLen = B.length x - xOffset BU.unsafeUseAsCString x $ \cstr -> copyBytes (content `plusPtr` offset) (cstr `plusPtr` xOffset) innerLen return (offset + innerLen) mapPair f (x,y) = (f x, f y) remoteReadPackFile :: MonadS3 m => OdbS3Details -> Text -> Bool -> ResourceT m (Maybe (FilePath, FilePath)) remoteReadPackFile dets packSha readPackAndIndex = do lgDebug $ "remoteReadPackFile " ++ show packSha let tmpDir = tempDirectory dets packPath = tmpDir ("pack-" <> T.unpack packSha <> ".pack") idxPath = replaceExtension packPath "idx" runMaybeT $ do -- jww (2013-07-22): It would help performance if we could drop the -- "True ||" here, but right now this is not working with the current -- libgit2. when (True || readPackAndIndex) $ do exists <- liftIO $ doesFileExist packPath void $ if exists then return (Just ()) else download packPath exists <- liftIO $ doesFileExist idxPath void $ if exists then return (Just ()) else download idxPath return (packPath,idxPath) where download path = do minfo <- lift $ remoteReadFile dets path for minfo $ \ObjectInfo {..} -> case infoData of Nothing -> throwM $ Git.BackendError $ "Failed to download data for " <> T.pack path Just xs -> liftIO $ BL.writeFile path xs remoteWriteFile :: MonadS3 m => OdbS3Details -> Text -> ObjectType -> BL.ByteString -> ResourceT m () remoteWriteFile dets path typ bytes = do mstatus <- wrapCheckQuota (checkQuota (callbacks dets)) (ObjectLength (fromIntegral (BL.length bytes))) case mstatus of Nothing -> go Just QuotaCheckSuccess -> go Just (QuotaSoftLimitExceeded {}) -> go Just (QuotaHardLimitExceeded {..}) -> do let e = Git.QuotaHardLimitExceeded (fromIntegral quotaStatusAmount) (fromIntegral quotaStatusLimit) wrapSetException (setException (callbacks dets)) e throwM e where go = do lgDebug $ "remoteWriteFile " ++ show path let hdr = Bin.encode ((fromIntegral (BL.length bytes), fromIntegral (getObjectType typ)) :: (Int64,Int64)) payload = BL.append hdr bytes putFileS3 dets path (sourceLazy payload) remoteLoadObject :: MonadS3 m => OdbS3Details -> SHA -> ResourceT m (Maybe ObjectInfo) remoteLoadObject dets sha = do let tmpDir = tempDirectory dets path = tmpDir fromSha sha remoteReadFile dets path remoteStoreObject :: MonadS3 m => OdbS3Details -> SHA -> ObjectInfo -> ResourceT m () remoteStoreObject dets sha (ObjectInfo _ typ _ (Just bytes)) = remoteWriteFile dets (shaToText sha) typ bytes remoteStoreObject _ _ _ = throwM $ Git.BackendError "remoteStoreObject was not given any data" remoteCatalogContents :: MonadS3 m => OdbS3Details -> ResourceT m () remoteCatalogContents dets = do lgDebug "remoteCatalogContents" items <- map T.unpack <$> listBucketS3 dets for_ items $ \item -> case () of () | ".idx" `L.isSuffixOf` item -> do let packSha = T.pack . drop 5 . takeBaseName $ item lgDebug $ "remoteCatalogContents: found pack file " ++ show packSha mpaths <- remoteReadPackFile dets packSha False for_ mpaths $ \(_, idxPath) -> do shas <- catalogPackFile dets packSha idxPath callbackRegisterPackFile dets packSha shas | ".pack" `L.isSuffixOf` item -> return () | length item == 40 -> do sha <- Git.textToSha . T.pack . takeBaseName $ item cacheUpdateEntry dets sha LooseRemote callbackRegisterCacheEntry dets sha LooseRemote | otherwise -> return () accessObject :: MonadS3 m => OdbS3Details -> SHA -> Bool -> m (Maybe CacheEntry) accessObject dets sha checkRemote = do mentry <- cacheLookupEntry dets sha case mentry of Just _ -> return mentry Nothing -> do mentry <- callbackLocateObject dets sha case mentry of Just entry -> do cacheUpdateEntry dets sha entry return mentry Nothing | checkRemote -> do exists <- runResourceT $ remoteObjectExists dets sha if exists then do cacheUpdateEntry dets sha LooseRemote callbackRegisterCacheEntry dets sha LooseRemote return $ Just LooseRemote else do -- This can be a very time consuming operation m <- liftIO $ atomically $ readTVar (knownPackFiles dets) if M.null m then do runResourceT $ remoteCatalogContents dets cacheLookupEntry dets sha else return Nothing | otherwise -> return Nothing -- All of these functions follow the same general outline: -- -- 1. Check whether the local cache can answer the request. -- -- 2. If the local cache does not know, ask the callback interface, which is -- usually much cheaper than querying Amazon S3. -- -- 3. If the callback interface does not know, ask Amazon directly if the -- object exists. -- -- 4. If Amazon does not know about that object per se, catalog the S3 bucket -- and re-index its contents. This operation is slow, but is preferable -- to a failure. -- -- 5. If the object legitimately does not exist, register this fact in the -- cache and with the callback interface. This is to avoid recataloging -- in the future. objectExists :: MonadS3 m => OdbS3Details -> SHA -> Bool -> m CacheEntry objectExists dets sha checkRemote = do mce <- accessObject dets sha checkRemote return $ fromMaybe DoesNotExist mce readObject :: MonadS3 m => OdbS3Details -> SHA -> Bool -> m (Maybe ObjectInfo) readObject dets sha metadataOnly = do ce <- objectExists dets sha True cacheLoadObject dets sha ce metadataOnly `orElse` return Nothing readObjectMetadata :: MonadS3 m => OdbS3Details -> SHA -> m (Maybe ObjectInfo) readObjectMetadata dets sha = readObject dets sha True writeObject :: MonadS3 m => OdbS3Details -> SHA -> ObjectInfo -> m () writeObject dets sha info = do runResourceT $ remoteStoreObject dets sha info callbackRegisterObject dets sha info cacheStoreObject dets sha info writePackFile :: MonadS3 m => OdbS3Details -> BL.ByteString -> m () writePackFile dets bytes = do let dir = tempDirectory dets len = BL.length bytes lgDebug $ "writePackFile: building index for " ++ show len ++ " bytes" (packSha, packPath, idxPath) <- lgBuildPackIndex dir bytes runResourceT $ remoteWriteFile dets (T.pack (takeFileName packPath)) plainFile bytes runResourceT . remoteWriteFile dets (T.pack (takeFileName idxPath)) plainFile =<< liftIO (BL.readFile idxPath) -- This updates the local cache and remote registry with knowledge of -- every object in the pack file. shas <- catalogPackFile dets packSha idxPath callbackRegisterPackFile dets packSha shas readCallback :: MonadS3 m => Ptr (Ptr ()) -> Ptr CSize -> Ptr C'git_otype -> Ptr C'git_odb_backend -> Ptr C'git_oid -> m CInt readCallback data_p len_p type_p be oid = do (dets, sha) <- liftIO $ unpackDetails be oid wrap (T.unpack $ "S3.readCallback " <> shaToText sha) (maybe c'GIT_ENOTFOUND (const c'GIT_OK) <$> go dets sha) (return c'GIT_ERROR) where go dets sha = do minfo <- readObject dets sha False liftIO $ for minfo $ \(ObjectInfo len typ _ (Just bytes)) -> do let bytesLen = BL.length bytes assert (getObjectLength len == bytesLen) $ do content <- castPtr <$> c'git_odb_backend_malloc be (fromIntegral bytesLen) poke data_p (castPtr content) foldM_ copyData content (BL.toChunks bytes) poke len_p (toLength len) poke type_p (toType typ) return (Just ()) where copyData p chunk = do let len = B.length chunk BU.unsafeUseAsCString chunk $ copyBytes p ?? len return $ p `plusPtr` len readPrefixCallback :: MonadS3 m => Ptr C'git_oid -> Ptr (Ptr ()) -> Ptr CSize -> Ptr C'git_otype -> Ptr C'git_odb_backend -> Ptr C'git_oid -> CSize -> m CInt readPrefixCallback oid_p data_p len_p type_p be oid (fromIntegral -> len) = do (dets, sha) <- liftIO $ unpackDetails be oid wrap (T.unpack $ "S3.readPrefixCallback " <> T.take len (shaToText sha)) (maybe c'GIT_ENOTFOUND (const c'GIT_OK) <$> go dets sha True) (return c'GIT_ERROR) where go dets sha shouldLoop = do objs <- liftIO $ readTVarIO (knownObjects dets) let subSha = B.take (len `div` 2) (getSHA sha) act . filter ((subSha ==) . B.take (len `div` 2) . getSHA) . M.keys $ objs where act [Git.SHA bs] = do liftIO $ BU.unsafeUseAsCString bs $ c'git_oid_fromraw oid_p . castPtr res <- readCallback data_p len_p type_p be oid_p return $ if res == c'GIT_OK then Just () else Nothing act _ | shouldLoop = do -- This is destined to fail, since the sha is too short to -- match anything exactly, but it will force cataloging to -- happen. _ <- accessObject dets sha True go dets sha False | otherwise = return Nothing readHeaderCallback :: MonadS3 m => Ptr CSize -> Ptr C'git_otype -> Ptr C'git_odb_backend -> Ptr C'git_oid -> m CInt readHeaderCallback len_p type_p be oid = do (dets, sha) <- liftIO $ unpackDetails be oid wrap (T.unpack $ "S3.readHeaderCallback " <> shaToText sha) (maybe c'GIT_ENOTFOUND (const c'GIT_OK) <$> go dets sha) (return c'GIT_ERROR) where go dets sha = do minfo <- readObjectMetadata dets sha liftIO $ for minfo $ \(ObjectInfo len typ _ _) -> do poke len_p (toLength len) poke type_p (toType typ) writeCallback :: MonadS3 m => Ptr C'git_oid -> Ptr C'git_odb_backend -> Ptr () -> CSize -> C'git_otype -> m CInt writeCallback oid be obj_data len obj_type = do r <- liftIO $ c'git_odb_hash oid obj_data len obj_type case r of 0 -> do (dets, sha) <- liftIO $ unpackDetails be oid wrap (T.unpack $ "S3.writeCallback " <> shaToText sha) (c'GIT_OK <$ go dets sha) (return c'GIT_ERROR) n -> do lgDebug "S3.writeCallback failed to hash data" return n where go dets sha = do bytes <- liftIO $ curry BU.unsafePackCStringLen (castPtr obj_data) (fromIntegral len) writeObject dets sha (ObjectInfo (fromLength len) (fromType obj_type) Nothing (Just (BL.fromChunks [bytes]))) existsCallback :: MonadS3 m => Ptr C'git_odb_backend -> Ptr C'git_oid -> CInt -> m CInt existsCallback be oid confirmNotExists = do (dets, sha) <- liftIO $ unpackDetails be oid wrap (T.unpack $ "S3.existsCallback " <> shaToText sha <> " " <> T.pack (show confirmNotExists)) (do ce <- objectExists dets sha (confirmNotExists == 0) return $ if ce == DoesNotExist then 0 else 1) (return c'GIT_ERROR) refreshCallback :: MonadS3 m => Ptr C'git_odb_backend -> m CInt refreshCallback _ = return c'GIT_OK -- do nothing foreachCallback :: MonadS3 m => Ptr C'git_odb_backend -> C'git_odb_foreach_cb -> Ptr () -> m CInt foreachCallback _be _callback _payload = return c'GIT_ERROR -- fallback to standard method writePackCallback :: MonadS3 m => Ptr (Ptr C'git_odb_writepack) -> Ptr C'git_odb_backend -> C'git_transfer_progress_callback -> Ptr () -> m CInt writePackCallback writePackPtr be _callback _payload = wrap "S3.writePackCallback" go (return c'GIT_ERROR) where go = liftIO $ do poke writePackPtr . packWriter =<< peek (castPtr be :: Ptr OdbS3Backend) return c'GIT_OK freeCallback :: F'git_odb_backend_free_callback freeCallback be = do odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) dets <- deRefStablePtr (details odbS3) shuttingDown (callbacks dets) packFiles <- atomically $ readTVar (knownPackFiles dets) mapM_ (runNoLoggingT . lgClosePackFile . fst) (M.elems packFiles) packFreeCallback (packWriter odbS3) freeStablePtr (details odbS3) backend <- peek be freeHaskellFunPtr (c'git_odb_backend'read backend) freeHaskellFunPtr (c'git_odb_backend'read_prefix backend) freeHaskellFunPtr (c'git_odb_backend'read_header backend) freeHaskellFunPtr (c'git_odb_backend'write backend) freeHaskellFunPtr (c'git_odb_backend'exists backend) freeHaskellFunPtr (c'git_odb_backend'refresh backend) freeHaskellFunPtr (c'git_odb_backend'foreach backend) freeHaskellFunPtr (c'git_odb_backend'writepack backend) free (castPtr be :: Ptr OdbS3Backend) foreign export ccall "freeCallback" freeCallback :: F'git_odb_backend_free_callback foreign import ccall "&freeCallback" freeCallbackPtr :: FunPtr F'git_odb_backend_free_callback packAddCallback :: MonadS3 m => Ptr C'git_odb_writepack -> Ptr () -> CSize -> Ptr C'git_transfer_progress -> m CInt packAddCallback wp dataPtr len _progress = wrap "S3.packAddCallback" (c'GIT_OK <$ go) (return c'GIT_ERROR) where go = do be <- liftIO $ c'git_odb_writepack'backend <$> peek wp odbS3 <- liftIO $ peek (castPtr be :: Ptr OdbS3Backend) dets <- liftIO $ deRefStablePtr (details odbS3) bytes <- liftIO $ curry BU.unsafePackCStringLen (castPtr dataPtr) (fromIntegral len) writePackFile dets (BL.fromChunks [bytes]) packCommitCallback :: MonadS3 m => Ptr C'git_odb_writepack -> Ptr C'git_transfer_progress -> m CInt packCommitCallback _wp _progress = return c'GIT_OK -- do nothing packFreeCallback :: F'git_odb_writepack_free_callback packFreeCallback wp = do writepack <- peek wp freeHaskellFunPtr (c'git_odb_writepack'add writepack) freeHaskellFunPtr (c'git_odb_writepack'commit writepack) free wp foreign export ccall "packFreeCallback" packFreeCallback :: F'git_odb_writepack_free_callback foreign import ccall "&packFreeCallback" packFreeCallbackPtr :: FunPtr F'git_odb_writepack_free_callback -- | Return an IO action that closes over the current monad transformer, but -- throws away any residual effects within that transformer. embedIO :: (MonadBaseControl IO m, MonadIO m) => (a -> m b) -> m (a -> IO b) embedIO f = liftBaseWith $ \run -> do result <- newIORef undefined return $ \a -> do _ <- run $ do res <- f a liftIO $ writeIORef result res readIORef result embedIO2 :: (MonadBaseControl IO m, MonadIO m) => (a -> b -> m r) -> m (a -> b -> IO r) embedIO2 f = liftBaseWith $ \run -> do result <- newIORef undefined return $ \a b -> do _ <- run $ do res <- f a b liftIO $ writeIORef result res readIORef result embedIO3 :: (MonadBaseControl IO m, MonadIO m) => (a -> b -> c -> m r) -> m (a -> b -> c -> IO r) embedIO3 f = liftBaseWith $ \run -> do result <- newIORef undefined return $ \a b c -> do _ <- run $ do res <- f a b c liftIO $ writeIORef result res readIORef result embedIO4 :: (MonadBaseControl IO m, MonadIO m) => (a -> b -> c -> d -> m r) -> m (a -> b -> c -> d -> IO r) embedIO4 f = liftBaseWith $ \run -> do result <- newIORef undefined return $ \a b c d -> do _ <- run $ do res <- f a b c d liftIO $ writeIORef result res readIORef result embedIO5 :: (MonadBaseControl IO m, MonadIO m) => (a -> b -> c -> d -> e -> m r) -> m (a -> b -> c -> d -> e -> IO r) embedIO5 f = liftBaseWith $ \run -> do result <- newIORef undefined return $ \a b c d e -> do _ <- run $ do res <- f a b c d e liftIO $ writeIORef result res readIORef result embedIO6 :: (MonadBaseControl IO m, MonadIO m) => (a -> b -> c -> d -> e -> f -> m r) -> m (a -> b -> c -> d -> e -> f -> IO r) embedIO6 x = liftBaseWith $ \run -> do result <- newIORef undefined return $ \a b c d e f -> do _ <- run $ do res <- x a b c d e f liftIO $ writeIORef result res readIORef result embedIO7 :: (MonadBaseControl IO m, MonadIO m) => (a -> b -> c -> d -> e -> f -> g -> m r) -> m (a -> b -> c -> d -> e -> f -> g -> IO r) embedIO7 x = liftBaseWith $ \run -> do result <- newIORef undefined return $ \a b c d e f g -> do _ <- run $ do res <- x a b c d e f g liftIO $ writeIORef result res readIORef result embedIO8 :: (MonadBaseControl IO m, MonadIO m) => (a -> b -> c -> d -> e -> f -> g -> h -> m r) -> m (a -> b -> c -> d -> e -> f -> g -> h -> IO r) embedIO8 x = liftBaseWith $ \run -> do result <- newIORef undefined return $ \a b c d e f g h -> do _ <- run $ do res <- x a b c d e f g h liftIO $ writeIORef result res readIORef result embedIO9 :: (MonadBaseControl IO m, MonadIO m) => (a -> b -> c -> d -> e -> f -> g -> h -> i -> m r) -> m (a -> b -> c -> d -> e -> f -> g -> h -> i -> IO r) embedIO9 x = liftBaseWith $ \run -> do result <- newIORef undefined return $ \a b c d e f g h i -> do _ <- run $ do res <- x a b c d e f g h i liftIO $ writeIORef result res readIORef result odbS3Backend :: MonadS3 m => Aws.S3Configuration NormalQuery -> Configuration -> Manager -> Text -> Text -> FilePath -> BackendCallbacks -> m (Ptr C'git_odb_backend) odbS3Backend s3config config manager bucket prefix dir callbacks = do readFun' <- embedIO5 readCallback readPrefixFun' <- embedIO7 readPrefixCallback readHeaderFun' <- embedIO4 readHeaderCallback writeFun' <- embedIO5 writeCallback existsFun' <- embedIO3 existsCallback refreshFun' <- embedIO refreshCallback foreachFun' <- embedIO3 foreachCallback writePackFun' <- embedIO4 writePackCallback readFun <- liftIO $ mk'git_odb_backend_read_callback readFun' readPrefixFun <- liftIO $ mk'git_odb_backend_read_prefix_callback readPrefixFun' readHeaderFun <- liftIO $ mk'git_odb_backend_read_header_callback readHeaderFun' writeFun <- liftIO $ mk'git_odb_backend_write_callback writeFun' existsFun <- liftIO $ mk'git_odb_backend_exists_callback existsFun' refreshFun <- liftIO $ mk'git_odb_backend_refresh_callback refreshFun' foreachFun <- liftIO $ mk'git_odb_backend_foreach_callback foreachFun' writePackFun <- liftIO $ mk'git_odb_backend_writepack_callback writePackFun' writePackAddFun' <- embedIO4 packAddCallback writePackCommitFun' <- embedIO2 packCommitCallback writePackAddFun <- liftIO $ mk'git_odb_writepack_add_callback writePackAddFun' writePackCommitFun <- liftIO $ mk'git_odb_writepack_commit_callback writePackCommitFun' objects <- liftIO $ newTVarIO M.empty packFiles <- liftIO $ newTVarIO M.empty let odbS3details = OdbS3Details { httpManager = manager , bucketName = bucket , objectPrefix = prefix , configuration = config , s3configuration = s3config , callbacks = callbacks , knownObjects = objects , knownPackFiles = packFiles , tempDirectory = dir } odbS3Parent = C'git_odb_backend { c'git_odb_backend'version = 1 , c'git_odb_backend'odb = nullPtr , c'git_odb_backend'read = readFun , c'git_odb_backend'read_prefix = readPrefixFun , c'git_odb_backend'readstream = nullFunPtr , c'git_odb_backend'read_header = readHeaderFun , c'git_odb_backend'write = writeFun , c'git_odb_backend'writestream = nullFunPtr , c'git_odb_backend'exists = existsFun , c'git_odb_backend'refresh = refreshFun , c'git_odb_backend'foreach = foreachFun , c'git_odb_backend'writepack = writePackFun , c'git_odb_backend'free = freeCallbackPtr } ptr <- liftIO $ do dirExists <- doesDirectoryExist dir unless dirExists $ createDirectoryIfMissing True dir details' <- newStablePtr odbS3details ptr <- castPtr <$> new OdbS3Backend { odbS3Parent = odbS3Parent , packWriter = nullPtr , details = details' } packWriterPtr <- new C'git_odb_writepack { c'git_odb_writepack'backend = ptr , c'git_odb_writepack'add = writePackAddFun , c'git_odb_writepack'commit = writePackCommitFun , c'git_odb_writepack'free = packFreeCallbackPtr } pokeByteOff ptr (sizeOf (undefined :: C'git_odb_backend)) packWriterPtr return ptr lgDebug $ "Created new S3 backend at " ++ show ptr return ptr -- | Given a repository object obtained from Libgit2, add an S3 backend to it, -- making it the primary store for objects associated with that repository. addS3Backend :: MonadS3 m => LgRepo -> Text -- ^ bucket -> Text -- ^ prefix -> Text -- ^ access key -> Text -- ^ secret key -> Maybe Manager -> Maybe Text -- ^ mock address -> LogLevel -> FilePath -> BackendCallbacks -- ^ callbacks -> m LgRepo addS3Backend repo bucket prefix access secret mmanager mockAddr level dir callbacks = do manager <- maybe (liftIO $ newManager conduitManagerSettings) return mmanager odbS3 <- odbS3Backend (case mockAddr of Nothing -> defServiceConfig Just addr -> (Aws.s3 HTTP (T.encodeUtf8 addr) False) { Aws.s3Port = 10001 , Aws.s3RequestStyle = Aws.PathStyle }) (Configuration Timestamp Credentials { accessKeyID = T.encodeUtf8 access , secretAccessKey = T.encodeUtf8 secret } (defaultLog level)) manager bucket prefix dir callbacks void $ liftIO $ odbBackendAdd repo odbS3 100 return repo s3Factory :: MonadS3 m => Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks -> Git.RepositoryFactory (ReaderT LgRepo (NoLoggingT m)) m LgRepo s3Factory bucket accessKey secretKey dir callbacks = lgFactory { Git.runRepository = \ctxt m -> runNoLoggingT $ runLgRepository ctxt (s3back >> m) } where s3back = do repo <- Git.getRepository void $ addS3Backend repo (fromMaybe "test-bucket" bucket) "" accessKey secretKey Nothing (if isNothing bucket then Just "127.0.0.1" else Nothing) Aws.Error dir callbacks s3FactoryLogger :: MonadS3 m => Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks -> Git.RepositoryFactory (ReaderT LgRepo m) m LgRepo s3FactoryLogger bucket accessKey secretKey dir callbacks = lgFactoryLogger { Git.runRepository = \ctxt -> runLgRepository ctxt . (s3back >>) } where s3back = do repo <- Git.getRepository void $ addS3Backend repo (fromMaybe "test-bucket" bucket) "" accessKey secretKey Nothing (if isNothing bucket then Just "127.0.0.1" else Nothing) Aws.Error dir callbacks data S3MockService = S3MockService { objects :: TVar (HashMap (Text, Text) BL.ByteString) } s3MockService :: IO S3MockService s3MockService = S3MockService <$> newTVarIO M.empty mockGetBucket :: MonadS3 m => S3MockService -> Text -> Text -> m (Maybe [Text]) mockGetBucket svc _bucket prefix = wrap "mockGetBucket" (Just <$> go) (return Nothing) where go = do objs <- liftIO $ readTVarIO (objects svc) return $ Prelude.filter (prefix `T.isPrefixOf`) $ map snd $ M.keys objs mockHeadObject :: MonadS3 m => S3MockService -> Text -> Text -> m (Maybe Bool) mockHeadObject svc bucket path = wrap "mockHeadObject" go (return Nothing) where go = do objs <- liftIO $ readTVarIO (objects svc) return $ maybe (Just False) (const (Just True)) $ M.lookup (bucket, path) objs mockGetObject :: MonadS3 m => S3MockService -> Text -> Text -> Maybe (Int64, Int64) -> m (Maybe (Either Text BL.ByteString)) mockGetObject svc bucket path range = wrap "mockHeadObject" go (return Nothing) where go = do objs <- liftIO $ readTVarIO (objects svc) let obj = maybe (Left $ T.pack $ "Not found: " ++ show bucket ++ "/" ++ show path) Right $ M.lookup (bucket, path) objs return $ Just $ case range of Just (beg,end) -> BL.drop beg <$> BL.take end <$> obj Nothing -> obj mockPutObject :: MonadS3 m => S3MockService -> Text -> Text -> Int -> BL.ByteString -> m (Maybe (Either Text ())) mockPutObject svc bucket path _ bytes = wrap "mockPutObject" go (return Nothing) where go = do liftIO $ atomically $ modifyTVar (objects svc) $ M.insert (bucket, path) bytes return $ Just $ Right ()