diff --git a/Git/S3.hs b/Git/S3.hs --- a/Git/S3.hs +++ b/Git/S3.hs @@ -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 = diff --git a/gitlib-s3.cabal b/gitlib-s3.cabal --- a/gitlib-s3.cabal +++ b/gitlib-s3.cabal @@ -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 diff --git a/test/Smoke.hs b/test/Smoke.hs --- a/test/Smoke.hs +++ b/test/Smoke.hs @@ -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