diff options
author | Joey Hess <joeyh@joeyh.name> | 2015-10-08 17:58:32 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2015-10-08 17:58:32 -0400 |
commit | a56d3c92b9672c6d84ac007a404b07d3eeb51025 (patch) | |
tree | 2264ea086ca39f7243deb1adfcb085551006b07d /Types/NumCopies.hs | |
parent | d5494842274030d21356c7492e6de5969173c34d (diff) |
support invalidating existing VerifiedCopys
Diffstat (limited to 'Types/NumCopies.hs')
-rw-r--r-- | Types/NumCopies.hs | 74 |
1 files changed, 57 insertions, 17 deletions
diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs index 732c928d2..0acb7cc3b 100644 --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -5,11 +5,22 @@ - Licensed under the GNU GPL version 3 or higher. -} -module Types.NumCopies where +module Types.NumCopies ( + NumCopies(..), + fromNumCopies, + VerifiedCopy(..), + checkVerifiedCopy, + invalidateVerifiedCopy, + strongestVerifiedCopy, + deDupVerifiedCopies, + mkVerifiedCopy, + invalidatableVerifiedCopy, +) where import Types.UUID import qualified Data.Map as M +import Control.Concurrent.MVar newtype NumCopies = NumCopies Int deriving (Ord, Eq) @@ -17,38 +28,67 @@ newtype NumCopies = NumCopies Int fromNumCopies :: NumCopies -> Int fromNumCopies (NumCopies n) = n +-- A verification that a copy of a key exists in a repository. data VerifiedCopy {- Use when a repository cannot be accessed, but it's - - a trusted repository, which is presumably not going to - - lose a copy. This is the weakest level of verification. -} - = TrustedCopy UUID + - a trusted repository, which is on record as containing a key + - and is presumably not going to lose its copy. + - This is the weakest level of verification. -} + = TrustedCopy V {- Represents a recent verification that a copy of an - object exists in a repository with the given UUID. -} - | VerifiedCopy UUID + | RecentlyVerifiedCopy V {- The strongest proof of the existence of a copy. - Until its associated action is called to unlock it, - the copy is locked in the repository and is guaranteed - not to be dropped by any git-annex process. -} - | VerifiedCopyLock UUID (IO ()) + | VerifiedCopyLock V + deriving (Show) instance ToUUID VerifiedCopy where - toUUID (VerifiedCopy u) = u - toUUID (VerifiedCopyLock u _) = u - toUUID (TrustedCopy u) = u + toUUID = _getUUID . toV + +toV :: VerifiedCopy -> V +toV (TrustedCopy v) = v +toV (RecentlyVerifiedCopy v) = v +toV (VerifiedCopyLock v) = v -instance Show VerifiedCopy where - show (TrustedCopy u) = "TrustedCopy " ++ show u - show (VerifiedCopy u) = "VerifiedCopy " ++ show u - show (VerifiedCopyLock u _) = "VerifiedCopyLock " ++ show u +-- Checks that it's still valid. +checkVerifiedCopy :: VerifiedCopy -> IO Bool +checkVerifiedCopy = _checkVerifiedCopy . toV + +invalidateVerifiedCopy :: VerifiedCopy -> IO () +invalidateVerifiedCopy = _invalidateVerifiedCopy . toV + +data V = V + { _getUUID :: UUID + , _checkVerifiedCopy :: IO Bool + , _invalidateVerifiedCopy :: IO () + } + +instance Show V where + show v = show (_getUUID v) strongestVerifiedCopy :: VerifiedCopy -> VerifiedCopy -> VerifiedCopy -strongestVerifiedCopy a@(VerifiedCopyLock _ _) _ = a -strongestVerifiedCopy _ b@(VerifiedCopyLock _ _) = b -strongestVerifiedCopy a@(VerifiedCopy _) _ = a -strongestVerifiedCopy _ b@(VerifiedCopy _) = b +strongestVerifiedCopy a@(VerifiedCopyLock _) _ = a +strongestVerifiedCopy _ b@(VerifiedCopyLock _) = b +strongestVerifiedCopy a@(RecentlyVerifiedCopy _) _ = a +strongestVerifiedCopy _ b@(RecentlyVerifiedCopy _) = b strongestVerifiedCopy a@(TrustedCopy _) _ = a -- Retains stronger verifications over weaker for the same uuid. deDupVerifiedCopies :: [VerifiedCopy] -> [VerifiedCopy] deDupVerifiedCopies l = M.elems $ M.fromListWith strongestVerifiedCopy (zip (map toUUID l) l) + +mkVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> VerifiedCopy +mkVerifiedCopy mk u = mk $ V (toUUID u) (return True) (return ()) + +invalidatableVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> IO VerifiedCopy +invalidatableVerifiedCopy mk u = do + v <- newEmptyMVar + let invalidate = do + _ <- tryPutMVar v () + return () + let check = isEmptyMVar v + return $ mk $ V (toUUID u) check invalidate |