diff --git a/Data/Git/Backend/S3.hs b/Data/Git/Backend/S3.hs deleted file mode 100644 --- a/Data/Git/Backend/S3.hs +++ /dev/null @@ -1,415 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Git.Backend.S3 - ( odbS3Backend - , createS3backend - , readRefs, writeRefs - , mirrorRefsFromS3, mirrorRefsToS3 ) - where - -import Aws -import Aws.Core -import Aws.S3 hiding (bucketName) -import Bindings.Libgit2.Odb -import Bindings.Libgit2.OdbBackend -import Bindings.Libgit2.Oid -import Bindings.Libgit2.Refs -import Bindings.Libgit2.Types -import Control.Applicative -import Control.Exception -import Control.Monad -import Control.Monad.IO.Class -import Data.Attempt -import Data.Binary -import Data.ByteString as B hiding (putStrLn) -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC -import Data.ByteString.Unsafe -import Data.Conduit -import Data.Conduit.Binary -import Data.Conduit.List hiding (mapM_, foldM, peek, - catMaybes, sequence) -import Data.Git hiding (getObject) -import Data.Git.Backend -import Data.Git.Backend.Trace -import Data.Git.Error -import Data.Git.Oid -import Data.Int (Int64) -import qualified Data.List as L -import Data.Map -import Data.Maybe -import Data.Stringable -import Data.Text as T -import qualified Data.Text.Encoding as E -import qualified Data.Text.Lazy.Encoding as LE -import qualified Data.Yaml as Y -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 Network.HTTP.Conduit hiding (Response) -import Prelude hiding (mapM_, catch) -import System.IO.Unsafe - -default (Text) - -data OdbS3Backend = - OdbS3Backend { odbS3Parent :: C'git_odb_backend - , httpManager :: StablePtr Manager - , bucketName :: StablePtr Text - , objectPrefix :: StablePtr Text - , configuration :: StablePtr Configuration - , s3configuration :: StablePtr (S3Configuration NormalQuery) } - -instance Storable OdbS3Backend where - sizeOf _ = sizeOf (undefined :: C'git_odb_backend) + - sizeOf (undefined :: StablePtr Manager) + - sizeOf (undefined :: StablePtr Text) + - sizeOf (undefined :: StablePtr Text) + - sizeOf (undefined :: StablePtr Configuration) + - sizeOf (undefined :: StablePtr (S3Configuration NormalQuery)) - alignment _ = alignment (undefined :: Ptr C'git_odb_backend) - peek p = do - v0 <- peekByteOff p 0 - let sizev1 = sizeOf (undefined :: C'git_odb_backend) - v1 <- peekByteOff p sizev1 - let sizev2 = sizev1 + sizeOf (undefined :: StablePtr Manager) - v2 <- peekByteOff p sizev2 - let sizev3 = sizev2 + sizeOf (undefined :: StablePtr Text) - v3 <- peekByteOff p sizev3 - let sizev4 = sizev3 + sizeOf (undefined :: StablePtr Text) - v4 <- peekByteOff p sizev4 - let sizev5 = sizev4 + sizeOf (undefined :: StablePtr Configuration) - v5 <- peekByteOff p sizev5 - return (OdbS3Backend v0 v1 v2 v3 v4 v5) - poke p (OdbS3Backend v0 v1 v2 v3 v4 v5) = do - pokeByteOff p 0 v0 - let sizev1 = sizeOf (undefined :: C'git_odb_backend) - pokeByteOff p sizev1 v1 - let sizev2 = sizev1 + sizeOf (undefined :: StablePtr Manager) - pokeByteOff p sizev2 v2 - let sizev3 = sizev2 + sizeOf (undefined :: StablePtr Text) - pokeByteOff p sizev3 v3 - let sizev4 = sizev3 + sizeOf (undefined :: StablePtr Text) - pokeByteOff p sizev4 v4 - let sizev5 = sizev4 + sizeOf (undefined :: StablePtr Configuration) - pokeByteOff p sizev5 v5 - return () - -odbS3dispatch :: - MonadIO m => - (Manager -> Text -> Text - -> Configuration -> S3Configuration NormalQuery -> a -> m b) - -> OdbS3Backend -> a -> m b -odbS3dispatch f odbS3 arg = do - manager <- liftIO $ deRefStablePtr (httpManager odbS3) - bucket <- liftIO $ deRefStablePtr (bucketName odbS3) - prefix <- liftIO $ deRefStablePtr (objectPrefix odbS3) - config <- liftIO $ deRefStablePtr (configuration odbS3) - s3config <- liftIO $ deRefStablePtr (s3configuration odbS3) - f manager bucket prefix config s3config arg - -testFileS3' :: Manager -> Text -> Text - -> Configuration -> S3Configuration NormalQuery - -> Text - -> ResourceT IO Bool -testFileS3' manager bucket prefix config s3config filepath = - isJust . readResponse <$> - aws config s3config manager - (headObject bucket (T.append prefix filepath)) - -testFileS3 :: OdbS3Backend -> Text -> ResourceT IO Bool -testFileS3 = odbS3dispatch testFileS3' - -getFileS3' :: Manager -> Text -> Text - -> Configuration -> S3Configuration NormalQuery - -> (Text, Maybe (Int,Int)) - -> ResourceT IO (ResumableSource (ResourceT IO) ByteString) -getFileS3' manager bucket prefix config s3config (filepath,range) = do - res <- aws config s3config manager - (getObject bucket (T.append prefix filepath)) - { goResponseContentRange = range } - gor <- readResponseIO res - return (responseBody (gorResponse gor)) - -getFileS3 :: OdbS3Backend -> Text -> Maybe (Int,Int) - -> ResourceT IO (ResumableSource (ResourceT IO) ByteString) -getFileS3 = curry . odbS3dispatch getFileS3' - -putFileS3' :: Manager -> Text -> Text - -> Configuration -> S3Configuration NormalQuery - -> (Text, Source (ResourceT IO) ByteString) - -> ResourceT IO BL.ByteString -putFileS3' manager bucket prefix config s3config (filepath,src) = do - lbs <- BL.fromChunks <$> (src $$ consume) - res <- aws config s3config manager - (putObject bucket (T.append prefix filepath) - (RequestBodyLBS lbs)) - _ <- readResponseIO res - return lbs - -putFileS3 :: OdbS3Backend -> Text -> Source (ResourceT IO) ByteString - -> ResourceT IO BL.ByteString -putFileS3 = curry . odbS3dispatch putFileS3' - -type RefMap = Map Text (Either Text Oid) - -instance Y.FromJSON Oid where - parseJSON (Y.String v) = - return . Oid . COid $ unsafePerformIO $ do - ptr <- mallocForeignPtr - withCStringable v $ \cstr -> - withForeignPtr ptr $ \ptr' -> do - r <- c'git_oid_fromstr ptr' cstr - when (r < 0) $ throwIO OidCopyFailed - return ptr - -coidToJSON :: ForeignPtr C'git_oid -> Y.Value -coidToJSON coid = unsafePerformIO $ withForeignPtr coid $ \oid -> - Y.toJSON <$> oidToStr oid - -instance Y.ToJSON Oid where - toJSON (PartialOid (COid coid) _) = throw RefCannotCreateFromPartialOid - toJSON (Oid (COid coid)) = coidToJSON coid - -readRefs :: Ptr C'git_odb_backend -> IO (Maybe RefMap) -readRefs be = do - odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) - exists <- catch (runResourceT $ testFileS3 odbS3 "refs.yml") - (\e -> print (e :: IOException) >> throwIO e) - if exists - then do - bytes <- catch (runResourceT $ do - result <- getFileS3 odbS3 "refs.yml" Nothing - result $$+- await) - (\e -> print (e :: IOException) >> throwIO e) - case bytes of - Nothing -> return Nothing - Just bytes' -> return (Y.decode bytes' :: Maybe RefMap) - - else return Nothing - -writeRefs :: Ptr C'git_odb_backend -> RefMap -> IO () -writeRefs be refs = do - let payload = Y.encode refs - odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) - void $ runResourceT $ - putFileS3 odbS3 "refs.yml" (sourceLbs (BL.fromChunks [payload])) - -mirrorRefsFromS3 :: Ptr C'git_odb_backend -> Repository -> IO () -mirrorRefsFromS3 be repo = do - refs <- readRefs be - case refs of - Nothing -> return () - Just refs' -> - forM_ (toList refs') $ \(name, ref) -> - withForeignPtr (repositoryPtr repo) $ \repoPtr -> - withCStringable name $ \namePtr -> alloca $ \ptr -> do - r <- case ref of - Left target -> - withCStringable target $ \targetPtr -> - c'git_reference_create_symbolic ptr repoPtr namePtr - targetPtr 1 - Right (PartialOid {}) -> - throwIO RefCannotCreateFromPartialOid - Right (Oid (COid coid)) -> - withForeignPtr coid $ \coidPtr -> - c'git_reference_create_oid ptr repoPtr namePtr coidPtr 1 - when (r < 0) $ throwIO RepositoryInvalid - -mirrorRefsToS3 :: Ptr C'git_odb_backend -> Repository -> IO () -mirrorRefsToS3 be repo = do - odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) - refs <- catMaybes <$> - mapAllRefs repo (\name -> do ref <- lookupRef repo name - return (go name <$> ref)) - writeRefs be (fromList refs) - where go name ref = - case refTarget ref of - RefTargetSymbolic target -> (name, Left target) - RefTargetId oid -> (name, Right oid) - -mapPair :: (a -> b) -> (a,a) -> (b,b) -mapPair f (x,y) = (f x, f y) - -odbS3BackendReadCallback :: F'git_odb_backend_read_callback -odbS3BackendReadCallback data_p len_p type_p be oid = - catch go (\e -> print (e :: IOException) >> return (-1)) - where - go = do - odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) - oidStr <- oidToStr oid - blocks <- runResourceT $ do - result <- getFileS3 odbS3 (T.pack oidStr) Nothing - result $$+- consume - case blocks of - [] -> return (-1) - bs -> do - let hdrLen = sizeOf (undefined :: Int64) * 2 - (len,typ) = - mapPair fromIntegral $ - (decode (BL.fromChunks [L.head bs]) :: (Int64,Int64)) - content <- mallocBytes len - foldM (\offset x -> do - let xOffset = if offset == 0 then hdrLen else 0 - innerLen = B.length x - xOffset - unsafeUseAsCString x $ \cstr -> - copyBytes (content `plusPtr` offset) - (cstr `plusPtr` xOffset) innerLen - return (offset + innerLen)) 0 bs - poke len_p (fromIntegral len) - poke type_p (fromIntegral typ) - poke data_p (castPtr content) - return 0 - -odbS3BackendReadPrefixCallback :: F'git_odb_backend_read_prefix_callback -odbS3BackendReadPrefixCallback out_oid oid_p len_p type_p be oid len = - return 0 - -odbS3BackendReadHeaderCallback :: F'git_odb_backend_read_header_callback -odbS3BackendReadHeaderCallback len_p type_p be oid = - catch go (\e -> print (e :: IOException) >> return (-1)) - where - go = do - let hdrLen = sizeOf (undefined :: Int64) * 2 - odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) - oidStr <- oidToStr oid - bytes <- runResourceT $ do - result <- getFileS3 odbS3 (T.pack oidStr) (Just (0,hdrLen - 1)) - result $$+- await - case bytes of - Nothing -> return (-1) - Just bs -> do - let (len,typ) = decode (BL.fromChunks [bs]) :: (Int64,Int64) - poke len_p (fromIntegral len) - poke type_p (fromIntegral typ) - return 0 - -odbS3BackendWriteCallback :: F'git_odb_backend_write_callback -odbS3BackendWriteCallback oid be obj_data len obj_type = do - r <- c'git_odb_hash oid obj_data len obj_type - case r of - 0 -> do - oidStr <- oidToStr oid - odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) - let hdr = encode ((fromIntegral len, - fromIntegral obj_type) :: (Int64,Int64)) - bytes <- curry unsafePackCStringLen - (castPtr obj_data) (fromIntegral len) - let payload = BL.append hdr (BL.fromChunks [bytes]) - catch (go odbS3 oidStr payload >> return 0) - (\e -> print (e :: IOException) >> return (-1)) - n -> return n - where - go odbS3 oidStr payload = - runResourceT $ putFileS3 odbS3 (T.pack oidStr) (sourceLbs payload) - -odbS3BackendExistsCallback :: F'git_odb_backend_exists_callback -odbS3BackendExistsCallback be oid = do - oidStr <- oidToStr oid - odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) - exists <- catch (runResourceT $ testFileS3 odbS3 (T.pack oidStr)) - (\e -> print (e :: IOException) >> return False) - return $ if exists then 1 else 0 - -odbS3BackendFreeCallback :: F'git_odb_backend_free_callback -odbS3BackendFreeCallback be = do - 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) - - odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) - freeStablePtr (httpManager odbS3) - freeStablePtr (bucketName odbS3) - freeStablePtr (objectPrefix odbS3) - freeStablePtr (configuration odbS3) - freeStablePtr (s3configuration odbS3) - -foreign export ccall "odbS3BackendFreeCallback" - odbS3BackendFreeCallback :: F'git_odb_backend_free_callback -foreign import ccall "&odbS3BackendFreeCallback" - odbS3BackendFreeCallbackPtr :: FunPtr F'git_odb_backend_free_callback - -odbS3Backend :: S3Configuration NormalQuery - -> Configuration - -> Manager -> Text -> Text - -> IO (Ptr C'git_odb_backend) -odbS3Backend s3config config manager bucket prefix = do - readFun <- mk'git_odb_backend_read_callback odbS3BackendReadCallback - readPrefixFun <- - mk'git_odb_backend_read_prefix_callback odbS3BackendReadPrefixCallback - readHeaderFun <- - mk'git_odb_backend_read_header_callback odbS3BackendReadHeaderCallback - writeFun <- mk'git_odb_backend_write_callback odbS3BackendWriteCallback - existsFun <- mk'git_odb_backend_exists_callback odbS3BackendExistsCallback - - manager' <- newStablePtr manager - bucket' <- newStablePtr bucket - prefix' <- newStablePtr prefix - s3config' <- newStablePtr s3config - config' <- newStablePtr config - - castPtr <$> new OdbS3Backend { - odbS3Parent = C'git_odb_backend { - 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'free = odbS3BackendFreeCallbackPtr } - , httpManager = manager' - , bucketName = bucket' - , objectPrefix = prefix' - , configuration = config' - , s3configuration = s3config' } - -createS3backend :: Text -- ^ bucket - -> Text -- ^ prefix - -> Text -- ^ access key - -> Text -- ^ secret key - -> Maybe Manager - -> Maybe Text -- ^ mock address - -> LogLevel - -> Bool -- ^ tracing? - -> Repository - -> IO Repository -createS3backend bucket prefix access secret mmanager mockAddr level tracing repo = do - manager <- maybe (newManager def) return mmanager - odbS3 <- - odbS3Backend - (case mockAddr of - Nothing -> defServiceConfig - Just addr -> (s3 HTTP (E.encodeUtf8 addr) False) { - s3Port = 10001 - , s3RequestStyle = PathStyle }) - (Configuration Timestamp Credentials { - accessKeyID = E.encodeUtf8 access - , secretAccessKey = E.encodeUtf8 secret } - (defaultLog level)) - manager bucket prefix - - if tracing - then do backend <- traceBackend odbS3 - odbBackendAdd repo backend 100 - else odbBackendAdd repo odbS3 100 - - -- Start by reading in the known refs from S3 - mirrorRefsFromS3 odbS3 repo - - -- Whenever a ref is written, update the refs in S3 - let onWrite = const $ mirrorRefsToS3 odbS3 repo - return repo { repoOnWriteRef = onWrite : repoOnWriteRef repo } - --- S3.hs diff --git a/Git/S3.hs b/Git/S3.hs new file mode 100644 --- /dev/null +++ b/Git/S3.hs @@ -0,0 +1,1361 @@ +{-# 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 + -- , readRefs, writeRefs + -- , mirrorRefsFromS3, mirrorRefsToS3 + ) where + +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 +import Bindings.Libgit2.OdbBackend +import Bindings.Libgit2.Oid +import Bindings.Libgit2.Refs +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.Lens ((??)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Resource +import Control.Retry +import Data.Aeson as A +import Data.Attempt +import Data.Bifunctor +import Data.Binary as Bin +import Data.ByteString as B hiding (putStrLn, foldr, map) +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Unsafe as BU +import Data.Conduit +import Data.Conduit.Binary +import qualified Data.Conduit.List as CList +import Data.Default +import Data.Foldable (for_) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as M +import Data.Int (Int64) +import Data.IORef +import qualified Data.List as L +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.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 +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.Libgit2 +import Git.Libgit2.Backend +import Git.Libgit2.Internal +import Git.Libgit2.Types +import Network.HTTP.Conduit hiding (Response) +import Prelude hiding (FilePath, mapM_, catch) +import System.IO.Unsafe + +data ObjectLength = ObjectLength { getObjectLength :: Int64 } + deriving (Eq, Show, Generic) +data ObjectType = ObjectType { getObjectType :: Int } + deriving (Eq, Show, Generic) + +plainFile :: ObjectType +plainFile = ObjectType 0 + +data ObjectInfo = ObjectInfo + { infoLength :: ObjectLength + , infoType :: ObjectType + , infoPath :: Maybe FilePath + , infoData :: Maybe ByteString + } deriving (Eq, Show) + +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) + +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 :: Text -> 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 -> [Text] -> ObjectLength -> 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 :: Text -> IO (Maybe ObjectStatus) + -- 'locateObject' takes a SHA, and returns: Nothing if the object is + -- "loose", or Just Text identifying the basename of the packfile that + -- the object is located within. + + , lookupPackFile :: Text -> IO (Maybe Bool) + -- 'locatePackFile' indicates whether a pack file with the given sha is + -- present on the remote, regardless of which objects it contains. + + , getBucket :: (MonadIO m, MonadBaseControl IO m) + => Text -> Text -> ResourceT m (Maybe [Text]) + , headObject :: (MonadIO m, MonadBaseControl IO m) + => Text -> Text -> ResourceT m (Maybe Bool) + , getObject :: (MonadIO m, MonadBaseControl IO m) + => Text -> Text -> Maybe (Int64, Int64) + -> ResourceT m (Maybe (Either Text BL.ByteString)) + , putObject :: (MonadIO m, MonadBaseControl IO m) + => Text -> Text -> ObjectLength -> BL.ByteString + -> ResourceT m (Maybe (Either Text ())) + -- These three 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 :: Text -> Text -> IO () + , resolveRef :: Text -> 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 + , lookupPackFile = \_ -> 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 :: 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 Text CacheEntry) + , 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 () + +debug :: MonadIO m => String -> m () +--debug = liftIO . putStrLn +debug = const (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, MonadIO m, MonadBaseControl IO m) + => String -> m a -> m a -> m a +wrap msg f g = Exc.catch + (do debug $ msg ++ "..." + r <- f + debug $ msg ++ "...done, result = " ++ show r + return r) + $ \e -> do liftIO $ putStrLn $ msg ++ "...FAILED" + liftIO $ print (e :: SomeException) + g + +orElse :: (MonadIO m, MonadBaseControl IO m) => m a -> m a -> m a +orElse f g = Exc.catch f $ \e -> do + liftIO $ putStrLn "A callback operation failed" + liftIO $ print (e :: SomeException) + g + +coidToJSON :: ForeignPtr C'git_oid -> A.Value +coidToJSON coid = unsafePerformIO $ withForeignPtr coid $ + fmap A.toJSON . oidToStr + +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, String, Text) +unpackDetails be oid = do + odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) + dets <- deRefStablePtr (details odbS3) + oidStr <- oidToStr oid + return (dets, oidStr, T.pack oidStr) + +wrapCheckQuota :: (ObjectLength -> IO (Maybe QuotaStatus)) + -> ObjectLength + -> IO (Maybe QuotaStatus) +wrapCheckQuota f len = + wrap ("checkQuota " ++ show len) + (f len) + (return Nothing) + +wrapRegisterObject :: (Text -> Maybe (ObjectLength, ObjectType) -> IO ()) + -> Text + -> Maybe (ObjectLength, ObjectType) + -> IO () +wrapRegisterObject f name metadata = + wrap ("registerObject " ++ show name ++ " " ++ show metadata) + (f name metadata) + (return ()) + +wrapRegisterPackFile :: (Text -> [Text] -> ObjectLength -> IO ()) + -> Text -> [Text] -> ObjectLength + -> IO () +wrapRegisterPackFile f name shas len = + wrap ("registerPackFile: " ++ show name) + (f name shas len) + (return ()) + +wrapLookupObject :: (Text -> IO (Maybe ObjectStatus)) + -> Text + -> IO (Maybe ObjectStatus) +wrapLookupObject f name = + wrap ("lookupObject: " ++ show name) + (f name) + (return Nothing) + +wrapLookupPackFile :: (Text -> IO (Maybe Bool)) -> Text -> IO (Maybe Bool) +wrapLookupPackFile f name = + wrap ("lookupPackFile: " ++ show name) + (f name) + (return Nothing) + +wrapGetBucket :: (MonadIO m, MonadBaseControl IO 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 :: (MonadIO m, MonadBaseControl IO 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 :: (MonadIO m, MonadBaseControl IO 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 :: (MonadIO m, MonadBaseControl IO 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 :: (Text -> Text -> IO ()) -> Text -> Text -> IO () +wrapUpdateRef f name sha = + wrap ("updateRef: " ++ show name ++ " " ++ show sha) + (f name sha) + (return ()) + +wrapResolveRef :: (Text -> IO (Maybe Text)) -> Text -> IO (Maybe Text) +wrapResolveRef f name = + wrap ("resolveRef: " ++ show name) + (f name) + (return Nothing) + +wrapAcquireLock :: (Text -> IO Text) -> Text -> IO Text +wrapAcquireLock f name = + wrap ("acquireLock: " ++ show name) + (f name) + (return "") + +wrapReleaseLock :: (Text -> IO ()) -> Text -> IO () +wrapReleaseLock f name = + wrap ("releaseLock: " ++ show name) + (f name) + (return ()) + +wrapShuttingDown :: IO () -> IO () +wrapShuttingDown f = wrap "shuttingDown..." f (return ()) + +wrapSetException :: (Git.GitException -> IO ()) -> Git.GitException -> IO () +wrapSetException f e = + wrap ("setException: " ++ show e) + (f e) + (return ()) + +awsRetry :: Transaction r a + => Configuration + -> ServiceConfiguration r NormalQuery + -> Manager + -> r + -> ResourceT IO (Response (ResponseMetadata a) a) +awsRetry = ((((retrying def (isFailure . responseResult) .) .) .) .) aws + +listBucketS3 :: OdbS3Details -> ResourceT IO [Text] +listBucketS3 dets = do + debug "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 + debug "Aws.getBucket" + res <- awsRetry (configuration dets) (s3configuration dets) + (httpManager dets) + ((Aws.getBucket bucket) + { gbPrefix = Just prefix + , gbMarker = mmarker }) + gbr <- readResponseIO res + let contents = map objectKey (gbrContents gbr) + case contents of + [] -> return [] + _ -> (++) <$> pure contents + <*> makeRequest bucket prefix + (Just (Prelude.last contents)) + (gbrIsTruncated gbr) + +testFileS3 :: OdbS3Details -> Text -> ResourceT IO Bool +testFileS3 dets filepath = do + debug $ "testFileS3: " ++ show filepath + + let bucket = bucketName dets + path = T.append (objectPrefix dets) filepath + + cbResult <- wrapHeadObject (headObject (callbacks dets)) + bucket path `orElse` return Nothing + case cbResult of + Just r -> return r + Nothing -> do + debug $ "Aws.headObject: " ++ show filepath + isJust . readResponse + <$> aws (configuration dets) (s3configuration dets) + (httpManager dets) (Aws.headObject bucket path) + +getFileS3 :: OdbS3Details -> Text -> Maybe (Int64,Int64) + -> ResourceT IO (ResumableSource (ResourceT IO) ByteString) +getFileS3 dets filepath range = do + debug $ "getFileS3: " ++ show filepath + + let bucket = bucketName dets + path = T.append (objectPrefix dets) filepath + + cbResult <- wrapGetObject (getObject (callbacks dets)) + bucket 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) + { Aws.goResponseContentRange = + bimap fromIntegral fromIntegral <$> range } + gor <- readResponseIO res + return (responseBody (Aws.gorResponse gor)) + +putFileS3 :: OdbS3Details -> Text -> Source (ResourceT IO) ByteString + -> ResourceT IO () +putFileS3 dets filepath src = do + debug $ "putFileS3: " ++ show filepath + + let bucket = bucketName dets + path = T.append (objectPrefix dets) filepath + lbs <- BL.fromChunks <$> (src $$ CList.consume) + + cbResult <- wrapPutObject (putObject (callbacks dets)) bucket path + (ObjectLength (BL.length lbs)) lbs + `orElse` return Nothing + case cbResult of + Just (Right r) -> return r + _ -> do + debug $ "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.Reference (LgRepository m) (Commit m))) + +-- jww (2013-04-26): Split these off into a gitlib-aeson library. +instance A.FromJSON (Reference m) where + parseJSON j = do + o <- A.parseJSON j + case L.lookup "symbolic" (M.toList (o :: A.Object)) of + Just _ -> Git.Reference + <$> o .: "symbolic" + <*> (Git.RefSymbolic <$> o .: "target") + Nothing -> Git.Reference + <$> o .: "name" + <*> (Git.RefObj . Git.ByOid . go <$> o .: "target") + where + go = return . Oid . unsafePerformIO . strToOid + +instance Git.MonadGit m => A.ToJSON (Reference m) where + toJSON (Git.Reference name (Git.RefSymbolic target)) = + object [ "symbolic" .= name + , "target" .= target ] + toJSON (Git.Reference name (Git.RefObj (Git.ByOid oid))) = + object [ "name" .= name + , "target" .= coidToJSON (getOid (unTagged oid)) ] + toJSON (Git.Reference name (Git.RefObj (Git.Known commit))) = + object [ "name" .= name + , "target" .= + coidToJSON (getOid (unTagged (Git.commitOid commit))) ] + +readRefs :: Ptr C'git_odb_backend -> IO (Maybe (RefMap m)) +readRefs be = do + odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) + dets <- deRefStablePtr (details odbS3) + exists <- wrap "Failed to check whether 'refs.json' exists" + (runResourceT $ testFileS3 dets "refs.json") + (return False) + if exists + then do + bytes <- wrap "Failed to read 'refs.json'" + (runResourceT $ do + result <- getFileS3 dets "refs.json" Nothing + result $$+- await) + (return Nothing) + return . join $ A.decode . BL.fromChunks . (:[]) <$> bytes + else return Nothing + +writeRefs :: Git.MonadGit m => Ptr C'git_odb_backend -> RefMap m -> IO () +writeRefs be refs = do + odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) + dets <- deRefStablePtr (details odbS3) + void $ runResourceT $ + putFileS3 dets "refs.json" $ sourceLbs (A.encode refs) + +mirrorRefsFromS3 :: Git.MonadGit m => Ptr C'git_odb_backend -> LgRepository m () +mirrorRefsFromS3 be = do + repo <- lgGet + refs <- liftIO $ readRefs be + for_ refs $ \refs' -> + forM_ (M.toList refs') $ \(name, ref) -> + liftIO $ withForeignPtr (repoObj repo) $ \repoPtr -> + withCString (T.unpack name) $ \namePtr -> + alloca (go repoPtr namePtr ref) + where + go repoPtr namePtr ref ptr = do + r <- case ref of + Just Git.Reference { Git.refTarget = Git.RefSymbolic target } -> + withCString (T.unpack target) $ \targetPtr -> + c'git_reference_symbolic_create ptr repoPtr namePtr + targetPtr 1 + Just Git.Reference { + Git.refTarget = Git.RefObj (Git.ByOid (Tagged coid)) } -> + withForeignPtr (getOid coid) $ \coidPtr -> + c'git_reference_create ptr repoPtr namePtr coidPtr 1 + _ -> return 0 + when (r < 0) $ throwIO Git.RepositoryInvalid + +mirrorRefsToS3 :: Git.MonadGit m => Ptr C'git_odb_backend -> LgRepository m () +mirrorRefsToS3 be = do + names <- Git.allRefNames + refs <- mapM Git.lookupRef names + liftIO $ writeRefs be (M.fromList (L.zip names refs)) + +observePackObjects :: OdbS3Details -> Text -> FilePath -> Bool -> Ptr C'git_odb + -> IO [Text] +observePackObjects dets packSha idxFile _alsoWithRemote odbPtr = do + debug $ "observePackObjects: " ++ show idxFile + + -- Iterate the "database", which gives us a list of all the oids contained + -- within it + mshas <- newIORef [] + r <- 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. + debug "observePackObjects: update known objects map" + now <- getCurrentTime + shas <- readIORef mshas + let obj = PackedCached now packSha (replaceExtension idxFile "pack") idxFile + atomically $ modifyTVar (knownObjects dets) $ \objs -> + foldr (`M.insert` obj) objs shas + + debug $ "observePackObjects: observed " + ++ show (Prelude.length shas) ++ " objects" + return shas + +catalogPackFile :: OdbS3Details -> Text -> FilePath -> IO [Text] +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. + debug $ "catalogPackFile: " ++ show packSha + lgWithPackFile idxPath $ + liftIO . observePackObjects dets packSha idxPath True + +cacheLookupEntry :: OdbS3Details -> Text -> IO (Maybe CacheEntry) +cacheLookupEntry dets sha = + wrap ("cacheLookupEntry " ++ show sha) + go + (return Nothing) + where + go = do + objs <- readTVarIO (knownObjects dets) + return $ M.lookup sha objs + +cacheUpdateEntry :: OdbS3Details -> Text -> CacheEntry -> IO () +cacheUpdateEntry dets sha ce = do + debug $ "cacheUpdateEntry " ++ show sha ++ " " ++ show ce + atomically $ modifyTVar (knownObjects dets) $ M.insert sha ce + +cacheLoadObject :: OdbS3Details -> Text -> CacheEntry -> Bool + -> IO (Maybe ObjectInfo) +cacheLoadObject dets sha ce metadataOnly = do + debug $ "cacheLoadObject " ++ show sha ++ " " ++ show metadataOnly + minfo <- go ce + for_ minfo $ cacheStoreObject dets sha -- refresh the cache's knowledge + 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 $ isFile path + if exists + then Just <$> (ObjectInfo + <$> pure len + <*> pure typ + <*> pure (Just path) + <*> (Just <$> B.readFile (pathStr path))) + else go LooseRemote + + go (PackedRemote packSha) = do + mpaths <- runResourceT $ remoteReadPackFile dets packSha + 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 $ (&&) <$> isFile packPath <*> isFile idxPath + if bothExist + then do + liftIO $ debug $ "getObjectFromPack " + ++ show packPath ++ " " ++ show sha + mresult <- lgReadFromPack idxPath sha metadataOnly + for mresult $ \(typ, len, bytes) -> + return $ ObjectInfo (fromLength len) (fromType typ) + Nothing (Just bytes) + else go (PackedRemote packSha) + +cacheStoreObject :: OdbS3Details -> Text -> ObjectInfo -> IO () +cacheStoreObject dets sha info@ObjectInfo {..} = do + debug $ "cacheStoreObject " ++ show sha ++ " " ++ show info + go >>= cacheUpdateEntry dets sha + where + go | Just path <- infoPath = do + now <- getCurrentTime + return $ LooseCached infoLength infoType now path + + | Just bytes <- infoData = do + let path = tempDirectory dets fromText sha + B.writeFile (pathStr path) bytes + now <- getCurrentTime + return $ LooseCached infoLength infoType now path + + | otherwise = + return $ LooseRemoteMetaKnown infoLength infoType + +callbackLocateObject :: OdbS3Details -> Text -> IO (Maybe CacheEntry) +callbackLocateObject dets sha = do + location <- wrapLookupObject (lookupObject (callbacks dets)) + sha `orElse` return Nothing + debug $ "callbackLocateObject lookup: " ++ show location + return $ case location of + Just (ObjectInPack base) -> Just (PackedRemote base) + Just ObjectLoose -> Just LooseRemote + _ -> Nothing + +callbackRegisterObject :: OdbS3Details -> Text -> ObjectInfo -> IO () +callbackRegisterObject dets sha info@ObjectInfo {..} = do + debug $ "callbackRegisterObject " ++ show sha ++ " " ++ show info + wrapRegisterObject (registerObject (callbacks dets)) sha + (Just (infoLength, infoType))`orElse` return () + +callbackRegisterPackFile :: OdbS3Details -> Text -> [Text] -> ObjectLength + -> IO () +callbackRegisterPackFile dets packSha shas len = do + debug $ "callbackRegisterPackFile " ++ show packSha + -- Let whoever is listening know about this pack files and its contained + -- objects + wrapRegisterPackFile (registerPackFile (callbacks dets)) + packSha shas len `orElse` return () + +callbackRegisterCacheEntry :: OdbS3Details -> Text -> CacheEntry -> IO () +callbackRegisterCacheEntry dets sha ce = + wrap ("callbackRegisterCacheEntry " ++ show 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 = throwIO (Git.BackendError $ + "callbackRecordInfo called with " <> T.pack (show ce)) + +remoteObjectExists :: OdbS3Details -> Text -> ResourceT IO Bool +remoteObjectExists dets sha = + wrap "remoteObjectExists" + (testFileS3 dets sha) + (return False) + +remoteReadFile :: OdbS3Details -> FilePath -> ResourceT IO (Maybe ObjectInfo) +remoteReadFile dets path = do + debug $ "remoteReadFile " ++ show path + exists <- liftIO $ isFile path + when exists $ do + debug $ "remoteReadFile: removing " ++ show path + liftIO $ removeFile path + blocks <- do + result <- getFileS3 dets (pathText (filename path)) Nothing + result $$+- CList.consume + debug $ "remoteReadFile: downloaded " ++ show path + case blocks of + [] -> return Nothing + bs -> 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)) + debug $ "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 + { infoLength = ObjectLength (fromIntegral len) + , infoType = ObjectType (fromIntegral typ) + , infoPath = Just path + , infoData = Just 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 :: OdbS3Details -> Text + -> ResourceT IO (Maybe (FilePath, FilePath)) +remoteReadPackFile dets packSha = do + debug $ "remoteReadPackFile " ++ show packSha + let tmpDir = tempDirectory dets + packPath = tmpDir fromText ("pack-" <> packSha <> ".pack") + idxPath = replaceExtension packPath "idx" + + runMaybeT $ do + exists <- liftIO $ isFile packPath + void $ if exists + then return (Just ()) + else download packPath + exists <- liftIO $ isFile 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 {..} -> + expectingJust + ("failed to download data for " <> pathText path) + infoData + >>= liftIO . B.writeFile (pathStr path) + +remoteWriteFile :: OdbS3Details -> Text -> ObjectType -> ByteString + -> ResourceT IO () +remoteWriteFile dets path typ bytes = do + mstatus <- liftIO $ wrapCheckQuota (checkQuota (callbacks dets)) + (ObjectLength (fromIntegral (B.length bytes))) + case mstatus of + Nothing -> go + Just QuotaCheckSuccess -> go + Just (QuotaSoftLimitExceeded {}) -> go + Just (QuotaHardLimitExceeded {..}) -> do + let e = Git.QuotaHardLimitExceeded + (fromIntegral quotaStatusAmount) + (fromIntegral quotaStatusLimit) + liftIO $ wrapSetException (setException (callbacks dets)) e + throw e + where + go = do + debug $ "remoteWriteFile " ++ show path + let hdr = Bin.encode ((fromIntegral (B.length bytes), + fromIntegral (getObjectType typ)) + :: (Int64,Int64)) + payload = BL.append hdr (BL.fromChunks [bytes]) + putFileS3 dets path (sourceLbs payload) + +remoteLoadObject :: OdbS3Details -> Text -> ResourceT IO (Maybe ObjectInfo) +remoteLoadObject dets sha = do + let tmpDir = tempDirectory dets + path = tmpDir fromText sha + remoteReadFile dets path + +remoteStoreObject :: OdbS3Details -> Text -> ObjectInfo -> ResourceT IO () +remoteStoreObject dets sha (ObjectInfo _ typ _ (Just bytes)) = + remoteWriteFile dets sha typ bytes +remoteStoreObject _ _ _ = + throw (Git.BackendError "remoteStoreObject was not given any data") + +remoteCatalogContents :: OdbS3Details -> ResourceT IO () +remoteCatalogContents dets = do + debug "remoteCatalogContents" + items <- listBucketS3 dets + for_ items $ \item -> + when (".idx" `T.isSuffixOf` item) $ do + let packName = fromText item + packSha = T.drop 5 (pathText (basename packName)) + debug $ "remoteCatalogContents: found pack file " ++ show packSha + mpaths <- remoteReadPackFile dets packSha + for_ mpaths $ \(_,idxPath) -> + liftIO $ catalogPackFile dets packSha idxPath + +accessObject :: OdbS3Details + -> Text + -> Bool + -> IO (Maybe CacheEntry) +accessObject dets sha remote = + flip runContT return $ callCC $ \exit -> do + mentry <- liftIO $ cacheLookupEntry dets sha + for_ mentry $ const $ + exit mentry + + mentry <- liftIO $ callbackLocateObject dets sha + for_ mentry $ \entry -> do + liftIO $ cacheUpdateEntry dets sha entry + exit mentry + + unless remote $ exit Nothing + + exists <- liftIO $ runResourceT $ remoteObjectExists dets sha + when exists $ do + liftIO $ cacheUpdateEntry dets sha LooseRemote + liftIO $ callbackRegisterCacheEntry dets sha LooseRemote + exit (Just LooseRemote) + + -- jww (2013-04-27): This is disabled, pending further discussion with + -- Snoyman about Bug #965. + -- + -- lift $ runResourceT $ remoteCatalogContents dets + -- + -- mentry <- liftIO $ cacheLookupEntry dets sha + -- for_ mentry $ \entry -> do + -- liftIO $ callbackRegisterCacheEntry dets sha entry + -- exit mentry + + 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. + +expectingJust :: (MonadIO m, MonadBaseControl IO m) => Text -> Maybe a -> m a +expectingJust msg Nothing = throw (Git.BackendError msg) +expectingJust _msg (Just x) = return x + +objectExists :: OdbS3Details -> Text -> Bool -> IO CacheEntry +objectExists dets sha remote = do + mce <- accessObject dets sha remote + return $ fromMaybe DoesNotExist mce + +readObject :: OdbS3Details -> Text -> Bool -> IO (Maybe ObjectInfo) +readObject dets sha metadataOnly = do + ce <- objectExists dets sha False + + -- By passing False to 'objectExists', we force it to query only the local + -- cache and database registry for information about the object, and not + -- Amazon. If it's unknown, we make the assumption that it exists loosely + -- on S3, as this will almost always be the case with objects saved by the + -- School of Haskell (which does not use packs). + let ce' = case ce of DoesNotExist -> LooseRemote; _ -> ce + cacheLoadObject dets sha ce' metadataOnly + `catch` \(_ :: SomeException) -> return Nothing + +readObjectMetadata :: OdbS3Details -> Text -> IO (Maybe ObjectInfo) +readObjectMetadata dets sha = readObject dets sha True + +writeObject :: OdbS3Details -> Text -> ObjectInfo -> IO () +writeObject dets sha info = do + runResourceT $ remoteStoreObject dets sha info + callbackRegisterObject dets sha info + cacheStoreObject dets sha info + +writePackFile :: OdbS3Details -> ByteString -> IO () +writePackFile dets bytes = do + let dir = tempDirectory dets + len = B.length bytes + debug $ "writePackFile: building index for " ++ show len ++ " bytes" + (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) + + -- 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 (ObjectLength (fromIntegral len)) + +readCallback :: F'git_odb_backend_read_callback +readCallback data_p len_p type_p be oid = do + (dets, _, sha) <- unpackDetails be oid + wrap (T.unpack $ "S3.readCallback " <> 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 + 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 ()) + +readPrefixCallback :: F'git_odb_backend_read_prefix_callback +readPrefixCallback _out_oid _oid_p _len_p _type_p _be _oid _len = + wrap "S3.readPrefixCallback" + -- jww (2013-04-22): Not yet implemented. + (throwIO (Git.BackendError + "S3.readPrefixCallback has not been implemented yet")) + (return c'GIT_ERROR) + +readHeaderCallback :: F'git_odb_backend_read_header_callback +readHeaderCallback len_p type_p be oid = do + (dets, _, sha) <- unpackDetails be oid + wrap (T.unpack $ "S3.readHeaderCallback " <> 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 + for minfo $ \(ObjectInfo len typ _ _) -> do + poke len_p (toLength len) + poke type_p (toType typ) + +writeCallback :: F'git_odb_backend_write_callback +writeCallback oid be obj_data len obj_type = do + r <- c'git_odb_hash oid obj_data len obj_type + case r of + 0 -> do + (dets, _, sha) <- unpackDetails be oid + wrap (T.unpack $ "S3.writeCallback " <> sha) + (go dets sha >> return c'GIT_OK) + (return c'GIT_ERROR) + n -> do + debug "S3.writeCallback failed to hash data" + return n + where + go dets sha = do + bytes <- curry BU.unsafePackCStringLen + (castPtr obj_data) (fromIntegral len) + writeObject dets sha + (ObjectInfo (fromLength len) (fromType obj_type) + Nothing (Just bytes)) + +existsCallback :: F'git_odb_backend_exists_callback +existsCallback be oid confirmNotExists = do + (dets, _, sha) <- unpackDetails be oid + wrap (T.unpack $ "S3.existsCallback " + <> 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 :: F'git_odb_backend_refresh_callback +refreshCallback _ = + return c'GIT_OK -- do nothing + +foreachCallback :: F'git_odb_backend_foreach_callback +foreachCallback _be _callback _payload = + return c'GIT_ERROR -- fallback to standard method + +writePackCallback :: F'git_odb_backend_writepack_callback +writePackCallback writePackPtr be _callback _payload = + wrap "S3.writePackCallback" go (return c'GIT_ERROR) + where + go = do + poke writePackPtr . packWriter + =<< peek (castPtr be :: Ptr OdbS3Backend) + return c'GIT_OK + +freeCallback :: F'git_odb_backend_free_callback +freeCallback be = do + debug "S3.freeCallback" + odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) + dets <- liftIO $ deRefStablePtr (details odbS3) + + wrapShuttingDown (shuttingDown (callbacks dets)) `orElse` return () + + let tmpDir = tempDirectory dets + exists <- isDirectory tmpDir + when exists $ do + debug $ "S3.freeCallback: removing tree " ++ show tmpDir + removeTree tmpDir `orElse` return () + + 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) + + free (packWriter odbS3) + freeStablePtr (details odbS3) + +foreign export ccall "freeCallback" + freeCallback :: F'git_odb_backend_free_callback +foreign import ccall "&freeCallback" + freeCallbackPtr :: FunPtr F'git_odb_backend_free_callback + +packAddCallback :: F'git_odb_writepack_add_callback +packAddCallback wp dataPtr len _progress = + wrap "S3.packAddCallback" + (go >> return c'GIT_OK) + (return c'GIT_ERROR) + where + go = do + be <- c'git_odb_writepack'backend <$> peek wp + odbS3 <- peek (castPtr be :: Ptr OdbS3Backend) + dets <- deRefStablePtr (details odbS3) + bytes <- curry BU.unsafePackCStringLen + (castPtr dataPtr) (fromIntegral len) + writePackFile dets bytes + +packCommitCallback :: F'git_odb_writepack_commit_callback +packCommitCallback _wp _progress = + return c'GIT_OK -- do nothing + +packFreeCallback :: F'git_odb_writepack_free_callback +packFreeCallback wp = do + debug "S3.packFreeCallback" + writepack <- peek wp + freeHaskellFunPtr (c'git_odb_writepack'add writepack) + freeHaskellFunPtr (c'git_odb_writepack'commit writepack) + +foreign export ccall "packFreeCallback" + packFreeCallback :: F'git_odb_writepack_free_callback +foreign import ccall "&packFreeCallback" + packFreeCallbackPtr :: FunPtr F'git_odb_writepack_free_callback + +odbS3Backend :: Git.MonadGit m + => S3Configuration NormalQuery + -> Configuration + -> Manager + -> Text + -> Text + -> FilePath + -> BackendCallbacks + -> m (Ptr C'git_odb_backend) +odbS3Backend s3config config manager bucket prefix dir callbacks = liftIO $ do + readFun <- mk'git_odb_backend_read_callback readCallback + readPrefixFun <- mk'git_odb_backend_read_prefix_callback readPrefixCallback + readHeaderFun <- mk'git_odb_backend_read_header_callback readHeaderCallback + writeFun <- mk'git_odb_backend_write_callback writeCallback + existsFun <- mk'git_odb_backend_exists_callback existsCallback + refreshFun <- mk'git_odb_backend_refresh_callback refreshCallback + foreachFun <- mk'git_odb_backend_foreach_callback foreachCallback + writepackFun <- mk'git_odb_backend_writepack_callback writePackCallback + + writePackAddFun <- mk'git_odb_writepack_add_callback packAddCallback + writePackCommitFun <- mk'git_odb_writepack_commit_callback packCommitCallback + + objects <- newTVarIO M.empty + dirExists <- isDirectory dir + unless dirExists $ createTree dir + + let odbS3details = OdbS3Details + { httpManager = manager + , bucketName = bucket + , objectPrefix = prefix + , configuration = config + , s3configuration = s3config + , callbacks = callbacks + , knownObjects = objects + , 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 + } + + 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 + +-- | 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 :: Git.MonadGit m + => Repository + -> Text -- ^ bucket + -> Text -- ^ prefix + -> Text -- ^ access key + -> Text -- ^ secret key + -> Maybe Manager + -> Maybe Text -- ^ mock address + -> LogLevel + -> FilePath + -> BackendCallbacks -- ^ callbacks + -> m Repository +addS3Backend repo bucket prefix access secret + mmanager mockAddr level dir callbacks = do + manager <- maybe (liftIO $ newManager def) return mmanager + odbS3 <- liftIO $ odbS3Backend + (case mockAddr of + Nothing -> defServiceConfig + Just addr -> (Aws.s3 HTTP (E.encodeUtf8 addr) False) { + Aws.s3Port = 10001 + , Aws.s3RequestStyle = PathStyle }) + (Configuration Timestamp Credentials { + accessKeyID = E.encodeUtf8 access + , secretAccessKey = E.encodeUtf8 secret } + (defaultLog level)) + manager bucket prefix dir callbacks + void $ liftIO $ odbBackendAdd repo odbS3 100 + return repo + +s3Factory :: Git.MonadGit m + => Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks + -> Git.RepositoryFactory LgRepository m Repository +s3Factory bucket accessKey secretKey dir callbacks = lgFactory + { Git.runRepository = \ctxt -> runLgRepository ctxt . (s3back >>) } + where + s3back = do + repo <- lgGet + void $ liftIO $ 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 :: (MonadIO m, MonadBaseControl IO m) + => S3MockService -> Text -> Text -> ResourceT 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 :: (MonadIO m, MonadBaseControl IO m) + => S3MockService -> Text -> Text -> ResourceT 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 :: (MonadIO m, MonadBaseControl IO m) + => S3MockService -> Text -> Text -> Maybe (Int64, Int64) + -> ResourceT 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 :: (MonadIO m, MonadBaseControl IO m) + => S3MockService -> Text -> Text -> Int -> BL.ByteString + -> ResourceT 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 () + +-- S3.hs diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/gitlib-s3.cabal b/gitlib-s3.cabal --- a/gitlib-s3.cabal +++ b/gitlib-s3.cabal @@ -1,7 +1,7 @@ Name: gitlib-s3 -Version: 0.2.1 -Synopsis: A repository backend for storing Git objects in Amazon S3 -Description: A repository backend for storing Git objects in Amazon S3. +Version: 1.0.1 +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 @@ -14,52 +14,66 @@ type: git location: git://github.com/fpco/gitlib.git -Library - hs-source-dirs: . - default-language: Haskell98 - build-depends: - base >= 3 && < 5 - , gitlib - , hlibgit2 >= 0.17 - , HUnit >= 1.2.5 - , bytestring >= 0.9.2.1 - , containers >= 0.4.2 - , transformers >= 0.2.2 - , lens >= 2.8 - , attempt >= 0.4.0 - , parallel-io >= 0.3.2.1 - , stringable >= 0.1.1 - , system-fileio >= 0.3.9 - , system-filepath >= 0.4.7 - , text >= 0.11.2 - , time >= 1.4 - , aws >= 0.7.5 - , conduit >= 0.5.5 - , http-conduit >= 1.8.5.1 - , binary >= 0.5.1.0 - , yaml >= 0.8.1.1 - exposed-modules: - Data.Git.Backend.S3 - Test-suite smoke default-language: Haskell98 + ghc-options: -Wall type: exitcode-stdio-1.0 main-is: Smoke.hs hs-source-dirs: test build-depends: base >=3 + , gitlib , gitlib-s3 + , gitlib-test + , gitlib-libgit2 + , hlibgit2 >= 0.18.0.1 + , aws >= 0.7.5 + , HUnit >= 1.2.5 + , hspec >= 1.4.4 + , hspec-expectations >= 0.3 + , data-default >= 0.5.1 + , resourcet >= 0.4.6 + , system-fileio >= 0.3.9 + , system-filepath >= 0.4.7 + , temporary >= 1.1.2.4 + , text >= 0.11.2 + , transformers >= 0.2.2 + +Library + ghc-options: -Wall + hs-source-dirs: . + default-language: Haskell98 + build-depends: + base >= 3 && < 5 , gitlib - , hlibgit2 >= 0.17 - , aws >= 0.7.5 - , HUnit >= 1.2.5 - , bytestring >= 0.9.2.1 - , containers >= 0.4.2 - , lens >= 2.8 - , http-conduit >= 1.8.5.1 - , parallel-io >= 0.3.2.1 - , stringable >= 0.1.1 - , system-fileio >= 0.3.9 - , system-filepath >= 0.4.7 - , text >= 0.11.2 - , time >= 1.4 + , gitlib-libgit2 + , ghc-prim + , hlibgit2 >= 0.18.0.1 + , HUnit >= 1.2.5 + , aeson >= 0.6.1.0 + , attempt >= 0.4.0 + , aws >= 0.7.5 + , bifunctors >= 3.2.0.1 + , binary >= 0.5.1.0 + , bytestring >= 0.9.2.1 + , conduit >= 0.5.5 + , containers >= 0.4.2 + , data-default >= 0.5.1 + , directory >= 1.1.0.2 + , either >= 3.4 + , errors >= 1.4.1 + , http-conduit >= 1.8.5.1 + , lens >= 3.8 + , lifted-base >= 0.2.0.2 + , resourcet >= 0.4.6 + , retry >= 0.2.0.0 + , stm >= 2.4.2 + , system-fileio >= 0.3.9 + , system-filepath >= 0.4.7 + , tagged >= 0.4.4 + , text >= 0.11.2 + , time >= 1.4 + , transformers >= 0.2.2 + , unordered-containers >= 0.2.3.0 + exposed-modules: + Git.S3 diff --git a/test/Smoke.hs b/test/Smoke.hs --- a/test/Smoke.hs +++ b/test/Smoke.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} {-# OPTIONS_GHC -fno-warn-wrong-do-bind #-} @@ -6,144 +8,78 @@ module Main where import Aws -import Aws.Core -import Aws.S3 hiding (bucketName) import Control.Applicative -import Control.Concurrent.ParallelIO +import Control.Exception (finally) import Control.Monad -import Data.Git -import Data.Git.Backend -import Data.Git.Backend.S3 -import Data.Git.Backend.Trace -import Data.Map -import Data.Maybe -import Data.Text as T hiding (map) -import qualified Data.Text.Encoding as E -import Data.Time.Clock.POSIX -import Data.Traversable -import Filesystem (removeTree, isDirectory) +import Control.Monad.IO.Class +import Data.Default (def) +import Data.Maybe (fromMaybe, isNothing) +import Data.Text as T +import Filesystem import Filesystem.Path.CurrentOS -import Network.HTTP.Conduit -import qualified Prelude -import Prelude (putStrLn) -import Prelude hiding (FilePath, putStr, putStrLn) +import qualified Git as Git +import qualified Git.Libgit2 as Lg +import qualified Git.S3 as S3 +import qualified Git.Smoke as Git import System.Environment -import System.Exit -import Test.HUnit - -default (Text) +import Test.Hspec.HUnit () +import Test.Hspec.Runner +s3Factory :: Git.MonadGit m + => Git.RepositoryFactory Lg.LgRepository m Lg.Repository +s3Factory = Lg.lgFactory + { Git.runRepository = \ctxt -> Lg.runLgRepository ctxt . (s3back >>) } + where + s3back = do + repo <- Lg.lgGet + void $ liftIO $ do + env <- getEnvironment + 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 + svc <- S3.s3MockService + let tmpDir = cwd "s3cache" + createDirectory True tmpDir + S3.addS3Backend + repo + (fromMaybe "test-bucket" bucket) + "" + (fromMaybe "" accessKey) + (fromMaybe "" secretKey) + Nothing + (if isNothing bucket + then Just "127.0.0.1" + else Nothing) + Error + tmpDir + def { -- S3.registerObject = \sha _ -> do + -- putStrLn $ "registerObject: " ++ show sha + -- modifyMVar_ objectMap + -- (return . Map.insert sha S3.ObjectLoose) + -- , S3.registerPackFile = \packBase shas -> do + -- putStrLn $ "registerPackFile: " ++ show packBase + -- modifyMVar_ objectMap + -- (\m -> return $ foldr + -- (flip Map.insert + -- (S3.ObjectInPack packBase)) m shas) + -- , S3.lookupObject = \sha -> do + -- putStrLn $ "lookupObject: " ++ show sha + -- Map.lookup sha <$> readMVar objectMap + S3.headObject = \bucket path -> + S3.mockHeadObject svc bucket path + , S3.getObject = \bucket path range -> + S3.mockGetObject svc bucket path range + , S3.putObject = \bucket path len bytes -> + S3.mockPutObject svc bucket path + (fromIntegral (S3.getObjectLength len)) bytes + } + main :: IO () main = do - counts' <- runTestTT tests - case counts' of - Counts _ _ errors' failures' -> - if errors' > 0 || failures' > 0 - then exitFailure - else exitSuccess - stopGlobalPool - -catBlob :: Repository -> Text -> IO (Maybe Text) -catBlob repo sha = do - hash <- parseOid sha - for hash $ \hash' -> do - obj <- lookupObject repo hash' - case obj of - Just (BlobObj b) -> do - (_, contents) <- getBlobContents b - str <- blobSourceToString contents - case str of - Nothing -> return T.empty - Just str' -> return (E.decodeUtf8 str') - - Just _ -> error "Found something else..." - Nothing -> error "Didn't find anything :(" - -withRepository :: Text -> (Repository -> Assertion) -> Assertion -withRepository n f = do - let p = fromText n - exists <- isDirectory p - when exists $ removeTree p - - -- we want exceptions to leave the repo behind - f =<< createRepository p True - - removeTree p - -oid :: Updatable a => a -> IO Text -oid = objectId >=> return . oidToText - -oidToText :: Oid -> Text -oidToText = T.pack . show - -sampleCommit :: Repository -> Tree -> Signature -> Commit -sampleCommit repo tr sig = - (createCommit repo sig) { commitTree = ObjRef tr - , commitLog = "Sample log message." } - -tests :: Test -tests = test [ - - "createTwoCommits" ~: - - withRepository "createTwoCommits.git" $ \repo' -> do - -- Store Git objects in S3 - s3Bucket <- T.pack <$> getEnv "S3_BUCKET" - awsAccessKey <- T.pack <$> getEnv "AWS_ACCESS_KEY" - awsSecretKey <- T.pack <$> getEnv "AWS_SECRET_KEY" - repo <- createS3backend s3Bucket "" awsAccessKey awsSecretKey - Nothing Nothing Error True repo' - - let hello = createBlob repo (E.encodeUtf8 "Hello, world!\n") - tr <- updateTree (createTree repo) "hello/world.txt" (blobRef hello) - - let goodbye = createBlob repo (E.encodeUtf8 "Goodbye, world!\n") - tr <- updateTree tr "goodbye/files/world.txt" (blobRef goodbye) - x <- oid tr - x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a" - - -- The Oid has been cleared in tr, so this tests that it gets written as - -- needed. - let sig = Signature { - signatureName = "John Wiegley" - , signatureEmail = "johnw@newartisans.com" - , signatureWhen = posixSecondsToUTCTime 1348980883 } - c = sampleCommit repo tr sig - x <- oid c - x @?= "44381a5e564d19893d783a5d5c59f9c745155b56" - - let goodbye2 = createBlob repo (E.encodeUtf8 "Goodbye, world again!\n") - tr <- updateTree tr "goodbye/files/world.txt" (blobRef goodbye2) - x <- oid tr - x @?= "f2b42168651a45a4b7ce98464f09c7ec7c06d706" - - let sig = Signature { - signatureName = "John Wiegley" - , signatureEmail = "johnw@newartisans.com" - , signatureWhen = posixSecondsToUTCTime 1348981883 } - c2 = (sampleCommit repo tr sig) { - commitLog = "Second sample log message." - , commitParents = [ObjRef c] } - x <- oid c2 - x @?= "2506e7fcc2dbfe4c083e2bd741871e2e14126603" - - putStrLn "Refs before creation..." - mapAllRefs repo (\name -> Prelude.putStrLn $ "Ref: " ++ unpack name) - putStrLn "Refs before creation...done" - - cid <- objectId c2 - writeRef $ createRef repo "refs/heads/master" (RefTargetId cid) - writeRef $ createRef repo "HEAD" (RefTargetSymbolic "refs/heads/master") - - x <- fmap oidToText <$> resolveRef repo "refs/heads/master" - x @?= Just "2506e7fcc2dbfe4c083e2bd741871e2e14126603" - - putStrLn "Refs after creation..." - mapAllRefs repo (\name -> Prelude.putStrLn $ "Ref: " ++ unpack name) - putStrLn "Refs after creation...done" - - return() - - ] + Git.startupBackend Lg.lgFactory + finally + (hspec $ Git.smokeTestSpec s3Factory s3Factory) + (Git.shutdownBackend Lg.lgFactory) --- Main.hs ends here +-- Smoke.hs ends here