factor out IncrementalHasher from IncrementalVerifier

Annex/Content.hs

@@ -656,8 +656,8 @@ downloadUrl listfailedurls k p iv urls file uo =
 			-- to be used for the other urls.
 			case iv of
 				Just iv' -> 
-					liftIO $ positionIncremental iv' >>= \case
+					liftIO $ positionIncrementalVerifier iv' >>= \case
-					Just n | n > 0 -> unableIncremental iv'
+					Just n | n > 0 -> unableIncrementalVerifier iv'
 					_ -> noop
 				Nothing -> noop
 			go us ((u, err) : errs)

Annex/CopyFile.hs

@@ -86,7 +86,7 @@ fileCopier _ src dest meterupdate iv = docopy
 fileCopier copycowtried src dest meterupdate iv =
 	ifM (liftIO $ tryCopyCoW copycowtried src dest meterupdate)
 		( do
-			liftIO $ maybe noop unableIncremental iv
+			liftIO $ maybe noop unableIncrementalVerifier iv
 			return CopiedCoW
 		, docopy
 		)
@@ -119,7 +119,7 @@ fileCopier copycowtried src dest meterupdate iv =
 			else do
 				let sofar' = addBytesProcessed sofar (S.length s)
 				S.hPut hdest s
-				maybe noop (flip updateIncremental s) iv
+				maybe noop (flip updateIncrementalVerifier s) iv
 				meterupdate sofar'
 				docopy' hdest hsrc sofar'
 
@@ -134,7 +134,7 @@ fileCopier copycowtried src dest meterupdate iv =
 				s' <- getnoshort (S.length s) hsrc
 				if s == s'
 					then do
-						maybe noop (flip updateIncremental s) iv
+						maybe noop (flip updateIncrementalVerifier s) iv
 						let sofar' = addBytesProcessed sofar (S.length s)
 						meterupdate sofar'
 						compareexisting hdest hsrc sofar'

Annex/Verify.hs

@@ -102,7 +102,7 @@ verifyKeyContent' k f =
 			Just verifier -> verifier k f
 
 resumeVerifyKeyContent :: Key -> RawFilePath -> IncrementalVerifier -> Annex Bool
-resumeVerifyKeyContent k f iv = liftIO (positionIncremental iv) >>= \case
+resumeVerifyKeyContent k f iv = liftIO (positionIncrementalVerifier iv) >>= \case
 	Nothing -> fallback
 	Just endpos -> do
 		fsz <- liftIO $ catchDefaultIO 0 $ getFileSize f
@@ -119,21 +119,21 @@ resumeVerifyKeyContent k f iv = liftIO (positionIncremental iv) >>= \case
 	go fsz endpos
 		| fsz == endpos =
 			liftIO $ catchDefaultIO (Just False) $
-				finalizeIncremental iv
+				finalizeIncrementalVerifier iv
 		| otherwise = do
-			showAction (descVerify iv)
+			showAction (descIncrementalVerifier iv)
 			liftIO $ catchDefaultIO (Just False) $
 				withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do
 					hSeek h AbsoluteSeek endpos
 					feedincremental h
-					finalizeIncremental iv
+					finalizeIncrementalVerifier iv
 	
 	feedincremental h = do
 		b <- S.hGetSome h chunk
 		if S.null b
 			then return ()
 			else do
-				updateIncremental iv b
+				updateIncrementalVerifier iv b
 				feedincremental h
 
 	chunk = 65536
@@ -174,7 +174,7 @@ finishVerifyKeyContentIncrementally :: Maybe IncrementalVerifier -> Annex (Bool,
 finishVerifyKeyContentIncrementally Nothing = 
 	return (True, UnVerified)
 finishVerifyKeyContentIncrementally (Just iv) =
-	liftIO (finalizeIncremental iv) >>= \case
+	liftIO (finalizeIncrementalVerifier iv) >>= \case
 		Just True -> return (True, Verified)
 		Just False -> do
 			warning "verification of content failed"
@@ -224,7 +224,7 @@ tailVerify :: IncrementalVerifier -> RawFilePath -> TMVar () -> IO ()
 tailVerify iv f finished = 
 	tryNonAsync go >>= \case
 		Right r -> return r
-		Left _ -> unableIncremental iv
+		Left _ -> unableIncrementalVerifier iv
   where
 	-- Watch the directory containing the file, and wait for
 	-- the file to be modified. It's possible that the file already
@@ -249,7 +249,7 @@ tailVerify iv f finished =
 		let cleanup = void . tryNonAsync . INotify.removeWatch
 		let stop w = do
 			cleanup w
-			unableIncremental iv
+			unableIncrementalVerifier iv
 		waitopen modified >>= \case
 			Nothing -> stop wd
 			Just h -> do
@@ -301,12 +301,12 @@ tailVerify iv f finished =
 						<$> takeTMVar finished)
 				cont
 			else do
