module Git.S3
( s3Factory, odbS3Backend, addS3Backend
, ObjectStatus(..), BackendCallbacks(..)
, ObjectType(..), ObjectLength(..), QuotaStatus(..)
, S3MockService(), s3MockService
, mockGetBucket, mockHeadObject, mockGetObject, mockPutObject
) where
import Aws
import Aws.Core
import qualified Aws.S3 as Aws
import Bindings.Libgit2
import Control.Applicative
import Control.Concurrent.STM hiding (orElse)
import Control.Exception.Lifted
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
import Data.Attempt
import Data.Bifunctor
import Data.Binary as Bin
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Unsafe as BU
import Data.Conduit
import Data.Conduit.Binary hiding (drop)
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.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)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time.Clock
import Data.Traversable (for)
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 (SHA(..), shaToText)
import Git.Libgit2
import Git.Libgit2.Backend
import Git.Libgit2.Internal
import Git.Libgit2.Types
import Network.HTTP.Conduit hiding (Response)
import Prelude hiding (mapM_, catch)
import System.Directory
import System.FilePath.Posix
import System.IO.Unsafe
newtype ObjectLength = ObjectLength { getObjectLength :: Int64 }
deriving (Eq, Show, Generic)
newtype ObjectType = ObjectType { getObjectType :: Int }
deriving (Eq, Show, Generic)
instance Bin.Binary ObjectLength where
put (ObjectLength x) = Bin.put x
get = ObjectLength <$> Bin.get
instance Bin.Binary ObjectType where
put (ObjectType x) = Bin.put x
get = ObjectType <$> Bin.get
plainFile :: ObjectType
plainFile = ObjectType 0
data ObjectInfo = ObjectInfo
{ infoLength :: ObjectLength
, infoType :: ObjectType
, infoPath :: Maybe FilePath
, infoData :: Maybe BL.ByteString
} deriving Eq
instance Show ObjectInfo where
show ObjectInfo {..} = "ObjectInfo {"
++ "infoLength = " ++ show infoLength
++ ", infoType = " ++ show infoType
++ ", infoPath = " ++ show infoPath
++ ", infoData = " ++ show (isJust infoData)
++ "}"
fromSha :: SHA -> FilePath
fromSha = T.unpack . shaToText
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)
type MonadS3 m = (Failure Git.GitException m,
MonadIO m, MonadBaseControl IO m, MonadLogger m)
data BackendCallbacks = BackendCallbacks
{ checkQuota :: ObjectLength -> IO (Maybe QuotaStatus)
, registerObject :: SHA -> Maybe (ObjectLength, ObjectType) -> IO ()
, registerPackFile :: Text -> [SHA] -> IO ()
, lookupObject :: SHA -> IO (Maybe ObjectStatus)
, 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 :: MonadS3 m => Text -> Text -> ObjectLength -> BL.ByteString
-> ResourceT m (Maybe (Either Text ()))
, updateRef :: Git.RefName -> Text -> IO ()
, resolveRef :: Git.RefName -> IO (Maybe Text)
, acquireLock :: Text -> IO Text
, releaseLock :: Text -> IO ()
, shuttingDown :: IO ()
, setException :: Git.GitException -> IO ()
}
instance Default BackendCallbacks where
def = BackendCallbacks
{ checkQuota = \_ -> return Nothing
, registerObject = \_ _ -> return ()
, registerPackFile = \_ _ -> return ()
, lookupObject = \_ -> 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
, objectPackSha :: Text
, objectPackPath :: FilePath
, objectIndexPath :: FilePath
}
deriving (Eq, Show)
data OdbS3Details = OdbS3Details
{ httpManager :: Manager
, bucketName :: Text
, objectPrefix :: Text
, configuration :: Configuration
, s3configuration :: Aws.S3Configuration NormalQuery
, callbacks :: BackendCallbacks
, knownObjects :: TVar (HashMap SHA 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 ()
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, MonadS3 m) => String -> m a -> m a -> m a
wrap msg f g = catch
(do lgDebug $ msg ++ "..."
r <- f
lgDebug $ msg ++ "...done, result = " ++ show r
return r)
$ \e -> do lgWarn $ msg ++ "...FAILED"
lgWarn $ show (e :: SomeException)
g
orElse :: MonadS3 m => m a -> m a -> m a
orElse f g = catch f $ \e -> do
lgWarn "A callback operation failed"
lgWarn $ show (e :: SomeException)
g
coidToJSON :: ForeignPtr C'git_oid -> A.Value
coidToJSON coid = unsafePerformIO $ withForeignPtr coid $
fmap A.toJSON . flip oidToStr 40
unpackDetails :: Ptr C'git_odb_backend -> Ptr C'git_oid
-> IO (OdbS3Details, SHA)
unpackDetails be oid = do
odbS3 <- peek (castPtr be :: Ptr OdbS3Backend)
dets <- deRefStablePtr (details odbS3)
sha <- oidToSha oid
return (dets, sha)
wrapCheckQuota :: MonadS3 m
=> (ObjectLength -> IO (Maybe QuotaStatus))
-> ObjectLength
-> m (Maybe QuotaStatus)
wrapCheckQuota f len =
wrap ("checkQuota " ++ show len)
(liftIO $ f len)
(return Nothing)
wrapRegisterObject :: MonadS3 m
=> (SHA -> Maybe (ObjectLength, ObjectType) -> IO ())
-> SHA
-> Maybe (ObjectLength, ObjectType)
-> m ()
wrapRegisterObject f name metadata =
wrap ("registerObject " ++ show (shaToText name) ++ " " ++ show metadata)
(liftIO $ f name metadata)
(return ())
wrapRegisterPackFile :: MonadS3 m
=> (Text -> [SHA] -> IO ()) -> Text -> [SHA] -> m ()
wrapRegisterPackFile f name shas =
wrap ("registerPackFile: " ++ show name)
(liftIO $ f name shas)
(return ())
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 :: MonadS3 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 :: MonadS3 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 :: MonadS3 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 :: MonadS3 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 :: MonadS3 m => (Text -> Text -> IO ()) -> Text -> Text -> m ()
wrapUpdateRef f name sha =
wrap ("updateRef: " ++ show name ++ " " ++ show sha)
(liftIO $ f name sha)
(return ())
wrapResolveRef :: MonadS3 m
=> (Text -> IO (Maybe Text)) -> Text -> m (Maybe Text)
wrapResolveRef f name =
wrap ("resolveRef: " ++ show name)
(liftIO $ f name)
(return Nothing)
wrapAcquireLock :: MonadS3 m => (Text -> IO Text) -> Text -> m Text
wrapAcquireLock f name =
wrap ("acquireLock: " ++ show name)
(liftIO $ f name)
(return "")
wrapReleaseLock :: MonadS3 m => (Text -> IO ()) -> Text -> m ()
wrapReleaseLock f name =
wrap ("releaseLock: " ++ show name)
(liftIO $ f name)
(return ())
wrapShuttingDown :: MonadS3 m => IO () -> m ()
wrapShuttingDown f = wrap "shuttingDown..." (liftIO f) (return ())
wrapSetException :: MonadS3 m
=> (Git.GitException -> IO ()) -> Git.GitException -> m ()
wrapSetException f e =
wrap ("setException: " ++ show e)
(liftIO $ f e)
(return ())
awsRetry :: (MonadIO m, Transaction r a)
=> Configuration
-> ServiceConfiguration r NormalQuery
-> Manager
-> r
-> ResourceT m (Response (ResponseMetadata a) a)
awsRetry cfg svcfg mgr r =
transResourceT liftIO $
retrying def (isFailure . responseResult) $ aws cfg svcfg mgr r
listBucketS3 :: MonadS3 m => OdbS3Details -> ResourceT m [Text]
listBucketS3 dets = do
lgDebug "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
lgDebug "Aws.getBucket"
res <- awsRetry (configuration dets) (s3configuration dets)
(httpManager dets)
((Aws.getBucket bucket)
{ Aws.gbPrefix = Just prefix
, Aws.gbMarker = mmarker })
gbr <- readResponseIO res
let contents = map Aws.objectKey (Aws.gbrContents gbr)
case contents of
[] -> return []
_ -> (++) <$> pure contents
<*> makeRequest bucket prefix
(Just (Prelude.last contents))
(Aws.gbrIsTruncated gbr)
testFileS3 :: MonadS3 m => OdbS3Details -> Text -> ResourceT m Bool
testFileS3 dets filepath = do
lgDebug $ "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
lgDebug $ "Aws.headObject: " ++ show filepath
resp <- awsRetry (configuration dets) (s3configuration dets)
(httpManager dets) (Aws.headObject bucket path)
_hor <- readResponseIO resp
return True
getFileS3 :: MonadS3 m
=> OdbS3Details -> FilePath -> Maybe (Int64,Int64)
-> ResourceT m (ResumableSource (ResourceT IO) ByteString)
getFileS3 dets filepath range = do
lgDebug $ "getFileS3: " ++ filepath
let bucket = bucketName dets
path = T.unpack (objectPrefix dets) <> filepath
cbResult <- wrapGetObject (getObject (callbacks dets))
bucket (T.pack path) range `orElse` return Nothing
case cbResult of
Just (Right r) ->
transResourceT liftIO $
fst <$> (sourceLbs r $$+ Data.Conduit.Binary.take 0)
_ -> do
lgDebug $ "Aws.getObject: " ++ show filepath ++ " " ++ show range
res <- awsRetry (configuration dets) (s3configuration dets)
(httpManager dets) (Aws.getObject bucket (T.pack path))
{ Aws.goResponseContentRange =
bimap fromIntegral fromIntegral <$> range }
gor <- readResponseIO res
return (responseBody (Aws.gorResponse gor))
putFileS3 :: MonadS3 m
=> OdbS3Details -> Text -> Source (ResourceT m) ByteString
-> ResourceT m ()
putFileS3 dets filepath src = do
lgDebug $ "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
lgDebug $ "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.RefTarget LgRepo))
instance A.FromJSON RefTarget where
parseJSON j = do
o <- A.parseJSON j
case L.lookup "symbolic" (M.toList (o :: A.Object)) of
Just _ -> Git.RefSymbolic <$> o .: "symbolic-target"
Nothing -> Git.RefObj . go <$> o .: "oid-target"
where
go = mkOid . unsafePerformIO . strToOid
strToOid :: String -> IO (ForeignPtr C'git_oid)
strToOid oidStr = do
ptr <- mallocForeignPtr
withCString oidStr $ \cstr ->
withForeignPtr ptr $ \ptr' -> do
r <- c'git_oid_fromstr ptr' cstr
when (r < 0) $ throwIO Git.OidCopyFailed
return ptr
instance A.ToJSON RefTarget where
toJSON (Git.RefSymbolic target) = object [ "symbolic-target" .= target ]
toJSON (Git.RefObj oid) = object [ "oid-target" .= coidToJSON (getOid oid) ]
observePackObjects :: MonadS3 m
=> OdbS3Details
-> Text
-> FilePath
-> Bool
-> Ptr C'git_odb
-> m [SHA]
observePackObjects dets packSha idxFile _alsoWithRemote odbPtr = do
lgDebug $ "observePackObjects: " ++ show idxFile
mshas <- liftIO $ newIORef []
r <- liftIO $ flip (lgForEachObject odbPtr) nullPtr $ \oid _ -> do
sha <- oidToSha oid
modifyIORef mshas (sha:)
return c'GIT_OK
checkResult r "lgForEachObject failed"
lgDebug "observePackObjects: update known objects map"
now <- liftIO getCurrentTime
shas <- liftIO $ readIORef mshas
let obj = PackedCached now packSha (replaceExtension idxFile "pack") idxFile
liftIO $ atomically $ modifyTVar (knownObjects dets) $ \objs ->
foldr (`M.insert` obj) objs shas
lgDebug $ "observePackObjects: observed "
++ show (Prelude.length shas) ++ " objects"
return shas
catalogPackFile :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> OdbS3Details -> Text -> FilePath -> m [SHA]
catalogPackFile dets packSha idxPath = do
lgDebug $ "catalogPackFile: " ++ show packSha
_ <- lgWithPackFile idxPath $
observePackObjects dets packSha idxPath True
return []
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 True)
(return Nothing)
where
go recurse = do
objs <- liftIO $ readTVarIO (knownObjects dets)
case M.lookup sha objs of
Nothing | M.null objs && recurse -> do
lgDebug "observeCacheObjects"
liftIO $ observeCacheObjects dets
go False
mres -> return mres
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 :: (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
case ce of
LooseCached {} -> return ()
_ -> for_ minfo $ cacheStoreObject dets sha
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 $ doesFileExist path
if exists
then Just <$> (ObjectInfo
<$> pure len
<*> pure typ
<*> pure (Just path)
<*> (Just <$> liftIO (BL.readFile path)))
else go LooseRemote
go (PackedRemote packSha) = do
mpaths <- runResourceT $ remoteReadPackFile dets packSha True
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 $ (&&) <$> doesFileExist packPath
<*> doesFileExist idxPath
if bothExist
then do
lgDebug $ "getObjectFromPack " ++ show packPath ++ " "
++ show sha
mresult <- lgReadFromPack idxPath sha metadataOnly
for mresult $ \(typ, len, bytes) ->
return $ ObjectInfo (fromLength len) (fromType typ)
Nothing (Just (BL.fromChunks [bytes]))
else go (PackedRemote packSha)
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 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 :: MonadS3 m => OdbS3Details -> SHA -> m (Maybe CacheEntry)
callbackLocateObject dets sha = do
location <- wrapLookupObject (lookupObject (callbacks dets))
sha `orElse` return Nothing
lgDebug $ "callbackLocateObject lookup: " ++ show location
return $ case location of
Just (ObjectInPack base) -> Just (PackedRemote base)
Just ObjectLoose -> Just LooseRemote
_ -> Nothing
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 :: MonadS3 m => OdbS3Details -> Text -> [SHA] -> m ()
callbackRegisterPackFile dets packSha shas = do
lgDebug $ "callbackRegisterPackFile " ++ show packSha
wrapRegisterPackFile (registerPackFile (callbacks dets))
packSha shas `orElse` return ()
callbackRegisterCacheEntry :: MonadS3 m
=> OdbS3Details -> SHA -> CacheEntry -> m ()
callbackRegisterCacheEntry dets sha ce =
wrap ("callbackRegisterCacheEntry "
++ show (shaToText 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 :: MonadS3 m => OdbS3Details -> SHA -> ResourceT m Bool
remoteObjectExists dets sha =
wrap "remoteObjectExists"
(testFileS3 dets (shaToText sha))
(return False)
remoteReadFile :: MonadS3 m
=> OdbS3Details -> FilePath -> ResourceT m (Maybe ObjectInfo)
remoteReadFile dets path = do
lgDebug $ "remoteReadFile " ++ show path
exists <- liftIO $ doesFileExist path
when exists $ do
lgDebug $ "remoteReadFile: removing " ++ show path
liftIO $ removeFile path
blocks <- do
result <- getFileS3 dets (takeFileName path) Nothing
transResourceT liftIO $ result $$+- CList.consume
lgDebug $ "remoteReadFile: downloaded " ++ show path
case blocks of
[] -> return Nothing
bs -> Just <$> 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))
lgDebug $ "downloadFile: length from header is " ++ show len
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 (BL.fromChunks [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 :: MonadS3 m
=> OdbS3Details -> Text -> Bool
-> ResourceT m (Maybe (FilePath, FilePath))
remoteReadPackFile dets packSha readPackAndIndex = do
lgDebug $ "remoteReadPackFile " ++ show packSha
let tmpDir = tempDirectory dets
packPath = tmpDir </> ("pack-" <> T.unpack packSha <> ".pack")
idxPath = replaceExtension packPath "idx"
runMaybeT $ do
when (True || readPackAndIndex) $ do
exists <- liftIO $ doesFileExist packPath
void $ if exists
then return (Just ())
else download packPath
exists <- liftIO $ doesFileExist 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 {..} ->
case infoData of
Nothing -> throw $ Git.BackendError $
"Failed to download data for " <> T.pack path
Just xs -> liftIO $ BL.writeFile path xs
remoteWriteFile :: MonadS3 m
=> OdbS3Details -> Text -> ObjectType -> BL.ByteString
-> ResourceT m ()
remoteWriteFile dets path typ bytes = do
mstatus <- wrapCheckQuota (checkQuota (callbacks dets))
(ObjectLength (fromIntegral (BL.length bytes)))
case mstatus of
Nothing -> go
Just QuotaCheckSuccess -> go
Just (QuotaSoftLimitExceeded {}) -> go
Just (QuotaHardLimitExceeded {..}) -> do
let e = Git.QuotaHardLimitExceeded
(fromIntegral quotaStatusAmount)
(fromIntegral quotaStatusLimit)
wrapSetException (setException (callbacks dets)) e
throw e
where
go = do
lgDebug $ "remoteWriteFile " ++ show path
let hdr = Bin.encode ((fromIntegral (BL.length bytes),
fromIntegral (getObjectType typ))
:: (Int64,Int64))
payload = BL.append hdr bytes
putFileS3 dets path (sourceLbs payload)
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 :: 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 :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> OdbS3Details -> ResourceT m ()
remoteCatalogContents dets = do
lgDebug "remoteCatalogContents"
items <- map T.unpack <$> listBucketS3 dets
for_ items $ \item -> case () of
() | ".idx" `L.isSuffixOf` item -> do
let packSha = T.pack . drop 5 . takeBaseName $ item
lgDebug $ "remoteCatalogContents: found pack file "
++ show packSha
mpaths <- remoteReadPackFile dets packSha False
for_ mpaths $ \(_, idxPath) -> do
shas <- catalogPackFile dets packSha idxPath
callbackRegisterPackFile dets packSha shas
| ".pack" `L.isSuffixOf` item -> return ()
| length item == 40 -> do
sha <- Git.textToSha . T.pack . takeBaseName $ item
cacheUpdateEntry dets sha LooseRemote
callbackRegisterCacheEntry dets sha LooseRemote
| otherwise -> return ()
accessObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> OdbS3Details -> SHA -> Bool -> m (Maybe CacheEntry)
accessObject dets sha checkRemote = do
mentry <- cacheLookupEntry dets sha
case mentry of
Just _ -> return mentry
Nothing -> do
mentry <- callbackLocateObject dets sha
case mentry of
Just entry -> do
cacheUpdateEntry dets sha entry
return mentry
Nothing
| checkRemote -> do
exists <- runResourceT $ remoteObjectExists dets sha
if exists
then do
cacheUpdateEntry dets sha LooseRemote
callbackRegisterCacheEntry dets sha LooseRemote
return $ Just LooseRemote
else do
runResourceT $ remoteCatalogContents dets
cacheLookupEntry dets sha
| otherwise -> return Nothing
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 :: (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 :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> OdbS3Details -> SHA -> m (Maybe ObjectInfo)
readObjectMetadata dets sha = readObject dets sha True
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 :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> OdbS3Details -> BL.ByteString -> m ()
writePackFile dets bytes = do
let dir = tempDirectory dets
len = BL.length bytes
lgDebug $ "writePackFile: building index for " ++ show len ++ " bytes"
(packSha, packPath, idxPath) <- lgBuildPackIndex dir bytes
runResourceT $
remoteWriteFile dets (T.pack (takeFileName packPath)) plainFile bytes
runResourceT
. remoteWriteFile dets (T.pack (takeFileName idxPath)) plainFile
=<< liftIO (BL.readFile idxPath)
shas <- catalogPackFile dets packSha idxPath
callbackRegisterPackFile dets packSha shas
readCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> Ptr (Ptr ())
-> Ptr CSize
-> Ptr C'git_otype
-> Ptr C'git_odb_backend
-> Ptr C'git_oid
-> m CInt
readCallback data_p len_p type_p be oid = do
(dets, sha) <- liftIO $ unpackDetails be oid
wrap (T.unpack $ "S3.readCallback " <> shaToText 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
liftIO $ for minfo $ \(ObjectInfo len typ _ (Just bytes)) -> do
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 :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> Ptr C'git_oid
-> Ptr (Ptr ())
-> Ptr CSize
-> Ptr C'git_otype
-> Ptr C'git_odb_backend
-> Ptr C'git_oid
-> CSize
-> m CInt
readPrefixCallback oid_p data_p len_p type_p be oid (fromIntegral -> len) = do
(dets, sha) <- liftIO $ unpackDetails be oid
wrap (T.unpack $ "S3.readPrefixCallback " <> T.take len (shaToText sha))
(maybe c'GIT_ENOTFOUND (const c'GIT_OK) <$> go dets sha True)
(return c'GIT_ERROR)
where
go dets sha shouldLoop = do
objs <- liftIO $ readTVarIO (knownObjects dets)
let subSha = B.take (len `div` 2) (getSHA sha)
act . filter ((subSha ==) . B.take (len `div` 2) . getSHA)
. M.keys
$ objs
where
act [Git.SHA bs] = do
liftIO $ BU.unsafeUseAsCString bs $
c'git_oid_fromraw oid_p . castPtr
res <- readCallback data_p len_p type_p be oid_p
return $ if res == c'GIT_OK then Just () else Nothing
act _
| shouldLoop = do
_ <- accessObject dets sha True
go dets sha False
| otherwise = return Nothing
readHeaderCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> Ptr CSize
-> Ptr C'git_otype
-> Ptr C'git_odb_backend
-> Ptr C'git_oid
-> m CInt
readHeaderCallback len_p type_p be oid = do
(dets, sha) <- liftIO $ unpackDetails be oid
wrap (T.unpack $ "S3.readHeaderCallback " <> shaToText 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
liftIO $ for minfo $ \(ObjectInfo len typ _ _) -> do
poke len_p (toLength len)
poke type_p (toType typ)
writeCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> Ptr C'git_oid
-> Ptr C'git_odb_backend
-> Ptr ()
-> CSize
-> C'git_otype
-> m CInt
writeCallback oid be obj_data len obj_type = do
r <- liftIO $ c'git_odb_hash oid obj_data len obj_type
case r of
0 -> do
(dets, sha) <- liftIO $ unpackDetails be oid
wrap (T.unpack $ "S3.writeCallback " <> shaToText sha)
(c'GIT_OK <$ go dets sha)
(return c'GIT_ERROR)
n -> do
lgDebug "S3.writeCallback failed to hash data"
return n
where
go dets sha = do
bytes <- liftIO $ curry BU.unsafePackCStringLen
(castPtr obj_data) (fromIntegral len)
writeObject dets sha
(ObjectInfo (fromLength len) (fromType obj_type)
Nothing (Just (BL.fromChunks [bytes])))
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
wrap (T.unpack $ "S3.existsCallback " <> shaToText 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 :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> Ptr C'git_odb_backend -> m CInt
refreshCallback _ =
return c'GIT_OK
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
writePackCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> Ptr (Ptr C'git_odb_writepack)
-> Ptr C'git_odb_backend
-> C'git_transfer_progress_callback
-> Ptr ()
-> m CInt
writePackCallback writePackPtr be _callback _payload =
wrap "S3.writePackCallback" go (return c'GIT_ERROR)
where
go = liftIO $ do
poke writePackPtr . packWriter
=<< peek (castPtr be :: Ptr OdbS3Backend)
return c'GIT_OK
freeCallback :: F'git_odb_backend_free_callback
freeCallback be = do
odbS3 <- peek (castPtr be :: Ptr OdbS3Backend)
dets <- deRefStablePtr (details odbS3)
shuttingDown (callbacks dets)
packFreeCallback (packWriter odbS3)
freeStablePtr (details odbS3)
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)
freeHaskellFunPtr (c'git_odb_backend'refresh backend)
freeHaskellFunPtr (c'git_odb_backend'foreach backend)
freeHaskellFunPtr (c'git_odb_backend'writepack backend)
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 :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> Ptr C'git_odb_writepack
-> Ptr ()
-> CSize
-> Ptr C'git_transfer_progress
-> m CInt
packAddCallback wp dataPtr len _progress =
wrap "S3.packAddCallback"
(c'GIT_OK <$ go)
(return c'GIT_ERROR)
where
go = do
be <- liftIO $ c'git_odb_writepack'backend <$> peek wp
odbS3 <- liftIO $ peek (castPtr be :: Ptr OdbS3Backend)
dets <- liftIO $ deRefStablePtr (details odbS3)
bytes <- liftIO $ curry BU.unsafePackCStringLen
(castPtr dataPtr) (fromIntegral len)
writePackFile dets (BL.fromChunks [bytes])
packCommitCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> Ptr C'git_odb_writepack -> Ptr C'git_transfer_progress
-> m CInt
packCommitCallback _wp _progress =
return c'GIT_OK
packFreeCallback :: F'git_odb_writepack_free_callback
packFreeCallback wp = do
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
foreign import ccall "&packFreeCallback"
packFreeCallbackPtr :: FunPtr F'git_odb_writepack_free_callback
embedIO :: (MonadBaseControl IO m, MonadIO m) => (a -> m b) -> m (a -> IO b)
embedIO f = liftBaseWith $ \run -> do
result <- newIORef undefined
return $ \a -> do
_ <- run $ do
res <- f a
liftIO $ writeIORef result res
readIORef result
embedIO2 :: (MonadBaseControl IO m, MonadIO m)
=> (a -> b -> m r) -> m (a -> b -> IO r)
embedIO2 f = liftBaseWith $ \run -> do
result <- newIORef undefined
return $ \a b -> do
_ <- run $ do
res <- f a b
liftIO $ writeIORef result res
readIORef result
embedIO3 :: (MonadBaseControl IO m, MonadIO m)
=> (a -> b -> c -> m r) -> m (a -> b -> c -> IO r)
embedIO3 f = liftBaseWith $ \run -> do
result <- newIORef undefined
return $ \a b c -> do
_ <- run $ do
res <- f a b c
liftIO $ writeIORef result res
readIORef result
embedIO4 :: (MonadBaseControl IO m, MonadIO m)
=> (a -> b -> c -> d -> m r) -> m (a -> b -> c -> d -> IO r)
embedIO4 f = liftBaseWith $ \run -> do
result <- newIORef undefined
return $ \a b c d -> do
_ <- run $ do
res <- f a b c d
liftIO $ writeIORef result res
readIORef result
embedIO5 :: (MonadBaseControl IO m, MonadIO m)
=> (a -> b -> c -> d -> e -> m r) -> m (a -> b -> c -> d -> e -> IO r)
embedIO5 f = liftBaseWith $ \run -> do
result <- newIORef undefined
return $ \a b c d e -> do
_ <- run $ do
res <- f a b c d e
liftIO $ writeIORef result res
readIORef result
embedIO6 :: (MonadBaseControl IO m, MonadIO m)
=> (a -> b -> c -> d -> e -> f -> m r)
-> m (a -> b -> c -> d -> e -> f -> IO r)
embedIO6 x = liftBaseWith $ \run -> do
result <- newIORef undefined
return $ \a b c d e f -> do
_ <- run $ do
res <- x a b c d e f
liftIO $ writeIORef result res
readIORef result
embedIO7 :: (MonadBaseControl IO m, MonadIO m)
=> (a -> b -> c -> d -> e -> f -> g -> m r)
-> m (a -> b -> c -> d -> e -> f -> g -> IO r)
embedIO7 x = liftBaseWith $ \run -> do
result <- newIORef undefined
return $ \a b c d e f g -> do
_ <- run $ do
res <- x a b c d e f g
liftIO $ writeIORef result res
readIORef result
embedIO8 :: (MonadBaseControl IO m, MonadIO m)
=> (a -> b -> c -> d -> e -> f -> g -> h -> m r)
-> m (a -> b -> c -> d -> e -> f -> g -> h -> IO r)
embedIO8 x = liftBaseWith $ \run -> do
result <- newIORef undefined
return $ \a b c d e f g h -> do
_ <- run $ do
res <- x a b c d e f g h
liftIO $ writeIORef result res
readIORef result
embedIO9 :: (MonadBaseControl IO m, MonadIO m)
=> (a -> b -> c -> d -> e -> f -> g -> h -> i -> m r)
-> m (a -> b -> c -> d -> e -> f -> g -> h -> i -> IO r)
embedIO9 x = liftBaseWith $ \run -> do
result <- newIORef undefined
return $ \a b c d e f g h i -> do
_ <- run $ do
res <- x a b c d e f g h i
liftIO $ writeIORef result res
readIORef result
odbS3Backend :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> Aws.S3Configuration NormalQuery
-> Configuration
-> Manager
-> Text
-> Text
-> FilePath
-> BackendCallbacks
-> m (Ptr C'git_odb_backend)
odbS3Backend s3config config manager bucket prefix dir callbacks = do
readFun' <- embedIO5 readCallback
readPrefixFun' <- embedIO7 readPrefixCallback
readHeaderFun' <- embedIO4 readHeaderCallback
writeFun' <- embedIO5 writeCallback
existsFun' <- embedIO3 existsCallback
refreshFun' <- embedIO refreshCallback
foreachFun' <- embedIO3 foreachCallback
writePackFun' <- embedIO4 writePackCallback
readFun <- liftIO $ mk'git_odb_backend_read_callback readFun'
readPrefixFun <-
liftIO $ mk'git_odb_backend_read_prefix_callback readPrefixFun'
readHeaderFun <-
liftIO $ mk'git_odb_backend_read_header_callback readHeaderFun'
writeFun <- liftIO $ mk'git_odb_backend_write_callback writeFun'
existsFun <- liftIO $ mk'git_odb_backend_exists_callback existsFun'
refreshFun <- liftIO $ mk'git_odb_backend_refresh_callback refreshFun'
foreachFun <- liftIO $ mk'git_odb_backend_foreach_callback foreachFun'
writePackFun <-
liftIO $ mk'git_odb_backend_writepack_callback writePackFun'
writePackAddFun' <- embedIO4 packAddCallback
writePackCommitFun' <- embedIO2 packCommitCallback
writePackAddFun <-
liftIO $ mk'git_odb_writepack_add_callback writePackAddFun'
writePackCommitFun <-
liftIO $ mk'git_odb_writepack_commit_callback writePackCommitFun'
objects <- liftIO $ newTVarIO M.empty
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
}
ptr <- liftIO $ do
dirExists <- doesDirectoryExist dir
unless dirExists $ createDirectoryIfMissing True dir
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
lgDebug $ "Created new S3 backend at " ++ show ptr
return ptr
addS3Backend :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> LgRepo
-> Text
-> Text
-> Text
-> Text
-> Maybe Manager
-> Maybe Text
-> LogLevel
-> FilePath
-> BackendCallbacks
-> m LgRepo
addS3Backend repo bucket prefix access secret
mmanager mockAddr level dir callbacks = do
manager <- maybe (liftIO $ newManager conduitManagerSettings) return
mmanager
odbS3 <- odbS3Backend
(case mockAddr of
Nothing -> defServiceConfig
Just addr -> (Aws.s3 HTTP (T.encodeUtf8 addr) False) {
Aws.s3Port = 10001
, Aws.s3RequestStyle = Aws.PathStyle })
(Configuration Timestamp Credentials {
accessKeyID = T.encodeUtf8 access
, secretAccessKey = T.encodeUtf8 secret }
(defaultLog level))
manager bucket prefix dir callbacks
void $ liftIO $ odbBackendAdd repo odbS3 100
return repo
s3Factory :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks
-> 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 <- Git.getRepository
void $ addS3Backend
repo
(fromMaybe "test-bucket" bucket)
""
accessKey
secretKey
Nothing
(if isNothing bucket
then Just "127.0.0.1"
else Nothing)
Aws.Error
dir
callbacks
s3FactoryLogger :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
=> Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks
-> Git.RepositoryFactory (ReaderT LgRepo m) m LgRepo
s3FactoryLogger bucket accessKey secretKey dir callbacks = lgFactoryLogger
{ Git.runRepository = \ctxt -> runLgRepository ctxt . (s3back >>) }
where
s3back = do
repo <- Git.getRepository
void $ 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 :: MonadS3 m
=> S3MockService -> Text -> Text -> 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 :: MonadS3 m
=> S3MockService -> Text -> Text -> 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 :: MonadS3 m
=> S3MockService -> Text -> Text -> Maybe (Int64, Int64)
-> 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 :: MonadS3 m
=> S3MockService -> Text -> Text -> Int -> BL.ByteString
-> 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 ()