E variant of external backend keys

3 files changed, 69 insertions, 40 deletions

diff --git a/Backend/External.hs b/Backend/External.hs
index 995445327c..6b2d062ecf 100644
--- a/Backend/External.hs
+++ b/Backend/External.hs
@@ -11,6 +11,7 @@ module Backend.External (makeBackend) where
 
 import Annex.Common
 import Annex.ExternalAddonProcess
+import Backend.Utilities
 import Types.Key
 import Types.Backend
 import Types.KeySource
@@ -19,6 +20,7 @@ import qualified Utility.SimpleProtocol as Proto
 
 import qualified Data.ByteString as S
 import qualified Data.Map.Strict as M
+import Data.Char
 import Control.Concurrent
 import System.IO.Unsafe (unsafePerformIO)
 import System.Log.Logger (debugM)
@@ -92,8 +94,7 @@ genKeyExternal ebname hasext ks meterupdate =
 	req = GENKEY (fromRawFilePath (contentLocation ks))
 	notavail = giveup $ "Cannot generate a key, since " ++ externalBackendProgram ebname ++ " is not available."
 	
-	-- TODO hasExt handling
-	go (GENKEY_SUCCESS (ProtoKey k)) = result k
+	go (GENKEY_SUCCESS pk) = Just $ Result <$> fromProtoKey pk hasext ks
 	go (GENKEY_FAILURE msg) = Just $ giveup $
 		"External backend program failed to generate a key: " ++ msg
 	go (PROGRESS bytesprocessed) = Just $ do
@@ -106,8 +107,7 @@ verifyKeyContentExternal ebname hasext meterupdate k f =
 	withExternalState ebname hasext $ \st ->
 		handleRequest st req notavail go
   where
-  	-- TODO hasExt handling
-	req = VERIFYKEYCONTENT (ProtoKey k) f
+	req = VERIFYKEYCONTENT (toProtoKey k) f
 
 	-- This should not be able to happen, because CANVERIFY is checked
 	-- before this function is enable, and so the external program 
@@ -273,6 +273,26 @@ withExternalState bname hasext a = do
 newtype ProtoKey = ProtoKey Key
 	deriving (Show)
 
+fromProtoKey :: ProtoKey -> HasExt -> KeySource -> Annex Key
+fromProtoKey (ProtoKey k) (HasExt False) _ = pure k
+fromProtoKey (ProtoKey k) hasext@(HasExt True) source =
+	addE source (setHasExt hasext) k
+
+toProtoKey :: Key -> ProtoKey
+toProtoKey k = ProtoKey $ alterKey k $ \d -> d
+	-- The extension can be easily removed, because the protocol
+	-- documentation does not allow '.' to be used in the keyName,
+	-- so the first one is the extension.
+	{ keyName = S.takeWhile (/= dot) (keyName d)
+	, keyVariety = setHasExt (HasExt False) (keyVariety d)
+	}
+  where
+	dot = fromIntegral (ord '.')
+
+setHasExt :: HasExt -> KeyVariety -> KeyVariety
+setHasExt hasext (ExternalKey name _) = ExternalKey name hasext
+setHasExt _ v = v
+
 instance Proto.Serializable ProtoKey where
 	serialize (ProtoKey k) = Proto.serialize k
 	deserialize = fmap ProtoKey . Proto.deserialize
diff --git a/Backend/Hash.hs b/Backend/Hash.hs
index 2b8bcd78d3..e80ad4216e 100644
--- a/Backend/Hash.hs
+++ b/Backend/Hash.hs
@@ -20,13 +20,11 @@ import Types.Backend
 import Types.KeySource
 import Utility.Hash
 import Utility.Metered
+import Backend.Utilities
 
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as L
-import qualified System.FilePath.ByteString as P
-import Data.Char
-import Data.Word
 import Control.DeepSeq
 import Control.Exception (evaluate)
 
@@ -114,29 +112,8 @@ keyValue hash source meterupdate = do
 {- Extension preserving keys. -}
 keyValueE :: Hash -> KeySource -> MeterUpdate -> Annex Key
 keyValueE hash source meterupdate =
