gitlib-s3 3.0.1 → 3.0.2
raw patch · 2 files changed
+53/−17 lines, 2 files
Files
- Git/S3.hs +50/−14
- gitlib-s3.cabal +3/−3
Git/S3.hs view
@@ -50,7 +50,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Unsafe as BU import Data.Conduit-import Data.Conduit.Binary hiding (drop)+import Data.Conduit.Binary hiding (mapM_, drop) import qualified Data.Conduit.List as CList import Data.Default import Data.Foldable (for_)@@ -271,6 +271,7 @@ -- 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 } @@ -325,6 +326,16 @@ 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"@@ -405,8 +416,8 @@ -> Maybe (Int64, Int64) -> ResourceT m (Maybe (Either Text BL.ByteString)) wrapGetObject f bucket path range =- wrap ("getObject: " ++ show bucket ++ "/" ++ show path- ++ " " ++ show range)+ wrap' ("getObject: " ++ show bucket ++ "/" ++ show path+ ++ " " ++ show range) (f bucket path range) (return Nothing) @@ -505,7 +516,7 @@ path = T.append (objectPrefix dets) filepath cbResult <- wrapHeadObject (headObject (callbacks dets))- bucket path `orElse` return Nothing+ bucket path `orElse` return (Just False) case cbResult of Just r -> return r Nothing -> do@@ -527,8 +538,10 @@ path = T.unpack (objectPrefix dets) <> filepath cbResult <- wrapGetObject (getObject (callbacks dets))- bucket (T.pack path) range `orElse` return Nothing+ bucket (T.pack path) range+ `orElse` return (Just (Left "Failed to get object from callback")) case cbResult of+ Just (Left e) -> throwIO $ Git.BackendError e Just (Right r) -> transResourceT liftIO $ fst <$> (sourceLbs r $$+ Data.Conduit.Binary.take 0)@@ -553,8 +566,9 @@ cbResult <- wrapPutObject (putObject (callbacks dets)) bucket path (ObjectLength (BL.length lbs)) lbs- `orElse` return Nothing+ `orElse` return (Just (Left "Failed to get object from callback")) case cbResult of+ Just (Left e) -> throwIO $ Git.BackendError e Just (Right r) -> return r _ -> do lgDebug $ "Aws.putObject: " ++ show filepath@@ -630,9 +644,18 @@ -- what it contains. When 'withPackFile' returns, the pack file will be -- closed and any associated resources freed. lgDebug $ "catalogPackFile: " ++ show packSha- _ <- lgWithPackFile idxPath $- observePackObjects dets packSha idxPath True- return []+ 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@@ -742,7 +765,11 @@ then do lgDebug $ "getObjectFromPack " ++ show packPath ++ " " ++ show sha- mresult <- lgReadFromPack idxPath sha metadataOnly+ m <- liftIO $ atomically $ readTVar (knownPackFiles dets)+ mresult <- case M.lookup idxPath m of+ Nothing -> throwIO $ 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]))@@ -977,9 +1004,14 @@ return $ Just LooseRemote else do -- This can be a very time consuming operation- runResourceT $ remoteCatalogContents dets-- cacheLookupEntry dets sha+ 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:@@ -1193,6 +1225,8 @@ 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)@@ -1385,7 +1419,8 @@ writePackCommitFun <- liftIO $ mk'git_odb_writepack_commit_callback writePackCommitFun' - objects <- liftIO $ newTVarIO M.empty+ objects <- liftIO $ newTVarIO M.empty+ packFiles <- liftIO $ newTVarIO M.empty let odbS3details = OdbS3Details { httpManager = manager@@ -1395,6 +1430,7 @@ , s3configuration = s3config , callbacks = callbacks , knownObjects = objects+ , knownPackFiles = packFiles , tempDirectory = dir } odbS3Parent = C'git_odb_backend
gitlib-s3.cabal view
@@ -1,18 +1,18 @@ Name: gitlib-s3-Version: 3.0.1+Version: 3.0.2 Synopsis: Gitlib repository backend for storing Git objects in Amazon S3 Description: Gitlib repository backend for storing Git objects in Amazon S3. License-file: LICENSE License: MIT Author: John Wiegley-Maintainer: johnw@fpcomplete.com+Maintainer: johnw@newartisans.com Build-Type: Simple Cabal-Version: >=1.10 Category: Git Source-repository head type: git- location: git://github.com/fpco/gitlib.git+ location: git://github.com/jwiegley/gitlib.git Test-suite smoke default-language: Haskell98