split ProvidedInfo and UserProvidedInfo

The latter is for git-annex matchexpression and matching against it can
throw an exception. Splitting out the former reduces the potential for
mistakes and avoids needing to worry about matching against that
throwing an exception.

This is more groundwork for matching largefiles while importing,
without downloading content.

This commit was sponsored by Graham Spencer on Patreon.

diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs
index db58c019b4090fccb09654ae082c29cc61817449..e46b75da6a4a07a6b05e469c41f21b84d2690fee 100644 (file)
--- a/Annex/FileMatcher.hs
+++ b/Annex/FileMatcher.hs
@@ -195,9 +195,9 @@ mkMatchExpressionParser = do
                commonKeylessTokens LimitDiskFiles ++
 #ifdef WITH_MAGICMIME
                [ mimer "mimetype" $
-                       matchMagic "mimetype" getMagicMimeType providedMimeType
+                       matchMagic "mimetype" getMagicMimeType providedMimeType userProvidedMimeType
                , mimer "mimeencoding" $
-                       matchMagic "mimeencoding" getMagicMimeEncoding providedMimeEncoding
+                       matchMagic "mimeencoding" getMagicMimeEncoding providedMimeEncoding userProvidedMimeEncoding
                ]
 #else
                [ mimer "mimetype"

diff --git a/Annex/Import.hs b/Annex/Import.hs
index 1691c6f3b1566b573242d3b24343e532aff199b2..9f9336e75d3b65fc474c85a685f21aad8714d14c 100644 (file)
--- a/Annex/Import.hs
+++ b/Annex/Import.hs
@@ -541,15 +541,12 @@ wantImport :: FileMatcher Annex -> ImportLocation -> ByteSize -> Annex Bool
 wantImport matcher loc sz = checkMatcher' matcher mi mempty
   where
        mi = MatchingInfo $ ProvidedInfo
-               { providedFilePath = Right $ fromRawFilePath $ fromImportLocation loc
-               , providedKey = unavail "key"
-               , providedFileSize = Right sz
-               , providedMimeType = unavail "mime"
-               , providedMimeEncoding = unavail "mime"
+               { providedFilePath = fromImportLocation loc
+               , providedKey = Nothing
+               , providedFileSize = sz
+               , providedMimeType = Nothing
+               , providedMimeEncoding = Nothing
                }
-       -- This should never run, as long as the FileMatcher was generated
-       -- using the preferredContentKeylessTokens.
-       unavail v = Left $ error $ "Internal error: unavailable " ++ v
 
 {- If a file is not preferred content, but it was previously exported or
  - imported to the remote, not importing it would result in a remote

diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs
index d0d14c363ca0dbd382d4a03f473699b710988d0f..bc6e5e2ae1432c08361527931795ef7fb26a9ce1 100644 (file)
--- a/Annex/Ingest.hs
+++ b/Annex/Ingest.hs
@@ -346,8 +346,8 @@ addAnnexedFile ci matcher file key mtmp = ifM (addUnlocked matcher mi)
                        (pure Nothing)
                        (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> getFileStatus tmp)
                        mtmp
-               stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key
-               Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (toRawFilePath file))
+               stagePointerFile file' mode =<< hashPointerFile key
+               Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file')
                case mtmp of
                        Just tmp -> ifM (moveAnnex key tmp)
                                ( linkunlocked mode >> return True
@@ -367,23 +367,23 @@ addAnnexedFile ci matcher file key mtmp = ifM (addUnlocked matcher mi)
        mi = case mtmp of
                Just tmp -> MatchingFile $ FileInfo
                        { contentFile = Just (toRawFilePath tmp)
-                       , matchFile = toRawFilePath file
+                       , matchFile = file'
                        }
                -- Provide as much info as we can without access to the
-               -- file's content. It's better to provide wrong info
-               -- than for an operation to fail just because it can't
-               -- tell if a file should be unlocked or locked.
+               -- file's content.
                Nothing -> MatchingInfo $ ProvidedInfo
-                       { providedFilePath = Right file
-                       , providedKey = Right key
-                       , providedFileSize = Right $ fromMaybe 0 $
+                       { providedFilePath = file'
+                       , providedKey = Just key
+                       , providedFileSize = fromMaybe 0 $
                                keySize `fromKey` key
-                       , providedMimeType = Right "application/octet-stream"
-                       , providedMimeEncoding = Right "binary"
+                       , providedMimeType = Nothing
+                       , providedMimeEncoding = Nothing
                        }
        
        linkunlocked mode = linkFromAnnex key file mode >>= \case
                LinkAnnexFailed -> liftIO $
-                       writePointerFile (toRawFilePath file) key mode
+                       writePointerFile file' key mode
                _ -> return ()
-       writepointer mode = liftIO $ writePointerFile (toRawFilePath file) key mode
+       writepointer mode = liftIO $ writePointerFile file' key mode
+
+       file' = toRawFilePath file

diff --git a/Command/MatchExpression.hs b/Command/MatchExpression.hs
index b48b82233773c9a09b3a8f0c87fbfec0d4ff0dd5..737cc21c9de07abb626aa36a1122a26b2b699305 100644 (file)
--- a/Command/MatchExpression.hs
+++ b/Command/MatchExpression.hs
@@ -37,9 +37,9 @@ optParser desc = MatchExpressionOptions
                ( long "largefiles"
                <> help "parse as annex.largefiles expression"
                )
-       <*> (MatchingInfo . addkeysize <$> dataparser)
+       <*> (MatchingUserInfo . addkeysize <$> dataparser)
   where
-       dataparser = ProvidedInfo
+       dataparser = UserProvidedInfo
                <$> optinfo "file" (strOption
                        ( long "file" <> metavar paramFile
                        <> help "specify filename to match against"
@@ -65,9 +65,9 @@ optParser desc = MatchExpressionOptions
                <|> (pure $ Left $ missingdata datadesc)
        missingdata datadesc = bail $ "cannot match this expression without " ++ datadesc ++ " data"
        -- When a key is provided, make its size also be provided.
-       addkeysize p = case providedKey p of
+       addkeysize p = case userProvidedKey p of
                Right k -> case fromKey keySize k of
-                       Just sz -> p { providedFileSize = Right sz }
+                       Just sz -> p { userProvidedFileSize = Right sz }
                        Nothing -> p
                Left _ -> p
 

diff --git a/Limit.hs b/Limit.hs
index 0a81c43e8cb84b30491063eb94b727d803cd82d3..be2611a242975955848589592333e92751b1c0de 100644 (file)
--- a/Limit.hs
+++ b/Limit.hs
@@ -117,20 +117,27 @@ matchGlobFile glob = go
   where
        cglob = compileGlob glob CaseSensative -- memoized
        go (MatchingFile fi) = pure $ matchGlob cglob (fromRawFilePath (matchFile fi))
-       go (MatchingInfo p) = matchGlob cglob <$> getInfo (providedFilePath p)
+       go (MatchingInfo p) = pure $ matchGlob cglob (fromRawFilePath (providedFilePath p))
+       go (MatchingUserInfo p) = matchGlob cglob <$> getUserInfo (userProvidedFilePath p)
        go (MatchingKey _ (AssociatedFile Nothing)) = pure False
        go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob (fromRawFilePath af)
 
 addMimeType :: String -> Annex ()
-addMimeType = addMagicLimit "mimetype" getMagicMimeType providedMimeType
+addMimeType = addMagicLimit "mimetype" getMagicMimeType providedMimeType userProvidedMimeType
 
 addMimeEncoding :: String -> Annex ()
-addMimeEncoding = addMagicLimit "mimeencoding" getMagicMimeEncoding providedMimeEncoding
-
-addMagicLimit :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> String -> Annex ()
-addMagicLimit limitname querymagic selectprovidedinfo glob = do
+addMimeEncoding = addMagicLimit "mimeencoding" getMagicMimeEncoding providedMimeEncoding userProvidedMimeEncoding
+
+addMagicLimit
+       :: String
+       -> (Magic -> FilePath -> Annex (Maybe String))
+       -> (ProvidedInfo -> Maybe String)
+       -> (UserProvidedInfo -> UserInfo String)
+       -> String
+       -> Annex ()
+addMagicLimit limitname querymagic selectprovidedinfo selectuserprovidedinfo glob = do
        magic <- liftIO initMagicMime
-       addLimit $ matchMagic limitname querymagic' selectprovidedinfo magic glob
+       addLimit $ matchMagic limitname querymagic' selectprovidedinfo selectuserprovidedinfo magic glob
   where
        querymagic' magic f = liftIO (isPointerFile (toRawFilePath f)) >>= \case
                -- Avoid getting magic of a pointer file, which would
@@ -143,8 +150,14 @@ addMagicLimit limitname querymagic selectprovidedinfo glob = do
                                querymagic magic . fromRawFilePath
                        Nothing -> querymagic magic f
 
-matchMagic :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> Maybe Magic -> MkLimit Annex
-matchMagic _limitname querymagic selectprovidedinfo (Just magic) glob = 
+matchMagic
+       :: String
+       -> (Magic -> FilePath -> Annex (Maybe String))
+       -> (ProvidedInfo -> Maybe String)
+       -> (UserProvidedInfo -> UserInfo String)
+       -> Maybe Magic
+       -> MkLimit Annex
+matchMagic _limitname querymagic selectprovidedinfo selectuserprovidedinfo (Just magic) glob = 
        Right $ MatchFiles
                { matchAction = const go
                , matchNeedsFileName = True
@@ -160,9 +173,11 @@ matchMagic _limitname querymagic selectprovidedinfo (Just magic) glob =
                        maybe False (matchGlob cglob)
                                <$> querymagic magic (fromRawFilePath f)
                Nothing -> return False
-       go (MatchingInfo p) =
-               matchGlob cglob <$> getInfo (selectprovidedinfo p)
-matchMagic limitname _ _ Nothing _ = 
+       go (MatchingInfo p) = pure $
+               maybe False (matchGlob cglob) (selectprovidedinfo p)
+       go (MatchingUserInfo p) =
+               matchGlob cglob <$> getUserInfo (selectuserprovidedinfo p)
+matchMagic limitname _ _ _ Nothing _ = 
        Left $ "unable to load magic database; \""++limitname++"\" cannot be used"
 
 addUnlocked :: Annex ()
@@ -186,6 +201,7 @@ addLocked = addLimit $ Right $ MatchFiles
 matchLockStatus :: Bool -> MatchInfo -> Annex Bool
 matchLockStatus _ (MatchingKey _ _) = pure False
 matchLockStatus _ (MatchingInfo _) = pure False
+matchLockStatus _ (MatchingUserInfo _) = pure False
 matchLockStatus wantlocked (MatchingFile fi) = case contentFile fi of
        Just f -> liftIO $ do
                islocked <- isPointerFile f >>= \case
@@ -256,8 +272,9 @@ limitInDir dir = MatchFiles
   where
        go (MatchingFile fi) = checkf $ fromRawFilePath $ matchFile fi
        go (MatchingKey _ (AssociatedFile Nothing)) = return False
-       go (MatchingKey _ (AssociatedFile (Just af))) = checkf (fromRawFilePath af)
-       go (MatchingInfo p) = checkf =<< getInfo (providedFilePath p)
+       go (MatchingKey _ (AssociatedFile (Just af))) = checkf $ fromRawFilePath af
+       go (MatchingInfo p) = checkf $ fromRawFilePath $ providedFilePath p
+       go (MatchingUserInfo p) = checkf =<< getUserInfo (userProvidedFilePath p)
        checkf = return . elem dir . splitPath . takeDirectory
 
 {- Adds a limit to skip files not believed to have the specified number
@@ -319,6 +336,7 @@ limitLackingCopies approx want = case readish want of
                                        fromRawFilePath $ matchFile fi
                                MatchingKey _ _ -> approxNumCopies
                                MatchingInfo {} -> approxNumCopies
+                               MatchingUserInfo {} -> approxNumCopies
                us <- filter (`S.notMember` notpresent)
                        <$> (trustExclude UnTrusted =<< Remote.keyLocations key)
                return $ numcopies - length us >= needed
@@ -339,10 +357,13 @@ limitUnused = MatchFiles
        }
   where
        go _ (MatchingFile _) = return False
-       go _ (MatchingKey k _) = S.member k <$> unusedKeys
-       go _ (MatchingInfo p) = do
-               k <- getInfo (providedKey p)
-               S.member k <$> unusedKeys
+       go _ (MatchingKey k _) = isunused k
+       go _ (MatchingInfo p) = maybe (pure False) isunused (providedKey p)
+       go _ (MatchingUserInfo p) = do
+               k <- getUserInfo (userProvidedKey p)
+               isunused k
+       
+       isunused k = S.member k <$> unusedKeys
 
 {- Limit that matches any version of any file or key. -}
 limitAnything :: MatchFiles Annex
@@ -448,8 +469,10 @@ limitSize lb vs s = case readSize dataUnits s of
                                return $ filesize `vs` Just sz
                        Nothing -> goannexed sz fi
        go sz _ (MatchingKey key _) = checkkey sz key
-       go sz _ (MatchingInfo p) =
-               getInfo (providedFileSize p) 
+       go sz _ (MatchingInfo p) = return $
+               Just (providedFileSize p) `vs` Just sz
+       go sz _ (MatchingUserInfo p) =
+               getUserInfo (userProvidedFileSize p) 
                        >>= \sz' -> return (Just sz' `vs` Just sz)
        goannexed sz fi = lookupFileKey fi >>= \case
                Just key -> checkkey sz key
@@ -520,5 +543,5 @@ lookupFileKey fi = case contentFile fi of
 checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool
 checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a
 checkKey a (MatchingKey k _) = a k
-checkKey a (MatchingInfo p) = a =<< getInfo (providedKey p)
-
+checkKey a (MatchingInfo p) = maybe (return False) a (providedKey p)
+checkKey a (MatchingUserInfo p) = a =<< getUserInfo (userProvidedKey p)

diff --git a/Limit/Wanted.hs b/Limit/Wanted.hs
index 07a6b1b1aeace22d3e895b406789faf8153e101d..fe5899597848f4887f5f320d6a6223c9c4cb004d 100644 (file)
--- a/Limit/Wanted.hs
+++ b/Limit/Wanted.hs
@@ -38,4 +38,5 @@ addPreferredContentLimit a = do
 checkWant :: (AssociatedFile -> Annex Bool) -> MatchInfo -> Annex Bool
 checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ matchFile fi))
 checkWant a (MatchingKey _ af) = a af
-checkWant _ (MatchingInfo {}) = return False
+checkWant a (MatchingInfo p) = a (AssociatedFile (Just $ providedFilePath p))
+checkWant _ (MatchingUserInfo {}) = return False

diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs
index 8f7f94f323b39e65de444c326884c778844bb19f..77c2526465afe20a036d99403a748ee5d772504f 100644 (file)
--- a/Types/FileMatcher.hs
+++ b/Types/FileMatcher.hs
@@ -1,6 +1,6 @@
 {- git-annex file matcher types
  -
- - Copyright 2013-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -23,6 +23,7 @@ data MatchInfo
        = MatchingFile FileInfo
        | MatchingKey Key AssociatedFile
        | MatchingInfo ProvidedInfo
+       | MatchingUserInfo UserProvidedInfo
 
 data FileInfo = FileInfo
        { contentFile :: Maybe RawFilePath
@@ -32,23 +33,32 @@ data FileInfo = FileInfo
        -- ^ filepath to match on; may be relative to top of repo or cwd
        }
 
--- This is used when testing a matcher, with values to match against
--- provided in some way, rather than queried from files on disk.
 data ProvidedInfo = ProvidedInfo
-       { providedFilePath :: OptInfo FilePath
-       , providedKey :: OptInfo Key
-       , providedFileSize :: OptInfo FileSize
-       , providedMimeType :: OptInfo MimeType
-       , providedMimeEncoding :: OptInfo MimeEncoding
+       { providedFilePath :: RawFilePath
+       , providedKey :: Maybe Key
+       , providedFileSize :: FileSize
+       , providedMimeType :: Maybe MimeType
+       , providedMimeEncoding :: Maybe MimeEncoding
+       }
+
+-- This is used when testing a matcher, with values to match against
+-- provided by the user.
+data UserProvidedInfo = UserProvidedInfo
+       { userProvidedFilePath :: UserInfo FilePath
+       , userProvidedKey :: UserInfo Key
+       , userProvidedFileSize :: UserInfo FileSize
+       , userProvidedMimeType :: UserInfo MimeType
+       , userProvidedMimeEncoding :: UserInfo MimeEncoding
        }
 
-type OptInfo a = Either (IO a) a
+-- This may fail if the user did not provide the information.
+type UserInfo a = Either (IO a) a
 
--- If the OptInfo is not available, accessing it may result in eg an
+-- If the UserInfo is not available, accessing it may result in eg an
 -- exception being thrown.
-getInfo :: MonadIO m => OptInfo a -> m a
-getInfo (Right i) = return i
-getInfo (Left e) = liftIO e
+getUserInfo :: MonadIO m => UserInfo a -> m a
+getUserInfo (Right i) = return i
+getUserInfo (Left e) = liftIO e
 
 type FileMatcherMap a = M.Map UUID (FileMatcher a)