e7652b0997
This needs the content to be present in order to hash it. But it's not possible for a module used by Backend.URL to call inAnnex because that would entail a dependency loop. So instead, rely on the fact that Command.Migrate calls inAnnex before performing a migration. But, Command.ExamineKey calls fastMigrate and the key may or may not exist, and it's not wanting to actually perform a migration in any case. To handle that, had to add an additional value to fastMigrate to indicate whether the content is inAnnex. Factored generateEquivilantKey out of Remote.Web. Note that migrateFromURLToVURL hardcodes use of the SHA256E backend. It would have been difficult not to, given all the dependency loop issues. But --backend and annex.backend are used to tell git-annex migrate to use VURL in any case, so there's no config knob that the user could expect to configure that. Sponsored-by: Brock Spratlen on Patreon
70 lines
2.1 KiB
Haskell
70 lines
2.1 KiB
Haskell
{- git-annex "WORM" backend -- Write Once, Read Many
|
|
-
|
|
- Copyright 2010 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Backend.WORM (backends) where
|
|
|
|
import Annex.Common
|
|
import Types.Key
|
|
import Types.Backend
|
|
import Types.KeySource
|
|
import Backend.Utilities
|
|
import Git.FilePath
|
|
import Utility.Metered
|
|
import qualified Utility.RawFilePath as R
|
|
|
|
import qualified Data.ByteString.Char8 as S8
|
|
import qualified Data.ByteString.Short as S (toShort, fromShort)
|
|
import System.PosixCompat.Files (modificationTime)
|
|
|
|
backends :: [Backend]
|
|
backends = [backend]
|
|
|
|
backend :: Backend
|
|
backend = Backend
|
|
{ backendVariety = WORMKey
|
|
, genKey = Just keyValue
|
|
, verifyKeyContent = Nothing
|
|
, verifyKeyContentIncrementally = Nothing
|
|
, canUpgradeKey = Just needsUpgrade
|
|
, fastMigrate = Just removeProblemChars
|
|
, isStableKey = const True
|
|
, isCryptographicallySecure = False
|
|
, isCryptographicallySecureKey = const (pure False)
|
|
}
|
|
|
|
{- The key includes the file size, modification time, and the
|
|
- original filename relative to the top of the git repository.
|
|
-}
|
|
keyValue :: KeySource -> MeterUpdate -> Annex Key
|
|
keyValue source _ = do
|
|
let f = contentLocation source
|
|
stat <- liftIO $ R.getFileStatus f
|
|
sz <- liftIO $ getFileSize' f stat
|
|
relf <- fromRawFilePath . getTopFilePath
|
|
<$> inRepo (toTopFilePath $ keyFilename source)
|
|
return $ mkKey $ \k -> k
|
|
{ keyName = genKeyName relf
|
|
, keyVariety = WORMKey
|
|
, keySize = Just sz
|
|
, keyMtime = Just $ modificationTime stat
|
|
}
|
|
|
|
{- Old WORM keys could contain spaces and carriage returns,
|
|
- and can be upgraded to remove them. -}
|
|
needsUpgrade :: Key -> Bool
|
|
needsUpgrade key =
|
|
any (`S8.elem` S.fromShort (fromKey keyName key)) [' ', '\r']
|
|
|
|
removeProblemChars :: Key -> Backend -> AssociatedFile -> Bool -> Annex (Maybe Key)
|
|
removeProblemChars oldkey newbackend _ _
|
|
| migratable = return $ Just $ alterKey oldkey $ \d -> d
|
|
{ keyName = S.toShort $ encodeBS $ reSanitizeKeyName $ decodeBS $ S.fromShort $ keyName d }
|
|
| otherwise = return Nothing
|
|
where
|
|
migratable = oldvariety == newvariety
|
|
oldvariety = fromKey keyVariety oldkey
|
|
newvariety = backendVariety newbackend
|