mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

groundwork for readonly access

Browse source 
Split S3Info out of S3Handle and added some stubs
This commit is contained in:
Joey Hess 2015-06-05 13:09:41 -04:00
parent 9b298f4c86
commit 334fd6d598
1 changed files with 66 additions and 58 deletions
Download patch file Download diff file Expand all files Collapse all files

124
Remote/S3.hs
View file

@ -1,6 +1,6 @@
{- S3 remotes {- S3 remotes
- -
- Copyright 2011-2014 Joey Hess <id@joeyh.name> - Copyright 2011-2015 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -63,10 +63,10 @@ gen r u c gc = do
return $ new cst info return $ new cst info
where where
new cst info = Just $ specialRemote c new cst info = Just $ specialRemote c
(prepareS3 this info $ store this) (prepareS3Handle this $ store this info)
(prepareS3 this info retrieve) (prepareS3HandleMaybe this $ retrieve info)
(prepareS3 this info remove) (prepareS3Handle this $ remove info)
(prepareS3 this info $ checkKey this) (prepareS3HandleMaybe this $ checkKey this info)
this this
where where
this = Remote this = Remote
@ -142,19 +142,24 @@ s3Setup' new u mcreds c = if configIA c then archiveorg else defaulthost
-- special constraints on key names -- special constraints on key names
M.insert "mungekeys" "ia" defaults M.insert "mungekeys" "ia" defaults
info <- extractS3Info archiveconfig info <- extractS3Info archiveconfig
withS3Handle archiveconfig u info $ withS3Handle archiveconfig u $
writeUUIDFile archiveconfig u writeUUIDFile archiveconfig u info
use archiveconfig use archiveconfig
-- Sets up a http connection manager for S3 endpoint, which allows -- Sets up a http connection manager for S3 endpoint, which allows
-- http connections to be reused across calls to the helper. -- http connections to be reused across calls to the helper.
prepareS3 :: Remote -> S3Info -> (S3Handle -> helper) -> Preparer helper prepareS3Handle :: Remote -> (S3Handle -> helper) -> Preparer helper
prepareS3 r info = resourcePrepare $ const $ prepareS3Handle r = resourcePrepare $ const $
withS3Handle (config r) (uuid r) info withS3Handle (config r) (uuid r)
store :: Remote -> S3Handle -> Storer -- Allows for read-only actions, which can be run without a S3Handle.
store r h = fileStorer $ \k f p -> do prepareS3HandleMaybe :: Remote -> (Maybe S3Handle -> helper) -> Preparer helper
case partSize (hinfo h) of prepareS3HandleMaybe r = resourcePrepare $ const $
withS3HandleMaybe (config r) (uuid r)
store :: Remote -> S3Info -> S3Handle -> Storer
store r info h = fileStorer $ \k f p -> do
case partSize info of
Just partsz | partsz > 0 -> do Just partsz | partsz > 0 -> do
fsz <- liftIO $ getFileSize f fsz <- liftIO $ getFileSize f
if fsz > partsz if fsz > partsz
@ -162,16 +167,15 @@ store r h = fileStorer $ \k f p -> do
else singlepartupload k f p else singlepartupload k f p
_ -> singlepartupload k f p _ -> singlepartupload k f p
-- Store public URL to item in Internet Archive. -- Store public URL to item in Internet Archive.
when (isIA (hinfo h) && not (isChunkKey k)) $ when (isIA info && not (isChunkKey k)) $
setUrlPresent webUUID k (iaKeyUrl r k) setUrlPresent webUUID k (iaKeyUrl r k)
return True return True
where where
singlepartupload k f p = do singlepartupload k f p = do
rbody <- liftIO $ httpBodyStorer f p rbody <- liftIO $ httpBodyStorer f p
void $ sendS3Handle h $ putObject h (bucketObject (hinfo h) k) rbody void $ sendS3Handle h $ putObject info (bucketObject info k) rbody
multipartupload fsz partsz k f p = do multipartupload fsz partsz k f p = do
#if MIN_VERSION_aws(0,10,6) #if MIN_VERSION_aws(0,10,6)
let info = hinfo h
let object = bucketObject info k let object = bucketObject info k
let startreq = (S3.postInitiateMultipartUpload (bucket info) object) let startreq = (S3.postInitiateMultipartUpload (bucket info) object)
@ -218,15 +222,14 @@ store r h = fileStorer $ \k f p -> do
{- Implemented as a fileRetriever, that uses conduit to stream the chunks {- Implemented as a fileRetriever, that uses conduit to stream the chunks
- out to the file. Would be better to implement a byteRetriever, but - out to the file. Would be better to implement a byteRetriever, but
- that is difficult. -} - that is difficult. -}
retrieve :: S3Handle -> Retriever retrieve :: S3Info -> Maybe S3Handle -> Retriever
retrieve h = fileRetriever $ \f k p -> liftIO $ runResourceT $ do retrieve info (Just h) = fileRetriever $ \f k p -> liftIO $ runResourceT $ do
(fr, fh) <- allocate (openFile f WriteMode) hClose (fr, fh) <- allocate (openFile f WriteMode) hClose
let req = S3.getObject (bucket info) (bucketObject info k) let req = S3.getObject (bucket info) (bucketObject info k)
S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle' h req S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle' h req
responseBody rsp $$+- sinkprogressfile fh p zeroBytesProcessed responseBody rsp $$+- sinkprogressfile fh p zeroBytesProcessed
release fr release fr
where where
info = hinfo h
sinkprogressfile fh meterupdate sofar = do sinkprogressfile fh meterupdate sofar = do
mbs <- await mbs <- await
case mbs of case mbs of
@ -237,6 +240,7 @@ retrieve h = fileRetriever $ \f k p -> liftIO $ runResourceT $ do
void $ meterupdate sofar' void $ meterupdate sofar'
S.hPut fh bs S.hPut fh bs
sinkprogressfile fh meterupdate sofar' sinkprogressfile fh meterupdate sofar'
retrieve _info Nothing = error "TODO"
retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False retrieveCheap _ _ _ = return False
@ -244,8 +248,8 @@ retrieveCheap _ _ _ = return False
{- Internet Archive doesn't easily allow removing content. {- Internet Archive doesn't easily allow removing content.
- While it may remove the file, there are generally other files - While it may remove the file, there are generally other files
- derived from it that it does not remove. -} - derived from it that it does not remove. -}
remove :: S3Handle -> Remover remove :: S3Info -> S3Handle -> Remover
remove h k remove info h k
| isIA info = do | isIA info = do
warning "Cannot remove content from the Internet Archive" warning "Cannot remove content from the Internet Archive"
return False return False
@ -253,11 +257,9 @@ remove h k
res <- tryNonAsync $ sendS3Handle h $ res <- tryNonAsync $ sendS3Handle h $
S3.DeleteObject (bucketObject info k) (bucket info) S3.DeleteObject (bucketObject info k) (bucket info)
return $ either (const False) (const True) res return $ either (const False) (const True) res
where
info = hinfo h
checkKey :: Remote -> S3Handle -> CheckPresent checkKey :: Remote -> S3Info -> Maybe S3Handle -> CheckPresent
checkKey r h k = do checkKey r info (Just h) k = do
showAction $ "checking " ++ name r showAction $ "checking " ++ name r
#if MIN_VERSION_aws(0,10,0) #if MIN_VERSION_aws(0,10,0)
rsp <- go rsp <- go
@ -269,7 +271,7 @@ checkKey r h k = do
#endif #endif
where where
go = sendS3Handle h $ go = sendS3Handle h $
S3.headObject (bucket (hinfo h)) (bucketObject (hinfo h) k) S3.headObject (bucket info) (bucketObject info k)
#if ! MIN_VERSION_aws(0,10,0) #if ! MIN_VERSION_aws(0,10,0)
{- Catch exception headObject returns when an object is not present {- Catch exception headObject returns when an object is not present
@ -283,6 +285,7 @@ checkKey r h k = do
| AWS.headerErrorMessage e == "ETag missing" = Just () | AWS.headerErrorMessage e == "ETag missing" = Just ()
| otherwise = Nothing | otherwise = Nothing
#endif #endif
checkKey _r _info Nothing _k = error "TODO"
{- Generate the bucket if it does not already exist, including creating the {- Generate the bucket if it does not already exist, including creating the
- UUID file within the bucket. - UUID file within the bucket.
@ -295,21 +298,21 @@ genBucket :: RemoteConfig -> UUID -> Annex ()
genBucket c u = do genBucket c u = do
showAction "checking bucket" showAction "checking bucket"
info <- extractS3Info c info <- extractS3Info c
withS3Handle c u info $ \h -> withS3Handle c u $ \h ->
go h =<< checkUUIDFile c u h go info h =<< checkUUIDFile c u info h
where where
go _ (Right True) = noop go _ _ (Right True) = noop
go h _ = do go info h _ = do
v <- tryNonAsync $ sendS3Handle h (S3.getBucket $ bucket $ hinfo h) v <- tryNonAsync $ sendS3Handle h (S3.getBucket $ bucket info)
case v of case v of
Right _ -> noop Right _ -> noop
Left _ -> do Left _ -> do
showAction $ "creating bucket in " ++ datacenter showAction $ "creating bucket in " ++ datacenter
void $ sendS3Handle h $ void $ sendS3Handle h $
S3.PutBucket (bucket $ hinfo h) Nothing $ S3.PutBucket (bucket info) Nothing $
mkLocationConstraint $ mkLocationConstraint $
T.pack datacenter T.pack datacenter
writeUUIDFile c u h writeUUIDFile c u info h
datacenter = fromJust $ M.lookup "datacenter" c datacenter = fromJust $ M.lookup "datacenter" c
@ -320,9 +323,9 @@ genBucket c u = do
- Note that IA buckets can only created by having a file - Note that IA buckets can only created by having a file
- stored in them. So this also takes care of that. - stored in them. So this also takes care of that.
-} -}
writeUUIDFile :: RemoteConfig -> UUID -> S3Handle -> Annex () writeUUIDFile :: RemoteConfig -> UUID -> S3Info -> S3Handle -> Annex ()
writeUUIDFile c u h = do writeUUIDFile c u info h = do
v <- checkUUIDFile c u h v <- checkUUIDFile c u info h
case v of case v of
Right True -> noop Right True -> noop
_ -> void $ sendS3Handle h mkobject _ -> void $ sendS3Handle h mkobject
@ -330,17 +333,17 @@ writeUUIDFile c u h = do
file = T.pack $ uuidFile c file = T.pack $ uuidFile c
uuidb = L.fromChunks [T.encodeUtf8 $ T.pack $ fromUUID u] uuidb = L.fromChunks [T.encodeUtf8 $ T.pack $ fromUUID u]
mkobject = putObject h file (RequestBodyLBS uuidb) mkobject = putObject info file (RequestBodyLBS uuidb)
{- Checks if the UUID file exists in the bucket {- Checks if the UUID file exists in the bucket
- and has the specified UUID already. -} - and has the specified UUID already. -}
checkUUIDFile :: RemoteConfig -> UUID -> S3Handle -> Annex (Either SomeException Bool) checkUUIDFile :: RemoteConfig -> UUID -> S3Info -> S3Handle -> Annex (Either SomeException Bool)
checkUUIDFile c u h = tryNonAsync $ check <$> get checkUUIDFile c u info h = tryNonAsync $ check <$> get
where where
get = liftIO get = liftIO
. runResourceT . runResourceT
. either (pure . Left) (Right <$$> AWS.loadToMemory) . either (pure . Left) (Right <$$> AWS.loadToMemory)
=<< tryS3 (sendS3Handle h (S3.getObject (bucket (hinfo h)) file)) =<< tryS3 (sendS3Handle h (S3.getObject (bucket info) file))
check (Right (S3.GetObjectMemoryResponse _meta rsp)) = check (Right (S3.GetObjectMemoryResponse _meta rsp)) =
responseStatus rsp == ok200 && responseBody rsp == uuidb responseStatus rsp == ok200 && responseBody rsp == uuidb
check (Left _S3Error) = False check (Left _S3Error) = False
@ -351,20 +354,10 @@ checkUUIDFile c u h = tryNonAsync $ check <$> get
uuidFile :: RemoteConfig -> FilePath uuidFile :: RemoteConfig -> FilePath
uuidFile c = getFilePrefix c ++ "annex-uuid" uuidFile c = getFilePrefix c ++ "annex-uuid"
putObject :: S3Handle -> T.Text -> RequestBody -> S3.PutObject
putObject h file rbody = (S3.putObject (bucket info) file rbody)
{ S3.poStorageClass = Just (storageClass info)
, S3.poMetadata = metaHeaders info
, S3.poAutoMakeBucket = isIA info
}
where
info = hinfo h
data S3Handle = S3Handle data S3Handle = S3Handle
{ hmanager :: Manager { hmanager :: Manager
, hawscfg :: AWS.Configuration , hawscfg :: AWS.Configuration
, hs3cfg :: S3.S3Configuration AWS.NormalQuery , hs3cfg :: S3.S3Configuration AWS.NormalQuery
, hinfo :: S3Info
} }
{- Sends a request to S3 and gets back the response. {- Sends a request to S3 and gets back the response.
@ -387,18 +380,26 @@ sendS3Handle'
-> ResourceT IO a -> ResourceT IO a
sendS3Handle' h r = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h) r sendS3Handle' h r = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h) r
withS3Handle :: RemoteConfig -> UUID -> S3Info -> (S3Handle -> Annex a) -> Annex a withS3Handle :: RemoteConfig -> UUID -> (S3Handle -> Annex a) -> Annex a
withS3Handle c u info a = do withS3Handle c u a = do
creds <- getRemoteCredPairFor "S3" c (AWS.creds u) withS3HandleMaybe c u $ \mh -> case mh of
awscreds <- liftIO $ genCredentials $ fromMaybe nocreds creds Just h -> a h
let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper Nothing -> error "No S3 credentials configured"
bracketIO (newManager httpcfg) closeManager $ \mgr ->
a $ S3Handle mgr awscfg s3cfg info withS3HandleMaybe :: RemoteConfig -> UUID -> (Maybe S3Handle -> Annex a) -> Annex a
withS3HandleMaybe c u a = do
mcreds <- getRemoteCredPairFor "S3" c (AWS.creds u)
case mcreds of
Just creds -> do
awscreds <- liftIO $ genCredentials creds
let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper
bracketIO (newManager httpcfg) closeManager $ \mgr ->
a $ Just $ S3Handle mgr awscfg s3cfg
Nothing -> a Nothing
where where
s3cfg = s3Configuration c s3cfg = s3Configuration c
httpcfg = defaultManagerSettings httpcfg = defaultManagerSettings
{ managerResponseTimeout = Nothing } { managerResponseTimeout = Nothing }
nocreds = error "Cannot use S3 without credentials configured"
s3Configuration :: RemoteConfig -> S3.S3Configuration AWS.NormalQuery s3Configuration :: RemoteConfig -> S3.S3Configuration AWS.NormalQuery
s3Configuration c = (S3.s3 proto endpoint False) { S3.s3Port = port } s3Configuration c = (S3.s3 proto endpoint False) { S3.s3Port = port }
@ -446,6 +447,13 @@ extractS3Info c = do
, isIA = configIA c , isIA = configIA c
} }
putObject :: S3Info -> T.Text -> RequestBody -> S3.PutObject
putObject info file rbody = (S3.putObject (bucket info) file rbody)
{ S3.poStorageClass = Just (storageClass info)
, S3.poMetadata = metaHeaders info
, S3.poAutoMakeBucket = isIA info
}
getBucketName :: RemoteConfig -> Maybe BucketName getBucketName :: RemoteConfig -> Maybe BucketName
getBucketName = map toLower <$$> M.lookup "bucket" getBucketName = map toLower <$$> M.lookup "bucket"