9f1577f746
The only remaining vestiage of backends is different types of keys. These are still called "backends", mostly to avoid needing to change user interface and configuration. But everything to do with storing keys in different backends was gone; instead different types of remotes are used. In the refactoring, lots of code was moved out of odd corners like Backend.File, to closer to where it's used, like Command.Drop and Command.Fsck. Quite a lot of dead code was removed. Several data structures became simpler, which may result in better runtime efficiency. There should be no user-visible changes.
126 lines
3.1 KiB
Haskell
126 lines
3.1 KiB
Haskell
{- git-annex SHA backend
|
|
-
|
|
- Copyright 2011 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Backend.SHA (backends) where
|
|
|
|
import Control.Monad.State
|
|
import Data.String.Utils
|
|
import System.Cmd.Utils
|
|
import System.IO
|
|
import System.Directory
|
|
import Data.Maybe
|
|
import System.Posix.Files
|
|
import System.FilePath
|
|
|
|
import Messages
|
|
import qualified Annex
|
|
import Locations
|
|
import Content
|
|
import Types
|
|
import Types.Backend
|
|
import Types.Key
|
|
import Utility
|
|
import qualified SysConfig
|
|
|
|
type SHASize = Int
|
|
|
|
sizes :: [Int]
|
|
sizes = [1, 256, 512, 224, 384]
|
|
|
|
backends :: [Backend Annex]
|
|
-- order is slightly significant; want sha1 first ,and more general
|
|
-- sizes earlier
|
|
backends = catMaybes $ map genBackend sizes ++ map genBackendE sizes
|
|
|
|
genBackend :: SHASize -> Maybe (Backend Annex)
|
|
genBackend size
|
|
| shaCommand size == Nothing = Nothing
|
|
| otherwise = Just b
|
|
where
|
|
b = Types.Backend.Backend
|
|
{ name = shaName size
|
|
, getKey = keyValue size
|
|
, fsckKey = checkKeyChecksum size
|
|
}
|
|
|
|
genBackendE :: SHASize -> Maybe (Backend Annex)
|
|
genBackendE size =
|
|
case genBackend size of
|
|
Nothing -> Nothing
|
|
Just b -> Just $ b
|
|
{ name = shaNameE size
|
|
, getKey = keyValueE size
|
|
}
|
|
|
|
shaCommand :: SHASize -> Maybe String
|
|
shaCommand 1 = SysConfig.sha1
|
|
shaCommand 256 = SysConfig.sha256
|
|
shaCommand 224 = SysConfig.sha224
|
|
shaCommand 384 = SysConfig.sha384
|
|
shaCommand 512 = SysConfig.sha512
|
|
shaCommand _ = Nothing
|
|
|
|
shaName :: SHASize -> String
|
|
shaName size = "SHA" ++ show size
|
|
|
|
shaNameE :: SHASize -> String
|
|
shaNameE size = shaName size ++ "E"
|
|
|
|
shaN :: SHASize -> FilePath -> Annex String
|
|
shaN size file = do
|
|
showNote "checksum..."
|
|
liftIO $ pOpen ReadFromPipe command (toCommand [File file]) $ \h -> do
|
|
line <- hGetLine h
|
|
let bits = split " " line
|
|
if null bits
|
|
then error $ command ++ " parse error"
|
|
else return $ head bits
|
|
where
|
|
command = fromJust $ shaCommand size
|
|
|
|
{- A key is a checksum of its contents. -}
|
|
keyValue :: SHASize -> FilePath -> Annex (Maybe Key)
|
|
keyValue size file = do
|
|
s <- shaN size file
|
|
stat <- liftIO $ getFileStatus file
|
|
return $ Just $ stubKey
|
|
{ keyName = s
|
|
, keyBackendName = shaName size
|
|
, keySize = Just $ fromIntegral $ fileSize stat
|
|
}
|
|
|
|
{- Extension preserving keys. -}
|
|
keyValueE :: SHASize -> FilePath -> Annex (Maybe Key)
|
|
keyValueE size file = keyValue size file >>= maybe (return Nothing) addE
|
|
where
|
|
addE k = return $ Just $ k
|
|
{ keyName = keyName k ++ extension
|
|
, keyBackendName = shaNameE size
|
|
}
|
|
naiveextension = takeExtension file
|
|
extension =
|
|
if length naiveextension > 6
|
|
then "" -- probably not really an extension
|
|
else naiveextension
|
|
|
|
-- A key's checksum is checked during fsck.
|
|
checkKeyChecksum :: SHASize -> Key -> Annex Bool
|
|
checkKeyChecksum size key = do
|
|
g <- Annex.gitRepo
|
|
fast <- Annex.getState Annex.fast
|
|
let file = gitAnnexLocation g key
|
|
present <- liftIO $ doesFileExist file
|
|
if (not present || fast)
|
|
then return True
|
|
else do
|
|
s <- shaN size file
|
|
if s == dropExtension (keyName key)
|
|
then return True
|
|
else do
|
|
dest <- moveBad key
|
|
warning $ "Bad file content; moved to " ++ dest
|
|
return False
|