Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: aa8b15d966
Fetching contributors…

Cannot retrieve contributors at this time

144 lines (127 sloc) 4.159 kb
{- git-annex SHA backends
-
- Copyright 2011,2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Backend.SHA (backends) where
import Common.Annex
import qualified Annex
import Types.Backend
import Types.Key
import Types.KeySource
import qualified Build.SysConfig as SysConfig
import Data.Digest.Pure.SHA
import qualified Data.ByteString.Lazy as L
import System.Process
type SHASize = Int
{- Order is slightly significant; want SHA256 first, and more general
- sizes earlier. -}
sizes :: [Int]
sizes = [256, 1, 512, 224, 384]
{- The SHA256E backend is the default. -}
backends :: [Backend]
backends = catMaybes $ map genBackendE sizes ++ map genBackend sizes
genBackend :: SHASize -> Maybe Backend
genBackend size = Just $ Backend
{ name = shaName size
, getKey = keyValue size
, fsckKey = Just $ checkKeyChecksum size
}
genBackendE :: SHASize -> Maybe Backend
genBackendE size = do
b <- genBackend size
return $ b
{ name = shaNameE size
, getKey = keyValueE size
}
shaName :: SHASize -> String
shaName size = "SHA" ++ show size
shaNameE :: SHASize -> String
shaNameE size = shaName size ++ "E"
shaN :: SHASize -> FilePath -> Integer -> Annex String
shaN shasize file filesize = do
showAction "checksum"
case shaCommand shasize filesize of
Left sha -> liftIO $ sha <$> L.readFile file
Right command -> liftIO $ parse command . lines <$>
readsha command (toCommand [File file])
where
parse command [] = bad command
parse command (l:_)
| null sha = bad command
| otherwise = sha
where
sha = fst $ separate (== ' ') l
bad command = error $ command ++ " parse error"
{- sha commands output the filename, so need to set fileEncoding -}
readsha command args =
withHandle StdoutHandle createProcessSuccess p $ \h -> do
fileEncoding h
output <- hGetContentsStrict h
hClose h
return output
where
p = (proc command args)
{ std_out = CreatePipe }
shaCommand :: SHASize -> Integer -> Either (L.ByteString -> String) String
shaCommand shasize filesize
| shasize == 1 = use SysConfig.sha1 sha1
| shasize == 256 = use SysConfig.sha256 sha256
| shasize == 224 = use SysConfig.sha224 sha224
| shasize == 384 = use SysConfig.sha384 sha384
| shasize == 512 = use SysConfig.sha512 sha512
| otherwise = error $ "bad sha size " ++ show shasize
where
use Nothing sha = Left $ showDigest . sha
use (Just c) sha
-- use builtin, but slower sha for small files
-- benchmarking indicates it's faster up to
-- and slightly beyond 50 kb files
| filesize < 51200 = use Nothing sha
| otherwise = Right c
{- A key is a checksum of its contents. -}
keyValue :: SHASize -> KeySource -> Annex (Maybe Key)
keyValue shasize source = do
let file = contentLocation source
stat <- liftIO $ getFileStatus file
let filesize = fromIntegral $ fileSize stat
s <- shaN shasize file filesize
return $ Just $ stubKey
{ keyName = s
, keyBackendName = shaName shasize
, keySize = Just filesize
}
{- Extension preserving keys. -}
keyValueE :: SHASize -> KeySource -> Annex (Maybe Key)
keyValueE size source = keyValue size source >>= maybe (return Nothing) addE
where
addE k = return $ Just $ k
{ keyName = keyName k ++ selectExtension (keyFilename source)
, keyBackendName = shaNameE size
}
selectExtension :: FilePath -> String
selectExtension f
| null es = ""
| otherwise = join "." ("":es)
where
es = filter (not . null) $ reverse $
take 2 $ takeWhile shortenough $
reverse $ split "." $ takeExtensions f
shortenough e
| '\n' `elem` e = False -- newline in extension?!
| otherwise = length e <= 4 -- long enough for "jpeg"
{- A key's checksum is checked during fsck. -}
checkKeyChecksum :: SHASize -> Key -> FilePath -> Annex Bool
checkKeyChecksum size key file = do
fast <- Annex.getState Annex.fast
mstat <- liftIO $ catchMaybeIO $ getFileStatus file
case (mstat, fast) of
(Just stat, False) -> do
let filesize = fromIntegral $ fileSize stat
check <$> shaN size file filesize
_ -> return True
where
check s
| s == dropExtensions (keyName key) = True
| otherwise = False
Jump to Line
Something went wrong with that request. Please try again.