-				updateIncremental iv b
+				updateIncrementalVerifier iv b
 				atomically (tryTakeTMVar finished) >>= \case
 					Nothing -> follow h modified
 					Just () -> return ()
 
 	chunk = 65536
 #else
-tailVerify iv _ _ = unableIncremental iv
+tailVerify iv _ _ = unableIncrementalVerifier iv
 #endif

P2P/Annex.hs

@@ -178,7 +178,7 @@ runLocal runst runner a = case a of
 					then defaultChunkSize
 					else fromIntegral n
 				b <- S.hGet h c
-				updateIncremental iv b
+				updateIncrementalVerifier iv b
 				unless (b == S.empty) $
 					go iv (n - fromIntegral (S.length b))
 
@@ -192,7 +192,7 @@ runLocal runst runner a = case a of
 						Nothing -> \c -> S.hPut h c
 						Just iv -> \c -> do
 							S.hPut h c
-							updateIncremental iv c
+							updateIncrementalVerifier iv c
 					meteredWrite p' writechunk b
 				indicatetransferred ti
 
@@ -203,7 +203,7 @@ runLocal runst runner a = case a of
 				runner validitycheck >>= \case
 					Right (Just Valid) -> case incrementalverifier of
 						Just iv
-							| rightsize -> liftIO (finalizeIncremental iv) >>= \case
+							| rightsize -> liftIO (finalizeIncrementalVerifier iv) >>= \case
 								Nothing -> return (True, UnVerified)
 								Just True -> return (True, Verified)
 								Just False -> return (False, UnVerified)

Remote/Helper/Chunked.hs

@@ -372,7 +372,7 @@ retrieveChunks retriever u vc chunkconfig encryptor basek dest basep enc encc
 	
 	finalize (Right Nothing) = return UnVerified
 	finalize (Right (Just iv)) =
-		liftIO (finalizeIncremental iv) >>= \case
+		liftIO (finalizeIncrementalVerifier iv) >>= \case
 			Just True -> return Verified
 			_ -> return UnVerified
 	finalize (Left v) = return v
@@ -426,7 +426,7 @@ writeRetrievedContent dest enc encc mh mp content miv = case (enc, mh, content)
 		Just p -> 
 			let writer = case miv of
 				Just iv -> \s -> do
-					updateIncremental iv s
+					updateIncrementalVerifier iv s
 					S.hPut h s
 				Nothing -> S.hPut h
 			in meteredWrite p writer b

Remote/Helper/Http.hs

@@ -83,5 +83,5 @@ httpBodyRetriever dest meterupdate iv resp
 				let sofar' = addBytesProcessed sofar $ S.length b
 				S.hPut h b
 				meterupdate sofar'
-				maybe noop (flip updateIncremental b) iv
+				maybe noop (flip updateIncrementalVerifier b) iv
 				go sofar' h

Remote/WebDAV.hs

@@ -173,7 +173,7 @@ retrieve hv cc = fileRetriever' $ \d k p iv ->
 	withDavHandle hv $ \dav -> case cc of
 		LegacyChunks _ -> do
 			-- Not doing incremental verification for chunks.
-			liftIO $ maybe noop unableIncremental iv
+			liftIO $ maybe noop unableIncrementalVerifier iv
 			retrieveLegacyChunked (fromRawFilePath d) k p dav
 		_ -> liftIO $ goDAV dav $
 			retrieveHelper (keyLocation k) (fromRawFilePath d) p iv

Utility/Hash.hs

@@ -64,6 +64,8 @@ module Utility.Hash (
 	Mac(..),
 	calcMac,
 	props_macs_stable,
+	IncrementalHasher(..),
+	mkIncrementalHasher,
 	IncrementalVerifier(..),
 	mkIncrementalVerifier,
 ) where