-	keyValue hash source meterupdate >>= addE
-  where
-	addE k = do
-		maxlen <- annexMaxExtensionLength <$> Annex.getGitConfig
-		let ext = selectExtension maxlen (keyFilename source)
-		return $ alterKey k $ \d -> d
-			{ keyName = keyName d <> ext
-			, keyVariety = hashKeyVariety hash (HasExt True)
-			}
-
-selectExtension :: Maybe Int -> RawFilePath -> S.ByteString
-selectExtension maxlen f
-	| null es = ""
-	| otherwise = S.intercalate "." ("":es)
-  where
-	es = filter (not . S.null) $ reverse $
-		take 2 $ filter (S.all validInExtension) $
-		takeWhile shortenough $
-		reverse $ S.split (fromIntegral (ord '.')) (P.takeExtensions f)
-	shortenough e = S.length e <= fromMaybe maxExtensionLen maxlen
-
-maxExtensionLen :: Int
-maxExtensionLen = 4 -- long enough for "jpeg"
+	keyValue hash source meterupdate
+		>>= addE source (const $ hashKeyVariety hash (HasExt True))
 
 {- A key's checksum is checked during fsck when it's content is present
  - except for in fast mode. -}
@@ -166,13 +143,6 @@ checkKeyChecksum hash key file = catchIOErrorType HardwareFault hwfault $ do
 keyHash :: Key -> S.ByteString
 keyHash = fst . splitKeyNameExtension
 
-validInExtension :: Word8 -> Bool
-validInExtension c
-	| isAlphaNum (chr (fromIntegral c)) = True
-	| fromIntegral c == ord '.' = True
-	| c <= 127 = False -- other ascii: spaces, punctuation, control chars
-	| otherwise = True -- utf8 is allowed, also other encodings
-
 {- Upgrade keys that have the \ prefix on their hash due to a bug, or
  - that contain non-alphanumeric characters in their extension.
  -
@@ -310,10 +280,10 @@ testKeyBackend =
 	let b = genBackendE (SHA2Hash (HashSize 256))
 	    gk = case genKey b of
 		Nothing -> Nothing
-		Just f -> Just (\ks p -> addE <$> f ks p)
+		Just f -> Just (\ks p -> addTestE <$> f ks p)
 	in b { genKey = gk }
   where
-	addE k = alterKey k $ \d -> d
+	addTestE k = alterKey k $ \d -> d
 		{ keyName = keyName d <> longext
 		}
 	longext = ".this-is-a-test-key"
diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs
index 0baaa476c9..16bbbdc9f9 100644
--- a/Backend/Utilities.hs
+++ b/Backend/Utilities.hs
@@ -1,17 +1,25 @@
 {- git-annex backend utilities
  -
- - Copyright 2012-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE OverloadedStrings #-}
+
 module Backend.Utilities where
 
 import Annex.Common
+import qualified Annex
 import Utility.Hash
+import Types.Key
+import Types.KeySource
 
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
+import qualified System.FilePath.ByteString as P
+import Data.Char
+import Data.Word
 
 {- Generates a keyName from an input string. Takes care of sanitizing it.
  - If it's not too long, the full string is used as the keyName.
@@ -32,3 +40,34 @@ genKeyName s
 	sha256len = 64
 	md5len = 32
 
+{- Converts a key to a version that includes an extension from the
+ - file that the key was generated from.  -}
+addE :: KeySource -> (KeyVariety -> KeyVariety) -> Key -> Annex Key
+addE source sethasext k = do
+	maxlen <- annexMaxExtensionLength <$> Annex.getGitConfig
+	let ext = selectExtension maxlen (keyFilename source)
+	return $ alterKey k $ \d -> d
+		{ keyName = keyName d <> ext
+		, keyVariety = sethasext (keyVariety d)
+		}
+
+selectExtension :: Maybe Int -> RawFilePath -> S.ByteString
+selectExtension maxlen f
+	| null es = ""
+	| otherwise = S.intercalate "." ("":es)
+  where
+	es = filter (not . S.null) $ reverse $
+		take 2 $ filter (S.all validInExtension) $
+		takeWhile shortenough $
+		reverse $ S.split (fromIntegral (ord '.')) (P.takeExtensions f)
+	shortenough e = S.length e <= fromMaybe maxExtensionLen maxlen
+
+validInExtension :: Word8 -> Bool
+validInExtension c
+	| isAlphaNum (chr (fromIntegral c)) = True
+	| fromIntegral c == ord '.' = True
+	| c <= 127 = False -- other ascii: spaces, punctuation, control chars
+	| otherwise = True -- utf8 is allowed, also other encodings
+
+maxExtensionLen :: Int
+maxExtensionLen = 4 -- long enough for "jpeg"