From 4da106cf1703c763f6cbe3d2843e5e10f4160405 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 21 Apr 2015 15:55:42 -0400 Subject: S3: Enable debug logging when annex.debug or --debug is set. To debug a bug report, but generally useful. --- Remote/S3.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) (limited to 'Remote/S3.hs') diff --git a/Remote/S3.hs b/Remote/S3.hs index b0c1de114..06aa79d65 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -28,6 +28,7 @@ import Control.Monad.Trans.Resource import Control.Monad.Catch import Data.Conduit import Data.IORef +import System.Log.Logger import Common.Annex import Types.Remote @@ -149,7 +150,7 @@ s3Setup' u mcreds c = if configIA c then archiveorg else defaulthost writeUUIDFile archiveconfig u use archiveconfig --- Sets up a http connection manager for S3 encdpoint, which allows +-- Sets up a http connection manager for S3 endpoint, which allows -- http connections to be reused across calls to the helper. prepareS3 :: Remote -> S3Info -> (S3Handle -> helper) -> Preparer helper prepareS3 r info = resourcePrepare $ const $ @@ -388,13 +389,13 @@ sendS3Handle' => S3Handle -> r -> ResourceT IO a -sendS3Handle' h = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h) +sendS3Handle' h r = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h) r withS3Handle :: RemoteConfig -> UUID -> S3Info -> (S3Handle -> Annex a) -> Annex a withS3Handle c u info a = do creds <- getRemoteCredPairFor "S3" c (AWS.creds u) awscreds <- liftIO $ genCredentials $ fromMaybe nocreds creds - let awscfg = AWS.Configuration AWS.Timestamp awscreds (AWS.defaultLog AWS.Error) + let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper bracketIO (newManager httpcfg) closeManager $ \mgr -> a $ S3Handle mgr awscfg s3cfg info where @@ -518,3 +519,7 @@ genCredentials (keyid, secret) = AWS.Credentials mkLocationConstraint :: AWS.Region -> S3.LocationConstraint mkLocationConstraint "US" = S3.locationUsClassic mkLocationConstraint r = r + +debugMapper :: AWS.Logger +debugMapper AWS.Debug t = debugM "S3" (T.unpack t) +debugMapper _ _ = noop -- cgit v1.2.3 From e1a773d68890a3ae5f5441e0ff916f229f768d08 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 21 Apr 2015 15:59:30 -0400 Subject: convert all log prorities, not just debug In particular, error should go to stderr --- Remote/S3.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'Remote/S3.hs') diff --git a/Remote/S3.hs b/Remote/S3.hs index 06aa79d65..c9de36745 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -521,5 +521,10 @@ mkLocationConstraint "US" = S3.locationUsClassic mkLocationConstraint r = r debugMapper :: AWS.Logger -debugMapper AWS.Debug t = debugM "S3" (T.unpack t) -debugMapper _ _ = noop +debugMapper level t = forward "S3" (T.unpack t) + where + forward = case level of + AWS.Debug -> debugM + AWS.Info -> infoM + AWS.Warning -> warningM + AWS.Error -> errorM -- cgit v1.2.3 From 8fb9ed4c74ecd332a1d2c8219cd3429b78053b0b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 23 Apr 2015 14:12:25 -0400 Subject: S3: git annex info will show additional information about a S3 remote (endpoint, port, storage class) --- Remote/S3.hs | 23 ++++++++++++++++------- debian/changelog | 2 ++ 2 files changed, 18 insertions(+), 7 deletions(-) (limited to 'Remote/S3.hs') diff --git a/Remote/S3.hs b/Remote/S3.hs index c9de36745..cf46c2b28 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -28,6 +28,7 @@ import Control.Monad.Trans.Resource import Control.Monad.Catch import Data.Conduit import Data.IORef +import Data.Bits.Utils import System.Log.Logger import Common.Annex @@ -89,13 +90,7 @@ gen r u c gc = do , availability = GloballyAvailable , remotetype = remote , mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc - , getInfo = includeCredsInfo c (AWS.creds u) $ catMaybes - [ Just ("bucket", fromMaybe "unknown" (getBucketName c)) - , if configIA c - then Just ("internet archive item", iaItemUrl $ fromMaybe "unknown" $ getBucketName c) - else Nothing - , Just ("partsize", maybe "unlimited" (roughSize storageUnits False) (getPartSize c)) - ] + , getInfo = includeCredsInfo c (AWS.creds u) (s3Info c) , claimUrl = Nothing , checkUrl = Nothing } @@ -528,3 +523,17 @@ debugMapper level t = forward "S3" (T.unpack t) AWS.Info -> infoM AWS.Warning -> warningM AWS.Error -> errorM + +s3Info :: RemoteConfig -> [(String, String)] +s3Info c = catMaybes + [ Just ("bucket", fromMaybe "unknown" (getBucketName c)) + , Just ("endpoint", w82s (S.unpack (S3.s3Endpoint s3c))) + , Just ("port", show (S3.s3Port s3c)) + , Just ("storage class", show (getStorageClass c)) + , if configIA c + then Just ("internet archive item", iaItemUrl $ fromMaybe "unknown" $ getBucketName c) + else Nothing + , Just ("partsize", maybe "unlimited" (roughSize storageUnits False) (getPartSize c)) + ] + where + s3c = s3Configuration c diff --git a/debian/changelog b/debian/changelog index 4553130d6..b151d2963 100644 --- a/debian/changelog +++ b/debian/changelog @@ -3,6 +3,8 @@ git-annex (5.20150421) UNRELEASED; urgency=medium * S3: Enable debug logging when annex.debug or --debug is set. * Dropped support for older versions of yesod, warp, and dbus than the ones in Debian Jessie. + * S3: git annex info will show additional information about a S3 remote + (endpoint, port, storage class) -- Joey Hess Tue, 21 Apr 2015 15:54:10 -0400 -- cgit v1.2.3 From 060e698c88fefab5a55e99d5d8a45897fc1571ac Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 23 Apr 2015 14:16:53 -0400 Subject: S3: git annex enableremote will not create a bucket name, which failed since the bucket already exists. --- Remote/S3.hs | 9 +++++---- debian/changelog | 2 ++ 2 files changed, 7 insertions(+), 4 deletions(-) (limited to 'Remote/S3.hs') diff --git a/Remote/S3.hs b/Remote/S3.hs index cf46c2b28..d290f9596 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -98,9 +98,9 @@ gen r u c gc = do s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) s3Setup mu mcreds c = do u <- maybe (liftIO genUUID) return mu - s3Setup' u mcreds c -s3Setup' :: UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) -s3Setup' u mcreds c = if configIA c then archiveorg else defaulthost + s3Setup' (isNothing mu) u mcreds c +s3Setup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) +s3Setup' new u mcreds c = if configIA c then archiveorg else defaulthost where remotename = fromJust (M.lookup "name" c) defbucket = remotename ++ "-" ++ fromUUID u @@ -120,7 +120,8 @@ s3Setup' u mcreds c = if configIA c then archiveorg else defaulthost (c', encsetup) <- encryptionSetup c c'' <- setRemoteCredPair encsetup c' (AWS.creds u) mcreds let fullconfig = c'' `M.union` defaults - genBucket fullconfig u + when new $ + genBucket fullconfig u use fullconfig archiveorg = do diff --git a/debian/changelog b/debian/changelog index b151d2963..fa707a0af 100644 --- a/debian/changelog +++ b/debian/changelog @@ -5,6 +5,8 @@ git-annex (5.20150421) UNRELEASED; urgency=medium in Debian Jessie. * S3: git annex info will show additional information about a S3 remote (endpoint, port, storage class) + * S3: git annex enableremote will not create a bucket name, which + failed since the bucket already exists. -- Joey Hess Tue, 21 Apr 2015 15:54:10 -0400 -- cgit v1.2.3 From c32e51a706258a8be90c125475c6741d9b4936ad Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 27 Apr 2015 18:00:58 -0400 Subject: S3: Fix incompatability with bucket names used by hS3; the aws library cannot handle upper-case bucket names. git-annex now converts them to lower case automatically. For example, it failed to get files from a bucket named S3. Also fixes `git annex initremote UPPERCASE type=S3`, which failed with the new aws library, with a signing error message. --- Remote/S3.hs | 4 ++-- debian/changelog | 3 +++ 2 files changed, 5 insertions(+), 2 deletions(-) (limited to 'Remote/S3.hs') diff --git a/Remote/S3.hs b/Remote/S3.hs index d290f9596..d8914d822 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -129,7 +129,7 @@ s3Setup' new u mcreds c = if configIA c then archiveorg else defaulthost c' <- setRemoteCredPair noEncryptionUsed c (AWS.creds u) mcreds -- Ensure user enters a valid bucket name, since -- this determines the name of the archive.org item. - let validbucket = replace " " "-" $ map toLower $ + let validbucket = replace " " "-" $ fromMaybe (error "specify bucket=") $ getBucketName c' let archiveconfig = @@ -447,7 +447,7 @@ extractS3Info c = do } getBucketName :: RemoteConfig -> Maybe BucketName -getBucketName = M.lookup "bucket" +getBucketName = map toLower <$$> M.lookup "bucket" getStorageClass :: RemoteConfig -> S3.StorageClass getStorageClass c = case M.lookup "storageclass" c of diff --git a/debian/changelog b/debian/changelog index 24acb8144..ffca9cda3 100644 --- a/debian/changelog +++ b/debian/changelog @@ -8,6 +8,9 @@ git-annex (5.20150421) UNRELEASED; urgency=medium * S3: git annex enableremote will not create a bucket name, which failed since the bucket already exists. * Fix bogus failure of fsck --fast. + * S3: Fix incompatability with bucket names used by hS3; the aws library + cannot handle upper-case bucket names. git-annex now converts them to + lower case automatically. -- Joey Hess Tue, 21 Apr 2015 15:54:10 -0400 -- cgit v1.2.3 From 246e7278f4770c87277c9e8aeedfba17547859d8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 10 May 2015 15:41:41 -0400 Subject: generalied elem/notElem in ghc 7.10 require some additional type signatures when using OverloadedStrings --- Remote/S3.hs | 2 +- Remote/Tahoe.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'Remote/S3.hs') diff --git a/Remote/S3.hs b/Remote/S3.hs index d8914d822..b86b17d56 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -483,7 +483,7 @@ iaMunge = (>>= munge) where munge c | isAsciiUpper c || isAsciiLower c || isNumber c = [c] - | c `elem` "_-.\"" = [c] + | c `elem` ("_-.\"" :: String) = [c] | isSpace c = [] | otherwise = "&" ++ show (ord c) ++ ";" diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index 56bf66427..bc4789e57 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -177,7 +177,7 @@ getSharedConvergenceSecret configdir = go (60 :: Int) v <- catchMaybeIO (readFile f) case v of Just s | "\n" `isSuffixOf` s || "\r" `isSuffixOf` s -> - return $ takeWhile (`notElem` "\n\r") s + return $ takeWhile (`notElem` ("\n\r" :: String)) s _ -> do threadDelaySeconds (Seconds 1) go (n - 1) -- cgit v1.2.3