@@ -280,44 +282,62 @@ props_macs_stable = map (\(desc, mac, result) -> (desc ++ " stable", calcMac mac
 	key = T.encodeUtf8 $ T.pack "foo"
 	msg = T.encodeUtf8 $ T.pack "bar"
 
-data IncrementalVerifier = IncrementalVerifier
+data IncrementalHasher = IncrementalHasher
-	{ updateIncremental :: S.ByteString -> IO ()
+	{ updateIncrementalHasher :: S.ByteString -> IO ()
 	-- ^ Called repeatedly on each peice of the content.
-	, finalizeIncremental :: IO (Maybe Bool)
+	, finalizeIncrementalHasher :: IO (Maybe String)
-	-- ^ Called once the full content has been sent, returns True
+	-- ^ Called once the full content has been sent, returns
-	-- if the hash verified, False if it did not, and Nothing if
+	-- the hash. (Nothing if unableIncremental was called.)
-	-- incremental verification was unable to be done.
+	, unableIncrementalHasher :: IO ()
-	, unableIncremental :: IO ()
+	-- ^ Call if the incremental hashing is unable to be done.
-	-- ^ Call if the incremental verification is unable to be done.
+	, positionIncrementalHasher :: IO (Maybe Integer)
-	, positionIncremental :: IO (Maybe Integer)
 	-- ^ Returns the number of bytes that have been fed to this
-	-- incremental verifier so far. (Nothing if unableIncremental was
+	-- incremental hasher so far. (Nothing if unableIncremental was
 	-- called.)
-	, descVerify :: String
+	, descIncrementalHasher :: String
-	-- ^ A description of what is done to verify the content.
 	}
 
-mkIncrementalVerifier :: HashAlgorithm h => Context h -> String -> (String -> Bool) -> IO IncrementalVerifier
+mkIncrementalHasher :: HashAlgorithm h => Context h -> String -> IO IncrementalHasher
-mkIncrementalVerifier ctx descverify samechecksum = do
+mkIncrementalHasher ctx desc = do
 	v <- newIORef (Just (ctx, 0))
-	return $ IncrementalVerifier
+	return $ IncrementalHasher
-		{ updateIncremental = \b ->
+		{ updateIncrementalHasher = \b ->
 			modifyIORef' v $ \case
 				(Just (ctx', n)) -> 
 					let !ctx'' = hashUpdate ctx' b
 					    !n' = n + fromIntegral (S.length b)
 					in (Just (ctx'', n'))
 				Nothing -> Nothing
-		, finalizeIncremental =
+		, finalizeIncrementalHasher =
 			readIORef v >>= \case
 				(Just (ctx', _)) -> do
 					let digest = hashFinalize ctx'
-					return $ Just $ 
+					return $ Just $ show digest
-						samechecksum (show digest)
 				Nothing -> return Nothing
-		, unableIncremental = writeIORef v Nothing
+		, unableIncrementalHasher = writeIORef v Nothing
-		, positionIncremental = readIORef v >>= \case
+		, positionIncrementalHasher = readIORef v >>= \case
 			Just (_, n) -> return (Just n)
 			Nothing -> return Nothing
-		, descVerify = descverify
+		, descIncrementalHasher = desc
+		}
+
+data IncrementalVerifier = IncrementalVerifier
+	{ updateIncrementalVerifier :: S.ByteString -> IO ()
+	, finalizeIncrementalVerifier :: IO (Maybe Bool)
+	, unableIncrementalVerifier :: IO ()
+	, positionIncrementalVerifier :: IO (Maybe Integer)
+	, descIncrementalVerifier :: String
+	}
+
+mkIncrementalVerifier :: HashAlgorithm h => Context h -> String -> (String -> Bool) -> IO IncrementalVerifier
+mkIncrementalVerifier ctx desc samechecksum = do
+	hasher <- mkIncrementalHasher ctx desc
+	return $ IncrementalVerifier
+		{ updateIncrementalVerifier = updateIncrementalHasher hasher
+		, finalizeIncrementalVerifier = 
+			maybe Nothing (Just . samechecksum)
+				<$> finalizeIncrementalHasher hasher
+		, unableIncrementalVerifier = unableIncrementalHasher hasher
+		, positionIncrementalVerifier = positionIncrementalHasher hasher
+		, descIncrementalVerifier = descIncrementalHasher hasher
 		}

Utility/Url.hs

@@ -451,7 +451,7 @@ download' nocurlerror meterupdate iv url file uo =
 			Nothing -> throwIO ex
 	followredir _ ex = throwIO ex
 
-	noverification = maybe noop unableIncremental iv
+	noverification = maybe noop unableIncrementalVerifier iv
 
 {- Download a perhaps large file using conduit, with auto-resume
  - of incomplete downloads.
@@ -554,7 +554,7 @@ downloadConduit meterupdate iv req file uo =
 				() <- signalsuccess False
 				throwM e
 	
-	noverification = maybe noop unableIncremental iv
+	noverification = maybe noop unableIncrementalVerifier iv
 	
 {- Sinks a Response's body to a file. The file can either be appended to
  - (AppendMode), or written from the start of the response (WriteMode).
@@ -575,9 +575,9 @@ sinkResponseFile
 sinkResponseFile meterupdate iv initialp file mode resp = do
 	ui <- case (iv, mode) of
 		(Just iv', AppendMode) -> do
-			liftIO $ unableIncremental iv'
+			liftIO $ unableIncrementalVerifier iv'
 			return (const noop)
-		(Just iv', _) -> return (updateIncremental iv')
+		(Just iv', _) -> return (updateIncrementalVerifier iv')
 		(Nothing, _) -> return (const noop)
 	(fr, fh) <- allocate (openBinaryFile file mode) hClose
 	runConduit $ responseBody resp .| go ui initialp fh