gitlib-s3 2.0.2.1 → 2.1.0.0
raw patch · 3 files changed
+96/−80 lines, 3 filesdep +filepathdep ~gitlibdep ~gitlib-libgit2dep ~gitlib-s3
Dependencies added: filepath
Dependency ranges changed: gitlib, gitlib-libgit2, gitlib-s3, gitlib-test, hlibgit2
Files
- Git/S3.hs +80/−67
- gitlib-s3.cabal +12/−9
- test/Smoke.hs +4/−4
Git/S3.hs view
@@ -28,8 +28,6 @@ import Aws import Aws.Core-import Aws.S3 hiding (ObjectInfo, bucketName,- getBucket, headObject, getObject, putObject) import qualified Aws.S3 as Aws import Bindings.Libgit2.Errors import Bindings.Libgit2.Odb@@ -39,8 +37,7 @@ import Bindings.Libgit2.Types import Control.Applicative import Control.Concurrent.STM hiding (orElse)-import Control.Exception-import qualified Control.Exception.Lifted as Exc+import Control.Exception.Lifted import Control.Lens ((??)) import Control.Monad import Control.Monad.IO.Class@@ -54,11 +51,12 @@ import Data.Bifunctor import qualified Data.Binary as Bin import Data.Binary as Bin-import Data.ByteString as B hiding (putStrLn, foldr, map)+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-import Data.Conduit.Binary+import Data.Conduit.Binary hiding (drop) import qualified Data.Conduit.List as CList import Data.Default import Data.Foldable (for_)@@ -70,12 +68,11 @@ import Data.Maybe import Data.Monoid import Data.Tagged-import Data.Text as T hiding (foldr, map)-import qualified Data.Text.Encoding as E+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 Filesystem-import Filesystem.Path.CurrentOS hiding (encode, decode) import Foreign.C.String import Foreign.C.Types import Foreign.ForeignPtr@@ -92,12 +89,14 @@ import Git.Libgit2.Internal import Git.Libgit2.Types import Network.HTTP.Conduit hiding (Response)-import Prelude hiding (FilePath, mapM_, catch)+import Prelude hiding (mapM_, catch)+import System.Directory+import System.FilePath.Posix import System.IO.Unsafe debug :: MonadIO m => String -> m ()-debug = liftIO . putStrLn---debug = const (return ())+--debug = liftIO . putStrLn+debug = const (return ()) newtype ObjectLength = ObjectLength { getObjectLength :: Int64 } deriving (Eq, Show, Generic)@@ -119,10 +118,18 @@ , infoType :: ObjectType , infoPath :: Maybe FilePath , infoData :: Maybe ByteString- } deriving (Eq, Show)+ } 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 = fromText . shaToText+fromSha = T.unpack . shaToText data ObjectStatus = ObjectLoose | ObjectLooseMetaKnown ObjectLength ObjectType@@ -194,8 +201,8 @@ -- if it succeeds, a Just Left on error, or Nothing if the method is not -- mocked. - , updateRef :: Text -> Text -> IO ()- , resolveRef :: Text -> IO (Maybe Text)+ , updateRef :: Git.RefName -> Text -> IO ()+ , resolveRef :: Git.RefName -> IO (Maybe Text) , acquireLock :: Text -> IO Text , releaseLock :: Text -> IO ()@@ -269,7 +276,7 @@ , bucketName :: Text , objectPrefix :: Text , configuration :: Configuration- , s3configuration :: S3Configuration NormalQuery+ , 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@@ -321,7 +328,7 @@ wrap :: (Show a, MonadIO m, MonadBaseControl IO m) => String -> m a -> m a -> m a-wrap msg f g = Exc.catch+wrap msg f g = catch (do debug $ msg ++ "..." r <- f debug $ msg ++ "...done, result = " ++ show r@@ -331,7 +338,7 @@ g orElse :: (MonadIO m, MonadBaseControl IO m) => m a -> m a -> m a-orElse f g = Exc.catch f $ \e -> do+orElse f g = catch f $ \e -> do liftIO $ putStrLn "A callback operation failed" liftIO $ print (e :: SomeException) g@@ -491,16 +498,16 @@ res <- awsRetry (configuration dets) (s3configuration dets) (httpManager dets) ((Aws.getBucket bucket)- { gbPrefix = Just prefix- , gbMarker = mmarker })+ { Aws.gbPrefix = Just prefix+ , Aws.gbMarker = mmarker }) gbr <- readResponseIO res- let contents = map objectKey (gbrContents gbr)+ let contents = map Aws.objectKey (Aws.gbrContents gbr) case contents of [] -> return [] _ -> (++) <$> pure contents <*> makeRequest bucket prefix (Just (Prelude.last contents))- (gbrIsTruncated gbr)+ (Aws.gbrIsTruncated gbr) testFileS3 :: OdbS3Details -> Text -> ResourceT IO Bool testFileS3 dets filepath = do@@ -515,26 +522,29 @@ Just r -> return r Nothing -> do debug $ "Aws.headObject: " ++ show filepath- isJust . readResponse- <$> aws (configuration dets) (s3configuration dets)- (httpManager dets) (Aws.headObject bucket path)+ resp <- aws (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 :: OdbS3Details -> Text -> Maybe (Int64,Int64)+getFileS3 :: OdbS3Details -> FilePath -> Maybe (Int64,Int64) -> ResourceT IO (ResumableSource (ResourceT IO) ByteString) getFileS3 dets filepath range = do- debug $ "getFileS3: " ++ show filepath+ debug $ "getFileS3: " ++ filepath let bucket = bucketName dets- path = T.append (objectPrefix dets) filepath+ path = T.unpack (objectPrefix dets) <> filepath cbResult <- wrapGetObject (getObject (callbacks dets))- bucket path range `orElse` return Nothing+ bucket (T.pack path) range `orElse` return Nothing case cbResult of Just (Right r) -> fst <$> (sourceLbs r $$+ Data.Conduit.Binary.take 0) _ -> do debug $ "Aws.getObject: " ++ show filepath ++ " " ++ show range res <- awsRetry (configuration dets) (s3configuration dets)- (httpManager dets) (Aws.getObject bucket path)+ (httpManager dets) (Aws.getObject bucket (T.pack path)) { Aws.goResponseContentRange = bimap fromIntegral fromIntegral <$> range } gor <- readResponseIO res@@ -634,7 +644,11 @@ refs <- mapM Git.lookupReference names liftIO $ writeRefs be (M.fromList (L.zip names refs)) -observePackObjects :: OdbS3Details -> Text -> FilePath -> Bool -> Ptr C'git_odb+observePackObjects :: OdbS3Details+ -> Text+ -> FilePath+ -> Bool+ -> Ptr C'git_odb -> IO [SHA] observePackObjects dets packSha idxFile _alsoWithRemote odbPtr = do debug $ "observePackObjects: " ++ show idxFile@@ -706,13 +720,13 @@ | metadataOnly = return . Just $ ObjectInfo len typ (Just path) Nothing | otherwise = do- exists <- liftIO $ isFile path+ exists <- liftIO $ doesFileExist path if exists then Just <$> (ObjectInfo <$> pure len <*> pure typ <*> pure (Just path)- <*> (Just <$> B.readFile (pathStr path)))+ <*> (Just <$> B.readFile path)) else go LooseRemote go (PackedRemote packSha) = do@@ -731,7 +745,8 @@ packLoadObject dets sha packSha packPath idxPath metadataOnly packLoadObject _dets sha packSha packPath idxPath metadataOnly = do- bothExist <- liftIO $ (&&) <$> isFile packPath <*> isFile idxPath+ bothExist <- liftIO $ (&&) <$> doesFileExist packPath+ <*> doesFileExist idxPath if bothExist then do liftIO $ debug $ "getObjectFromPack "@@ -748,13 +763,13 @@ go >>= cacheUpdateEntry dets sha where go | Just path <- infoPath = do- for_ infoData $ B.writeFile (pathStr path)+ for_ infoData $ B.writeFile path now <- getCurrentTime return $ LooseCached infoLength infoType now path | Just bytes <- infoData = do let path = tempDirectory dets </> fromSha sha- B.writeFile (pathStr path) bytes+ B.writeFile path bytes now <- getCurrentTime return $ LooseCached infoLength infoType now path @@ -814,12 +829,12 @@ remoteReadFile :: OdbS3Details -> FilePath -> ResourceT IO (Maybe ObjectInfo) remoteReadFile dets path = do debug $ "remoteReadFile " ++ show path- exists <- liftIO $ isFile path+ exists <- liftIO $ doesFileExist path when exists $ do debug $ "remoteReadFile: removing " ++ show path liftIO $ removeFile path blocks <- do- result <- getFileS3 dets (pathText (filename path)) Nothing+ result <- getFileS3 dets (takeFileName path) Nothing result $$+- CList.consume debug $ "remoteReadFile: downloaded " ++ show path case blocks of@@ -859,7 +874,7 @@ remoteReadPackFile dets packSha readPackAndIndex = do debug $ "remoteReadPackFile " ++ show packSha let tmpDir = tempDirectory dets- packPath = tmpDir </> fromText ("pack-" <> packSha <> ".pack")+ packPath = tmpDir </> ("pack-" <> T.unpack packSha <> ".pack") idxPath = replaceExtension packPath "idx" runMaybeT $ do@@ -867,11 +882,11 @@ -- "True ||" here, but right now this is not working with the current -- libgit2. when (True || readPackAndIndex) $ do- exists <- liftIO $ isFile packPath+ exists <- liftIO $ doesFileExist packPath void $ if exists then return (Just ()) else download packPath- exists <- liftIO $ isFile idxPath+ exists <- liftIO $ doesFileExist idxPath void $ if exists then return (Just ()) else download idxPath@@ -881,9 +896,8 @@ minfo <- lift $ remoteReadFile dets path for minfo $ \ObjectInfo {..} -> expectingJust- ("failed to download data for " <> pathText path)- infoData- >>= liftIO . B.writeFile (pathStr path)+ ("failed to download data for " <> T.pack path) infoData+ >>= liftIO . B.writeFile path remoteWriteFile :: OdbS3Details -> Text -> ObjectType -> ByteString -> ResourceT IO ()@@ -924,22 +938,21 @@ remoteCatalogContents :: OdbS3Details -> ResourceT IO () remoteCatalogContents dets = do debug "remoteCatalogContents"- items <- listBucketS3 dets+ items <- map T.unpack <$> listBucketS3 dets for_ items $ \item -> case () of- () | ".idx" `T.isSuffixOf` item -> do- let packName = fromText item- packSha = T.drop 5 (pathText (basename packName))+ () | ".idx" `L.isSuffixOf` item -> do+ let packSha = T.pack . drop 5 . takeBaseName $ item debug $ "remoteCatalogContents: found pack file " ++ show packSha mpaths <- remoteReadPackFile dets packSha False- for_ mpaths $ \(_,idxPath) -> liftIO $ do+ for_ mpaths $ \(_, idxPath) -> liftIO $ do shas <- catalogPackFile dets packSha idxPath callbackRegisterPackFile dets packSha shas - | ".pack" `T.isSuffixOf` item -> return ()+ | ".pack" `L.isSuffixOf` item -> return () - | T.length item == 40 -> liftIO $ do- sha <- Git.textToSha . pathText . basename . fromText $ item+ | length item == 40 -> liftIO $ do+ sha <- Git.textToSha . T.pack . takeBaseName $ item cacheUpdateEntry dets sha LooseRemote callbackRegisterCacheEntry dets sha LooseRemote @@ -1020,10 +1033,10 @@ (packSha, packPath, idxPath) <- lgBuildPackIndex dir bytes runResourceT $- remoteWriteFile dets (pathText (filename packPath)) plainFile bytes- (runResourceT .- remoteWriteFile dets (pathText (filename idxPath)) plainFile)- =<< B.readFile (pathStr idxPath)+ remoteWriteFile dets (T.pack (takeFileName packPath)) plainFile bytes+ runResourceT+ . remoteWriteFile dets (T.pack (takeFileName idxPath)) plainFile+ =<< B.readFile idxPath -- This updates the local cache and remote registry with knowledge of -- every object in the pack file.@@ -1121,10 +1134,10 @@ wrapShuttingDown (shuttingDown (callbacks dets)) `orElse` return () let tmpDir = tempDirectory dets- exists <- isDirectory tmpDir+ exists <- doesDirectoryExist tmpDir when exists $ do debug $ "S3.freeCallback: removing tree " ++ show tmpDir- removeTree tmpDir `orElse` return ()+ removeDirectoryRecursive tmpDir `orElse` return () backend <- peek be freeHaskellFunPtr (c'git_odb_backend'read backend)@@ -1172,7 +1185,7 @@ packFreeCallbackPtr :: FunPtr F'git_odb_writepack_free_callback odbS3Backend :: Git.MonadGit m- => S3Configuration NormalQuery+ => Aws.S3Configuration NormalQuery -> Configuration -> Manager -> Text@@ -1194,8 +1207,8 @@ writePackCommitFun <- mk'git_odb_writepack_commit_callback packCommitCallback objects <- newTVarIO M.empty- dirExists <- isDirectory dir- unless dirExists $ createTree dir+ dirExists <- doesDirectoryExist dir+ unless dirExists $ createDirectoryIfMissing True dir let odbS3details = OdbS3Details { httpManager = manager@@ -1260,12 +1273,12 @@ odbS3 <- liftIO $ odbS3Backend (case mockAddr of Nothing -> defServiceConfig- Just addr -> (Aws.s3 HTTP (E.encodeUtf8 addr) False) {+ Just addr -> (Aws.s3 HTTP (T.encodeUtf8 addr) False) { Aws.s3Port = 10001- , Aws.s3RequestStyle = PathStyle })+ , Aws.s3RequestStyle = Aws.PathStyle }) (Configuration Timestamp Credentials {- accessKeyID = E.encodeUtf8 access- , secretAccessKey = E.encodeUtf8 secret }+ accessKeyID = T.encodeUtf8 access+ , secretAccessKey = T.encodeUtf8 secret } (defaultLog level)) manager bucket prefix dir callbacks void $ liftIO $ odbBackendAdd repo odbS3 100
gitlib-s3.cabal view
@@ -1,5 +1,5 @@ Name: gitlib-s3-Version: 2.0.2.1+Version: 2.1.0.0 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@@ -22,16 +22,18 @@ hs-source-dirs: test build-depends: base >=3- , gitlib >= 2.0.1.0- , gitlib-s3 >= 2.0.2.0- , gitlib-test >= 2.0.0.0- , gitlib-libgit2 >= 2.0.2.1- , hlibgit2 >= 0.18.0.9+ , gitlib >= 2.1.0.0+ , gitlib-s3 >= 2.1.0.0+ , gitlib-test >= 2.1.0.0+ , gitlib-libgit2 >= 2.1.0.0+ , hlibgit2 >= 0.18.0.10 , aws >= 0.7.5 , HUnit >= 1.2.5 , hspec >= 1.4.4 , hspec-expectations >= 0.3 , data-default >= 0.5.1+ , directory >= 1.1.0.2+ , filepath >= 1.3.0 , resourcet >= 0.4.6 , system-fileio >= 0.3.9 , system-filepath >= 0.4.7@@ -45,10 +47,10 @@ default-language: Haskell98 build-depends: base >= 3 && < 5- , gitlib >= 2.0.1.0- , gitlib-libgit2 >= 2.0.2.1+ , gitlib >= 2.1.0.0+ , gitlib-libgit2 >= 2.1.0.0 , ghc-prim- , hlibgit2 >= 0.18.0.9+ , hlibgit2 >= 0.18.0.10 , HUnit >= 1.2.5 , aeson >= 0.6.1.0 , attempt >= 0.4.0@@ -62,6 +64,7 @@ , directory >= 1.1.0.2 , either >= 3.4 , errors >= 1.4.1+ , filepath >= 1.3.0 , http-conduit >= 1.8.5.1 , lens >= 3.8 , lifted-base >= 0.2.0.2
test/Smoke.hs view
@@ -15,8 +15,6 @@ import Data.Default (def) import Data.Maybe (fromMaybe, isNothing) import Data.Text as T-import Filesystem-import Filesystem.Path.CurrentOS import qualified Git as Git import qualified Git.Libgit2 as Lg import qualified Git.S3 as S3@@ -24,6 +22,8 @@ import System.Environment import Test.Hspec.HUnit () import Test.Hspec.Runner+import System.Directory+import System.FilePath.Posix s3Factory :: Git.MonadGit m => Git.RepositoryFactory Lg.LgRepository m Lg.Repository@@ -37,10 +37,10 @@ let bucket = T.pack <$> lookup "S3_BUCKET" env accessKey = T.pack <$> lookup "AWS_ACCESS_KEY" env secretKey = T.pack <$> lookup "AWS_SECRET_KEY" env- cwd <- getWorkingDirectory+ cwd <- getCurrentDirectory svc <- S3.s3MockService let tmpDir = cwd </> "s3cache"- createDirectory True tmpDir+ createDirectoryIfMissing True tmpDir S3.addS3Backend repo (fromMaybe "test-bucket" bucket)