Merge /home/joey/tmp/git-annex
This commit is contained in:
commit
61af9d8f63
53 changed files with 388 additions and 289 deletions
|
@ -329,7 +329,7 @@ getViaTmpFromDisk rsp v key action = checkallowed $ do
|
|||
checkallowed a = case rsp of
|
||||
RetrievalAllKeysSecure -> a
|
||||
RetrievalVerifiableKeysSecure
|
||||
| isVerifiable (keyVariety key) -> a
|
||||
| isVerifiable (fromKey keyVariety key) -> a
|
||||
| otherwise -> ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig)
|
||||
( a
|
||||
, warnUnverifiableInsecure key >> return False
|
||||
|
@ -353,7 +353,7 @@ verifyKeyContent :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> K
|
|||
verifyKeyContent rsp v verification k f = case (rsp, verification) of
|
||||
(_, Verified) -> return True
|
||||
(RetrievalVerifiableKeysSecure, _)
|
||||
| isVerifiable (keyVariety k) -> verify
|
||||
| isVerifiable (fromKey keyVariety k) -> verify
|
||||
| otherwise -> ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig)
|
||||
( verify
|
||||
, warnUnverifiableInsecure k >> return False
|
||||
|
@ -365,12 +365,12 @@ verifyKeyContent rsp v verification k f = case (rsp, verification) of
|
|||
(_, MustVerify) -> verify
|
||||
where
|
||||
verify = enteringStage VerifyStage $ verifysize <&&> verifycontent
|
||||
verifysize = case keySize k of
|
||||
verifysize = case fromKey keySize k of
|
||||
Nothing -> return True
|
||||
Just size -> do
|
||||
size' <- liftIO $ catchDefaultIO 0 $ getFileSize f
|
||||
return (size' == size)
|
||||
verifycontent = case Types.Backend.verifyKeyContent =<< Backend.maybeLookupBackendVariety (keyVariety k) of
|
||||
verifycontent = case Types.Backend.verifyKeyContent =<< Backend.maybeLookupBackendVariety (fromKey keyVariety k) of
|
||||
Nothing -> return True
|
||||
Just verifier -> verifier k f
|
||||
|
||||
|
@ -382,7 +382,7 @@ warnUnverifiableInsecure k = warning $ unwords
|
|||
, "this safety check.)"
|
||||
]
|
||||
where
|
||||
kv = decodeBS (formatKeyVariety (keyVariety k))
|
||||
kv = decodeBS (formatKeyVariety (fromKey keyVariety k))
|
||||
|
||||
data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify
|
||||
|
||||
|
@ -490,10 +490,10 @@ moveAnnex key src = ifM (checkSecureHashes key)
|
|||
|
||||
checkSecureHashes :: Key -> Annex Bool
|
||||
checkSecureHashes key
|
||||
| cryptographicallySecure (keyVariety key) = return True
|
||||
| cryptographicallySecure (fromKey keyVariety key) = return True
|
||||
| otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig)
|
||||
( do
|
||||
warning $ "annex.securehashesonly blocked adding " ++ decodeBS (formatKeyVariety (keyVariety key)) ++ " key to annex objects"
|
||||
warning $ "annex.securehashesonly blocked adding " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key to annex objects"
|
||||
return False
|
||||
, return True
|
||||
)
|
||||
|
|
|
@ -100,7 +100,7 @@ preserveGitMode _ _ = return True
|
|||
- when doing concurrent downloads.
|
||||
-}
|
||||
checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool
|
||||
checkDiskSpace destdir key = checkDiskSpace' (fromMaybe 1 (keySize key)) destdir key
|
||||
checkDiskSpace destdir key = checkDiskSpace' (fromMaybe 1 (fromKey keySize key)) destdir key
|
||||
|
||||
{- Allows specifying the size of the key, if it's known, which is useful
|
||||
- as not all keys know their size. -}
|
||||
|
|
|
@ -65,14 +65,14 @@ hashDirs (HashLevels 1) sz s = addTrailingPathSeparator $ take sz s
|
|||
hashDirs _ sz s = addTrailingPathSeparator $ take sz s </> drop sz s
|
||||
|
||||
hashDirLower :: HashLevels -> Hasher
|
||||
hashDirLower n k = hashDirs n 3 $ take 6 $ show $ md5 $ serializeKey' $ nonChunkKey k
|
||||
hashDirLower n k = hashDirs n 3 $ take 6 $ show $ md5s $ serializeKey' $ nonChunkKey k
|
||||
|
||||
{- This was originally using Data.Hash.MD5 from MissingH. This new version
|
||||
- is faster, but ugly as it has to replicate the 4 Word32's that produced. -}
|
||||
hashDirMixed :: HashLevels -> Hasher
|
||||
hashDirMixed n k = hashDirs n 2 $ take 4 $ concatMap display_32bits_as_dir $
|
||||
encodeWord32 $ map fromIntegral $ Data.ByteArray.unpack $
|
||||
Utility.Hash.md5 $ serializeKey' $ nonChunkKey k
|
||||
Utility.Hash.md5s $ serializeKey' $ nonChunkKey k
|
||||
where
|
||||
encodeWord32 (b1:b2:b3:b4:rest) =
|
||||
(shiftL b4 24 .|. shiftL b3 16 .|. shiftL b2 8 .|. b1)
|
||||
|
|
|
@ -33,7 +33,7 @@ exportKey :: Git.Sha -> Annex ExportKey
|
|||
exportKey sha = mk <$> catKey sha
|
||||
where
|
||||
mk (Just k) = AnnexKey k
|
||||
mk Nothing = GitKey $ Key
|
||||
mk Nothing = GitKey $ mkKey $ \k -> k
|
||||
{ keyName = encodeBS $ Git.fromRef sha
|
||||
, keyVariety = SHA1Key (HasExt False)
|
||||
, keySize = Nothing
|
||||
|
|
|
@ -398,7 +398,7 @@ downloadImport remote importtreeconfig importablecontents = do
|
|||
{- Temporary key used for import of a ContentIdentifier while downloading
|
||||
- content, before generating its real key. -}
|
||||
importKey :: ContentIdentifier -> Integer -> Key
|
||||
importKey (ContentIdentifier cid) size = stubKey
|
||||
importKey (ContentIdentifier cid) size = mkKey $ \k -> k
|
||||
{ keyName = cid
|
||||
, keyVariety = OtherKey "CID"
|
||||
, keySize = Just size
|
||||
|
|
|
@ -93,7 +93,6 @@ module Annex.Locations (
|
|||
import Data.Char
|
||||
import Data.Default
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
|
||||
import Common
|
||||
import Key
|
||||
|
@ -563,7 +562,7 @@ keyFile = fromRawFilePath . keyFile'
|
|||
|
||||
keyFile' :: Key -> RawFilePath
|
||||
keyFile' k =
|
||||
let b = L.toStrict (serializeKey' k)
|
||||
let b = serializeKey' k
|
||||
in if any (`S8.elem` b) ['&', '%', ':', '/']
|
||||
then S8.concatMap esc b
|
||||
else b
|
||||
|
|
|
@ -40,15 +40,15 @@ import Data.Ord
|
|||
|
||||
upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
|
||||
upload u key f d a _witness = guardHaveUUID u $
|
||||
runTransfer (Transfer Upload u key) f d a
|
||||
runTransfer (Transfer Upload u (fromKey id key)) f d a
|
||||
|
||||
alwaysUpload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
|
||||
alwaysUpload u key f d a _witness = guardHaveUUID u $
|
||||
alwaysRunTransfer (Transfer Upload u key) f d a
|
||||
alwaysRunTransfer (Transfer Upload u (fromKey id key)) f d a
|
||||
|
||||
download :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
|
||||
download u key f d a _witness = guardHaveUUID u $
|
||||
runTransfer (Transfer Download u key) f d a
|
||||
runTransfer (Transfer Download u (fromKey id key)) f d a
|
||||
|
||||
guardHaveUUID :: Observable v => UUID -> Annex v -> Annex v
|
||||
guardHaveUUID u a
|
||||
|
@ -185,7 +185,7 @@ checkSecureHashes t a
|
|||
, a
|
||||
)
|
||||
where
|
||||
variety = keyVariety (transferKey t)
|
||||
variety = fromKey keyVariety (transferKey t)
|
||||
|
||||
type RetryDecider = Annex (TransferInfo -> TransferInfo -> Annex Bool)
|
||||
|
||||
|
|
|
@ -10,7 +10,7 @@ module Annex.VariantFile where
|
|||
import Annex.Common
|
||||
import Utility.Hash
|
||||
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString as S
|
||||
|
||||
variantMarker :: String
|
||||
variantMarker = ".variant-"
|
||||
|
@ -41,5 +41,5 @@ variantFile file key
|
|||
where
|
||||
doubleconflict = variantMarker `isInfixOf` file
|
||||
|
||||
shortHash :: L.ByteString -> String
|
||||
shortHash = take 4 . show . md5
|
||||
shortHash :: S.ByteString -> String
|
||||
shortHash = take 4 . show . md5s
|
||||
|
|
|
@ -64,7 +64,7 @@ removableRemote urlrenderer uuid = do
|
|||
where
|
||||
queueremaining r k =
|
||||
queueTransferWhenSmall "remaining object in unwanted remote"
|
||||
(AssociatedFile Nothing) (Transfer Download uuid k) r
|
||||
(AssociatedFile Nothing) (Transfer Download uuid (fromKey id k)) r
|
||||
{- Scanning for keys can take a long time; do not tie up
|
||||
- the Annex monad while doing it, so other threads continue to
|
||||
- run. -}
|
||||
|
|
|
@ -186,7 +186,7 @@ genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote
|
|||
genTransfer direction want key slocs r
|
||||
| direction == Upload && Remote.readonly r = Nothing
|
||||
| S.member (Remote.uuid r) slocs == want = Just
|
||||
(r, Transfer direction (Remote.uuid r) key)
|
||||
(r, Transfer direction (Remote.uuid r) (fromKey id key))
|
||||
| otherwise = Nothing
|
||||
|
||||
remoteHas :: Remote -> Key -> Annex Bool
|
||||
|
|
|
@ -96,7 +96,7 @@ queueTransfersMatching matching reason schedule k f direction
|
|||
inset s r = S.member (Remote.uuid r) s
|
||||
gentransfer r = Transfer
|
||||
{ transferDirection = direction
|
||||
, transferKey = k
|
||||
, transferKeyData = fromKey id k
|
||||
, transferUUID = Remote.uuid r
|
||||
}
|
||||
defer
|
||||
|
@ -129,7 +129,7 @@ queueDeferredDownloads reason schedule = do
|
|||
where
|
||||
gentransfer r = Transfer
|
||||
{ transferDirection = Download
|
||||
, transferKey = k
|
||||
, transferKeyData = fromKey id k
|
||||
, transferUUID = Remote.uuid r
|
||||
}
|
||||
|
||||
|
|
|
@ -62,7 +62,7 @@ describeUnused' whenbig = liftAnnex $ go =<< readUnusedLog ""
|
|||
tenthused Nothing _ = False
|
||||
tenthused (Just disksize) used = used >= disksize `div` 10
|
||||
|
||||
sumkeysize s k = s + fromMaybe 0 (keySize k)
|
||||
sumkeysize s k = s + fromMaybe 0 (fromKey keySize k)
|
||||
|
||||
forpath a = inRepo $ liftIO . a . Git.repoPath
|
||||
|
||||
|
|
|
@ -25,7 +25,6 @@ import Annex.Content
|
|||
import Annex.UUID
|
||||
import qualified Backend
|
||||
import qualified Types.Backend
|
||||
import qualified Types.Key
|
||||
import Assistant.TransferQueue
|
||||
import Assistant.TransferSlots
|
||||
import Remote (remoteFromUUID)
|
||||
|
@ -91,13 +90,13 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol
|
|||
maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just f)) t)
|
||||
=<< liftAnnex (remoteFromUUID webUUID)
|
||||
startTransfer t
|
||||
k = distributionKey d
|
||||
k = mkKey $ const $ distributionKey d
|
||||
u = distributionUrl d
|
||||
f = takeFileName u ++ " (for upgrade)"
|
||||
t = Transfer
|
||||
{ transferDirection = Download
|
||||
, transferUUID = webUUID
|
||||
, transferKey = k
|
||||
, transferKeyData = fromKey id k
|
||||
}
|
||||
cleanup = liftAnnex $ do
|
||||
lockContentForRemoval k removeAnnex
|
||||
|
@ -117,8 +116,8 @@ distributionDownloadComplete d dest cleanup t
|
|||
=<< liftAnnex (withObjectLoc k fsckit)
|
||||
| otherwise = cleanup
|
||||
where
|
||||
k = distributionKey d
|
||||
fsckit f = case Backend.maybeLookupBackendVariety (Types.Key.keyVariety k) of
|
||||
k = mkKey $ const $ distributionKey d
|
||||
fsckit f = case Backend.maybeLookupBackendVariety (fromKey keyVariety k) of
|
||||
Nothing -> return $ Just f
|
||||
Just b -> case Types.Backend.verifyKeyContent b of
|
||||
Nothing -> return $ Just f
|
||||
|
|
10
Backend.hs
10
Backend.hs
|
@ -59,16 +59,18 @@ genKey source meterupdate preferredbackend = do
|
|||
Just k -> Just (makesane k, b)
|
||||
where
|
||||
-- keyNames should not contain newline characters.
|
||||
makesane k = k { keyName = S8.map fixbadchar (keyName k) }
|
||||
makesane k = alterKey k $ \d -> d
|
||||
{ keyName = S8.map fixbadchar (fromKey keyName k)
|
||||
}
|
||||
fixbadchar c
|
||||
| c == '\n' = '_'
|
||||
| otherwise = c
|
||||
|
||||
getBackend :: FilePath -> Key -> Annex (Maybe Backend)
|
||||
getBackend file k = case maybeLookupBackendVariety (keyVariety k) of
|
||||
getBackend file k = case maybeLookupBackendVariety (fromKey keyVariety k) of
|
||||
Just backend -> return $ Just backend
|
||||
Nothing -> do
|
||||
warning $ "skipping " ++ file ++ " (unknown backend " ++ decodeBS (formatKeyVariety (keyVariety k)) ++ ")"
|
||||
warning $ "skipping " ++ file ++ " (unknown backend " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ ")"
|
||||
return Nothing
|
||||
|
||||
{- Looks up the backend that should be used for a file.
|
||||
|
@ -95,4 +97,4 @@ varietyMap = M.fromList $ zip (map B.backendVariety list) list
|
|||
|
||||
isStableKey :: Key -> Bool
|
||||
isStableKey k = maybe False (`B.isStableKey` k)
|
||||
(maybeLookupBackendVariety (keyVariety k))
|
||||
(maybeLookupBackendVariety (fromKey keyVariety k))
|
||||
|
|
|
@ -91,7 +91,7 @@ keyValue hash source meterupdate = do
|
|||
let file = contentLocation source
|
||||
filesize <- liftIO $ getFileSize file
|
||||
s <- hashFile hash file meterupdate
|
||||
return $ Just $ stubKey
|
||||
return $ Just $ mkKey $ \k -> k
|
||||
{ keyName = encodeBS s
|
||||
, keyVariety = hashKeyVariety hash (HasExt False)
|
||||
, keySize = Just filesize
|
||||
|
@ -105,8 +105,8 @@ keyValueE hash source meterupdate =
|
|||
addE k = do
|
||||
maxlen <- annexMaxExtensionLength <$> Annex.getGitConfig
|
||||
let ext = selectExtension maxlen (keyFilename source)
|
||||
return $ Just $ k
|
||||
{ keyName = keyName k <> encodeBS ext
|
||||
return $ Just $ alterKey k $ \d -> d
|
||||
{ keyName = keyName d <> encodeBS ext
|
||||
, keyVariety = hashKeyVariety hash (HasExt True)
|
||||
}
|
||||
|
||||
|
@ -169,7 +169,7 @@ needsUpgrade :: Key -> Bool
|
|||
needsUpgrade key = or
|
||||
[ "\\" `S8.isPrefixOf` keyHash key
|
||||
, any (not . validInExtension) (decodeBS $ snd $ splitKeyNameExtension key)
|
||||
, not (hasExt (keyVariety key)) && keyHash key /= keyName key
|
||||
, not (hasExt (fromKey keyVariety key)) && keyHash key /= fromKey keyName key
|
||||
]
|
||||
|
||||
trivialMigrate :: Key -> Backend -> AssociatedFile -> Annex (Maybe Key)
|
||||
|
@ -179,14 +179,14 @@ trivialMigrate oldkey newbackend afile = trivialMigrate' oldkey newbackend afile
|
|||
trivialMigrate' :: Key -> Backend -> AssociatedFile -> Maybe Int -> Maybe Key
|
||||
trivialMigrate' oldkey newbackend afile maxextlen
|
||||
{- Fast migration from hashE to hash backend. -}
|
||||
| migratable && hasExt oldvariety = Just $ oldkey
|
||||
| migratable && hasExt oldvariety = Just $ alterKey oldkey $ \d -> d
|
||||
{ keyName = keyHash oldkey
|
||||
, keyVariety = newvariety
|
||||
}
|
||||
{- Fast migration from hash to hashE backend. -}
|
||||
| migratable && hasExt newvariety = case afile of
|
||||
AssociatedFile Nothing -> Nothing
|
||||
AssociatedFile (Just file) -> Just $ oldkey
|
||||
AssociatedFile (Just file) -> Just $ alterKey oldkey $ \d -> d
|
||||
{ keyName = keyHash oldkey
|
||||
<> encodeBS (selectExtension maxextlen file)
|
||||
, keyVariety = newvariety
|
||||
|
@ -195,14 +195,15 @@ trivialMigrate' oldkey newbackend afile maxextlen
|
|||
- non-extension preserving key, with an extension
|
||||
- in its keyName. -}
|
||||
| newvariety == oldvariety && not (hasExt oldvariety) &&
|
||||
keyHash oldkey /= keyName oldkey = Just $ oldkey
|
||||
{ keyName = keyHash oldkey
|
||||
}
|
||||
keyHash oldkey /= fromKey keyName oldkey =
|
||||
Just $ alterKey oldkey $ \d -> d
|
||||
{ keyName = keyHash oldkey
|
||||
}
|
||||
| otherwise = Nothing
|
||||
where
|
||||
migratable = oldvariety /= newvariety
|
||||
&& sameExceptExt oldvariety newvariety
|
||||
oldvariety = keyVariety oldkey
|
||||
oldvariety = fromKey keyVariety oldkey
|
||||
newvariety = backendVariety newbackend
|
||||
|
||||
hashFile :: Hash -> FilePath -> MeterUpdate -> Annex String
|
||||
|
@ -294,5 +295,7 @@ testKeyBackend =
|
|||
let b = genBackendE (SHA2Hash (HashSize 256))
|
||||
in b { getKey = \ks p -> (fmap addE) <$> getKey b ks p }
|
||||
where
|
||||
addE k = k { keyName = keyName k <> longext }
|
||||
addE k = alterKey k $ \d -> d
|
||||
{ keyName = keyName d <> longext
|
||||
}
|
||||
longext = ".this-is-a-test-key"
|
||||
|
|
|
@ -32,7 +32,7 @@ backend = Backend
|
|||
|
||||
{- Every unique url has a corresponding key. -}
|
||||
fromUrl :: String -> Maybe Integer -> Key
|
||||
fromUrl url size = stubKey
|
||||
fromUrl url size = mkKey $ \k -> k
|
||||
{ keyName = genKeyName url
|
||||
, keyVariety = URLKey
|
||||
, keySize = size
|
||||
|
|
|
@ -39,7 +39,7 @@ keyValue source _ = do
|
|||
stat <- liftIO $ getFileStatus f
|
||||
sz <- liftIO $ getFileSize' f stat
|
||||
relf <- getTopFilePath <$> inRepo (toTopFilePath $ keyFilename source)
|
||||
return $ Just $ stubKey
|
||||
return $ Just $ mkKey $ \k -> k
|
||||
{ keyName = genKeyName relf
|
||||
, keyVariety = WORMKey
|
||||
, keySize = Just sz
|
||||
|
@ -48,14 +48,14 @@ keyValue source _ = do
|
|||
|
||||
{- Old WORM keys could contain spaces, and can be upgraded to remove them. -}
|
||||
needsUpgrade :: Key -> Bool
|
||||
needsUpgrade key = ' ' `S8.elem` keyName key
|
||||
needsUpgrade key = ' ' `S8.elem` fromKey keyName key
|
||||
|
||||
removeSpaces :: Key -> Backend -> AssociatedFile -> Annex (Maybe Key)
|
||||
removeSpaces oldkey newbackend _
|
||||
| migratable = return $ Just $ oldkey
|
||||
{ keyName = encodeBS $ reSanitizeKeyName $ decodeBS $ keyName oldkey }
|
||||
| migratable = return $ Just $ alterKey oldkey $ \d -> d
|
||||
{ keyName = encodeBS $ reSanitizeKeyName $ decodeBS $ keyName d }
|
||||
| otherwise = return Nothing
|
||||
where
|
||||
migratable = oldvariety == newvariety
|
||||
oldvariety = keyVariety oldkey
|
||||
oldvariety = fromKey keyVariety oldkey
|
||||
newvariety = backendVariety newbackend
|
||||
|
|
|
@ -1,5 +1,9 @@
|
|||
git-annex (7.20191115) UNRELEASED; urgency=medium
|
||||
|
||||
* Sped up many git-annex commands that operare on many files, by
|
||||
avoiding reserialization of keys.
|
||||
find is 7% faster; whereis is 3% faster; and git-annex get when
|
||||
all files are already present is 5% faster
|
||||
* Stop displaying rsync progress, and use git-annex's own progress display
|
||||
for local-to-local repo transfers.
|
||||
* git-lfs: The url provided to initremote/enableremote will now be
|
||||
|
|
|
@ -162,7 +162,7 @@ performRemote r o uri file sz = ifAnnexed file adduri geturi
|
|||
adduri = addUrlChecked o loguri file (Remote.uuid r) checkexistssize
|
||||
checkexistssize key = return $ case sz of
|
||||
Nothing -> (True, True, loguri)
|
||||
Just n -> (True, n == fromMaybe n (keySize key), loguri)
|
||||
Just n -> (True, n == fromMaybe n (fromKey keySize key), loguri)
|
||||
geturi = next $ isJust <$> downloadRemoteFile r (downloadOptions o) uri file sz
|
||||
|
||||
downloadRemoteFile :: Remote -> DownloadOptions -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key)
|
||||
|
@ -218,7 +218,7 @@ performWeb o url file urlinfo = ifAnnexed file addurl geturl
|
|||
addurl = addUrlChecked o url file webUUID $ \k ->
|
||||
ifM (pure (not (rawOption (downloadOptions o))) <&&> youtubeDlSupported url)
|
||||
( return (True, True, setDownloader url YoutubeDownloader)
|
||||
, return (Url.urlExists urlinfo, Url.urlSize urlinfo == keySize k, url)
|
||||
, return (Url.urlExists urlinfo, Url.urlSize urlinfo == fromKey keySize k, url)
|
||||
)
|
||||
|
||||
{- Check that the url exists, and has the same size as the key,
|
||||
|
@ -379,7 +379,9 @@ finishDownloadWith tmp u url file = do
|
|||
|
||||
{- Adds the url size to the Key. -}
|
||||
addSizeUrlKey :: Url.UrlInfo -> Key -> Key
|
||||
addSizeUrlKey urlinfo key = key { keySize = Url.urlSize urlinfo }
|
||||
addSizeUrlKey urlinfo key = alterKey key $ \d -> d
|
||||
{ keySize = Url.urlSize urlinfo
|
||||
}
|
||||
|
||||
{- Adds worktree file to the repository. -}
|
||||
addWorkTree :: UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex ()
|
||||
|
|
|
@ -87,14 +87,14 @@ showFormatted format unformatted vars =
|
|||
keyVars :: Key -> [(String, String)]
|
||||
keyVars key =
|
||||
[ ("key", serializeKey key)
|
||||
, ("backend", decodeBS $ formatKeyVariety $ keyVariety key)
|
||||
, ("backend", decodeBS $ formatKeyVariety $ fromKey keyVariety key)
|
||||
, ("bytesize", size show)
|
||||
, ("humansize", size $ roughSize storageUnits True)
|
||||
, ("keyname", decodeBS $ keyName key)
|
||||
, ("keyname", decodeBS $ fromKey keyName key)
|
||||
, ("hashdirlower", hashDirLower def key)
|
||||
, ("hashdirmixed", hashDirMixed def key)
|
||||
, ("mtime", whenavail show $ keyMtime key)
|
||||
, ("mtime", whenavail show $ fromKey keyMtime key)
|
||||
]
|
||||
where
|
||||
size c = whenavail c $ keySize key
|
||||
size c = whenavail c $ fromKey keySize key
|
||||
whenavail = maybe "unknown"
|
||||
|
|
|
@ -49,14 +49,14 @@ seekBatch fmt = batchInput fmt parse commandAction
|
|||
parse s =
|
||||
let (keyname, file) = separate (== ' ') s
|
||||
in if not (null keyname) && not (null file)
|
||||
then Right $ go file (mkKey keyname)
|
||||
then Right $ go file (keyOpt keyname)
|
||||
else Left "Expected pairs of key and filename"
|
||||
go file key = starting "fromkey" (mkActionItem (key, file)) $
|
||||
perform key file
|
||||
|
||||
start :: Bool -> (String, FilePath) -> CommandStart
|
||||
start force (keyname, file) = do
|
||||
let key = mkKey keyname
|
||||
let key = keyOpt keyname
|
||||
unless force $ do
|
||||
inbackend <- inAnnex key
|
||||
unless inbackend $ giveup $
|
||||
|
@ -71,8 +71,8 @@ start force (keyname, file) = do
|
|||
-- For example, "WORM--a:a" parses as an uri. To disambiguate, check
|
||||
-- the uri scheme, to see if it looks like the prefix of a key. This relies
|
||||
-- on key backend names never containing a ':'.
|
||||
mkKey :: String -> Key
|
||||
mkKey s = case parseURI s of
|
||||
keyOpt :: String -> Key
|
||||
keyOpt s = case parseURI s of
|
||||
Just u | not (isKeyPrefix (uriScheme u)) ->
|
||||
Backend.URL.fromUrl s Nothing
|
||||
_ -> case deserializeKey s of
|
||||
|
|
|
@ -182,7 +182,7 @@ performRemote key afile backend numcopies remote =
|
|||
|
||||
startKey :: Maybe Remote -> Incremental -> (Key, ActionItem) -> NumCopies -> CommandStart
|
||||
startKey from inc (key, ai) numcopies =
|
||||
case Backend.maybeLookupBackendVariety (keyVariety key) of
|
||||
case Backend.maybeLookupBackendVariety (fromKey keyVariety key) of
|
||||
Nothing -> stop
|
||||
Just backend -> runFsck inc ai key $
|
||||
case from of
|
||||
|
@ -244,9 +244,9 @@ verifyLocationLog key keystatus ai = do
|
|||
- insecure hash is present. This should only be able to happen
|
||||
- if the repository already contained the content before the
|
||||
- config was set. -}
|
||||
when (present && not (cryptographicallySecure (keyVariety key))) $
|
||||
when (present && not (cryptographicallySecure (fromKey keyVariety key))) $
|
||||
whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $
|
||||
warning $ "** Despite annex.securehashesonly being set, " ++ obj ++ " has content present in the annex using an insecure " ++ decodeBS (formatKeyVariety (keyVariety key)) ++ " key"
|
||||
warning $ "** Despite annex.securehashesonly being set, " ++ obj ++ " has content present in the annex using an insecure " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key"
|
||||
|
||||
verifyLocationLog' key ai present u (logChange key u)
|
||||
|
||||
|
@ -362,7 +362,7 @@ checkKeySizeRemote key remote ai localcopy =
|
|||
checkKeySizeOr (badContentRemote remote localcopy) key localcopy ai
|
||||
|
||||
checkKeySizeOr :: (Key -> Annex String) -> Key -> FilePath -> ActionItem -> Annex Bool
|
||||
checkKeySizeOr bad key file ai = case keySize key of
|
||||
checkKeySizeOr bad key file ai = case fromKey keySize key of
|
||||
Nothing -> return True
|
||||
Just size -> do
|
||||
size' <- liftIO $ getFileSize file
|
||||
|
@ -396,7 +396,7 @@ checkKeyUpgrade backend key ai (AssociatedFile (Just file)) =
|
|||
[ actionItemDesc ai
|
||||
, ": Can be upgraded to an improved key format. "
|
||||
, "You can do so by running: git annex migrate --backend="
|
||||
, decodeBS (formatKeyVariety (keyVariety key)) ++ " "
|
||||
, decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " "
|
||||
, file
|
||||
]
|
||||
return True
|
||||
|
|
|
@ -50,23 +50,23 @@ import qualified Command.Unused
|
|||
type Stat = StatState (Maybe (String, StatState String))
|
||||
|
||||
-- data about a set of keys
|
||||
data KeyData = KeyData
|
||||
data KeyInfo = KeyInfo
|
||||
{ countKeys :: Integer
|
||||
, sizeKeys :: Integer
|
||||
, unknownSizeKeys :: Integer
|
||||
, backendsKeys :: M.Map KeyVariety Integer
|
||||
}
|
||||
|
||||
instance Sem.Semigroup KeyData where
|
||||
a <> b = KeyData
|
||||
instance Sem.Semigroup KeyInfo where
|
||||
a <> b = KeyInfo
|
||||
{ countKeys = countKeys a + countKeys b
|
||||
, sizeKeys = sizeKeys a + sizeKeys b
|
||||
, unknownSizeKeys = unknownSizeKeys a + unknownSizeKeys b
|
||||
, backendsKeys = backendsKeys a <> backendsKeys b
|
||||
}
|
||||
|
||||
instance Monoid KeyData where
|
||||
mempty = KeyData 0 0 0 M.empty
|
||||
instance Monoid KeyInfo where
|
||||
mempty = KeyInfo 0 0 0 M.empty
|
||||
|
||||
data NumCopiesStats = NumCopiesStats
|
||||
{ numCopiesVarianceMap :: M.Map Variance Integer
|
||||
|
@ -82,9 +82,9 @@ instance Show Variance where
|
|||
|
||||
-- cached info that multiple Stats use
|
||||
data StatInfo = StatInfo
|
||||
{ presentData :: Maybe KeyData
|
||||
, referencedData :: Maybe KeyData
|
||||
, repoData :: M.Map UUID KeyData
|
||||
{ presentData :: Maybe KeyInfo
|
||||
, referencedData :: Maybe KeyInfo
|
||||
, repoData :: M.Map UUID KeyInfo
|
||||
, numCopiesStats :: Maybe NumCopiesStats
|
||||
, infoOptions :: InfoOptions
|
||||
}
|
||||
|
@ -512,7 +512,7 @@ reposizes_total :: Stat
|
|||
reposizes_total = simpleStat "combined size of repositories containing these files" $
|
||||
showSizeKeys . mconcat . M.elems =<< cachedRepoData
|
||||
|
||||
cachedPresentData :: StatState KeyData
|
||||
cachedPresentData :: StatState KeyInfo
|
||||
cachedPresentData = do
|
||||
s <- get
|
||||
case presentData s of
|
||||
|
@ -522,7 +522,7 @@ cachedPresentData = do
|
|||
put s { presentData = Just v }
|
||||
return v
|
||||
|
||||
cachedRemoteData :: UUID -> StatState KeyData
|
||||
cachedRemoteData :: UUID -> StatState KeyInfo
|
||||
cachedRemoteData u = do
|
||||
s <- get
|
||||
case M.lookup u (repoData s) of
|
||||
|
@ -531,19 +531,19 @@ cachedRemoteData u = do
|
|||
let combinedata d uk = finishCheck uk >>= \case
|
||||
Nothing -> return d
|
||||
Just k -> return $ addKey k d
|
||||
v <- lift $ foldM combinedata emptyKeyData
|
||||
v <- lift $ foldM combinedata emptyKeyInfo
|
||||
=<< loggedKeysFor' u
|
||||
put s { repoData = M.insert u v (repoData s) }
|
||||
return v
|
||||
|
||||
cachedReferencedData :: StatState KeyData
|
||||
cachedReferencedData :: StatState KeyInfo
|
||||
cachedReferencedData = do
|
||||
s <- get
|
||||
case referencedData s of
|
||||
Just v -> return v
|
||||
Nothing -> do
|
||||
!v <- lift $ Command.Unused.withKeysReferenced
|
||||
emptyKeyData addKey
|
||||
emptyKeyInfo addKey
|
||||
put s { referencedData = Just v }
|
||||
return v
|
||||
|
||||
|
@ -552,7 +552,7 @@ cachedNumCopiesStats :: StatState (Maybe NumCopiesStats)
|
|||
cachedNumCopiesStats = numCopiesStats <$> get
|
||||
|
||||
-- currently only available for directory info
|
||||
cachedRepoData :: StatState (M.Map UUID KeyData)
|
||||
cachedRepoData :: StatState (M.Map UUID KeyInfo)
|
||||
cachedRepoData = repoData <$> get
|
||||
|
||||
getDirStatInfo :: InfoOptions -> FilePath -> Annex StatInfo
|
||||
|
@ -564,7 +564,7 @@ getDirStatInfo o dir = do
|
|||
(update matcher fast)
|
||||
return $ StatInfo (Just presentdata) (Just referenceddata) repodata (Just numcopiesstats) o
|
||||
where
|
||||
initial = (emptyKeyData, emptyKeyData, emptyNumCopiesStats, M.empty)
|
||||
initial = (emptyKeyInfo, emptyKeyInfo, emptyNumCopiesStats, M.empty)
|
||||
update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats, repodata) =
|
||||
ifM (matcher $ MatchingFile $ FileInfo file file)
|
||||
( do
|
||||
|
@ -594,7 +594,7 @@ getTreeStatInfo o r = do
|
|||
, return Nothing
|
||||
)
|
||||
where
|
||||
initial = (emptyKeyData, emptyKeyData, M.empty)
|
||||
initial = (emptyKeyInfo, emptyKeyInfo, M.empty)
|
||||
go _ [] vs = return vs
|
||||
go fast (l:ls) vs@(presentdata, referenceddata, repodata) = do
|
||||
mk <- catKey (LsTree.sha l)
|
||||
|
@ -613,33 +613,33 @@ getTreeStatInfo o r = do
|
|||
return (updateRepoData key locs repodata)
|
||||
go fast ls $! (presentdata', referenceddata', repodata')
|
||||
|
||||
emptyKeyData :: KeyData
|
||||
emptyKeyData = KeyData 0 0 0 M.empty
|
||||
emptyKeyInfo :: KeyInfo
|
||||
emptyKeyInfo = KeyInfo 0 0 0 M.empty
|
||||
|
||||
emptyNumCopiesStats :: NumCopiesStats
|
||||
emptyNumCopiesStats = NumCopiesStats M.empty
|
||||
|
||||
foldKeys :: [Key] -> KeyData
|
||||
foldKeys = foldl' (flip addKey) emptyKeyData
|
||||
foldKeys :: [Key] -> KeyInfo
|
||||
foldKeys = foldl' (flip addKey) emptyKeyInfo
|
||||
|
||||
addKey :: Key -> KeyData -> KeyData
|
||||
addKey key (KeyData count size unknownsize backends) =
|
||||
KeyData count' size' unknownsize' backends'
|
||||
addKey :: Key -> KeyInfo -> KeyInfo
|
||||
addKey key (KeyInfo count size unknownsize backends) =
|
||||
KeyInfo count' size' unknownsize' backends'
|
||||
where
|
||||
{- All calculations strict to avoid thunks when repeatedly
|
||||
- applied to many keys. -}
|
||||
!count' = count + 1
|
||||
!backends' = M.insertWith (+) (keyVariety key) 1 backends
|
||||
!backends' = M.insertWith (+) (fromKey keyVariety key) 1 backends
|
||||
!size' = maybe size (+ size) ks
|
||||
!unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks
|
||||
ks = keySize key
|
||||
ks = fromKey keySize key
|
||||
|
||||
updateRepoData :: Key -> [UUID] -> M.Map UUID KeyData -> M.Map UUID KeyData
|
||||
updateRepoData :: Key -> [UUID] -> M.Map UUID KeyInfo -> M.Map UUID KeyInfo
|
||||
updateRepoData key locs m = m'
|
||||
where
|
||||
!m' = M.unionWith (\_old new -> new) m $
|
||||
M.fromList $ zip locs (map update locs)
|
||||
update loc = addKey key (fromMaybe emptyKeyData $ M.lookup loc m)
|
||||
update loc = addKey key (fromMaybe emptyKeyInfo $ M.lookup loc m)
|
||||
|
||||
updateNumCopiesStats :: FilePath -> NumCopiesStats -> [UUID] -> Annex NumCopiesStats
|
||||
updateNumCopiesStats file (NumCopiesStats m) locs = do
|
||||
|
@ -649,7 +649,7 @@ updateNumCopiesStats file (NumCopiesStats m) locs = do
|
|||
let !ret = NumCopiesStats m'
|
||||
return ret
|
||||
|
||||
showSizeKeys :: KeyData -> StatState String
|
||||
showSizeKeys :: KeyInfo -> StatState String
|
||||
showSizeKeys d = do
|
||||
sizer <- mkSizer
|
||||
return $ total sizer ++ missingnote
|
||||
|
|
|
@ -67,7 +67,7 @@ optParser desc = MatchExpressionOptions
|
|||
missingdata datadesc = bail $ "cannot match this expression without " ++ datadesc ++ " data"
|
||||
-- When a key is provided, make its size also be provided.
|
||||
addkeysize p = case providedKey p of
|
||||
Right k -> case keySize k of
|
||||
Right k -> case fromKey keySize k of
|
||||
Just sz -> p { providedFileSize = Right sz }
|
||||
Nothing -> p
|
||||
Left _ -> p
|
||||
|
|
|
@ -50,7 +50,7 @@ start file key = do
|
|||
- - Something has changed in the backend, such as a bug fix.
|
||||
-}
|
||||
upgradableKey :: Backend -> Key -> Bool
|
||||
upgradableKey backend key = isNothing (keySize key) || backendupgradable
|
||||
upgradableKey backend key = isNothing (fromKey keySize key) || backendupgradable
|
||||
where
|
||||
backendupgradable = maybe False (\a -> a key) (canUpgradeKey backend)
|
||||
|
||||
|
|
|
@ -11,7 +11,7 @@ module Command.RegisterUrl where
|
|||
|
||||
import Command
|
||||
import Logs.Web
|
||||
import Command.FromKey (mkKey)
|
||||
import Command.FromKey (keyOpt)
|
||||
import qualified Remote
|
||||
|
||||
cmd :: Command
|
||||
|
@ -41,7 +41,7 @@ seek o = case (batchOption o, keyUrlPairs o) of
|
|||
start :: [String] -> CommandStart
|
||||
start (keyname:url:[]) =
|
||||
starting "registerurl" (ActionItemOther (Just url)) $ do
|
||||
let key = mkKey keyname
|
||||
let key = keyOpt keyname
|
||||
perform key url
|
||||
start _ = giveup "specify a key and an url"
|
||||
|
||||
|
@ -55,7 +55,7 @@ massAdd fmt = go True =<< map (separate (== ' ')) <$> batchLines fmt
|
|||
where
|
||||
go status [] = next $ return status
|
||||
go status ((keyname,u):rest) | not (null keyname) && not (null u) = do
|
||||
let key = mkKey keyname
|
||||
let key = keyOpt keyname
|
||||
ok <- perform' key u
|
||||
let !status' = status && ok
|
||||
go status' rest
|
||||
|
|
|
@ -49,7 +49,7 @@ fieldTransfer direction key a = do
|
|||
afile <- AssociatedFile <$> Fields.getField Fields.associatedFile
|
||||
ok <- maybe (a $ const noop)
|
||||
-- Using noRetry here because we're the sender.
|
||||
(\u -> runner (Transfer direction (toUUID u) key) afile noRetry a)
|
||||
(\u -> runner (Transfer direction (toUUID u) (fromKey id key)) afile noRetry a)
|
||||
=<< Fields.getField Fields.remoteUUID
|
||||
liftIO $ debugM "fieldTransfer" "transfer done"
|
||||
liftIO $ exitBool ok
|
||||
|
|
|
@ -21,11 +21,11 @@ seek = withWords (commandAction . start)
|
|||
|
||||
start :: [String] -> CommandStart
|
||||
start (keyname:file:[]) = starting "setkey" (ActionItemOther (Just file)) $
|
||||
perform file (mkKey keyname)
|
||||
perform file (keyOpt keyname)
|
||||
start _ = giveup "specify a key and a content file"
|
||||
|
||||
mkKey :: String -> Key
|
||||
mkKey = fromMaybe (giveup "bad key") . deserializeKey
|
||||
keyOpt :: String -> Key
|
||||
keyOpt = fromMaybe (giveup "bad key") . deserializeKey
|
||||
|
||||
perform :: FilePath -> Key -> CommandPerform
|
||||
perform file key = do
|
||||
|
|
|
@ -119,7 +119,7 @@ clean file = do
|
|||
-- Look up the backend that was used for this file
|
||||
-- before, so that when git re-cleans a file its
|
||||
-- backend does not change.
|
||||
let oldbackend = maybe Nothing (maybeLookupBackendVariety . keyVariety) oldkey
|
||||
let oldbackend = maybe Nothing (maybeLookupBackendVariety . fromKey keyVariety) oldkey
|
||||
-- Can't restage associated files because git add
|
||||
-- runs this and has the index locked.
|
||||
let norestage = Restage False
|
||||
|
|
|
@ -107,14 +107,14 @@ perform rs unavailrs exportr ks = do
|
|||
next $ cleanup rs ks ok
|
||||
where
|
||||
desc r' k = intercalate "; " $ map unwords
|
||||
[ [ "key size", show (keySize k) ]
|
||||
[ [ "key size", show (fromKey keySize k) ]
|
||||
, [ show (getChunkConfig (Remote.config r')) ]
|
||||
, ["encryption", fromMaybe "none" (M.lookup "encryption" (Remote.config r'))]
|
||||
]
|
||||
descexport k1 k2 = intercalate "; " $ map unwords
|
||||
[ [ "exporttree=yes" ]
|
||||
, [ "key1 size", show (keySize k1) ]
|
||||
, [ "key2 size", show (keySize k2) ]
|
||||
, [ "key1 size", show (fromKey keySize k1) ]
|
||||
, [ "key2 size", show (fromKey keySize k2) ]
|
||||
]
|
||||
|
||||
adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote)
|
||||
|
@ -199,7 +199,7 @@ test st r k = catMaybes
|
|||
Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed"
|
||||
present b = check ("present " ++ show b) $
|
||||
(== Right b) <$> Remote.hasKey r k
|
||||
fsck = case maybeLookupBackendVariety (keyVariety k) of
|
||||
fsck = case maybeLookupBackendVariety (fromKey keyVariety k) of
|
||||
Nothing -> return True
|
||||
Just b -> case Backend.verifyKeyContent b of
|
||||
Nothing -> return True
|
||||
|
|
|
@ -47,7 +47,7 @@ start (k:[]) = do
|
|||
let t = Transfer
|
||||
{ transferDirection = Upload
|
||||
, transferUUID = u
|
||||
, transferKey = key
|
||||
, transferKeyData = fromKey id key
|
||||
}
|
||||
tinfo <- liftIO $ startTransferInfo afile
|
||||
(update, tfile, createtfile, _) <- mkProgressUpdater t tinfo
|
||||
|
|
|
@ -161,7 +161,7 @@ type EncKey = Key -> Key
|
|||
- reversable, nor does it need to be the same type of encryption used
|
||||
- on content. It does need to be repeatable. -}
|
||||
encryptKey :: Mac -> Cipher -> EncKey
|
||||
encryptKey mac c k = stubKey
|
||||
encryptKey mac c k = mkKey $ \d -> d
|
||||
{ keyName = encodeBS (macWithCipher mac c (serializeKey k))
|
||||
, keyVariety = OtherKey $
|
||||
encryptedBackendNamePrefix <> encodeBS (showMac mac)
|
||||
|
@ -171,7 +171,7 @@ encryptedBackendNamePrefix :: S.ByteString
|
|||
encryptedBackendNamePrefix = "GPG"
|
||||
|
||||
isEncKey :: Key -> Bool
|
||||
isEncKey k = case keyVariety k of
|
||||
isEncKey k = case fromKey keyVariety k of
|
||||
OtherKey s -> encryptedBackendNamePrefix `S.isPrefixOf` s
|
||||
_ -> False
|
||||
|
||||
|
|
|
@ -87,7 +87,7 @@ populateAssociatedFiles h num = do
|
|||
H.flushDbQueue h
|
||||
|
||||
keyN :: Integer -> Key
|
||||
keyN n = stubKey
|
||||
keyN n = mkKey $ \k -> k
|
||||
{ keyName = B8.pack $ "key" ++ show n
|
||||
, keyVariety = OtherKey "BENCH"
|
||||
}
|
||||
|
|
143
Key.hs
143
Key.hs
|
@ -8,10 +8,12 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Key (
|
||||
Key(..),
|
||||
Key,
|
||||
KeyData(..),
|
||||
AssociatedFile(..),
|
||||
stubKey,
|
||||
buildKey,
|
||||
fromKey,
|
||||
mkKey,
|
||||
alterKey,
|
||||
keyParser,
|
||||
serializeKey,
|
||||
serializeKey',
|
||||
|
@ -28,13 +30,7 @@ module Key (
|
|||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.ByteString.Builder
|
||||
import Data.ByteString.Builder.Extra
|
||||
import qualified Data.Attoparsec.ByteString as A
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A8
|
||||
import Foreign.C.Types
|
||||
|
||||
import Common
|
||||
import Types.Key
|
||||
|
@ -43,134 +39,37 @@ import Utility.Bloom
|
|||
import Utility.Aeson
|
||||
import qualified Utility.SimpleProtocol as Proto
|
||||
|
||||
stubKey :: Key
|
||||
stubKey = Key
|
||||
{ keyName = mempty
|
||||
, keyVariety = OtherKey mempty
|
||||
, keySize = Nothing
|
||||
, keyMtime = Nothing
|
||||
, keyChunkSize = Nothing
|
||||
, keyChunkNum = Nothing
|
||||
}
|
||||
|
||||
-- Gets the parent of a chunk key.
|
||||
nonChunkKey :: Key -> Key
|
||||
nonChunkKey k = k
|
||||
{ keyChunkSize = Nothing
|
||||
, keyChunkNum = Nothing
|
||||
}
|
||||
nonChunkKey k
|
||||
| fromKey keyChunkSize k == Nothing && fromKey keyChunkNum k == Nothing = k
|
||||
| otherwise = alterKey k $ \d -> d
|
||||
{ keyChunkSize = Nothing
|
||||
, keyChunkNum = Nothing
|
||||
}
|
||||
|
||||
-- Where a chunk key is offset within its parent.
|
||||
chunkKeyOffset :: Key -> Maybe Integer
|
||||
chunkKeyOffset k = (*)
|
||||
<$> keyChunkSize k
|
||||
<*> (pred <$> keyChunkNum k)
|
||||
<$> fromKey keyChunkSize k
|
||||
<*> (pred <$> fromKey keyChunkNum k)
|
||||
|
||||
isChunkKey :: Key -> Bool
|
||||
isChunkKey k = isJust (keyChunkSize k) && isJust (keyChunkNum k)
|
||||
|
||||
-- Checks if a string looks like at least the start of a key.
|
||||
isKeyPrefix :: String -> Bool
|
||||
isKeyPrefix s = [fieldSep, fieldSep] `isInfixOf` s
|
||||
|
||||
fieldSep :: Char
|
||||
fieldSep = '-'
|
||||
|
||||
{- Builds a ByteString from a Key.
|
||||
-
|
||||
- The name field is always shown last, separated by doubled fieldSeps,
|
||||
- and is the only field allowed to contain the fieldSep.
|
||||
-}
|
||||
buildKey :: Key -> Builder
|
||||
buildKey k = byteString (formatKeyVariety (keyVariety k))
|
||||
<> 's' ?: (integerDec <$> keySize k)
|
||||
<> 'm' ?: (integerDec . (\(CTime t) -> fromIntegral t) <$> keyMtime k)
|
||||
<> 'S' ?: (integerDec <$> keyChunkSize k)
|
||||
<> 'C' ?: (integerDec <$> keyChunkNum k)
|
||||
<> sepbefore (sepbefore (byteString (keyName k)))
|
||||
where
|
||||
sepbefore s = char7 fieldSep <> s
|
||||
c ?: (Just b) = sepbefore (char7 c <> b)
|
||||
_ ?: Nothing = mempty
|
||||
isChunkKey k = isJust (fromKey keyChunkSize k) && isJust (fromKey keyChunkNum k)
|
||||
|
||||
serializeKey :: Key -> String
|
||||
serializeKey = decodeBL' . serializeKey'
|
||||
serializeKey = decodeBS' . serializeKey'
|
||||
|
||||
serializeKey' :: Key -> L.ByteString
|
||||
serializeKey' = toLazyByteStringWith (safeStrategy 128 smallChunkSize) L.empty . buildKey
|
||||
|
||||
{- This is a strict parser for security reasons; a key
|
||||
- can contain only 4 fields, which all consist only of numbers.
|
||||
- Any key containing other fields, or non-numeric data will fail
|
||||
- to parse.
|
||||
-
|
||||
- If a key contained non-numeric fields, they could be used to
|
||||
- embed data used in a SHA1 collision attack, which would be a
|
||||
- problem since the keys are committed to git.
|
||||
-}
|
||||
keyParser :: A.Parser Key
|
||||
keyParser = do
|
||||
-- key variety cannot be empty
|
||||
v <- (parseKeyVariety <$> A8.takeWhile1 (/= fieldSep))
|
||||
s <- parsesize
|
||||
m <- parsemtime
|
||||
cs <- parsechunksize
|
||||
cn <- parsechunknum
|
||||
_ <- A8.char fieldSep
|
||||
_ <- A8.char fieldSep
|
||||
n <- A.takeByteString
|
||||
if validKeyName v n
|
||||
then return $ Key
|
||||
{ keyName = n
|
||||
, keyVariety = v
|
||||
, keySize = s
|
||||
, keyMtime = m
|
||||
, keyChunkSize = cs
|
||||
, keyChunkNum = cn
|
||||
}
|
||||
else fail "invalid keyName"
|
||||
where
|
||||
parseopt p = (Just <$> (A8.char fieldSep *> p)) <|> pure Nothing
|
||||
parsesize = parseopt $ A8.char 's' *> A8.decimal
|
||||
parsemtime = parseopt $ CTime <$> (A8.char 'm' *> A8.decimal)
|
||||
parsechunksize = parseopt $ A8.char 'S' *> A8.decimal
|
||||
parsechunknum = parseopt $ A8.char 'C' *> A8.decimal
|
||||
serializeKey' :: Key -> S.ByteString
|
||||
serializeKey' = keySerialization
|
||||
|
||||
deserializeKey :: String -> Maybe Key
|
||||
deserializeKey = deserializeKey' . encodeBS'
|
||||
|
||||
deserializeKey' :: S.ByteString -> Maybe Key
|
||||
deserializeKey' b = eitherToMaybe $ A.parseOnly keyParser b
|
||||
deserializeKey' = either (const Nothing) Just . A.parseOnly keyParser
|
||||
|
||||
{- This splits any extension out of the keyName, returning the
|
||||
- keyName minus extension, and the extension (including leading dot).
|
||||
-}
|
||||
splitKeyNameExtension :: Key -> (S.ByteString, S.ByteString)
|
||||
splitKeyNameExtension = splitKeyNameExtension' . keyName
|
||||
|
||||
splitKeyNameExtension' :: S.ByteString -> (S.ByteString, S.ByteString)
|
||||
splitKeyNameExtension' keyname = S8.span (/= '.') keyname
|
||||
|
||||
{- Limits the length of the extension in the keyName to mitigate against
|
||||
- SHA1 collision attacks.
|
||||
-
|
||||
- In such an attack, the extension of the key could be made to contain
|
||||
- the collision generation data, with the result that a signed git commit
|
||||
- including such keys would not be secure.
|
||||
-
|
||||
- The maximum extension length ever generated for such a key was 8
|
||||
- characters, but they may be unicode which could use up to 4 bytes each,
|
||||
- so 32 bytes. 64 bytes is used here to give a little future wiggle-room.
|
||||
- The SHA1 common-prefix attack needs 128 bytes of data.
|
||||
-}
|
||||
validKeyName :: KeyVariety -> S.ByteString -> Bool
|
||||
validKeyName kv name
|
||||
| hasExt kv =
|
||||
let ext = snd $ splitKeyNameExtension' name
|
||||
in S.length ext <= 64
|
||||
| otherwise = True
|
||||
|
||||
instance Arbitrary Key where
|
||||
instance Arbitrary KeyData where
|
||||
arbitrary = Key
|
||||
<$> (encodeBS <$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t"))
|
||||
<*> (parseKeyVariety . encodeBS <$> (listOf1 $ elements ['A'..'Z'])) -- BACKEND
|
||||
|
@ -179,6 +78,9 @@ instance Arbitrary Key where
|
|||
<*> ((abs <$>) <$> arbitrary) -- chunksize cannot be negative
|
||||
<*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative
|
||||
|
||||
instance Arbitrary Key where
|
||||
arbitrary = mkKey . const <$> arbitrary
|
||||
|
||||
instance Hashable Key where
|
||||
hashIO32 = hashIO32 . serializeKey'
|
||||
hashIO64 = hashIO64 . serializeKey'
|
||||
|
@ -196,3 +98,4 @@ instance Proto.Serializable Key where
|
|||
|
||||
prop_isomorphic_key_encode :: Key -> Bool
|
||||
prop_isomorphic_key_encode k = Just k == (deserializeKey . serializeKey) k
|
||||
|
||||
|
|
6
Limit.hs
6
Limit.hs
|
@ -294,7 +294,7 @@ addInBackend = addLimit . limitInBackend
|
|||
limitInBackend :: MkLimit Annex
|
||||
limitInBackend name = Right $ const $ checkKey check
|
||||
where
|
||||
check key = pure $ keyVariety key == variety
|
||||
check key = pure $ fromKey keyVariety key == variety
|
||||
variety = parseKeyVariety (encodeBS name)
|
||||
|
||||
{- Adds a limit to skip files not using a secure hash. -}
|
||||
|
@ -302,7 +302,7 @@ addSecureHash :: Annex ()
|
|||
addSecureHash = addLimit $ Right limitSecureHash
|
||||
|
||||
limitSecureHash :: MatchFiles Annex
|
||||
limitSecureHash _ = checkKey $ pure . cryptographicallySecure . keyVariety
|
||||
limitSecureHash _ = checkKey $ pure . cryptographicallySecure . fromKey keyVariety
|
||||
|
||||
{- Adds a limit to skip files that are too large or too small -}
|
||||
addLargerThan :: String -> Annex ()
|
||||
|
@ -327,7 +327,7 @@ limitSize lb vs s = case readSize dataUnits s of
|
|||
go sz _ (MatchingInfo p) =
|
||||
getInfo (providedFileSize p)
|
||||
>>= \sz' -> return (Just sz' `vs` Just sz)
|
||||
checkkey sz key = return $ keySize key `vs` Just sz
|
||||
checkkey sz key = return $ fromKey keySize key `vs` Just sz
|
||||
|
||||
addMetaData :: String -> Annex ()
|
||||
addMetaData = addLimit . limitMetaData
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
{- git-annex transfer information files and lock files
|
||||
-
|
||||
- Copyright 2012 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2012-2019 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
@ -41,12 +41,14 @@ describeTransfer t info = unwords
|
|||
equivilantTransfer :: Transfer -> Transfer -> Bool
|
||||
equivilantTransfer t1 t2
|
||||
| transferDirection t1 == Download && transferDirection t2 == Download &&
|
||||
transferKey t1 == transferKey t2 = True
|
||||
transferKeyData t1 == transferKeyData t2 = True
|
||||
| otherwise = t1 == t2
|
||||
|
||||
percentComplete :: Transfer -> TransferInfo -> Maybe Percentage
|
||||
percentComplete (Transfer { transferKey = key }) info =
|
||||
percentage <$> keySize key <*> Just (fromMaybe 0 $ bytesComplete info)
|
||||
percentComplete t info =
|
||||
percentage
|
||||
<$> keySize (transferKeyData t)
|
||||
<*> Just (fromMaybe 0 $ bytesComplete info)
|
||||
|
||||
{- Generates a callback that can be called as transfer progresses to update
|
||||
- the transfer info file. Also returns the file it'll be updating,
|
||||
|
@ -72,7 +74,7 @@ mkProgressUpdater t info = do
|
|||
{- The minimum change in bytesComplete that is worth
|
||||
- updating a transfer info file for is 1% of the total
|
||||
- keySize, rounded down. -}
|
||||
mindelta = case keySize (transferKey t) of
|
||||
mindelta = case keySize (transferKeyData t) of
|
||||
Just sz -> sz `div` 100
|
||||
Nothing -> 100 * 1024 -- arbitrarily, 100 kb
|
||||
|
||||
|
@ -155,7 +157,7 @@ sizeOfDownloadsInProgress wanted = sum . map remaining
|
|||
<$> getTransfers' [Download] wanted
|
||||
where
|
||||
remaining (t, info) =
|
||||
case (keySize (transferKey t), bytesComplete info) of
|
||||
case (fromKey keySize (transferKey t), bytesComplete info) of
|
||||
(Just sz, Just done) -> sz - done
|
||||
(Just sz, Nothing) -> sz
|
||||
(Nothing, _) -> 0
|
||||
|
@ -191,14 +193,14 @@ recordFailedTransfer t info = do
|
|||
|
||||
{- The transfer information file to use for a given Transfer. -}
|
||||
transferFile :: Transfer -> Git.Repo -> FilePath
|
||||
transferFile (Transfer direction u key) r = transferDir direction r
|
||||
transferFile (Transfer direction u kd) r = transferDir direction r
|
||||
</> filter (/= '/') (fromUUID u)
|
||||
</> keyFile key
|
||||
</> keyFile (mkKey (const kd))
|
||||
|
||||
{- The transfer information file to use to record a failed Transfer -}
|
||||
failedTransferFile :: Transfer -> Git.Repo -> FilePath
|
||||
failedTransferFile (Transfer direction u key) r = failedTransferDir u direction r
|
||||
</> keyFile key
|
||||
failedTransferFile (Transfer direction u kd) r = failedTransferDir u direction r
|
||||
</> keyFile (mkKey (const kd))
|
||||
|
||||
{- The transfer lock file corresponding to a given transfer info file. -}
|
||||
transferLockFile :: FilePath -> FilePath
|
||||
|
@ -213,7 +215,7 @@ parseTransferFile file
|
|||
[direction, u, key] -> Transfer
|
||||
<$> parseDirection direction
|
||||
<*> pure (toUUID u)
|
||||
<*> fileKey key
|
||||
<*> fmap (fromKey id) (fileKey key)
|
||||
_ -> Nothing
|
||||
where
|
||||
bits = splitDirectories file
|
||||
|
|
|
@ -36,7 +36,7 @@ instance MeterSize FileSize where
|
|||
getMeterSize = pure . Just
|
||||
|
||||
instance MeterSize Key where
|
||||
getMeterSize = pure . keySize
|
||||
getMeterSize = pure . fromKey keySize
|
||||
|
||||
instance MeterSize InodeCache where
|
||||
getMeterSize = pure . Just . inodeCacheFileSize
|
||||
|
@ -51,7 +51,7 @@ instance MeterSize KeySource where
|
|||
data KeySizer = KeySizer Key (Annex (Maybe FilePath))
|
||||
|
||||
instance MeterSize KeySizer where
|
||||
getMeterSize (KeySizer k getsrcfile) = case keySize k of
|
||||
getMeterSize (KeySizer k getsrcfile) = case fromKey keySize k of
|
||||
Just sz -> return (Just sz)
|
||||
Nothing -> do
|
||||
srcfile <- getsrcfile
|
||||
|
|
|
@ -258,7 +258,7 @@ downloadTorrentContent k u dest filenum p = do
|
|||
, return False
|
||||
)
|
||||
where
|
||||
download torrent tmpdir = ariaProgress (keySize k) p
|
||||
download torrent tmpdir = ariaProgress (fromKey keySize k) p
|
||||
[ Param $ "--select-file=" ++ show filenum
|
||||
, File torrent
|
||||
, Param "-d"
|
||||
|
|
|
@ -716,7 +716,7 @@ checkKeyUrl :: Git.Repo -> CheckPresent
|
|||
checkKeyUrl r k = do
|
||||
showChecking r
|
||||
us <- getWebUrls k
|
||||
anyM (\u -> withUrlOptions $ checkBoth u (keySize k)) us
|
||||
anyM (\u -> withUrlOptions $ checkBoth u (fromKey keySize k)) us
|
||||
|
||||
getWebUrls :: Key -> Annex [URLString]
|
||||
getWebUrls key = filter supported <$> getUrls key
|
||||
|
|
4
Remote/External/Types.hs
vendored
4
Remote/External/Types.hs
vendored
|
@ -101,10 +101,10 @@ newtype SafeKey = SafeKey Key
|
|||
|
||||
mkSafeKey :: Key -> Either String SafeKey
|
||||
mkSafeKey k
|
||||
| any isSpace (decodeBS $ keyName k) = Left $ concat
|
||||
| any isSpace (decodeBS $ fromKey keyName k) = Left $ concat
|
||||
[ "Sorry, this file cannot be stored on an external special remote because its key's name contains a space. "
|
||||
, "To avoid this problem, you can run: git-annex migrate --backend="
|
||||
, decodeBS (formatKeyVariety (keyVariety k))
|
||||
, decodeBS (formatKeyVariety (fromKey keyVariety k))
|
||||
, " and pass it the name of the file"
|
||||
]
|
||||
| otherwise = Right (SafeKey k)
|
||||
|
|
|
@ -367,7 +367,7 @@ inAnnex' repo rmt (State connpool duc _ _) key
|
|||
checkhttp = do
|
||||
showChecking repo
|
||||
gc <- Annex.getGitConfig
|
||||
ifM (Url.withUrlOptions $ \uo -> anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls gc repo rmt key))
|
||||
ifM (Url.withUrlOptions $ \uo -> anyM (\u -> Url.checkBoth u (fromKey keySize key) uo) (keyUrls gc repo rmt key))
|
||||
( return True
|
||||
, giveup "not found"
|
||||
)
|
||||
|
@ -511,7 +511,7 @@ copyFromRemote'' repo forcersync r st@(State connpool _ _ _) key file dest meter
|
|||
Nothing -> return (False, UnVerified)
|
||||
Just (object, checksuccess) -> do
|
||||
copier <- mkCopier hardlink st params
|
||||
runTransfer (Transfer Download u key)
|
||||
runTransfer (Transfer Download u (fromKey id key))
|
||||
file stdRetry $ \p ->
|
||||
metered (Just (combineMeterUpdate p meterupdate)) key $ \_ p' ->
|
||||
copier object dest p' checksuccess
|
||||
|
@ -647,7 +647,7 @@ copyToRemote' repo r st@(State connpool duc _ _) key file meterupdate
|
|||
-- run copy from perspective of remote
|
||||
onLocalFast repo r $ ifM (Annex.Content.inAnnex key)
|
||||
( return True
|
||||
, runTransfer (Transfer Download u key) file stdRetry $ \p -> do
|
||||
, runTransfer (Transfer Download u (fromKey id key)) file stdRetry $ \p -> do
|
||||
copier <- mkCopier hardlink st params
|
||||
let verify = Annex.Content.RemoteVerify r
|
||||
let rsp = RetrievalAllKeysSecure
|
||||
|
|
|
@ -344,10 +344,10 @@ sendTransferRequest req endpoint = do
|
|||
LFS.ParseFailed err -> Left err
|
||||
|
||||
extractKeySha256 :: Key -> Maybe LFS.SHA256
|
||||
extractKeySha256 k = case keyVariety k of
|
||||
extractKeySha256 k = case fromKey keyVariety k of
|
||||
SHA2Key (HashSize 256) (HasExt hasext)
|
||||
| hasext -> eitherToMaybe $ E.decodeUtf8' (keyHash k)
|
||||
| otherwise -> eitherToMaybe $ E.decodeUtf8' (keyName k)
|
||||
| otherwise -> eitherToMaybe $ E.decodeUtf8' (fromKey keyName k)
|
||||
_ -> Nothing
|
||||
|
||||
-- The size of an encrypted key is the size of the input data, but we need
|
||||
|
@ -355,7 +355,7 @@ extractKeySha256 k = case keyVariety k of
|
|||
extractKeySize :: Key -> Maybe Integer
|
||||
extractKeySize k
|
||||
| isEncKey k = Nothing
|
||||
| otherwise = keySize k
|
||||
| otherwise = fromKey keySize k
|
||||
|
||||
mkUploadRequest :: RemoteStateHandle -> Key -> FilePath -> Annex (LFS.TransferRequest, LFS.SHA256, Integer)
|
||||
mkUploadRequest rs k content = case (extractKeySha256 k, extractKeySize k) of
|
||||
|
|
|
@ -117,7 +117,7 @@ prepareStore r = checkPrepare nonEmpty (byteStorer $ store r)
|
|||
|
||||
nonEmpty :: Key -> Annex Bool
|
||||
nonEmpty k
|
||||
| keySize k == Just 0 = do
|
||||
| fromKey keySize k == Just 0 = do
|
||||
warning "Cannot store empty files in Glacier."
|
||||
return False
|
||||
| otherwise = return True
|
||||
|
|
|
@ -68,8 +68,10 @@ newtype ChunkKeyStream = ChunkKeyStream [Key]
|
|||
chunkKeyStream :: Key -> ChunkSize -> ChunkKeyStream
|
||||
chunkKeyStream basek chunksize = ChunkKeyStream $ map mk [1..]
|
||||
where
|
||||
mk chunknum = sizedk { keyChunkNum = Just chunknum }
|
||||
sizedk = basek { keyChunkSize = Just (toInteger chunksize) }
|
||||
mk chunknum = alterKey sizedk $ \d -> d
|
||||
{ keyChunkNum = Just chunknum }
|
||||
sizedk = alterKey basek $ \d -> d
|
||||
{ keyChunkSize = Just (toInteger chunksize) }
|
||||
|
||||
nextChunkKeyStream :: ChunkKeyStream -> (Key, ChunkKeyStream)
|
||||
nextChunkKeyStream (ChunkKeyStream (k:l)) = (k, ChunkKeyStream l)
|
||||
|
@ -80,7 +82,7 @@ takeChunkKeyStream n (ChunkKeyStream l) = genericTake n l
|
|||
|
||||
-- Number of chunks already consumed from the stream.
|
||||
numChunks :: ChunkKeyStream -> Integer
|
||||
numChunks = pred . fromJust . keyChunkNum . fst . nextChunkKeyStream
|
||||
numChunks = pred . fromJust . fromKey keyChunkNum . fst . nextChunkKeyStream
|
||||
|
||||
{- Splits up the key's content into chunks, passing each chunk to
|
||||
- the storer action, along with a corresponding chunk key and a
|
||||
|
@ -173,7 +175,7 @@ seekResume
|
|||
-> Annex (ChunkKeyStream, BytesProcessed)
|
||||
seekResume h encryptor chunkkeys checker = do
|
||||
sz <- liftIO (hFileSize h)
|
||||
if sz <= fromMaybe 0 (keyChunkSize $ fst $ nextChunkKeyStream chunkkeys)
|
||||
if sz <= fromMaybe 0 (fromKey keyChunkSize $ fst $ nextChunkKeyStream chunkkeys)
|
||||
then return (chunkkeys, zeroBytesProcessed)
|
||||
else check 0 chunkkeys sz
|
||||
where
|
||||
|
@ -193,7 +195,7 @@ seekResume h encryptor chunkkeys checker = do
|
|||
return (cks, toBytesProcessed pos)
|
||||
where
|
||||
(k, cks') = nextChunkKeyStream cks
|
||||
pos' = pos + fromMaybe 0 (keyChunkSize k)
|
||||
pos' = pos + fromMaybe 0 (fromKey keyChunkSize k)
|
||||
|
||||
{- Removes all chunks of a key from a remote, by calling a remover
|
||||
- action on each.
|
||||
|
@ -208,7 +210,7 @@ removeChunks remover u chunkconfig encryptor k = do
|
|||
ls <- chunkKeys u chunkconfig k
|
||||
ok <- allM (remover . encryptor) (concat ls)
|
||||
when ok $ do
|
||||
let chunksizes = catMaybes $ map (keyChunkSize <=< headMaybe) ls
|
||||
let chunksizes = catMaybes $ map (fromKey keyChunkSize <=< headMaybe) ls
|
||||
forM_ chunksizes $ chunksRemoved u k . FixedSizeChunks . fromIntegral
|
||||
return ok
|
||||
|
||||
|
@ -272,7 +274,7 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink
|
|||
bracketIO (maybe opennew openresume offset) hClose $ \h -> do
|
||||
void $ tosink (Just h) p content
|
||||
let sz = toBytesProcessed $
|
||||
fromMaybe 0 $ keyChunkSize k
|
||||
fromMaybe 0 $ fromKey keyChunkSize k
|
||||
getrest p h sz sz ks
|
||||
`catchNonAsync` unable
|
||||
case v of
|
||||
|
@ -333,7 +335,7 @@ setupResume :: [[Key]] -> Integer -> [[Key]]
|
|||
setupResume ls currsize = map dropunneeded ls
|
||||
where
|
||||
dropunneeded [] = []
|
||||
dropunneeded l@(k:_) = case keyChunkSize k of
|
||||
dropunneeded l@(k:_) = case fromKey keyChunkSize k of
|
||||
Just chunksize | chunksize > 0 ->
|
||||
genericDrop (currsize `div` chunksize) l
|
||||
_ -> l
|
||||
|
|
|
@ -324,7 +324,7 @@ adjustExportImport r rs = case M.lookup "exporttree" (config r) of
|
|||
liftIO $ Export.getExportTree db k
|
||||
|
||||
retrieveKeyFileFromExport dbv k _af dest p = unVerified $
|
||||
if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k))
|
||||
if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (fromKey keyVariety k))
|
||||
then do
|
||||
locs <- getexportlocs dbv k
|
||||
case locs of
|
||||
|
@ -336,5 +336,5 @@ adjustExportImport r rs = case M.lookup "exporttree" (config r) of
|
|||
return False
|
||||
(l:_) -> retrieveExport (exportActions r) k l dest p
|
||||
else do
|
||||
warning $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (keyVariety k)) ++ " backend"
|
||||
warning $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend"
|
||||
return False
|
||||
|
|
|
@ -347,7 +347,7 @@ checkKey hv r rs c info k = withS3Handle hv $ \case
|
|||
Right us -> do
|
||||
showChecking r
|
||||
let check u = withUrlOptions $
|
||||
Url.checkBoth u (keySize k)
|
||||
Url.checkBoth u (fromKey keySize k)
|
||||
anyM check us
|
||||
|
||||
checkKeyHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> Annex Bool
|
||||
|
@ -417,7 +417,7 @@ checkPresentExportS3 hv r info k loc = withS3Handle hv $ \case
|
|||
Just h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))
|
||||
Nothing -> case getPublicUrlMaker info of
|
||||
Just geturl -> withUrlOptions $
|
||||
Url.checkBoth (geturl $ bucketExportLocation info loc) (keySize k)
|
||||
Url.checkBoth (geturl $ bucketExportLocation info loc) (fromKey keySize k)
|
||||
Nothing -> do
|
||||
warning $ needS3Creds (uuid r)
|
||||
giveup "No S3 credentials configured"
|
||||
|
|
|
@ -117,7 +117,7 @@ checkKey' key us = firsthit us (Right False) $ \u -> do
|
|||
case downloader of
|
||||
YoutubeDownloader -> youtubeDlCheck u'
|
||||
_ -> catchMsgIO $
|
||||
Url.withUrlOptions $ Url.checkBoth u' (keySize key)
|
||||
Url.withUrlOptions $ Url.checkBoth u' (fromKey keySize key)
|
||||
where
|
||||
firsthit [] miss _ = return miss
|
||||
firsthit (u:rest) _ a = do
|
||||
|
|
|
@ -21,7 +21,9 @@ type GitAnnexVersion = String
|
|||
|
||||
data GitAnnexDistribution = GitAnnexDistribution
|
||||
{ distributionUrl :: String
|
||||
, distributionKey :: Key
|
||||
, distributionKey :: KeyData
|
||||
-- ^ This used to be a Key, but now KeyData serializes
|
||||
-- to Key { ... }, so back-compat for Read and Show is preserved.
|
||||
, distributionVersion :: GitAnnexVersion
|
||||
, distributionReleasedate :: UTCTime
|
||||
, distributionUrgentUpgrade :: Maybe GitAnnexVersion
|
||||
|
@ -46,7 +48,7 @@ parseInfoFile s = case lines s of
|
|||
formatGitAnnexDistribution :: GitAnnexDistribution -> String
|
||||
formatGitAnnexDistribution d = unlines
|
||||
[ distributionUrl d
|
||||
, serializeKey (distributionKey d)
|
||||
, serializeKey $ mkKey $ const $ distributionKey d
|
||||
, distributionVersion d
|
||||
, show (distributionReleasedate d)
|
||||
, maybe "" show (distributionUrgentUpgrade d)
|
||||
|
@ -56,7 +58,7 @@ parseGitAnnexDistribution :: String -> Maybe GitAnnexDistribution
|
|||
parseGitAnnexDistribution s = case lines s of
|
||||
(u:k:v:d:uu:_) -> GitAnnexDistribution
|
||||
<$> pure u
|
||||
<*> deserializeKey k
|
||||
<*> fmap (fromKey id) (deserializeKey k)
|
||||
<*> pure v
|
||||
<*> readish d
|
||||
<*> pure (readish uu)
|
||||
|
|
173
Types/Key.hs
173
Types/Key.hs
|
@ -7,19 +7,47 @@
|
|||
|
||||
{-# LANGUAGE OverloadedStrings, DeriveGeneric #-}
|
||||
|
||||
module Types.Key where
|
||||
module Types.Key (
|
||||
KeyData(..),
|
||||
Key,
|
||||
fromKey,
|
||||
mkKey,
|
||||
alterKey,
|
||||
isKeyPrefix,
|
||||
splitKeyNameExtension,
|
||||
keyParser,
|
||||
keySerialization,
|
||||
AssociatedFile(..),
|
||||
KeyVariety(..),
|
||||
HasExt(..),
|
||||
HashSize(..),
|
||||
hasExt,
|
||||
sameExceptExt,
|
||||
cryptographicallySecure,
|
||||
isVerifiable,
|
||||
formatKeyVariety,
|
||||
parseKeyVariety,
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.ByteString.Builder
|
||||
import Data.ByteString.Builder.Extra
|
||||
import qualified Data.Attoparsec.ByteString as A
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A8
|
||||
import Data.List
|
||||
import System.Posix.Types
|
||||
import Foreign.C.Types
|
||||
import Data.Monoid
|
||||
import Control.Applicative
|
||||
import GHC.Generics
|
||||
import Control.DeepSeq
|
||||
import Prelude
|
||||
|
||||
{- A Key has a unique name, which is derived from a particular backend,
|
||||
- and may contain other optional metadata. -}
|
||||
data Key = Key
|
||||
data KeyData = Key
|
||||
{ keyName :: S.ByteString
|
||||
, keyVariety :: KeyVariety
|
||||
, keySize :: Maybe Integer
|
||||
|
@ -28,8 +56,149 @@ data Key = Key
|
|||
, keyChunkNum :: Maybe Integer
|
||||
} deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
instance NFData KeyData
|
||||
|
||||
{- Caching the seralization of a key is an optimization.
|
||||
-
|
||||
- This constructor is not exported, and all smart constructors maintain
|
||||
- the serialization.
|
||||
-}
|
||||
data Key = MkKey
|
||||
{ keyData :: KeyData
|
||||
, keySerialization :: S.ByteString
|
||||
} deriving (Show, Generic)
|
||||
|
||||
instance Eq Key where
|
||||
-- comparing the serialization would be unncessary work
|
||||
a == b = keyData a == keyData b
|
||||
|
||||
instance Ord Key where
|
||||
compare a b = compare (keyData a) (keyData b)
|
||||
|
||||
instance NFData Key
|
||||
|
||||
{- Access a field of data from the KeyData. -}
|
||||
{-# INLINE fromKey #-}
|
||||
fromKey :: (KeyData -> a) -> Key -> a
|
||||
fromKey f = f . keyData
|
||||
|
||||
{- Smart constructor for a Key. The provided KeyData has all values empty. -}
|
||||
mkKey :: (KeyData -> KeyData) -> Key
|
||||
mkKey f =
|
||||
let d = f stub
|
||||
in MkKey d (mkKeySerialization d)
|
||||
where
|
||||
stub = Key
|
||||
{ keyName = mempty
|
||||
, keyVariety = OtherKey mempty
|
||||
, keySize = Nothing
|
||||
, keyMtime = Nothing
|
||||
, keyChunkSize = Nothing
|
||||
, keyChunkNum = Nothing
|
||||
}
|
||||
|
||||
{- Alter a Key's data. -}
|
||||
alterKey :: Key -> (KeyData -> KeyData) -> Key
|
||||
alterKey k f =
|
||||
let d = f (keyData k)
|
||||
in MkKey d (mkKeySerialization d)
|
||||
|
||||
-- Checks if a string looks like at least the start of a key.
|
||||
isKeyPrefix :: String -> Bool
|
||||
isKeyPrefix s = [fieldSep, fieldSep] `isInfixOf` s
|
||||
|
||||
fieldSep :: Char
|
||||
fieldSep = '-'
|
||||
|
||||
mkKeySerialization :: KeyData -> S.ByteString
|
||||
mkKeySerialization = L.toStrict
|
||||
. toLazyByteStringWith (safeStrategy 128 smallChunkSize) L.empty
|
||||
. buildKeyData
|
||||
|
||||
{- Builds a ByteString from a KeyData.
|
||||
-
|
||||
- The name field is always shown last, separated by doubled fieldSeps,
|
||||
- and is the only field allowed to contain the fieldSep.
|
||||
-}
|
||||
buildKeyData :: KeyData -> Builder
|
||||
buildKeyData k = byteString (formatKeyVariety (keyVariety k))
|
||||
<> 's' ?: (integerDec <$> keySize k)
|
||||
<> 'm' ?: (integerDec . (\(CTime t) -> fromIntegral t) <$> keyMtime k)
|
||||
<> 'S' ?: (integerDec <$> keyChunkSize k)
|
||||
<> 'C' ?: (integerDec <$> keyChunkNum k)
|
||||
<> sepbefore (sepbefore (byteString (keyName k)))
|
||||
where
|
||||
sepbefore s = char7 fieldSep <> s
|
||||
c ?: (Just b) = sepbefore (char7 c <> b)
|
||||
_ ?: Nothing = mempty
|
||||
|
||||
{- This is a strict parser for security reasons; a key
|
||||
- can contain only 4 fields, which all consist only of numbers.
|
||||
- Any key containing other fields, or non-numeric data will fail
|
||||
- to parse.
|
||||
-
|
||||
- If a key contained non-numeric fields, they could be used to
|
||||
- embed data used in a SHA1 collision attack, which would be a
|
||||
- problem since the keys are committed to git.
|
||||
-}
|
||||
keyParser :: A.Parser Key
|
||||
keyParser = do
|
||||
-- key variety cannot be empty
|
||||
v <- (parseKeyVariety <$> A8.takeWhile1 (/= fieldSep))
|
||||
s <- parsesize
|
||||
m <- parsemtime
|
||||
cs <- parsechunksize
|
||||
cn <- parsechunknum
|
||||
_ <- A8.char fieldSep
|
||||
_ <- A8.char fieldSep
|
||||
n <- A.takeByteString
|
||||
if validKeyName v n
|
||||
then
|
||||
let d = Key
|
||||
{ keyName = n
|
||||
, keyVariety = v
|
||||
, keySize = s
|
||||
, keyMtime = m
|
||||
, keyChunkSize = cs
|
||||
, keyChunkNum = cn
|
||||
}
|
||||
in pure $ MkKey d (mkKeySerialization d)
|
||||
else fail "invalid keyName"
|
||||
where
|
||||
parseopt p = (Just <$> (A8.char fieldSep *> p)) <|> pure Nothing
|
||||
parsesize = parseopt $ A8.char 's' *> A8.decimal
|
||||
parsemtime = parseopt $ CTime <$> (A8.char 'm' *> A8.decimal)
|
||||
parsechunksize = parseopt $ A8.char 'S' *> A8.decimal
|
||||
parsechunknum = parseopt $ A8.char 'C' *> A8.decimal
|
||||
|
||||
{- Limits the length of the extension in the keyName to mitigate against
|
||||
- SHA1 collision attacks.
|
||||
-
|
||||
- In such an attack, the extension of the key could be made to contain
|
||||
- the collision generation data, with the result that a signed git commit
|
||||
- including such keys would not be secure.
|
||||
-
|
||||
- The maximum extension length ever generated for such a key was 8
|
||||
- characters, but they may be unicode which could use up to 4 bytes each,
|
||||
- so 32 bytes. 64 bytes is used here to give a little future wiggle-room.
|
||||
- The SHA1 common-prefix attack needs 128 bytes of data.
|
||||
-}
|
||||
validKeyName :: KeyVariety -> S.ByteString -> Bool
|
||||
validKeyName kv name
|
||||
| hasExt kv =
|
||||
let ext = snd $ splitKeyNameExtension' name
|
||||
in S.length ext <= 64
|
||||
| otherwise = True
|
||||
|
||||
{- This splits any extension out of the keyName, returning the
|
||||
- keyName minus extension, and the extension (including leading dot).
|
||||
-}
|
||||
splitKeyNameExtension :: Key -> (S.ByteString, S.ByteString)
|
||||
splitKeyNameExtension = splitKeyNameExtension' . keyName . keyData
|
||||
|
||||
splitKeyNameExtension' :: S.ByteString -> (S.ByteString, S.ByteString)
|
||||
splitKeyNameExtension' keyname = S8.span (/= '.') keyname
|
||||
|
||||
{- A filename may be associated with a Key. -}
|
||||
newtype AssociatedFile = AssociatedFile (Maybe FilePath)
|
||||
deriving (Show, Eq, Ord)
|
||||
|
|
|
@ -11,6 +11,7 @@ module Types.Transfer where
|
|||
|
||||
import Types
|
||||
import Types.Remote (Verification(..))
|
||||
import Types.Key
|
||||
import Utility.PID
|
||||
import Utility.QuickCheck
|
||||
import Utility.Url
|
||||
|
@ -24,9 +25,12 @@ import Prelude
|
|||
data Transfer = Transfer
|
||||
{ transferDirection :: Direction
|
||||
, transferUUID :: UUID
|
||||
, transferKey :: Key
|
||||
, transferKeyData :: KeyData
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
deriving (Eq, Ord, Show, Read)
|
||||
|
||||
transferKey :: Transfer -> Key
|
||||
transferKey = mkKey . const . transferKeyData
|
||||
|
||||
{- Information about a Transfer, stored in the transfer information file.
|
||||
-
|
||||
|
|
|
@ -134,7 +134,7 @@ oldlog2key l
|
|||
where
|
||||
len = length l - 4
|
||||
k = readKey1 (take len l)
|
||||
sane = (not . S.null $ keyName k) && (not . S.null $ formatKeyVariety $ keyVariety k)
|
||||
sane = (not . S.null $ fromKey keyName k) && (not . S.null $ formatKeyVariety $ fromKey keyVariety k)
|
||||
|
||||
-- WORM backend keys: "WORM:mtime:size:filename"
|
||||
-- all the rest: "backend:key"
|
||||
|
@ -145,7 +145,7 @@ oldlog2key l
|
|||
readKey1 :: String -> Key
|
||||
readKey1 v
|
||||
| mixup = fromJust $ deserializeKey $ intercalate ":" $ Prelude.tail bits
|
||||
| otherwise = stubKey
|
||||
| otherwise = mkKey $ \d -> d
|
||||
{ keyName = encodeBS n
|
||||
, keyVariety = parseKeyVariety (encodeBS b)
|
||||
, keySize = s
|
||||
|
@ -165,12 +165,16 @@ readKey1 v
|
|||
mixup = wormy && isUpper (Prelude.head $ bits !! 1)
|
||||
|
||||
showKey1 :: Key -> String
|
||||
showKey1 Key { keyName = n , keyVariety = v, keySize = s, keyMtime = t } =
|
||||
intercalate ":" $ filter (not . null) [b, showifhere t, showifhere s, decodeBS n]
|
||||
showKey1 k = intercalate ":" $ filter (not . null)
|
||||
[b, showifhere t, showifhere s, decodeBS n]
|
||||
where
|
||||
showifhere Nothing = ""
|
||||
showifhere (Just x) = show x
|
||||
b = decodeBS $ formatKeyVariety v
|
||||
n = fromKey keyName k
|
||||
v = fromKey keyVariety k
|
||||
s = fromKey keySize k
|
||||
t = fromKey keyMtime k
|
||||
|
||||
keyFile1 :: Key -> FilePath
|
||||
keyFile1 key = replace "/" "%" $ replace "%" "&s" $ replace "&" "&a" $ showKey1 key
|
||||
|
@ -194,7 +198,7 @@ lookupFile1 file = do
|
|||
Right l -> makekey l
|
||||
where
|
||||
getsymlink = takeFileName <$> readSymbolicLink file
|
||||
makekey l = case maybeLookupBackendVariety (keyVariety k) of
|
||||
makekey l = case maybeLookupBackendVariety (fromKey keyVariety k) of
|
||||
Nothing -> do
|
||||
unless (null kname || null bname ||
|
||||
not (isLinkToAnnex (toRawFilePath l))) $
|
||||
|
@ -203,8 +207,8 @@ lookupFile1 file = do
|
|||
Just backend -> return $ Just (k, backend)
|
||||
where
|
||||
k = fileKey1 l
|
||||
bname = decodeBS (formatKeyVariety (keyVariety k))
|
||||
kname = decodeBS (keyName k)
|
||||
bname = decodeBS (formatKeyVariety (fromKey keyVariety k))
|
||||
kname = decodeBS (fromKey keyName k)
|
||||
skip = "skipping " ++ file ++
|
||||
" (unknown backend " ++ bname ++ ")"
|
||||
|
||||
|
|
|
@ -24,6 +24,7 @@ module Utility.Hash (
|
|||
blake2b_512,
|
||||
blake2bp_512,
|
||||
md5,
|
||||
md5s,
|
||||
prop_hashes_stable,
|
||||
Mac(..),
|
||||
calcMac,
|
||||
|
@ -106,6 +107,9 @@ blake2bp_512 = hashlazy
|
|||
md5 :: L.ByteString -> Digest MD5
|
||||
md5 = hashlazy
|
||||
|
||||
md5s :: S.ByteString -> Digest MD5
|
||||
md5s = hash
|
||||
|
||||
{- Check that all the hashes continue to hash the same. -}
|
||||
prop_hashes_stable :: Bool
|
||||
prop_hashes_stable = all (\(hasher, result) -> hasher foo == result)
|
||||
|
|
|
@ -15,7 +15,7 @@
|
|||
<small>
|
||||
<a href="@{EditRepositoryR $ RepoUUID $ transferUUID transfer}">
|
||||
#{maybe "unknown" Remote.name $ transferRemote info}
|
||||
$with size <- maybe "unknown" (roughSize dataUnits True) $ keySize $ transferKey transfer
|
||||
$with size <- maybe "unknown" (roughSize dataUnits True) $ keySize $ transferKeyData transfer
|
||||
$if isJust $ startedTime info
|
||||
$if isrunning info
|
||||
<span .pull-right><b>#{percent} of #{size}</b>
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue