fix associatedfile sanity check

It seems best to require that the file just be relative, and not some ../ trick.

git-annex-shell sendkey and recvkey both update transfer information now

Fields.hs

@@ -15,18 +15,18 @@ import Data.Char
 {- A field, stored in Annex state, with a value sanity checker. -}
 data Field = Field
 	{ fieldName :: String
-	, fieldCheck :: String -> IO Bool
+	, fieldCheck :: String -> Bool
 	}
 
 remoteUUID :: Field
 remoteUUID = Field "remoteuuid" $
 	-- does it look like a UUID?
-	return . all (\c -> isAlphaNum c || c == '-')
+	all (\c -> isAlphaNum c || c == '-')
 
 associatedFile :: Field
-associatedFile = Field "associatedfile" $ \value ->
+associatedFile = Field "associatedfile" $ \f ->
-	-- is the file located within the current directory?
+	-- is the file a safe relative filename?
-	dirContains <$> getCurrentDirectory <*> pure value
+	not (isAbsolute f) && not ("../" `isPrefixOf` f)
 
 getField :: Field -> Annex (Maybe String)
 getField = Annex.getField . fieldName

GitAnnexShell.hs

@@ -85,7 +85,7 @@ builtin :: String -> String -> [String] -> IO ()
 builtin cmd dir params = do
 	checkNotReadOnly cmd
 	let (params', fieldparams) = partitionParams params
-	fields <- filterM checkField $ parseFields fieldparams
+	let fields = filter checkField $ parseFields fieldparams
 	dispatch False (cmd : params') cmds options fields header $
 		Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath
 
@@ -113,11 +113,11 @@ parseFields = map (separate (== '='))
 
 {- Only allow known fields to be set, ignore others.
  - Make sure that field values make sense. -}
-checkField :: (String, String) -> IO Bool
+checkField :: (String, String) -> Bool
 checkField (field, value)
 	| field == fieldName remoteUUID = fieldCheck remoteUUID value
 	| field == fieldName associatedFile = fieldCheck associatedFile value
-	| otherwise = return False
+	| otherwise = False
 
 failure :: IO ()
 failure = error $ "bad parameters\n\n" ++ usage header cmds options