gitlib-s3 2.2.0.0 → 3.0.0
raw patch · 3 files changed
+204/−151 lines, 3 filesdep +failuredep +splitdep ~gitlibdep ~gitlib-libgit2dep ~gitlib-s3
Dependencies added: failure, split
Dependency ranges changed: gitlib, gitlib-libgit2, gitlib-s3, gitlib-test, http-conduit, stm
Files
- Git/S3.hs +184/−136
- gitlib-s3.cabal +11/−9
- test/Smoke.hs +9/−6
Git/S3.hs view
@@ -31,13 +31,14 @@ import Control.Applicative import Control.Concurrent.STM hiding (orElse) import Control.Exception.Lifted-import Control.Lens ((??))+import Control.Lens ((??), under, reversed) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger hiding (LogLevel) import Control.Monad.Trans.Class import Control.Monad.Trans.Control import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Control.Retry import Data.Aeson as A@@ -58,6 +59,7 @@ 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)@@ -105,7 +107,7 @@ { infoLength :: ObjectLength , infoType :: ObjectType , infoPath :: Maybe FilePath- , infoData :: Maybe ByteString+ , infoData :: Maybe BL.ByteString } deriving Eq instance Show ObjectInfo where@@ -139,6 +141,9 @@ } deriving (Eq, Show, Generic) +type MonadS3 m = (Failure Git.GitException 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@@ -159,11 +164,11 @@ -- "loose", or Just SHA identifying the basename of the packfile that -- the object is located within. - , getBucket :: MonadLg m => Text -> Text -> ResourceT m (Maybe [Text])- , headObject :: MonadLg m => Text -> Text -> ResourceT m (Maybe Bool)- , getObject :: MonadLg m => Text -> Text -> Maybe (Int64, Int64)+ , 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 :: MonadLg m => Text -> Text -> ObjectLength -> BL.ByteString+ , putObject :: MonadS3 m => Text -> Text -> ObjectLength -> BL.ByteString -> ResourceT m (Maybe (Either Text ())) -- These four methods allow mocking of S3. --@@ -310,7 +315,7 @@ fromLength :: CSize -> ObjectLength fromLength = ObjectLength . fromIntegral -wrap :: (Show a, MonadLg m) => String -> m a -> m a -> m a+wrap :: (Show a, MonadS3 m) => String -> m a -> m a -> m a wrap msg f g = catch (do lgDebug $ msg ++ "..." r <- f@@ -320,7 +325,7 @@ lgWarn $ show (e :: SomeException) g -orElse :: MonadLg m => m a -> m a -> m a+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)@@ -330,12 +335,6 @@ coidToJSON coid = unsafePerformIO $ withForeignPtr coid $ fmap A.toJSON . flip oidToStr 40 -pokeByteString :: ByteString -> Ptr (Ptr b) -> ObjectLength -> IO ()-pokeByteString bytes data_p (fromIntegral . getObjectLength -> len) = do- content <- mallocBytes len- BU.unsafeUseAsCString bytes $ copyBytes content ?? len- poke data_p (castPtr content)- unpackDetails :: Ptr C'git_odb_backend -> Ptr C'git_oid -> IO (OdbS3Details, SHA) unpackDetails be oid = do@@ -344,7 +343,7 @@ sha <- oidToSha oid return (dets, sha) -wrapCheckQuota :: MonadLg m+wrapCheckQuota :: MonadS3 m => (ObjectLength -> IO (Maybe QuotaStatus)) -> ObjectLength -> m (Maybe QuotaStatus)@@ -353,7 +352,7 @@ (liftIO $ f len) (return Nothing) -wrapRegisterObject :: MonadLg m+wrapRegisterObject :: MonadS3 m => (SHA -> Maybe (ObjectLength, ObjectType) -> IO ()) -> SHA -> Maybe (ObjectLength, ObjectType)@@ -363,26 +362,22 @@ (liftIO $ f name metadata) (return ()) -wrapRegisterPackFile :: MonadLg m- => (Text -> [SHA] -> IO ())- -> Text- -> [SHA]- -> m ()+wrapRegisterPackFile :: MonadS3 m+ => (Text -> [SHA] -> IO ()) -> Text -> [SHA] -> m () wrapRegisterPackFile f name shas = wrap ("registerPackFile: " ++ show name) (liftIO $ f name shas) (return ()) -wrapLookupObject :: MonadLg m- => (SHA -> IO (Maybe ObjectStatus))- -> SHA+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 :: MonadLg m+wrapGetBucket :: MonadS3 m => (Text -> Text -> ResourceT m (Maybe [Text])) -> Text -> Text@@ -392,7 +387,7 @@ (f bucket prefix) (return Nothing) -wrapHeadObject :: MonadLg m+wrapHeadObject :: MonadS3 m => (Text -> Text -> ResourceT m (Maybe Bool)) -> Text -> Text@@ -402,7 +397,7 @@ (f bucket path) (return Nothing) -wrapGetObject :: MonadLg m+wrapGetObject :: MonadS3 m => (Text -> Text -> Maybe (Int64, Int64) -> ResourceT m (Maybe (Either Text BL.ByteString))) -> Text@@ -415,7 +410,7 @@ (f bucket path range) (return Nothing) -wrapPutObject :: MonadLg m+wrapPutObject :: MonadS3 m => (Text -> Text -> ObjectLength -> BL.ByteString -> ResourceT m (Maybe (Either Text ()))) -> Text@@ -429,35 +424,35 @@ (f bucket path len bytes) (return Nothing) -wrapUpdateRef :: MonadLg m => (Text -> Text -> IO ()) -> Text -> Text -> m ()+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 :: MonadLg m+wrapResolveRef :: MonadS3 m => (Text -> IO (Maybe Text)) -> Text -> m (Maybe Text) wrapResolveRef f name = wrap ("resolveRef: " ++ show name) (liftIO $ f name) (return Nothing) -wrapAcquireLock :: MonadLg m => (Text -> IO Text) -> Text -> m Text+wrapAcquireLock :: MonadS3 m => (Text -> IO Text) -> Text -> m Text wrapAcquireLock f name = wrap ("acquireLock: " ++ show name) (liftIO $ f name) (return "") -wrapReleaseLock :: MonadLg m => (Text -> IO ()) -> Text -> m ()+wrapReleaseLock :: MonadS3 m => (Text -> IO ()) -> Text -> m () wrapReleaseLock f name = wrap ("releaseLock: " ++ show name) (liftIO $ f name) (return ()) -wrapShuttingDown :: MonadLg m => IO () -> m ()+wrapShuttingDown :: MonadS3 m => IO () -> m () wrapShuttingDown f = wrap "shuttingDown..." (liftIO f) (return ()) -wrapSetException :: MonadLg m+wrapSetException :: MonadS3 m => (Git.GitException -> IO ()) -> Git.GitException -> m () wrapSetException f e = wrap ("setException: " ++ show e)@@ -474,7 +469,7 @@ transResourceT liftIO $ retrying def (isFailure . responseResult) $ aws cfg svcfg mgr r -listBucketS3 :: MonadLg m => OdbS3Details -> ResourceT m [Text]+listBucketS3 :: MonadS3 m => OdbS3Details -> ResourceT m [Text] listBucketS3 dets = do lgDebug "listBucketS3" let bucket = bucketName dets@@ -502,7 +497,7 @@ (Just (Prelude.last contents)) (Aws.gbrIsTruncated gbr) -testFileS3 :: MonadLg m => OdbS3Details -> Text -> ResourceT m Bool+testFileS3 :: MonadS3 m => OdbS3Details -> Text -> ResourceT m Bool testFileS3 dets filepath = do lgDebug $ "testFileS3: " ++ show filepath @@ -522,7 +517,7 @@ -- means the object exists. return True -getFileS3 :: MonadLg m+getFileS3 :: MonadS3 m => OdbS3Details -> FilePath -> Maybe (Int64,Int64) -> ResourceT m (ResumableSource (ResourceT IO) ByteString) getFileS3 dets filepath range = do@@ -546,7 +541,7 @@ gor <- readResponseIO res return (responseBody (Aws.gorResponse gor)) -putFileS3 :: MonadLg m+putFileS3 :: MonadS3 m => OdbS3Details -> Text -> Source (ResourceT m) ByteString -> ResourceT m () putFileS3 dets filepath src = do@@ -571,10 +566,10 @@ (RequestBodyLBS lbs)) void $ readResponseIO res -type RefMap m = M.HashMap Text (Maybe (Git.RefTarget (LgRepository m)))+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 m) where+instance A.FromJSON RefTarget where parseJSON j = do o <- A.parseJSON j case L.lookup "symbolic" (M.toList (o :: A.Object)) of@@ -592,11 +587,11 @@ when (r < 0) $ throwIO Git.OidCopyFailed return ptr -instance Git.MonadGit m => A.ToJSON (RefTarget m) where+instance A.ToJSON RefTarget where toJSON (Git.RefSymbolic target) = object [ "symbolic-target" .= target ] toJSON (Git.RefObj oid) = object [ "oid-target" .= coidToJSON (getOid oid) ] -observePackObjects :: MonadLg m+observePackObjects :: MonadS3 m => OdbS3Details -> Text -> FilePath@@ -628,7 +623,7 @@ ++ show (Prelude.length shas) ++ " objects" return shas -catalogPackFile :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+catalogPackFile :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => OdbS3Details -> Text -> FilePath -> m [SHA] catalogPackFile dets packSha idxPath = do -- Load the pack file, and iterate over the objects within it to determine@@ -639,28 +634,69 @@ observePackObjects dets packSha idxPath True return [] -cacheLookupEntry :: MonadLg m => OdbS3Details -> SHA -> m (Maybe CacheEntry)+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+ (go True) (return Nothing) where- go = do+ go recurse = do objs <- liftIO $ readTVarIO (knownObjects dets)- return $ M.lookup sha objs+ case M.lookup sha objs of+ Nothing | M.null objs && recurse -> do+ lgDebug "observeCacheObjects"+ liftIO $ observeCacheObjects dets+ go False+ mres -> return mres -cacheUpdateEntry :: MonadLg m => OdbS3Details -> SHA -> CacheEntry -> m ()+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 :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+cacheLoadObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => OdbS3Details -> SHA -> CacheEntry -> Bool -> m (Maybe ObjectInfo) cacheLoadObject dets sha ce metadataOnly = do lgDebug $ "cacheLoadObject " ++ show sha ++ " " ++ show metadataOnly minfo <- go ce- for_ minfo $ cacheStoreObject dets sha -- refresh the cache's knowledge+ 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@@ -681,7 +717,7 @@ <$> pure len <*> pure typ <*> pure (Just path)- <*> (Just <$> liftIO (B.readFile path)))+ <*> (Just <$> liftIO (BL.readFile path))) else go LooseRemote go (PackedRemote packSha) = do@@ -709,29 +745,27 @@ mresult <- lgReadFromPack idxPath sha metadataOnly for mresult $ \(typ, len, bytes) -> return $ ObjectInfo (fromLength len) (fromType typ)- Nothing (Just bytes)+ Nothing (Just (BL.fromChunks [bytes])) else go (PackedRemote packSha) -cacheStoreObject :: MonadLg m => OdbS3Details -> SHA -> ObjectInfo -> m ()+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 path <- infoPath = do- 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 path bytes+ 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 :: MonadLg m => OdbS3Details -> SHA -> m (Maybe CacheEntry)+callbackLocateObject :: MonadS3 m => OdbS3Details -> SHA -> m (Maybe CacheEntry) callbackLocateObject dets sha = do location <- wrapLookupObject (lookupObject (callbacks dets)) sha `orElse` return Nothing@@ -741,13 +775,13 @@ Just ObjectLoose -> Just LooseRemote _ -> Nothing -callbackRegisterObject :: MonadLg m => OdbS3Details -> SHA -> ObjectInfo -> m ()+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 :: MonadLg m => OdbS3Details -> Text -> [SHA] -> m ()+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@@ -755,7 +789,7 @@ wrapRegisterPackFile (registerPackFile (callbacks dets)) packSha shas `orElse` return () -callbackRegisterCacheEntry :: MonadLg m+callbackRegisterCacheEntry :: MonadS3 m => OdbS3Details -> SHA -> CacheEntry -> m () callbackRegisterCacheEntry dets sha ce = wrap ("callbackRegisterCacheEntry "@@ -776,13 +810,13 @@ err = throwIO (Git.BackendError $ "callbackRecordInfo called with " <> T.pack (show ce)) -remoteObjectExists :: MonadLg m => OdbS3Details -> SHA -> ResourceT m Bool+remoteObjectExists :: MonadS3 m => OdbS3Details -> SHA -> ResourceT m Bool remoteObjectExists dets sha = wrap "remoteObjectExists" (testFileS3 dets (shaToText sha)) (return False) -remoteReadFile :: MonadLg m+remoteReadFile :: MonadS3 m => OdbS3Details -> FilePath -> ResourceT m (Maybe ObjectInfo) remoteReadFile dets path = do lgDebug $ "remoteReadFile " ++ show path@@ -796,7 +830,7 @@ lgDebug $ "remoteReadFile: downloaded " ++ show path case blocks of [] -> return Nothing- bs -> processData bs+ bs -> Just <$> processData bs where processData bs = do let hdrLen = sizeOf (undefined :: Int64) * 2@@ -805,15 +839,14 @@ (Bin.decode (BL.fromChunks [L.head bs]) :: (Int64,Int64)) lgDebug $ "downloadFile: length from header is " ++ show len- content <- liftIO $ mallocBytes len- foldM_ (readData hdrLen content) 0 bs- bytes <- liftIO $ curry BU.unsafePackCStringLen- (castPtr content) (fromIntegral len)- return . Just $ ObjectInfo+ 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 bytes+ , infoData = Just (BL.fromChunks [bytes]) } readData hdrLen content offset x = liftIO $ do@@ -826,7 +859,7 @@ mapPair f (x,y) = (f x, f y) -remoteReadPackFile :: MonadLg m+remoteReadPackFile :: MonadS3 m => OdbS3Details -> Text -> Bool -> ResourceT m (Maybe (FilePath, FilePath)) remoteReadPackFile dets packSha readPackAndIndex = do@@ -844,6 +877,7 @@ void $ if exists then return (Just ()) else download packPath+ exists <- liftIO $ doesFileExist idxPath void $ if exists then return (Just ())@@ -855,15 +889,15 @@ for minfo $ \ObjectInfo {..} -> case infoData of Nothing -> throw $ Git.BackendError $- "failed to download data for " <> T.pack path- Just xs -> liftIO $ B.writeFile path xs+ "Failed to download data for " <> T.pack path+ Just xs -> liftIO $ BL.writeFile path xs -remoteWriteFile :: MonadLg m- => OdbS3Details -> Text -> ObjectType -> ByteString+remoteWriteFile :: MonadS3 m+ => OdbS3Details -> Text -> ObjectType -> BL.ByteString -> ResourceT m () remoteWriteFile dets path typ bytes = do mstatus <- wrapCheckQuota (checkQuota (callbacks dets))- (ObjectLength (fromIntegral (B.length bytes)))+ (ObjectLength (fromIntegral (BL.length bytes))) case mstatus of Nothing -> go Just QuotaCheckSuccess -> go@@ -877,27 +911,27 @@ where go = do lgDebug $ "remoteWriteFile " ++ show path- let hdr = Bin.encode ((fromIntegral (B.length bytes),+ let hdr = Bin.encode ((fromIntegral (BL.length bytes), fromIntegral (getObjectType typ)) :: (Int64,Int64))- payload = BL.append hdr (BL.fromChunks [bytes])+ payload = BL.append hdr bytes putFileS3 dets path (sourceLbs payload) -remoteLoadObject :: MonadLg m+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 :: MonadLg m+remoteStoreObject :: MonadS3 m => OdbS3Details -> SHA -> ObjectInfo -> ResourceT m () remoteStoreObject dets sha (ObjectInfo _ typ _ (Just bytes)) = remoteWriteFile dets (shaToText sha) typ bytes remoteStoreObject _ _ _ = throw (Git.BackendError "remoteStoreObject was not given any data") -remoteCatalogContents :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+remoteCatalogContents :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => OdbS3Details -> ResourceT m () remoteCatalogContents dets = do lgDebug "remoteCatalogContents"@@ -921,7 +955,7 @@ | otherwise -> return () -accessObject :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+accessObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => OdbS3Details -> SHA -> Bool -> m (Maybe CacheEntry) accessObject dets sha checkRemote = do mentry <- cacheLookupEntry dets sha@@ -966,33 +1000,33 @@ -- cache and with the callback interface. This is to avoid recataloging -- in the future. -objectExists :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+objectExists :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => OdbS3Details -> SHA -> Bool -> m CacheEntry objectExists dets sha checkRemote = do mce <- accessObject dets sha checkRemote return $ fromMaybe DoesNotExist mce -readObject :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+readObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow 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 :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+readObjectMetadata :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => OdbS3Details -> SHA -> m (Maybe ObjectInfo) readObjectMetadata dets sha = readObject dets sha True -writeObject :: MonadLg m => OdbS3Details -> SHA -> ObjectInfo -> m ()+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 :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)- => OdbS3Details -> ByteString -> m ()+writePackFile :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+ => OdbS3Details -> BL.ByteString -> m () writePackFile dets bytes = do let dir = tempDirectory dets- len = B.length bytes+ len = BL.length bytes lgDebug $ "writePackFile: building index for " ++ show len ++ " bytes" (packSha, packPath, idxPath) <- lgBuildPackIndex dir bytes @@ -1000,14 +1034,14 @@ remoteWriteFile dets (T.pack (takeFileName packPath)) plainFile bytes runResourceT . remoteWriteFile dets (T.pack (takeFileName idxPath)) plainFile- =<< liftIO (B.readFile idxPath)+ =<< 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 :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+readCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => Ptr (Ptr ()) -> Ptr CSize -> Ptr C'git_otype@@ -1023,12 +1057,22 @@ go dets sha = do minfo <- readObject dets sha False liftIO $ for minfo $ \(ObjectInfo len typ _ (Just bytes)) -> do- pokeByteString bytes data_p len- poke len_p (toLength len)- poke type_p (toType typ)- return (Just ())+ 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 :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+readPrefixCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => Ptr C'git_oid -> Ptr (Ptr ()) -> Ptr CSize@@ -1064,7 +1108,7 @@ go dets sha False | otherwise = return Nothing -readHeaderCallback :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+readHeaderCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => Ptr CSize -> Ptr C'git_otype -> Ptr C'git_odb_backend@@ -1082,7 +1126,7 @@ poke len_p (toLength len) poke type_p (toType typ) -writeCallback :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+writeCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => Ptr C'git_oid -> Ptr C'git_odb_backend -> Ptr ()@@ -1095,7 +1139,7 @@ 0 -> do (dets, sha) <- liftIO $ unpackDetails be oid wrap (T.unpack $ "S3.writeCallback " <> shaToText sha)- (go dets sha >> return c'GIT_OK)+ (c'GIT_OK <$ go dets sha) (return c'GIT_ERROR) n -> do lgDebug "S3.writeCallback failed to hash data"@@ -1106,9 +1150,9 @@ (castPtr obj_data) (fromIntegral len) writeObject dets sha (ObjectInfo (fromLength len) (fromType obj_type)- Nothing (Just bytes))+ Nothing (Just (BL.fromChunks [bytes]))) -existsCallback :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+existsCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => Ptr C'git_odb_backend -> Ptr C'git_oid -> CInt -> m CInt existsCallback be oid confirmNotExists = do (dets, sha) <- liftIO $ unpackDetails be oid@@ -1118,18 +1162,18 @@ return $ if ce == DoesNotExist then 0 else 1) (return c'GIT_ERROR) -refreshCallback :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+refreshCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => Ptr C'git_odb_backend -> m CInt refreshCallback _ = return c'GIT_OK -- do nothing -foreachCallback :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+foreachCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow 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 :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+writePackCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => Ptr (Ptr C'git_odb_writepack) -> Ptr C'git_odb_backend -> C'git_transfer_progress_callback@@ -1150,11 +1194,8 @@ shuttingDown (callbacks dets) - let tmpDir = tempDirectory dets- exists <- doesDirectoryExist tmpDir- when exists $- removeDirectoryRecursive tmpDir- `catch` \(_ :: SomeException) -> return ()+ packFreeCallback (packWriter odbS3)+ freeStablePtr (details odbS3) backend <- peek be freeHaskellFunPtr (c'git_odb_backend'read backend)@@ -1162,16 +1203,18 @@ 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 (packWriter odbS3)- freeStablePtr (details odbS3)+ 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 :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+packAddCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => Ptr C'git_odb_writepack -> Ptr () -> CSize@@ -1179,7 +1222,7 @@ -> m CInt packAddCallback wp dataPtr len _progress = wrap "S3.packAddCallback"- (go >> return c'GIT_OK)+ (c'GIT_OK <$ go) (return c'GIT_ERROR) where go = do@@ -1188,9 +1231,9 @@ dets <- liftIO $ deRefStablePtr (details odbS3) bytes <- liftIO $ curry BU.unsafePackCStringLen (castPtr dataPtr) (fromIntegral len)- writePackFile dets bytes+ writePackFile dets (BL.fromChunks [bytes]) -packCommitCallback :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+packCommitCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => Ptr C'git_odb_writepack -> Ptr C'git_transfer_progress -> m CInt packCommitCallback _wp _progress =@@ -1201,6 +1244,7 @@ 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@@ -1302,7 +1346,7 @@ liftIO $ writeIORef result res readIORef result -odbS3Backend :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+odbS3Backend :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => Aws.S3Configuration NormalQuery -> Configuration -> Manager@@ -1369,7 +1413,7 @@ , c'git_odb_backend'free = freeCallbackPtr } - liftIO $ do+ ptr <- liftIO $ do dirExists <- doesDirectoryExist dir unless dirExists $ createDirectoryIfMissing True dir @@ -1387,13 +1431,16 @@ , 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 :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)- => Repository+addS3Backend :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)+ => LgRepo -> Text -- ^ bucket -> Text -- ^ prefix -> Text -- ^ access key@@ -1403,10 +1450,11 @@ -> LogLevel -> FilePath -> BackendCallbacks -- ^ callbacks- -> m Repository+ -> m LgRepo addS3Backend repo bucket prefix access secret mmanager mockAddr level dir callbacks = do- manager <- maybe (liftIO $ newManager def) return mmanager+ manager <- maybe (liftIO $ newManager conduitManagerSettings) return+ mmanager odbS3 <- odbS3Backend (case mockAddr of Nothing -> defServiceConfig@@ -1421,15 +1469,15 @@ void $ liftIO $ odbBackendAdd repo odbS3 100 return repo -s3Factory :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+s3Factory :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks- -> Git.RepositoryFactory (LgRepository (NoLoggingT m)) m Repository+ -> 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 <- lgGet+ repo <- Git.getRepository void $ addS3Backend repo (fromMaybe "test-bucket" bucket)@@ -1444,14 +1492,14 @@ dir callbacks -s3FactoryLogger :: (MonadLg m, MonadUnsafeIO m, MonadThrow m)+s3FactoryLogger :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m) => Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks- -> Git.RepositoryFactory (LgRepository m) m Repository+ -> Git.RepositoryFactory (ReaderT LgRepo m) m LgRepo s3FactoryLogger bucket accessKey secretKey dir callbacks = lgFactoryLogger { Git.runRepository = \ctxt -> runLgRepository ctxt . (s3back >>) } where s3back = do- repo <- lgGet+ repo <- Git.getRepository void $ addS3Backend repo (fromMaybe "test-bucket" bucket)@@ -1473,7 +1521,7 @@ s3MockService :: IO S3MockService s3MockService = S3MockService <$> newTVarIO M.empty -mockGetBucket :: MonadLg m+mockGetBucket :: MonadS3 m => S3MockService -> Text -> Text -> m (Maybe [Text]) mockGetBucket svc _bucket prefix = wrap "mockGetBucket" (Just <$> go) (return Nothing)@@ -1484,7 +1532,7 @@ $ map snd $ M.keys objs -mockHeadObject :: MonadLg m+mockHeadObject :: MonadS3 m => S3MockService -> Text -> Text -> m (Maybe Bool) mockHeadObject svc bucket path = wrap "mockHeadObject" go (return Nothing)@@ -1494,7 +1542,7 @@ return $ maybe (Just False) (const (Just True)) $ M.lookup (bucket, path) objs -mockGetObject :: MonadLg m+mockGetObject :: MonadS3 m => S3MockService -> Text -> Text -> Maybe (Int64, Int64) -> m (Maybe (Either Text BL.ByteString)) mockGetObject svc bucket path range =@@ -1510,7 +1558,7 @@ Just (beg,end) -> BL.drop beg <$> BL.take end <$> obj Nothing -> obj -mockPutObject :: MonadLg m+mockPutObject :: MonadS3 m => S3MockService -> Text -> Text -> Int -> BL.ByteString -> m (Maybe (Either Text ())) mockPutObject svc bucket path _ bytes =
gitlib-s3.cabal view
@@ -1,5 +1,5 @@ Name: gitlib-s3-Version: 2.2.0.0+Version: 3.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,10 +22,10 @@ hs-source-dirs: test build-depends: base >=3- , gitlib >= 2.2.0.0- , gitlib-s3 >= 2.2.0.0- , gitlib-test >= 2.2.0.0- , gitlib-libgit2 >= 2.2.0.0+ , gitlib >= 3.0.0+ , gitlib-s3 >= 3.0.0+ , gitlib-test >= 3.0.0+ , gitlib-libgit2 >= 3.0.0 , hlibgit2 >= 0.18.0.11 , aws >= 0.7.5 , HUnit >= 1.2.5@@ -33,6 +33,7 @@ , hspec-expectations >= 0.3 , data-default >= 0.5.1 , directory >= 1.1.0.2+ , failure >= 0.2.0.1 , filepath >= 1.3.0 , monad-logger >= 0.3.1.1 , resourcet >= 0.4.6@@ -46,8 +47,8 @@ default-language: Haskell98 build-depends: base >= 3 && < 5- , gitlib >= 2.2.0.0- , gitlib-libgit2 >= 2.2.0.0+ , gitlib >= 3.0.0+ , gitlib-libgit2 >= 3.0.0 , ghc-prim , hlibgit2 >= 0.18.0.11 , aeson >= 0.6.1.0@@ -60,14 +61,15 @@ , data-default >= 0.5.1 , directory >= 1.1.0.2 , filepath >= 1.3.0- , http-conduit >= 1.8.5.1+ , http-conduit >= 2.0 , lens >= 3.8 , lifted-base >= 0.2.0.2 , monad-control , monad-logger >= 0.3.1.1 , resourcet >= 0.4.6 , retry >= 0.2.0.0- , stm >= 2.4.2+ , split >= 0.2.2+ , stm >= 2.4 , text >= 0.11.2 , template-haskell , time >= 1.4
test/Smoke.hs view
@@ -11,8 +11,10 @@ import Aws import Control.Applicative+import Control.Failure import Control.Monad.IO.Class import Control.Monad.Logger+import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Data.Default (def) import Data.Maybe (fromMaybe, isNothing)@@ -21,21 +23,22 @@ import qualified Git.Libgit2 as Lg import qualified Git.S3 as S3 import qualified Git.Smoke as Git+import System.Directory import System.Environment+import System.FilePath.Posix import Test.Hspec.HUnit () import Test.Hspec.Runner-import System.Directory-import System.FilePath.Posix -s3Factory :: (Git.MonadGit m, MonadUnsafeIO m, MonadThrow m)- => Git.RepositoryFactory- (Lg.LgRepository (NoLoggingT m)) m Lg.Repository+s3Factory+ :: (Failure Git.GitException m, MonadIO m, MonadBaseControl IO m,+ MonadUnsafeIO m, MonadThrow m)+ => Git.RepositoryFactory (ReaderT Lg.LgRepo (NoLoggingT m)) m Lg.LgRepo s3Factory = Lg.lgFactory { Git.runRepository = \ctxt m -> runNoLoggingT $ Lg.runLgRepository ctxt (s3back >> m) } where s3back = do- repo <- Lg.lgGet+ repo <- Git.getRepository env <- liftIO getEnvironment let bucket = T.pack <$> lookup "S3_BUCKET" env accessKey = T.pack <$> lookup "AWS_ACCESS_KEY" env