diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -214,7 +214,7 @@ new :: Git.Repo -> IO AnnexState new r = do r' <- Git.Config.read =<< Git.relPath r - let c = extractGitConfig r' + let c = extractGitConfig FromGitConfig r' newState c =<< fixupRepo r' c {- Performs an action in the Annex monad from a starting state, @@ -325,7 +325,7 @@ r' <- liftIO $ adjuster r changeState $ \s -> s { repo = r' - , gitconfig = extractGitConfig r' + , gitconfig = extractGitConfig FromGitConfig r' } {- Adds an adjustment to the Repo data. Adjustments persist across reloads diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -112,8 +112,8 @@ adjustToSymlink' :: (FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath) -> TreeItem -> Annex (Maybe TreeItem) adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case Just k -> do - absf <- inRepo $ \r -> absPath $ - fromTopFilePath f r + absf <- inRepo $ \r -> absPath $ + fromRawFilePath $ fromTopFilePath f r linktarget <- calcRepo $ gitannexlink absf k Just . TreeItem f (fromTreeItemType TreeSymlink) <$> hashSymlink linktarget @@ -376,7 +376,7 @@ -} changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do tmpwt <- fromRepo gitAnnexMergeDir - git_dir <- fromRepo Git.localGitDir + git_dir <- fromRawFilePath <$> fromRepo Git.localGitDir withTmpDirIn othertmpdir "git" $ \tmpgit -> withWorkTreeRelated tmpgit $ withemptydir tmpwt $ withWorkTree tmpwt $ do liftIO $ writeFile (tmpgit "HEAD") (fromRef updatedorig) @@ -580,7 +580,7 @@ where m = M.fromList $ map (\i@(TreeItem f' _ _) -> (norm f', i)) $ map diffTreeToTreeItem changes - norm = normalise . getTopFilePath + norm = normalise . fromRawFilePath . getTopFilePath diffTreeToTreeItem :: Git.DiffTree.DiffTreeItem -> TreeItem diffTreeToTreeItem dti = TreeItem diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.AutoMerge ( autoMergeFrom , resolveMerge @@ -122,7 +124,7 @@ unless (null deleted) $ Annex.Queue.addCommand "rm" [Param "--quiet", Param "-f", Param "--"] - deleted + (map fromRawFilePath deleted) void $ liftIO cleanup2 when merged $ do @@ -169,7 +171,7 @@ -- Neither side is annexed file; cannot resolve. (Nothing, Nothing) -> return ([], Nothing) where - file = LsFiles.unmergedFile u + file = fromRawFilePath $ LsFiles.unmergedFile u getkey select = case select (LsFiles.unmergedSha u) of @@ -196,30 +198,30 @@ stagefile :: FilePath -> Annex FilePath stagefile f - | inoverlay = ( f) <$> fromRepo Git.repoPath + | inoverlay = ( f) . fromRawFilePath <$> fromRepo Git.repoPath | otherwise = pure f makesymlink key dest = do l <- calcRepo $ gitAnnexLink dest key unless inoverlay $ replacewithsymlink dest l - dest' <- stagefile dest + dest' <- toRawFilePath <$> stagefile dest stageSymlink dest' =<< hashSymlink l replacewithsymlink dest link = withworktree dest $ \f -> - replaceFile f $ makeGitLink link + replaceFile f $ makeGitLink link . toRawFilePath makepointer key dest destmode = do unless inoverlay $ unlessM (reuseOldFile unstagedmap key file dest) $ linkFromAnnex key dest destmode >>= \case LinkAnnexFailed -> liftIO $ - writePointerFile dest key destmode + writePointerFile (toRawFilePath dest) key destmode _ -> noop - dest' <- stagefile dest + dest' <- toRawFilePath <$> stagefile dest stagePointerFile dest' destmode =<< hashPointerFile key unless inoverlay $ Database.Keys.addAssociatedFile key - =<< inRepo (toTopFilePath dest) + =<< inRepo (toTopFilePath (toRawFilePath dest)) withworktree f a = a f @@ -239,7 +241,7 @@ Nothing -> noop Just sha -> do link <- catSymLinkTarget sha - replacewithsymlink item link + replacewithsymlink item (fromRawFilePath link) -- And when grafting in anything else vs a symlink, -- the work tree already contains what we want. (_, Just TreeSymlink) -> noop @@ -290,8 +292,8 @@ matchesresolved is i f | S.member f fs || S.member (conflictCruftBase f) fs = anyM id [ pure (S.member i is) - , inks <$> isAnnexLink f - , inks <$> liftIO (isPointerFile f) + , inks <$> isAnnexLink (toRawFilePath f) + , inks <$> liftIO (isPointerFile (toRawFilePath f)) ] | otherwise = return False @@ -328,13 +330,13 @@ type InodeMap = M.Map InodeCacheKey FilePath -inodeMap :: Annex ([FilePath], IO Bool) -> Annex InodeMap +inodeMap :: Annex ([RawFilePath], IO Bool) -> Annex InodeMap inodeMap getfiles = do (fs, cleanup) <- getfiles fsis <- forM fs $ \f -> do mi <- withTSDelta (liftIO . genInodeCache f) return $ case mi of Nothing -> Nothing - Just i -> Just (inodeCacheToKey Strongly i, f) + Just i -> Just (inodeCacheToKey Strongly i, fromRawFilePath f) void $ liftIO cleanup return $ M.fromList $ catMaybes fsis diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -215,7 +215,7 @@ - content is returned. - - Returns an empty string if the file doesn't exist yet. -} -get :: FilePath -> Annex L.ByteString +get :: RawFilePath -> Annex L.ByteString get file = do update getLocal file @@ -224,21 +224,21 @@ - reflect changes in remotes. - (Changing the value this returns, and then merging is always the - same as using get, and then changing its value.) -} -getLocal :: FilePath -> Annex L.ByteString +getLocal :: RawFilePath -> Annex L.ByteString getLocal file = go =<< getJournalFileStale file where go (Just journalcontent) = return journalcontent go Nothing = getRef fullname file {- Gets the content of a file as staged in the branch's index. -} -getStaged :: FilePath -> Annex L.ByteString +getStaged :: RawFilePath -> Annex L.ByteString getStaged = getRef indexref where -- This makes git cat-file be run with ":file", -- so it looks at the index. indexref = Ref "" -getHistorical :: RefDate -> FilePath -> Annex L.ByteString +getHistorical :: RefDate -> RawFilePath -> Annex L.ByteString getHistorical date file = -- This check avoids some ugly error messages when the reflog -- is empty. @@ -247,7 +247,7 @@ , getRef (Git.Ref.dateRef fullname date) file ) -getRef :: Ref -> FilePath -> Annex L.ByteString +getRef :: Ref -> RawFilePath -> Annex L.ByteString getRef ref file = withIndex $ catFile ref file {- Applies a function to modify the content of a file. @@ -255,11 +255,11 @@ - Note that this does not cause the branch to be merged, it only - modifes the current content of the file on the branch. -} -change :: Journalable content => FilePath -> (L.ByteString -> content) -> Annex () +change :: Journalable content => RawFilePath -> (L.ByteString -> content) -> Annex () change file f = lockJournal $ \jl -> f <$> getLocal file >>= set jl file {- Applies a function which can modify the content of a file, or not. -} -maybeChange :: Journalable content => FilePath -> (L.ByteString -> Maybe content) -> Annex () +maybeChange :: Journalable content => RawFilePath -> (L.ByteString -> Maybe content) -> Annex () maybeChange file f = lockJournal $ \jl -> do v <- getLocal file case f v of @@ -269,7 +269,7 @@ _ -> noop {- Records new content of a file into the journal -} -set :: Journalable content => JournalLocked -> FilePath -> content -> Annex () +set :: Journalable content => JournalLocked -> RawFilePath -> content -> Annex () set = setJournalFile {- Commit message used when making a commit of whatever data has changed @@ -353,23 +353,23 @@ {- Lists all files on the branch. including ones in the journal - that have not been committed yet. There may be duplicates in the list. -} -files :: Annex [FilePath] +files :: Annex [RawFilePath] files = do update -- ++ forces the content of the first list to be buffered in memory, -- so use getJournalledFilesStale which should be much smaller most -- of the time. branchFiles will stream as the list is consumed. (++) - <$> getJournalledFilesStale + <$> (map toRawFilePath <$> getJournalledFilesStale) <*> branchFiles {- Files in the branch, not including any from journalled changes, - and without updating the branch. -} -branchFiles :: Annex [FilePath] +branchFiles :: Annex [RawFilePath] branchFiles = withIndex $ inRepo branchFiles' -branchFiles' :: Git.Repo -> IO [FilePath] -branchFiles' = Git.Command.pipeNullSplitZombie +branchFiles' :: Git.Repo -> IO [RawFilePath] +branchFiles' = Git.Command.pipeNullSplitZombie' (lsTreeParams Git.LsTree.LsTreeRecursive fullname [Param "--name-only"]) {- Populates the branch's index file with the current branch contents. @@ -482,7 +482,7 @@ sha <- Git.HashObject.hashFile h path hPutStrLn jlogh file streamer $ Git.UpdateIndex.updateIndexLine - sha TreeFile (asTopFilePath $ fileJournal file) + sha TreeFile (asTopFilePath $ fileJournal $ toRawFilePath file) genstream dir h jh jlogh streamer -- Clean up the staged files, as listed in the temp log file. -- The temp file is used to avoid needing to buffer all the @@ -593,7 +593,7 @@ if L.null content' then do Annex.Queue.addUpdateIndex - =<< inRepo (Git.UpdateIndex.unstageFile file) + =<< inRepo (Git.UpdateIndex.unstageFile (fromRawFilePath file)) -- File is deleted; can't run any other -- transitions on it. return () diff --git a/Annex/Branch/Transitions.hs b/Annex/Branch/Transitions.hs --- a/Annex/Branch/Transitions.hs +++ b/Annex/Branch/Transitions.hs @@ -34,7 +34,7 @@ = ChangeFile Builder | PreserveFile -type TransitionCalculator = TrustMap -> M.Map UUID RemoteConfig -> FilePath -> L.ByteString -> FileTransition +type TransitionCalculator = TrustMap -> M.Map UUID RemoteConfig -> RawFilePath -> L.ByteString -> FileTransition getTransitionCalculator :: Transition -> Maybe TransitionCalculator getTransitionCalculator ForgetGitHistory = Nothing diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -1,6 +1,6 @@ {- git cat-file interface, with handle automatically stored in the Annex monad - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -16,6 +16,7 @@ catObjectMetaData, catFileStop, catKey, + catKey', catSymLinkTarget, catKeyFile, catKeyFileHEAD, @@ -39,12 +40,12 @@ import Annex.CurrentBranch import Types.AdjustedBranch -catFile :: Git.Branch -> FilePath -> Annex L.ByteString +catFile :: Git.Branch -> RawFilePath -> Annex L.ByteString catFile branch file = do h <- catFileHandle liftIO $ Git.CatFile.catFile h branch file -catFileDetails :: Git.Branch -> FilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType)) +catFileDetails :: Git.Branch -> RawFilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails branch file = do h <- catFileHandle liftIO $ Git.CatFile.catFileDetails h branch file @@ -54,7 +55,7 @@ h <- catFileHandle liftIO $ Git.CatFile.catObject h ref -catObjectMetaData :: Git.Ref -> Annex (Maybe (Integer, ObjectType)) +catObjectMetaData :: Git.Ref -> Annex (Maybe (Sha, Integer, ObjectType)) catObjectMetaData ref = do h <- catFileHandle liftIO $ Git.CatFile.catObjectMetaData h ref @@ -99,18 +100,20 @@ {- From ref to a symlink or a pointer file, get the key. -} catKey :: Ref -> Annex (Maybe Key) -catKey ref = go =<< catObjectMetaData ref - where - go (Just (sz, _)) - -- Avoid catting large files, that cannot be symlinks or - -- pointer files, which would require buffering their - -- content in memory, as well as a lot of IO. - | sz <= maxPointerSz = parseLinkTargetOrPointer . L.toStrict <$> catObject ref - go _ = return Nothing +catKey ref = catKey' ref =<< catObjectMetaData ref +catKey' :: Ref -> Maybe (Sha, Integer, ObjectType) -> Annex (Maybe Key) +catKey' ref (Just (_, sz, _)) + -- Avoid catting large files, that cannot be symlinks or + -- pointer files, which would require buffering their + -- content in memory, as well as a lot of IO. + | sz <= maxPointerSz = + parseLinkTargetOrPointer . L.toStrict <$> catObject ref +catKey' _ _ = return Nothing + {- Gets a symlink target. -} -catSymLinkTarget :: Sha -> Annex String -catSymLinkTarget sha = fromInternalGitPath . decodeBL <$> get +catSymLinkTarget :: Sha -> Annex RawFilePath +catSymLinkTarget sha = fromInternalGitPath . L.toStrict <$> get where -- Avoid buffering the whole file content, which might be large. -- 8192 is enough if it really is a symlink. @@ -137,24 +140,24 @@ - - So, this gets info from the index, unless running as a daemon. -} -catKeyFile :: FilePath -> Annex (Maybe Key) +catKeyFile :: RawFilePath -> Annex (Maybe Key) catKeyFile f = ifM (Annex.getState Annex.daemon) ( catKeyFileHEAD f , catKey $ Git.Ref.fileRef f ) -catKeyFileHEAD :: FilePath -> Annex (Maybe Key) +catKeyFileHEAD :: RawFilePath -> Annex (Maybe Key) catKeyFileHEAD f = catKey $ Git.Ref.fileFromRef Git.Ref.headRef f {- Look in the original branch from whence an adjusted branch is based - to find the file. But only when the adjustment hides some files. -} -catKeyFileHidden :: FilePath -> CurrBranch -> Annex (Maybe Key) +catKeyFileHidden :: RawFilePath -> CurrBranch -> Annex (Maybe Key) catKeyFileHidden = hiddenCat catKey -catObjectMetaDataHidden :: FilePath -> CurrBranch -> Annex (Maybe (Integer, ObjectType)) +catObjectMetaDataHidden :: RawFilePath -> CurrBranch -> Annex (Maybe (Sha, Integer, ObjectType)) catObjectMetaDataHidden = hiddenCat catObjectMetaData -hiddenCat :: (Ref -> Annex (Maybe a)) -> FilePath -> CurrBranch -> Annex (Maybe a) +hiddenCat :: (Ref -> Annex (Maybe a)) -> RawFilePath -> CurrBranch -> Annex (Maybe a) hiddenCat a f (Just origbranch, Just adj) | adjustmentHidesFiles adj = a (Git.Ref.fileFromRef origbranch f) hiddenCat _ _ _ = return Nothing diff --git a/Annex/ChangedRefs.hs b/Annex/ChangedRefs.hs --- a/Annex/ChangedRefs.hs +++ b/Annex/ChangedRefs.hs @@ -76,7 +76,7 @@ chan <- liftIO $ newTBMChanIO 100 g <- gitRepo - let refdir = Git.localGitDir g "refs" + let refdir = fromRawFilePath (Git.localGitDir g) "refs" liftIO $ createDirectoryIfMissing True refdir let notifyhook = Just $ notifyHook chan diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -89,17 +89,20 @@ import Annex.Content.PointerFile import Annex.Concurrent import Types.WorkerPool +import qualified Utility.RawFilePath as R +import qualified System.FilePath.ByteString as P + {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool -inAnnex key = inAnnexCheck key $ liftIO . doesFileExist +inAnnex key = inAnnexCheck key $ liftIO . R.doesPathExist {- Runs an arbitrary check on a key's content. -} -inAnnexCheck :: Key -> (FilePath -> Annex Bool) -> Annex Bool +inAnnexCheck :: Key -> (RawFilePath -> Annex Bool) -> Annex Bool inAnnexCheck key check = inAnnex' id False check key {- inAnnex that performs an arbitrary check of the key's content. -} -inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a +inAnnex' :: (a -> Bool) -> a -> (RawFilePath -> Annex a) -> Key -> Annex a inAnnex' isgood bad check key = withObjectLoc key $ \loc -> do r <- check loc if isgood r @@ -120,12 +123,15 @@ {- Like inAnnex, checks if the object file for a key exists, - but there are no guarantees it has the right content. -} objectFileExists :: Key -> Annex Bool -objectFileExists key = calcRepo (gitAnnexLocation key) >>= liftIO . doesFileExist +objectFileExists key = + calcRepo (gitAnnexLocation key) + >>= liftIO . R.doesPathExist {- A safer check; the key's content must not only be present, but - is not in the process of being removed. -} inAnnexSafe :: Key -> Annex (Maybe Bool) -inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key +inAnnexSafe key = + inAnnex' (fromMaybe True) (Just False) (go . fromRawFilePath) key where is_locked = Nothing is_unlocked = Just True @@ -246,7 +252,7 @@ lockContentUsing :: ContentLocker -> Key -> Annex a -> Annex a lockContentUsing locker key a = do - contentfile <- calcRepo $ gitAnnexLocation key + contentfile <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) lockfile <- contentLockFile key bracket (lock contentfile lockfile) @@ -474,11 +480,11 @@ , return False ) where - storeobject dest = ifM (liftIO $ doesFileExist dest) + storeobject dest = ifM (liftIO $ R.doesPathExist dest) ( alreadyhave - , modifyContent dest $ do + , modifyContent dest' $ do freezeContent src - liftIO $ moveFile src dest + liftIO $ moveFile src dest' g <- Annex.gitRepo fs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key @@ -486,6 +492,8 @@ ics <- mapM (populatePointerFile (Restage True) key dest) fs Database.Keys.storeInodeCaches' key [dest] (catMaybes ics) ) + where + dest' = fromRawFilePath dest alreadyhave = liftIO $ removeFile src checkSecureHashes :: Key -> Annex Bool @@ -505,7 +513,7 @@ linkToAnnex :: Key -> FilePath -> Maybe InodeCache -> Annex LinkAnnexResult linkToAnnex key src srcic = ifM (checkSecureHashes key) ( do - dest <- calcRepo (gitAnnexLocation key) + dest <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) modifyContent dest $ linkAnnex To key src srcic dest Nothing , return LinkAnnexFailed ) @@ -515,7 +523,7 @@ linkFromAnnex key dest destmode = do src <- calcRepo (gitAnnexLocation key) srcic <- withTSDelta (liftIO . genInodeCache src) - linkAnnex From key src srcic dest destmode + linkAnnex From key (fromRawFilePath src) srcic dest destmode data FromTo = From | To @@ -534,7 +542,7 @@ linkAnnex :: FromTo -> Key -> FilePath -> Maybe InodeCache -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult linkAnnex _ _ _ Nothing _ _ = return LinkAnnexFailed linkAnnex fromto key src (Just srcic) dest destmode = - withTSDelta (liftIO . genInodeCache dest) >>= \case + withTSDelta (liftIO . genInodeCache dest') >>= \case Just destic -> do cs <- Database.Keys.getInodeCaches key if null cs @@ -551,12 +559,13 @@ Linked -> noop checksrcunchanged where + dest' = toRawFilePath dest failed = do Database.Keys.addInodeCaches key [srcic] return LinkAnnexFailed - checksrcunchanged = withTSDelta (liftIO . genInodeCache src) >>= \case + checksrcunchanged = withTSDelta (liftIO . genInodeCache (toRawFilePath src)) >>= \case Just srcic' | compareStrong srcic srcic' -> do - destic <- withTSDelta (liftIO . genInodeCache dest) + destic <- withTSDelta (liftIO . genInodeCache dest') Database.Keys.addInodeCaches key $ catMaybes [destic, Just srcic] return LinkAnnexOk @@ -567,7 +576,7 @@ {- Removes the annex object file for a key. Lowlevel. -} unlinkAnnex :: Key -> Annex () unlinkAnnex key = do - obj <- calcRepo $ gitAnnexLocation key + obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) modifyContent obj $ do secureErase obj liftIO $ nukeFile obj @@ -616,15 +625,15 @@ else pure cache return $ if null cache' then Nothing - else Just (f, sameInodeCache f cache') + else Just (fromRawFilePath f, sameInodeCache f cache') {- Performs an action, passing it the location to use for a key's content. -} -withObjectLoc :: Key -> (FilePath -> Annex a) -> Annex a +withObjectLoc :: Key -> (RawFilePath -> Annex a) -> Annex a withObjectLoc key a = a =<< calcRepo (gitAnnexLocation key) cleanObjectLoc :: Key -> Annex () -> Annex () cleanObjectLoc key cleaner = do - file <- calcRepo $ gitAnnexLocation key + file <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) void $ tryIO $ thawContentDir file cleaner liftIO $ removeparents file (3 :: Int) @@ -640,8 +649,9 @@ removeAnnex :: ContentRemovalLock -> Annex () removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> cleanObjectLoc key $ do - secureErase file - liftIO $ nukeFile file + let file' = fromRawFilePath file + secureErase file' + liftIO $ nukeFile file' g <- Annex.gitRepo mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g) =<< Database.Keys.getAssociatedFiles key @@ -655,7 +665,7 @@ -- If it was a hard link to the annex object, -- that object might have been frozen as part of the -- removal process, so thaw it. - , void $ tryIO $ thawContent file + , void $ tryIO $ thawContent $ fromRawFilePath file ) {- Check if a file contains the unmodified content of the key. @@ -663,12 +673,12 @@ - The expensive way to tell is to do a verification of its content. - The cheaper way is to see if the InodeCache for the key matches the - file. -} -isUnmodified :: Key -> FilePath -> Annex Bool +isUnmodified :: Key -> RawFilePath -> Annex Bool isUnmodified key f = go =<< geti where go Nothing = return False go (Just fc) = isUnmodifiedCheap' key fc <||> expensivecheck fc - expensivecheck fc = ifM (verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified key f) + expensivecheck fc = ifM (verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified key (fromRawFilePath f)) ( do -- The file could have been modified while it was -- being verified. Detect that. @@ -691,7 +701,7 @@ - this may report a false positive when repeated edits are made to a file - within a small time window (eg 1 second). -} -isUnmodifiedCheap :: Key -> FilePath -> Annex Bool +isUnmodifiedCheap :: Key -> RawFilePath -> Annex Bool isUnmodifiedCheap key f = maybe (return False) (isUnmodifiedCheap' key) =<< withTSDelta (liftIO . genInodeCache f) @@ -703,7 +713,7 @@ - returns the file it was moved to. -} moveBad :: Key -> Annex FilePath moveBad key = do - src <- calcRepo $ gitAnnexLocation key + src <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) bad <- fromRepo gitAnnexBadDir let dest = bad takeFileName src createAnnexDirectory (parentDir dest) @@ -734,7 +744,7 @@ if depth < 2 then do contents' <- filterM (present s) contents - let keys = mapMaybe (fileKey . takeFileName) contents' + let keys = mapMaybe (fileKey . P.takeFileName . toRawFilePath) contents' continue keys [] else do let deeper = walk s (depth - 1) @@ -791,7 +801,7 @@ copy = ifM (liftIO $ doesFileExist file) ( return True , do - s <- calcRepo $ gitAnnexLocation key + s <- fromRawFilePath <$> (calcRepo $ gitAnnexLocation key) liftIO $ ifM (doesFileExist s) ( copyFileExternal CopyTimeStamps s file , return False @@ -808,7 +818,7 @@ contents <- liftIO $ getDirectoryContents dir files <- liftIO $ filterM doesFileExist $ map (dir ) contents - return $ mapMaybe (fileKey . takeFileName) files + return $ mapMaybe (fileKey . P.takeFileName . toRawFilePath) files , return [] ) @@ -827,7 +837,8 @@ dir <- fromRepo dirspec forM_ dups $ \k -> - pruneTmpWorkDirBefore (dir keyFile k) (liftIO . removeFile) + pruneTmpWorkDirBefore (dir fromRawFilePath (keyFile k)) + (liftIO . removeFile) if nottransferred then do diff --git a/Annex/Content/LowLevel.hs b/Annex/Content/LowLevel.hs --- a/Annex/Content/LowLevel.hs +++ b/Annex/Content/LowLevel.hs @@ -128,7 +128,7 @@ _ -> return True ) where - dir = maybe (fromRepo gitAnnexDir) return destdir + dir = maybe (fromRawFilePath <$> fromRepo gitAnnexDir) return destdir needMoreDiskSpace :: Integer -> String needMoreDiskSpace n = "not enough free space, need " ++ diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -30,17 +30,19 @@ - - Returns an InodeCache if it populated the pointer file. -} -populatePointerFile :: Restage -> Key -> FilePath -> FilePath -> Annex (Maybe InodeCache) +populatePointerFile :: Restage -> Key -> RawFilePath -> RawFilePath -> Annex (Maybe InodeCache) populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f) where go (Just k') | k == k' = do - destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f - liftIO $ nukeFile f - (ic, populated) <- replaceFile f $ \tmp -> do - ok <- linkOrCopy k obj tmp destmode >>= \case + let f' = fromRawFilePath f + destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f' + liftIO $ nukeFile f' + (ic, populated) <- replaceFile f' $ \tmp -> do + let tmp' = toRawFilePath tmp + ok <- linkOrCopy k (fromRawFilePath obj) tmp destmode >>= \case Just _ -> thawContent tmp >> return True - Nothing -> liftIO (writePointerFile tmp k destmode) >> return False - ic <- withTSDelta (liftIO . genInodeCache tmp) + Nothing -> liftIO (writePointerFile tmp' k destmode) >> return False + ic <- withTSDelta (liftIO . genInodeCache tmp') return (ic, ok) maybe noop (restagePointerFile restage f) ic if populated @@ -51,14 +53,15 @@ {- Removes the content from a pointer file, replacing it with a pointer. - - Does not check if the pointer file is modified. -} -depopulatePointerFile :: Key -> FilePath -> Annex () +depopulatePointerFile :: Key -> RawFilePath -> Annex () depopulatePointerFile key file = do - st <- liftIO $ catchMaybeIO $ getFileStatus file + let file' = fromRawFilePath file + st <- liftIO $ catchMaybeIO $ getFileStatus file' let mode = fmap fileMode st - secureErase file - liftIO $ nukeFile file - ic <- replaceFile file $ \tmp -> do - liftIO $ writePointerFile tmp key mode + secureErase file' + liftIO $ nukeFile file' + ic <- replaceFile file' $ \tmp -> do + liftIO $ writePointerFile (toRawFilePath tmp) key mode #if ! defined(mingw32_HOST_OS) -- Don't advance mtime; this avoids unncessary re-smudging -- by git in some cases. @@ -66,5 +69,5 @@ (\t -> touch tmp t False) (fmap modificationTimeHiRes st) #endif - withTSDelta (liftIO . genInodeCache tmp) + withTSDelta (liftIO . genInodeCache (toRawFilePath tmp)) maybe noop (restagePointerFile (Restage True) file) ic diff --git a/Annex/Difference.hs b/Annex/Difference.hs --- a/Annex/Difference.hs +++ b/Annex/Difference.hs @@ -54,5 +54,5 @@ else return ds ) forM_ (listDifferences ds') $ \d -> - setConfig (ConfigKey $ differenceConfigKey d) (differenceConfigVal d) + setConfig (differenceConfigKey d) (differenceConfigVal d) recordDifferences ds' u diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs --- a/Annex/DirHashes.hs +++ b/Annex/DirHashes.hs @@ -1,6 +1,6 @@ {- git-annex file locations - - - Copyright 2010-2017 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -19,7 +19,10 @@ import Data.Default import Data.Bits -import qualified Data.ByteArray +import qualified Data.ByteArray as BA +import qualified Data.ByteArray.Encoding as BA +import qualified Data.ByteString as S +import qualified System.FilePath.ByteString as P import Common import Key @@ -28,7 +31,7 @@ import Utility.Hash import Utility.MD5 -type Hasher = Key -> FilePath +type Hasher = Key -> RawFilePath -- Number of hash levels to use. 2 is the default. newtype HashLevels = HashLevels Int @@ -47,7 +50,7 @@ | hasDifference d (annexDifferences config) = HashLevels 1 | otherwise = def -branchHashDir :: GitConfig -> Key -> String +branchHashDir :: GitConfig -> Key -> S.ByteString branchHashDir = hashDirLower . branchHashLevels {- Two different directory hashes may be used. The mixed case hash @@ -60,19 +63,26 @@ dirHashes :: [HashLevels -> Hasher] dirHashes = [hashDirLower, hashDirMixed] -hashDirs :: HashLevels -> Int -> String -> FilePath -hashDirs (HashLevels 1) sz s = addTrailingPathSeparator $ take sz s -hashDirs _ sz s = addTrailingPathSeparator $ take sz s drop sz s +hashDirs :: HashLevels -> Int -> S.ByteString -> RawFilePath +hashDirs (HashLevels 1) sz s = P.addTrailingPathSeparator $ S.take sz s +hashDirs _ sz s = P.addTrailingPathSeparator $ h P. t + where + (h, t) = S.splitAt sz s hashDirLower :: HashLevels -> Hasher -hashDirLower n k = hashDirs n 3 $ take 6 $ show $ md5s $ serializeKey' $ nonChunkKey k +hashDirLower n k = hashDirs n 3 $ S.pack $ take 6 $ conv $ + md5s $ serializeKey' $ nonChunkKey k + where + conv v = BA.unpack $ + (BA.convertToBase BA.Base16 v :: BA.Bytes) {- This was originally using Data.Hash.MD5 from MissingH. This new version - is faster, but ugly as it has to replicate the 4 Word32's that produced. -} hashDirMixed :: HashLevels -> Hasher -hashDirMixed n k = hashDirs n 2 $ take 4 $ concatMap display_32bits_as_dir $ - encodeWord32 $ map fromIntegral $ Data.ByteArray.unpack $ - Utility.Hash.md5s $ serializeKey' $ nonChunkKey k +hashDirMixed n k = hashDirs n 2 $ S.pack $ take 4 $ + concatMap display_32bits_as_dir $ + encodeWord32 $ map fromIntegral $ BA.unpack $ + Utility.Hash.md5s $ serializeKey' $ nonChunkKey k where encodeWord32 (b1:b2:b3:b4:rest) = (shiftL b4 24 .|. shiftL b3 16 .|. shiftL b2 8 .|. b1) diff --git a/Annex/Drop.hs b/Annex/Drop.hs --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -49,7 +49,8 @@ handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex () handleDropsFrom locs rs reason fromhere key afile preverified runner = do g <- Annex.gitRepo - l <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key + l <- map (`fromTopFilePath` g) + <$> Database.Keys.getAssociatedFiles key let fs = case afile of AssociatedFile (Just f) -> nub (f : l) AssociatedFile Nothing -> l @@ -62,7 +63,7 @@ (untrusted, have) <- trustPartition UnTrusted locs numcopies <- if null fs then getNumCopies - else maximum <$> mapM getFileNumCopies fs + else maximum <$> mapM (getFileNumCopies . fromRawFilePath) fs return (NumCopies (length have), numcopies, S.fromList untrusted) {- Check that we have enough copies still to drop the content. @@ -107,7 +108,7 @@ [ "dropped" , case afile of AssociatedFile Nothing -> serializeKey key - AssociatedFile (Just af) -> af + AssociatedFile (Just af) -> fromRawFilePath af , "(from " ++ maybe "here" show u ++ ")" , "(copies now " ++ show (fromNumCopies have - 1) ++ ")" , ": " ++ reason diff --git a/Annex/Environment.hs b/Annex/Environment.hs --- a/Annex/Environment.hs +++ b/Annex/Environment.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.Environment where import Annex.Common @@ -45,6 +47,6 @@ where retry _ = do name <- liftIO $ either (const "unknown") id <$> myUserName - setConfig (ConfigKey "user.name") name - setConfig (ConfigKey "user.email") name + setConfig "user.name" name + setConfig "user.email" name a diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -20,8 +20,12 @@ preferredContentParser, ParseToken, parsedToMatcher, - mkLargeFilesParser, + mkMatchExpressionParser, largeFilesMatcher, + AddUnlockedMatcher, + addUnlockedMatcher, + checkAddUnlockedMatcher, + module Types.FileMatcher ) where import qualified Data.Map as M @@ -30,12 +34,14 @@ import Limit import Utility.Matcher import Types.Group -import qualified Annex import Types.FileMatcher +import Types.GitConfig +import Config.GitConfig import Git.FilePath import Types.Remote (RemoteConfig) import Annex.CheckAttr import Git.CheckAttr (unspecifiedAttr) +import qualified Git.Config #ifdef WITH_MAGICMIME import Annex.Magic #endif @@ -54,7 +60,7 @@ matcher <- getmatcher file checkMatcher matcher Nothing afile S.empty notconfigured d where - afile = AssociatedFile (Just file) + afile = AssociatedFile (Just (toRawFilePath file)) -- checkMatcher will never use this, because afile is provided. d = return True @@ -72,7 +78,7 @@ checkMatcher' matcher mi notpresent = matchMrun matcher $ \a -> a notpresent mi -fileMatchInfo :: FilePath -> Annex MatchInfo +fileMatchInfo :: RawFilePath -> Annex MatchInfo fileMatchInfo file = do matchfile <- getTopFilePath <$> inRepo (toTopFilePath file) return $ MatchingFile FileInfo @@ -173,8 +179,8 @@ preferredContentParser :: [ParseToken (MatchFiles Annex)] -> String -> [ParseResult (MatchFiles Annex)] preferredContentParser tokens = map (parseToken tokens) . tokenizeMatcher -mkLargeFilesParser :: Annex (String -> [ParseResult (MatchFiles Annex)]) -mkLargeFilesParser = do +mkMatchExpressionParser :: Annex (String -> [ParseResult (MatchFiles Annex)]) +mkMatchExpressionParser = do #ifdef WITH_MAGICMIME magicmime <- liftIO initMagicMime let mimer n f = ValueToken n (usev $ f magicmime) @@ -197,26 +203,57 @@ ] #endif return $ map parse . tokenizeMatcher - where {- Generates a matcher for files large enough (or meeting other criteria) - - to be added to the annex, rather than directly to git. -} + - to be added to the annex, rather than directly to git. + - + - annex.largefiles is configured in git config, or git attributes, + - or global git-annex config, in that order. + -} largeFilesMatcher :: Annex GetFileMatcher -largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig +largeFilesMatcher = go =<< getGitConfigVal' annexLargeFiles where - go (Just expr) = do - matcher <- mkmatcher expr + go (HasGitConfig (Just expr)) = do + matcher <- mkmatcher expr "git config" return $ const $ return matcher - go Nothing = return $ \file -> do + go v = return $ \file -> do expr <- checkAttr "annex.largefiles" file if null expr || expr == unspecifiedAttr - then return matchAll - else mkmatcher expr + then case v of + HasGlobalConfig (Just expr') -> + mkmatcher expr' "git-annex config" + _ -> return matchAll + else mkmatcher expr "gitattributes" - mkmatcher expr = do - parser <- mkLargeFilesParser - either badexpr return $ parsedToMatcher $ parser expr - badexpr e = giveup $ "bad annex.largefiles configuration: " ++ e + mkmatcher expr cfgfrom = do + parser <- mkMatchExpressionParser + either (badexpr cfgfrom) return $ parsedToMatcher $ parser expr + badexpr cfgfrom e = giveup $ "bad annex.largefiles configuration in " ++ cfgfrom ++ ": " ++ e + +newtype AddUnlockedMatcher = AddUnlockedMatcher (FileMatcher Annex) + +addUnlockedMatcher :: Annex AddUnlockedMatcher +addUnlockedMatcher = AddUnlockedMatcher <$> + (go =<< getGitConfigVal' annexAddUnlocked) + where + go (HasGitConfig (Just expr)) = mkmatcher expr "git config" + go (HasGlobalConfig (Just expr)) = mkmatcher expr "git annex config" + go _ = matchalways False + + mkmatcher :: String -> String -> Annex (FileMatcher Annex) + mkmatcher expr cfgfrom = case Git.Config.isTrueFalse expr of + Just b -> matchalways b + Nothing -> do + parser <- mkMatchExpressionParser + either (badexpr cfgfrom) return $ parsedToMatcher $ parser expr + badexpr cfgfrom e = giveup $ "bad annex.addunlocked configuration in " ++ cfgfrom ++ ": " ++ e + + matchalways True = return $ MOp limitAnything + matchalways False = return $ MOp limitNothing + +checkAddUnlockedMatcher :: AddUnlockedMatcher -> MatchInfo -> Annex Bool +checkAddUnlockedMatcher (AddUnlockedMatcher matcher) mi = + checkMatcher' matcher mi S.empty simply :: MatchFiles Annex -> ParseResult (MatchFiles Annex) simply = Right . Operation diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.Fixup where import Git.Types @@ -17,6 +19,7 @@ import Utility.Directory import Utility.Exception import Utility.Monad +import Utility.FileSystemEncoding import Utility.PartialPrelude import System.IO @@ -27,6 +30,8 @@ import Control.Monad import Control.Monad.IfElse import qualified Data.Map as M +import qualified System.FilePath.ByteString as P +import qualified Data.ByteString as S import Control.Applicative import Prelude @@ -50,10 +55,10 @@ fixupDirect :: Repo -> Repo fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do r - { location = l { worktree = Just (parentDir d) } + { location = l { worktree = Just (toRawFilePath (parentDir (fromRawFilePath d))) } , gitGlobalOpts = gitGlobalOpts r ++ [ Param "-c" - , Param $ coreBare ++ "=" ++ boolConfig False + , Param $ fromConfigKey coreBare ++ "=" ++ boolConfig False ] } fixupDirect r = r @@ -108,12 +113,13 @@ , return r ) where - dotgit = w ".git" + dotgit = w P. ".git" + dotgit' = fromRawFilePath dotgit - replacedotgit = whenM (doesFileExist dotgit) $ do - linktarget <- relPathDirToFile w d - nukeFile dotgit - createSymbolicLink linktarget dotgit + replacedotgit = whenM (doesFileExist dotgit') $ do + linktarget <- relPathDirToFile (fromRawFilePath w) (fromRawFilePath d) + nukeFile dotgit' + createSymbolicLink linktarget dotgit' unsetcoreworktree = maybe (error "unset core.worktree failed") (\_ -> return ()) @@ -123,13 +129,13 @@ -- git-worktree sets up a "commondir" file that contains -- the path to the main git directory. -- Using --separate-git-dir does not. - catchDefaultIO Nothing (headMaybe . lines <$> readFile (d "commondir")) >>= \case + catchDefaultIO Nothing (headMaybe . lines <$> readFile (fromRawFilePath (d P. "commondir"))) >>= \case Just gd -> do -- Make the worktree's git directory -- contain an annex symlink to the main -- repository's annex directory. let linktarget = gd "annex" - createSymbolicLink linktarget (dotgit "annex") + createSymbolicLink linktarget (dotgit' "annex") Nothing -> return () -- Repo adjusted, so that symlinks to objects that get checked @@ -139,12 +145,12 @@ | coreSymlinks c = r { location = l { gitdir = dotgit } } | otherwise = r - notnoannex = isNothing <$> noAnnexFileContent (Git.repoWorkTree r) + notnoannex = isNothing <$> noAnnexFileContent (fmap fromRawFilePath (Git.repoWorkTree r)) fixupUnusualRepos r _ = return r needsSubmoduleFixup :: Repo -> Bool needsSubmoduleFixup (Repo { location = (Local { worktree = Just _, gitdir = d }) }) = - (".git" "modules") `isInfixOf` d + (".git" P. "modules") `S.isInfixOf` d needsSubmoduleFixup _ = False needsGitLinkFixup :: Repo -> IO Bool @@ -152,6 +158,6 @@ -- Optimization: Avoid statting .git in the common case; only -- when the gitdir is not in the usual place inside the worktree -- might .git be a file. - | wt ".git" == d = return False - | otherwise = doesFileExist (wt ".git") + | wt P. ".git" == d = return False + | otherwise = doesFileExist (fromRawFilePath (wt P. ".git")) needsGitLinkFixup _ = return False diff --git a/Annex/GitOverlay.hs b/Annex/GitOverlay.hs --- a/Annex/GitOverlay.hs +++ b/Annex/GitOverlay.hs @@ -54,7 +54,7 @@ (\g -> return $ g { location = modlocation (location g), gitGlobalOpts = gitGlobalOpts g ++ disableSmudgeConfig }) (\g g' -> g' { location = location g, gitGlobalOpts = gitGlobalOpts g }) where - modlocation l@(Local {}) = l { worktree = Just d } + modlocation l@(Local {}) = l { worktree = Just (toRawFilePath d) } modlocation _ = error "withWorkTree of non-local git repo" disableSmudgeConfig = map Param [ "-c", "filter.annex.smudge=" @@ -73,7 +73,8 @@ withWorkTreeRelated d = withAltRepo modrepo unmodrepo where modrepo g = liftIO $ do - g' <- addGitEnv g "GIT_COMMON_DIR" =<< absPath (localGitDir g) + g' <- addGitEnv g "GIT_COMMON_DIR" + =<< absPath (fromRawFilePath (localGitDir g)) g'' <- addGitEnv g' "GIT_DIR" d return (g'' { gitEnvOverridesGitDir = True }) unmodrepo g g' = g' diff --git a/Annex/HashObject.hs b/Annex/HashObject.hs --- a/Annex/HashObject.hs +++ b/Annex/HashObject.hs @@ -21,7 +21,7 @@ hashObjectHandle = maybe startup return =<< Annex.getState Annex.hashobjecthandle where startup = do - h <- inRepo $ Git.HashObject.hashObjectStart + h <- inRepo $ Git.HashObject.hashObjectStart True Annex.changeState $ \s -> s { Annex.hashobjecthandle = Just h } return h diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -57,6 +57,7 @@ import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified System.FilePath.Posix as Posix +import qualified System.FilePath.ByteString as P {- Configures how to build an import tree. -} data ImportTreeConfig @@ -123,7 +124,7 @@ Nothing -> pure committedtree Just dir -> let subtreeref = Ref $ - fromRef committedtree ++ ":" ++ getTopFilePath dir + fromRef committedtree ++ ":" ++ fromRawFilePath (getTopFilePath dir) in fromMaybe emptyTree <$> inRepo (Git.Ref.tree subtreeref) updateexportdb importedtree @@ -267,9 +268,9 @@ let lf = fromImportLocation loc let treepath = asTopFilePath lf let topf = asTopFilePath $ - maybe lf (\sd -> getTopFilePath sd lf) msubdir + maybe lf (\sd -> getTopFilePath sd P. lf) msubdir relf <- fromRepo $ fromTopFilePath topf - symlink <- calcRepo $ gitAnnexLink relf k + symlink <- calcRepo $ gitAnnexLink (fromRawFilePath relf) k linksha <- hashSymlink symlink return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha @@ -327,7 +328,7 @@ (k:_) -> return $ Left $ Just (loc, k) [] -> do job <- liftIO $ newEmptyTMVarIO - let ai = ActionItemOther (Just (fromImportLocation loc)) + let ai = ActionItemOther (Just (fromRawFilePath (fromImportLocation loc))) let downloadaction = starting ("import " ++ Remote.name remote) ai $ do when oldversion $ showNote "old version" @@ -368,9 +369,9 @@ mkkey loc tmpfile = do f <- fromRepo $ fromTopFilePath $ locworktreefilename loc - backend <- chooseBackend f + backend <- chooseBackend (fromRawFilePath f) let ks = KeySource - { keyFilename = f + { keyFilename = (fromRawFilePath f) , contentLocation = tmpfile , inodeCache = Nothing } @@ -379,7 +380,7 @@ locworktreefilename loc = asTopFilePath $ case importtreeconfig of ImportTree -> fromImportLocation loc ImportSubTree subdir _ -> - getTopFilePath subdir fromImportLocation loc + getTopFilePath subdir P. fromImportLocation loc getcidkey cidmap db cid = liftIO $ CIDDb.getContentIdentifierKeys db rs cid >>= \case @@ -450,7 +451,7 @@ wantImport matcher loc sz = checkMatcher' matcher mi mempty where mi = MatchingInfo $ ProvidedInfo - { providedFilePath = Right $ fromImportLocation loc + { providedFilePath = Right $ fromRawFilePath $ fromImportLocation loc , providedKey = unavail "key" , providedFileSize = Right sz , providedMimeType = unavail "mime" @@ -503,4 +504,4 @@ , importableHistory = map removegitspecial (importableHistory ic) } - gitspecial l = ".git" `elem` Posix.splitDirectories (fromImportLocation l) + gitspecial l = ".git" `elem` Posix.splitDirectories (fromRawFilePath (fromImportLocation l)) diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -25,6 +25,7 @@ import Annex.Common import Types.KeySource +import Types.FileMatcher import Backend import Annex.Content import Annex.Perms @@ -45,6 +46,7 @@ import Git.FilePath import Annex.InodeSentinal import Annex.AdjustedBranch +import Annex.FileMatcher import Control.Exception (IOException) @@ -92,7 +94,7 @@ nohardlink = withTSDelta $ liftIO . nohardlink' nohardlink' delta = do - cache <- genInodeCache file delta + cache <- genInodeCache (toRawFilePath file) delta return $ LockedDown cfg $ KeySource { keyFilename = file , contentLocation = file @@ -112,7 +114,7 @@ withhardlink' delta tmpfile = do createLink file tmpfile - cache <- genInodeCache tmpfile delta + cache <- genInodeCache (toRawFilePath tmpfile) delta return $ LockedDown cfg $ KeySource { keyFilename = file , contentLocation = tmpfile @@ -136,7 +138,7 @@ then addLink f k mic else do mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus (contentLocation source) - stagePointerFile f mode =<< hashPointerFile k + stagePointerFile (toRawFilePath f) mode =<< hashPointerFile k return (Just k) {- Ingests a locked down file into the annex. Does not update the working @@ -187,7 +189,7 @@ gounlocked _ _ _ = failure "failed statting file" success k mcache s = do - genMetaData k (keyFilename source) s + genMetaData k (toRawFilePath (keyFilename source)) s return (Just k, mcache) failure msg = do @@ -202,7 +204,8 @@ finishIngestUnlocked' :: Key -> KeySource -> Restage -> Annex () finishIngestUnlocked' key source restage = do - Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (keyFilename source)) + Database.Keys.addAssociatedFile key + =<< inRepo (toTopFilePath (toRawFilePath (keyFilename source))) populateAssociatedFiles key source restage {- Copy to any other locations using the same key. -} @@ -211,7 +214,7 @@ obj <- calcRepo (gitAnnexLocation key) g <- Annex.gitRepo ingestedf <- flip fromTopFilePath g - <$> inRepo (toTopFilePath (keyFilename source)) + <$> inRepo (toTopFilePath (toRawFilePath (keyFilename source))) afs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key forM_ (filter (/= ingestedf) afs) $ populatePointerFile restage key obj @@ -226,8 +229,8 @@ cleanOldKeys :: FilePath -> Key -> Annex () cleanOldKeys file newkey = do g <- Annex.gitRepo - ingestedf <- flip fromTopFilePath g <$> inRepo (toTopFilePath file) - topf <- inRepo (toTopFilePath file) + topf <- inRepo (toTopFilePath (toRawFilePath file)) + ingestedf <- fromRepo $ fromTopFilePath topf oldkeys <- filter (/= newkey) <$> Database.Keys.getAssociatedKey topf forM_ oldkeys $ \key -> @@ -243,7 +246,7 @@ -- so no need for any recovery. (f:_) -> do ic <- withTSDelta (liftIO . genInodeCache f) - void $ linkToAnnex key f ic + void $ linkToAnnex key (fromRawFilePath f) ic _ -> logStatus key InfoMissing {- On error, put the file back so it doesn't seem to have vanished. @@ -254,7 +257,7 @@ liftIO $ nukeFile file -- The key could be used by other files too, so leave the -- content in the annex, and make a copy back to the file. - obj <- calcRepo $ gitAnnexLocation key + obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) unlessM (liftIO $ copyFileExternal CopyTimeStamps obj file) $ warning $ "Unable to restore content of " ++ file ++ "; it should be located in " ++ obj thawContent file @@ -264,7 +267,7 @@ makeLink :: FilePath -> Key -> Maybe InodeCache -> Annex String makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do l <- calcRepo $ gitAnnexLink file key - replaceFile file $ makeAnnexLink l + replaceFile file $ makeAnnexLink l . toRawFilePath -- touch symlink to have same time as the original file, -- as provided in the InodeCache @@ -291,7 +294,7 @@ Annex.Queue.addCommand "add" (ps++[Param "--"]) [file] , do l <- makeLink file key mcache - addAnnexLink l file + addAnnexLink l (toRawFilePath file) ) {- Parameters to pass to git add, forcing addition of ignored files. -} @@ -305,10 +308,10 @@ - unless symlinks are not supported. annex.addunlocked can override that. - Also, when in an adjusted unlocked branch, always add files unlocked. -} -addUnlocked :: Annex Bool -addUnlocked = +addUnlocked :: AddUnlockedMatcher -> MatchInfo -> Annex Bool +addUnlocked matcher mi = ((not . coreSymlinks <$> Annex.getGitConfig) <||> - (annexAddUnlocked <$> Annex.getGitConfig) <||> + (checkAddUnlockedMatcher matcher mi) <||> (maybe False isadjustedunlocked . snd <$> getCurrentBranch) ) where @@ -318,19 +321,20 @@ {- Adds a file to the work tree for the key, and stages it in the index. - The content of the key may be provided in a temp file, which will be - - moved into place. + - moved into place. If no content is provided, adds an annex link but does + - not ingest the content. - - When the content of the key is not accepted into the annex, returns False. -} -addAnnexedFile :: FilePath -> Key -> Maybe FilePath -> Annex Bool -addAnnexedFile file key mtmp = ifM addUnlocked +addAnnexedFile :: AddUnlockedMatcher -> FilePath -> Key -> Maybe FilePath -> Annex Bool +addAnnexedFile matcher file key mtmp = ifM (addUnlocked matcher mi) ( do mode <- maybe (pure Nothing) (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> getFileStatus tmp) mtmp - stagePointerFile file mode =<< hashPointerFile key - Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) + stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key + Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (toRawFilePath file)) case mtmp of Just tmp -> ifM (moveAnnex key tmp) ( linkunlocked mode >> return True @@ -347,8 +351,26 @@ Nothing -> return True ) where + mi = case mtmp of + Just tmp -> MatchingFile $ FileInfo + { currFile = toRawFilePath tmp + , matchFile = toRawFilePath 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. + Nothing -> MatchingInfo $ ProvidedInfo + { providedFilePath = Right file + , providedKey = Right key + , providedFileSize = Right $ fromMaybe 0 $ + keySize `fromKey` key + , providedMimeType = Right "application/octet-stream" + , providedMimeEncoding = Right "binary" + } + linkunlocked mode = linkFromAnnex key file mode >>= \case LinkAnnexFailed -> liftIO $ - writePointerFile file key mode + writePointerFile (toRawFilePath file) key mode _ -> return () - writepointer mode = liftIO $ writePointerFile file key mode + writepointer mode = liftIO $ writePointerFile (toRawFilePath file) key mode diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Annex.Init ( ensureInitialized, @@ -22,6 +23,7 @@ import qualified Git import qualified Git.Config import qualified Git.Objects +import Git.Types (fromConfigValue) import qualified Annex.Branch import Logs.UUID import Logs.Trust.Basic @@ -54,7 +56,7 @@ import qualified Data.Map as M checkCanInitialize :: Annex a -> Annex a -checkCanInitialize a = inRepo (noAnnexFileContent . Git.repoWorkTree) >>= \case +checkCanInitialize a = inRepo (noAnnexFileContent . fmap fromRawFilePath . Git.repoWorkTree) >>= \case Nothing -> a Just noannexmsg -> do warning "Initialization prevented by .noannex file (remove the file to override)" @@ -65,7 +67,9 @@ genDescription :: Maybe String -> Annex UUIDDesc genDescription (Just d) = return $ UUIDDesc $ encodeBS d genDescription Nothing = do - reldir <- liftIO . relHome =<< liftIO . absPath =<< fromRepo Git.repoPath + reldir <- liftIO . relHome + =<< liftIO . absPath . fromRawFilePath + =<< fromRepo Git.repoPath hostname <- fromMaybe "" <$> liftIO getHostname let at = if null hostname then "" else "@" v <- liftIO myUserName @@ -204,7 +208,7 @@ - filesystem. -} whenM (coreSymlinks <$> Annex.getGitConfig) $ do warning "Disabling core.symlinks." - setConfig (ConfigKey "core.symlinks") + setConfig "core.symlinks" (Git.Config.boolConfig False) probeLockSupport :: Annex Bool @@ -274,5 +278,5 @@ - affect it. -} propigateSecureHashesOnly :: Annex () propigateSecureHashesOnly = - maybe noop (setConfig (ConfigKey "annex.securehashesonly")) + maybe noop (setConfig "annex.securehashesonly" . fromConfigValue) =<< getGlobalConfig "annex.securehashesonly" diff --git a/Annex/InodeSentinal.hs b/Annex/InodeSentinal.hs --- a/Annex/InodeSentinal.hs +++ b/Annex/InodeSentinal.hs @@ -29,7 +29,7 @@ {- Checks if one of the provided old InodeCache matches the current - version of a file. -} -sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool +sameInodeCache :: RawFilePath -> [InodeCache] -> Annex Bool sameInodeCache _ [] = return False sameInodeCache file old = go =<< withTSDelta (liftIO . genInodeCache file) where @@ -78,7 +78,7 @@ createInodeSentinalFile evenwithobjects = unlessM (alreadyexists <||> hasobjects) $ do s <- annexSentinalFile - createAnnexDirectory (parentDir (sentinalFile s)) + createAnnexDirectory (parentDir (fromRawFilePath (sentinalFile s))) liftIO $ writeSentinalFile s where alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile diff --git a/Annex/Journal.hs b/Annex/Journal.hs --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -20,7 +20,9 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S +import qualified System.FilePath.ByteString as P import Data.ByteString.Builder +import Data.Char class Journalable t where writeJournalHandle :: Handle -> t -> IO () @@ -44,18 +46,18 @@ - getJournalFileStale to always return a consistent journal file - content, although possibly not the most current one. -} -setJournalFile :: Journalable content => JournalLocked -> FilePath -> content -> Annex () +setJournalFile :: Journalable content => JournalLocked -> RawFilePath -> content -> Annex () setJournalFile _jl file content = withOtherTmp $ \tmp -> do createAnnexDirectory =<< fromRepo gitAnnexJournalDir -- journal file is written atomically - jfile <- fromRepo $ journalFile file + jfile <- fromRawFilePath <$> fromRepo (journalFile file) let tmpfile = tmp takeFileName jfile liftIO $ do withFile tmpfile WriteMode $ \h -> writeJournalHandle h content moveFile tmpfile jfile {- Gets any journalled content for a file in the branch. -} -getJournalFile :: JournalLocked -> FilePath -> Annex (Maybe L.ByteString) +getJournalFile :: JournalLocked -> RawFilePath -> Annex (Maybe L.ByteString) getJournalFile _jl = getJournalFileStale {- Without locking, this is not guaranteed to be the most recent @@ -69,9 +71,9 @@ - concurrency or other issues with a lazy read, and the minor loss of - laziness doesn't matter much, as the files are not very large. -} -getJournalFileStale :: FilePath -> Annex (Maybe L.ByteString) +getJournalFileStale :: RawFilePath -> Annex (Maybe L.ByteString) getJournalFileStale file = inRepo $ \g -> catchMaybeIO $ - L.fromStrict <$> S.readFile (journalFile file g) + L.fromStrict <$> S.readFile (fromRawFilePath $ journalFile file g) {- List of existing journal files, but without locking, may miss new ones - just being added, or may have false positives if the journal is staged @@ -81,7 +83,8 @@ g <- gitRepo fs <- liftIO $ catchDefaultIO [] $ getDirectoryContents $ gitAnnexJournalDir g - return $ filter (`notElem` [".", ".."]) $ map fileJournal fs + return $ filter (`notElem` [".", ".."]) $ + map (fromRawFilePath . fileJournal . toRawFilePath) fs withJournalHandle :: (DirectoryHandle -> IO a) -> Annex a withJournalHandle a = do @@ -102,19 +105,33 @@ - used in the branch is not necessary, and all the files are put directly - in the journal directory. -} -journalFile :: FilePath -> Git.Repo -> FilePath -journalFile file repo = gitAnnexJournalDir repo concatMap mangle file +journalFile :: RawFilePath -> Git.Repo -> RawFilePath +journalFile file repo = gitAnnexJournalDir' repo P. S.concatMap mangle file where mangle c - | c == pathSeparator = "_" - | c == '_' = "__" - | otherwise = [c] + | P.isPathSeparator c = S.singleton underscore + | c == underscore = S.pack [underscore, underscore] + | otherwise = S.singleton c + underscore = fromIntegral (ord '_') {- Converts a journal file (relative to the journal dir) back to the - filename on the branch. -} -fileJournal :: FilePath -> FilePath -fileJournal = replace [pathSeparator, pathSeparator] "_" . - replace "_" [pathSeparator] +fileJournal :: RawFilePath -> RawFilePath +fileJournal = go + where + go b = + let (h, t) = S.break (== underscore) b + in h <> case S.uncons t of + Nothing -> t + Just (_u, t') -> case S.uncons t' of + Nothing -> t' + Just (w, t'') + | w == underscore -> + S.cons underscore (go t'') + | otherwise -> + S.cons P.pathSeparator (go t') + + underscore = fromIntegral (ord '_') {- Sentinal value, only produced by lockJournal; required - as a parameter by things that need to ensure the journal is diff --git a/Annex/Link.hs b/Annex/Link.hs --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -39,11 +39,12 @@ 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 type LinkTarget = String {- Checks if a file is a link to a key. -} -isAnnexLink :: FilePath -> Annex (Maybe Key) +isAnnexLink :: RawFilePath -> Annex (Maybe Key) isAnnexLink file = maybe Nothing parseLinkTargetOrPointer <$> getAnnexLinkTarget file {- Gets the link target of a symlink. @@ -54,13 +55,13 @@ - Returns Nothing if the file is not a symlink, or not a link to annex - content. -} -getAnnexLinkTarget :: FilePath -> Annex (Maybe S.ByteString) +getAnnexLinkTarget :: RawFilePath -> Annex (Maybe S.ByteString) getAnnexLinkTarget f = getAnnexLinkTarget' f =<< (coreSymlinks <$> Annex.getGitConfig) {- Pass False to force looking inside file, for when git checks out - symlinks as plain files. -} -getAnnexLinkTarget' :: FilePath -> Bool -> Annex (Maybe S.ByteString) +getAnnexLinkTarget' :: RawFilePath -> Bool -> Annex (Maybe S.ByteString) getAnnexLinkTarget' file coresymlinks = if coresymlinks then check probesymlink $ return Nothing @@ -75,9 +76,9 @@ | otherwise -> return Nothing Nothing -> fallback - probesymlink = R.readSymbolicLink $ toRawFilePath file + probesymlink = R.readSymbolicLink file - probefilecontent = withFile file ReadMode $ \h -> do + probefilecontent = withFile (fromRawFilePath file) ReadMode $ \h -> do s <- S.hGet h unpaddedMaxPointerSz -- If we got the full amount, the file is too large -- to be a symlink target. @@ -92,7 +93,7 @@ then mempty else s -makeAnnexLink :: LinkTarget -> FilePath -> Annex () +makeAnnexLink :: LinkTarget -> RawFilePath -> Annex () makeAnnexLink = makeGitLink {- Creates a link on disk. @@ -102,48 +103,48 @@ - it's staged as such, so use addAnnexLink when adding a new file or - modified link to git. -} -makeGitLink :: LinkTarget -> FilePath -> Annex () +makeGitLink :: LinkTarget -> RawFilePath -> Annex () makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig) ( liftIO $ do - void $ tryIO $ removeFile file - createSymbolicLink linktarget file - , liftIO $ writeFile file linktarget + void $ tryIO $ removeFile (fromRawFilePath file) + createSymbolicLink linktarget (fromRawFilePath file) + , liftIO $ writeFile (fromRawFilePath file) linktarget ) {- Creates a link on disk, and additionally stages it in git. -} -addAnnexLink :: LinkTarget -> FilePath -> Annex () +addAnnexLink :: LinkTarget -> RawFilePath -> Annex () addAnnexLink linktarget file = do makeAnnexLink linktarget file stageSymlink file =<< hashSymlink linktarget {- Injects a symlink target into git, returning its Sha. -} hashSymlink :: LinkTarget -> Annex Sha -hashSymlink linktarget = hashBlob $ toRawFilePath $ toInternalGitPath linktarget +hashSymlink = hashBlob . toInternalGitPath . toRawFilePath {- Stages a symlink to an annexed object, using a Sha of its target. -} -stageSymlink :: FilePath -> Sha -> Annex () +stageSymlink :: RawFilePath -> Sha -> Annex () stageSymlink file sha = Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.stageSymlink file sha) + inRepo (Git.UpdateIndex.stageSymlink (fromRawFilePath file) sha) {- Injects a pointer file content into git, returning its Sha. -} hashPointerFile :: Key -> Annex Sha hashPointerFile key = hashBlob $ formatPointer key {- Stages a pointer file, using a Sha of its content -} -stagePointerFile :: FilePath -> Maybe FileMode -> Sha -> Annex () +stagePointerFile :: RawFilePath -> Maybe FileMode -> Sha -> Annex () stagePointerFile file mode sha = Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.stageFile sha treeitemtype file) + inRepo (Git.UpdateIndex.stageFile sha treeitemtype $ fromRawFilePath file) where treeitemtype | maybe False isExecutable mode = TreeExecutable | otherwise = TreeFile -writePointerFile :: FilePath -> Key -> Maybe FileMode -> IO () +writePointerFile :: RawFilePath -> Key -> Maybe FileMode -> IO () writePointerFile file k mode = do - S.writeFile file (formatPointer k) - maybe noop (setFileMode file) mode + S.writeFile (fromRawFilePath file) (formatPointer k) + maybe noop (setFileMode $ fromRawFilePath file) mode newtype Restage = Restage Bool @@ -172,14 +173,14 @@ - the worktree file is changed by something else before git update-index - gets to look at it. -} -restagePointerFile :: Restage -> FilePath -> InodeCache -> Annex () +restagePointerFile :: Restage -> RawFilePath -> InodeCache -> Annex () restagePointerFile (Restage False) f _ = - toplevelWarning True $ unableToRestage (Just f) + toplevelWarning True $ unableToRestage $ Just $ fromRawFilePath f restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do -- update-index is documented as picky about "./file" and it -- fails on "../../repo/path/file" when cwd is not in the repo -- being acted on. Avoid these problems with an absolute path. - absf <- liftIO $ absPath f + absf <- liftIO $ absPath $ fromRawFilePath f Annex.Queue.addInternalAction runner [(absf, isunmodified tsd)] where isunmodified tsd = genInodeCache f tsd >>= return . \case @@ -200,7 +201,7 @@ unlockindex = liftIO . maybe noop Git.LockFile.closeLock showwarning = warning $ unableToRestage Nothing go Nothing = showwarning - go (Just _) = withTmpDirIn (Git.localGitDir r) "annexindex" $ \tmpdir -> do + go (Just _) = withTmpDirIn (fromRawFilePath $ Git.localGitDir r) "annexindex" $ \tmpdir -> do let tmpindex = tmpdir "index" let updatetmpindex = do r' <- Git.Env.addGitEnv r Git.Index.indexEnv @@ -252,7 +253,7 @@ {- Parses a symlink target to a Key. -} parseLinkTarget :: S.ByteString -> Maybe Key parseLinkTarget l - | isLinkToAnnex l = fileKey' $ snd $ S8.breakEnd pathsep l + | isLinkToAnnex l = fileKey $ snd $ S8.breakEnd pathsep l | otherwise = Nothing where pathsep '/' = True @@ -262,9 +263,9 @@ pathsep _ = False formatPointer :: Key -> S.ByteString -formatPointer k = prefix <> keyFile' k <> nl +formatPointer k = prefix <> keyFile k <> nl where - prefix = toRawFilePath $ toInternalGitPath (pathSeparator:objectDir) + prefix = toInternalGitPath $ P.pathSeparator `S.cons` objectDir' nl = S8.singleton '\n' {- Maximum size of a file that could be a pointer to a key. @@ -283,8 +284,8 @@ {- Checks if a worktree file is a pointer to a key. - - Unlocked files whose content is present are not detected by this. -} -isPointerFile :: FilePath -> IO (Maybe Key) -isPointerFile f = catchDefaultIO Nothing $ withFile f ReadMode $ \h -> +isPointerFile :: RawFilePath -> IO (Maybe Key) +isPointerFile f = catchDefaultIO Nothing $ withFile (fromRawFilePath f) ReadMode $ \h -> parseLinkTargetOrPointer <$> S.hGet h unpaddedMaxPointerSz {- Checks a symlink target or pointer file first line to see if it @@ -301,8 +302,7 @@ || p' `S.isInfixOf` s #endif where - sp = (pathSeparator:objectDir) - p = toRawFilePath sp + p = P.pathSeparator `S.cons` objectDir' #ifdef mingw32_HOST_OS - p' = toRawFilePath (toInternalGitPath sp) + p' = toInternalGitPath p #endif diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -9,13 +9,12 @@ module Annex.Locations ( keyFile, - keyFile', fileKey, - fileKey', keyPaths, keyPath, annexDir, objectDir, + objectDir', gitAnnexLocation, gitAnnexLocationDepth, gitAnnexLink, @@ -62,6 +61,7 @@ gitAnnexFeedState, gitAnnexMergeDir, gitAnnexJournalDir, + gitAnnexJournalDir', gitAnnexJournalLock, gitAnnexGitQueueLock, gitAnnexPreCommitLock, @@ -93,6 +93,7 @@ import Data.Char import Data.Default import qualified Data.ByteString.Char8 as S8 +import qualified System.FilePath.ByteString as P import Common import Key @@ -104,6 +105,7 @@ import Git.FilePath import Annex.DirHashes import Annex.Fixup +import qualified Utility.RawFilePath as R {- Conventions: - @@ -120,24 +122,27 @@ {- The directory git annex uses for local state, relative to the .git - directory -} -annexDir :: FilePath -annexDir = addTrailingPathSeparator "annex" +annexDir :: RawFilePath +annexDir = P.addTrailingPathSeparator "annex" {- The directory git annex uses for locally available object content, - relative to the .git directory -} objectDir :: FilePath -objectDir = addTrailingPathSeparator $ annexDir "objects" +objectDir = fromRawFilePath objectDir' +objectDir' :: RawFilePath +objectDir' = P.addTrailingPathSeparator $ annexDir P. "objects" + {- Annexed file's possible locations relative to the .git directory. - There are two different possibilities, using different hashes. - - Also, some repositories have a Difference in hash directory depth. -} -annexLocations :: GitConfig -> Key -> [FilePath] +annexLocations :: GitConfig -> Key -> [RawFilePath] annexLocations config key = map (annexLocation config key) dirHashes -annexLocation :: GitConfig -> Key -> (HashLevels -> Hasher) -> FilePath -annexLocation config key hasher = objectDir keyPath key (hasher $ objectHashLevels config) +annexLocation :: GitConfig -> Key -> (HashLevels -> Hasher) -> RawFilePath +annexLocation config key hasher = objectDir' P. keyPath key (hasher $ objectHashLevels config) {- Number of subdirectories from the gitAnnexObjectDir - to the gitAnnexLocation. -} @@ -157,9 +162,14 @@ - This does not take direct mode into account, so in direct mode it is not - the actual location of the file's content. -} -gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO FilePath -gitAnnexLocation key r config = gitAnnexLocation' key r config (annexCrippledFileSystem config) (coreSymlinks config) doesFileExist (Git.localGitDir r) -gitAnnexLocation' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (FilePath -> IO Bool) -> FilePath -> IO FilePath +gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO RawFilePath +gitAnnexLocation key r config = gitAnnexLocation' key r config + (annexCrippledFileSystem config) + (coreSymlinks config) + R.doesPathExist + (Git.localGitDir r) + +gitAnnexLocation' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (RawFilePath -> IO Bool) -> RawFilePath -> IO RawFilePath gitAnnexLocation' key r config crippled symlinkssupported checker gitdir {- Bare repositories default to hashDirLower for new - content, as it's more portable. But check all locations. -} @@ -181,7 +191,7 @@ only = return . inrepo . annexLocation config key checkall = check $ map inrepo $ annexLocations config key - inrepo d = gitdir d + inrepo d = gitdir P. d check locs@(l:_) = fromMaybe l <$> firstM checker locs check [] = error "internal" @@ -192,17 +202,22 @@ let absfile = absNormPathUnix currdir file let gitdir = getgitdir currdir loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir - toInternalGitPath <$> relPathDirToFile (parentDir absfile) loc + fromRawFilePath . toInternalGitPath . toRawFilePath + <$> relPathDirToFile (parentDir absfile) (fromRawFilePath loc) where getgitdir currdir {- This special case is for git submodules on filesystems not - supporting symlinks; generate link target that will - work portably. -} | not (coreSymlinks config) && needsSubmoduleFixup r = - absNormPathUnix currdir $ Git.repoPath r ".git" + toRawFilePath $ + absNormPathUnix currdir $ fromRawFilePath $ + Git.repoPath r P. ".git" | otherwise = Git.localGitDir r - absNormPathUnix d p = toInternalGitPath $ - absPathFrom (toInternalGitPath d) (toInternalGitPath p) + absNormPathUnix d p = fromRawFilePath $ toInternalGitPath $ toRawFilePath $ + absPathFrom + (fromRawFilePath $ toInternalGitPath $ toRawFilePath d) + (fromRawFilePath $ toInternalGitPath $ toRawFilePath p) {- Calculates a symlink target as would be used in a typical git - repository, with .git in the top of the work tree. -} @@ -211,7 +226,7 @@ where r' = case r of Git.Repo { Git.location = l@Git.Local { Git.worktree = Just wt } } -> - r { Git.location = l { Git.gitdir = wt ".git" } } + r { Git.location = l { Git.gitdir = wt P. ".git" } } _ -> r config' = config { annexCrippledFileSystem = False @@ -222,61 +237,69 @@ gitAnnexContentLock :: Key -> Git.Repo -> GitConfig -> IO FilePath gitAnnexContentLock key r config = do loc <- gitAnnexLocation key r config - return $ loc ++ ".lck" + return $ fromRawFilePath loc ++ ".lck" {- File that maps from a key to the file(s) in the git repository. - Used in direct mode. -} gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO FilePath gitAnnexMapping key r config = do loc <- gitAnnexLocation key r config - return $ loc ++ ".map" + return $ fromRawFilePath loc ++ ".map" {- File that caches information about a key's content, used to determine - if a file has changed. - Used in direct mode. -} gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO FilePath -gitAnnexInodeCache key r config = do +gitAnnexInodeCache key r config = do loc <- gitAnnexLocation key r config - return $ loc ++ ".cache" + return $ fromRawFilePath loc ++ ".cache" -gitAnnexInodeSentinal :: Git.Repo -> FilePath -gitAnnexInodeSentinal r = gitAnnexDir r "sentinal" +gitAnnexInodeSentinal :: Git.Repo -> RawFilePath +gitAnnexInodeSentinal r = gitAnnexDir r P. "sentinal" -gitAnnexInodeSentinalCache :: Git.Repo -> FilePath -gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r ++ ".cache" +gitAnnexInodeSentinalCache :: Git.Repo -> RawFilePath +gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r <> ".cache" {- The annex directory of a repository. -} -gitAnnexDir :: Git.Repo -> FilePath -gitAnnexDir r = addTrailingPathSeparator $ Git.localGitDir r annexDir +gitAnnexDir :: Git.Repo -> RawFilePath +gitAnnexDir r = P.addTrailingPathSeparator $ Git.localGitDir r P. annexDir {- The part of the annex directory where file contents are stored. -} gitAnnexObjectDir :: Git.Repo -> FilePath -gitAnnexObjectDir r = addTrailingPathSeparator $ Git.localGitDir r objectDir +gitAnnexObjectDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ Git.localGitDir r P. objectDir' {- .git/annex/tmp/ is used for temp files for key's contents -} gitAnnexTmpObjectDir :: Git.Repo -> FilePath -gitAnnexTmpObjectDir r = addTrailingPathSeparator $ gitAnnexDir r "tmp" +gitAnnexTmpObjectDir = fromRawFilePath . gitAnnexTmpObjectDir' +gitAnnexTmpObjectDir' :: Git.Repo -> RawFilePath +gitAnnexTmpObjectDir' r = P.addTrailingPathSeparator $ gitAnnexDir r P. "tmp" + {- .git/annex/othertmp/ is used for other temp files -} gitAnnexTmpOtherDir :: Git.Repo -> FilePath -gitAnnexTmpOtherDir r = addTrailingPathSeparator $ gitAnnexDir r "othertmp" +gitAnnexTmpOtherDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "othertmp" {- Lock file for gitAnnexTmpOtherDir. -} gitAnnexTmpOtherLock :: Git.Repo -> FilePath -gitAnnexTmpOtherLock r = gitAnnexDir r "othertmp.lck" +gitAnnexTmpOtherLock r = fromRawFilePath $ gitAnnexDir r P. "othertmp.lck" {- .git/annex/misctmp/ was used by old versions of git-annex and is still - used during initialization -} gitAnnexTmpOtherDirOld :: Git.Repo -> FilePath -gitAnnexTmpOtherDirOld r = addTrailingPathSeparator $ gitAnnexDir r "misctmp" +gitAnnexTmpOtherDirOld r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "misctmp" {- .git/annex/watchtmp/ is used by the watcher and assistant -} gitAnnexTmpWatcherDir :: Git.Repo -> FilePath -gitAnnexTmpWatcherDir r = addTrailingPathSeparator $ gitAnnexDir r "watchtmp" +gitAnnexTmpWatcherDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "watchtmp" {- The temp file to use for a given key's content. -} gitAnnexTmpObjectLocation :: Key -> Git.Repo -> FilePath -gitAnnexTmpObjectLocation key r = gitAnnexTmpObjectDir r keyFile key +gitAnnexTmpObjectLocation key r = fromRawFilePath $ + gitAnnexTmpObjectDir' r P. keyFile key {- Given a temp file such as gitAnnexTmpObjectLocation, makes a name for a - subdirectory in the same location, that can be used as a work area @@ -293,19 +316,21 @@ {- .git/annex/bad/ is used for bad files found during fsck -} gitAnnexBadDir :: Git.Repo -> FilePath -gitAnnexBadDir r = addTrailingPathSeparator $ gitAnnexDir r "bad" +gitAnnexBadDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "bad" {- The bad file to use for a given key. -} gitAnnexBadLocation :: Key -> Git.Repo -> FilePath -gitAnnexBadLocation key r = gitAnnexBadDir r keyFile key +gitAnnexBadLocation key r = gitAnnexBadDir r fromRawFilePath (keyFile key) {- .git/annex/foounused is used to number possibly unused keys -} gitAnnexUnusedLog :: FilePath -> Git.Repo -> FilePath -gitAnnexUnusedLog prefix r = gitAnnexDir r (prefix ++ "unused") +gitAnnexUnusedLog prefix r = + fromRawFilePath (gitAnnexDir r) (prefix ++ "unused") {- .git/annex/keys/ contains a database of information about keys. -} gitAnnexKeysDb :: Git.Repo -> FilePath -gitAnnexKeysDb r = gitAnnexDir r "keys" +gitAnnexKeysDb r = fromRawFilePath $ gitAnnexDir r P. "keys" {- Lock file for the keys database. -} gitAnnexKeysDbLock :: Git.Repo -> FilePath @@ -319,7 +344,8 @@ {- .git/annex/fsck/uuid/ is used to store information about incremental - fscks. -} gitAnnexFsckDir :: UUID -> Git.Repo -> FilePath -gitAnnexFsckDir u r = gitAnnexDir r "fsck" fromUUID u +gitAnnexFsckDir u r = fromRawFilePath $ + gitAnnexDir r P. "fsck" P. fromUUID u {- used to store information about incremental fscks. -} gitAnnexFsckState :: UUID -> Git.Repo -> FilePath @@ -335,20 +361,21 @@ {- .git/annex/fsckresults/uuid is used to store results of git fscks -} gitAnnexFsckResultsLog :: UUID -> Git.Repo -> FilePath -gitAnnexFsckResultsLog u r = gitAnnexDir r "fsckresults" fromUUID u +gitAnnexFsckResultsLog u r = fromRawFilePath $ + gitAnnexDir r P. "fsckresults" P. fromUUID u {- .git/annex/smudge.log is used to log smudges worktree files that need to - be updated. -} gitAnnexSmudgeLog :: Git.Repo -> FilePath -gitAnnexSmudgeLog r = gitAnnexDir r "smudge.log" +gitAnnexSmudgeLog r = fromRawFilePath $ gitAnnexDir r P. "smudge.log" gitAnnexSmudgeLock :: Git.Repo -> FilePath -gitAnnexSmudgeLock r = gitAnnexDir r "smudge.lck" +gitAnnexSmudgeLock r = fromRawFilePath $ gitAnnexDir r P. "smudge.lck" {- .git/annex/export/uuid/ is used to store information about - exports to special remotes. -} gitAnnexExportDir :: UUID -> Git.Repo -> FilePath -gitAnnexExportDir u r = gitAnnexDir r "export" fromUUID u +gitAnnexExportDir u r = fromRawFilePath (gitAnnexDir r) "export" fromUUID u {- Directory containing database used to record export info. -} gitAnnexExportDbDir :: UUID -> Git.Repo -> FilePath @@ -365,7 +392,8 @@ {- Log file used to keep track of files that were in the tree exported to a - remote, but were excluded by its preferred content settings. -} gitAnnexExportExcludeLog :: UUID -> Git.Repo -> FilePath -gitAnnexExportExcludeLog u r = gitAnnexDir r "export.ex" fromUUID u +gitAnnexExportExcludeLog u r = fromRawFilePath $ + gitAnnexDir r P. "export.ex" P. fromUUID u {- Directory containing database used to record remote content ids. - @@ -373,7 +401,7 @@ - need to be rebuilt with a new name.) -} gitAnnexContentIdentifierDbDir :: Git.Repo -> FilePath -gitAnnexContentIdentifierDbDir r = gitAnnexDir r "cids" +gitAnnexContentIdentifierDbDir r = fromRawFilePath $ gitAnnexDir r P. "cids" {- Lock file for writing to the content id database. -} gitAnnexContentIdentifierLock :: Git.Repo -> FilePath @@ -382,125 +410,137 @@ {- .git/annex/schedulestate is used to store information about when - scheduled jobs were last run. -} gitAnnexScheduleState :: Git.Repo -> FilePath -gitAnnexScheduleState r = gitAnnexDir r "schedulestate" +gitAnnexScheduleState r = fromRawFilePath $ gitAnnexDir r P. "schedulestate" {- .git/annex/creds/ is used to store credentials to access some special - remotes. -} gitAnnexCredsDir :: Git.Repo -> FilePath -gitAnnexCredsDir r = addTrailingPathSeparator $ gitAnnexDir r "creds" +gitAnnexCredsDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "creds" {- .git/annex/certificate.pem and .git/annex/key.pem are used by the webapp - when HTTPS is enabled -} gitAnnexWebCertificate :: Git.Repo -> FilePath -gitAnnexWebCertificate r = gitAnnexDir r "certificate.pem" +gitAnnexWebCertificate r = fromRawFilePath $ gitAnnexDir r P. "certificate.pem" gitAnnexWebPrivKey :: Git.Repo -> FilePath -gitAnnexWebPrivKey r = gitAnnexDir r "privkey.pem" +gitAnnexWebPrivKey r = fromRawFilePath $ gitAnnexDir r P. "privkey.pem" {- .git/annex/feeds/ is used to record per-key (url) state by importfeeds -} gitAnnexFeedStateDir :: Git.Repo -> FilePath -gitAnnexFeedStateDir r = addTrailingPathSeparator $ gitAnnexDir r "feedstate" +gitAnnexFeedStateDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "feedstate" gitAnnexFeedState :: Key -> Git.Repo -> FilePath -gitAnnexFeedState k r = gitAnnexFeedStateDir r keyFile k +gitAnnexFeedState k r = gitAnnexFeedStateDir r fromRawFilePath (keyFile k) {- .git/annex/merge/ is used as a empty work tree for direct mode merges and - merges in adjusted branches. -} gitAnnexMergeDir :: Git.Repo -> FilePath -gitAnnexMergeDir r = addTrailingPathSeparator $ gitAnnexDir r "merge" +gitAnnexMergeDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "merge" {- .git/annex/transfer/ is used to record keys currently - being transferred, and other transfer bookkeeping info. -} gitAnnexTransferDir :: Git.Repo -> FilePath -gitAnnexTransferDir r = addTrailingPathSeparator $ gitAnnexDir r "transfer" +gitAnnexTransferDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "transfer" {- .git/annex/journal/ is used to journal changes made to the git-annex - branch -} gitAnnexJournalDir :: Git.Repo -> FilePath -gitAnnexJournalDir r = addTrailingPathSeparator $ gitAnnexDir r "journal" +gitAnnexJournalDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "journal" +gitAnnexJournalDir' :: Git.Repo -> RawFilePath +gitAnnexJournalDir' r = P.addTrailingPathSeparator $ gitAnnexDir r P. "journal" + {- Lock file for the journal. -} gitAnnexJournalLock :: Git.Repo -> FilePath -gitAnnexJournalLock r = gitAnnexDir r "journal.lck" +gitAnnexJournalLock r = fromRawFilePath $ gitAnnexDir r P. "journal.lck" {- Lock file for flushing a git queue that writes to the git index or - other git state that should only have one writer at a time. -} gitAnnexGitQueueLock :: Git.Repo -> FilePath -gitAnnexGitQueueLock r = gitAnnexDir r "gitqueue.lck" +gitAnnexGitQueueLock r = fromRawFilePath $ gitAnnexDir r P. "gitqueue.lck" {- Lock file for the pre-commit hook. -} gitAnnexPreCommitLock :: Git.Repo -> FilePath -gitAnnexPreCommitLock r = gitAnnexDir r "precommit.lck" +gitAnnexPreCommitLock r = fromRawFilePath $ gitAnnexDir r P. "precommit.lck" {- Lock file for direct mode merge. -} gitAnnexMergeLock :: Git.Repo -> FilePath -gitAnnexMergeLock r = gitAnnexDir r "merge.lck" +gitAnnexMergeLock r = fromRawFilePath $ gitAnnexDir r P. "merge.lck" {- .git/annex/index is used to stage changes to the git-annex branch -} gitAnnexIndex :: Git.Repo -> FilePath -gitAnnexIndex r = gitAnnexDir r "index" +gitAnnexIndex r = fromRawFilePath $ gitAnnexDir r P. "index" {- Holds the ref of the git-annex branch that the index was last updated to. - - The .lck in the name is a historical accident; this is not used as a - lock. -} gitAnnexIndexStatus :: Git.Repo -> FilePath -gitAnnexIndexStatus r = gitAnnexDir r "index.lck" +gitAnnexIndexStatus r = fromRawFilePath $ gitAnnexDir r P. "index.lck" {- The index file used to generate a filtered branch view._-} gitAnnexViewIndex :: Git.Repo -> FilePath -gitAnnexViewIndex r = gitAnnexDir r "viewindex" +gitAnnexViewIndex r = fromRawFilePath $ gitAnnexDir r P. "viewindex" {- File containing a log of recently accessed views. -} gitAnnexViewLog :: Git.Repo -> FilePath -gitAnnexViewLog r = gitAnnexDir r "viewlog" +gitAnnexViewLog r = fromRawFilePath $ gitAnnexDir r P. "viewlog" {- List of refs that have already been merged into the git-annex branch. -} gitAnnexMergedRefs :: Git.Repo -> FilePath -gitAnnexMergedRefs r = gitAnnexDir r "mergedrefs" +gitAnnexMergedRefs r = fromRawFilePath $ gitAnnexDir r P. "mergedrefs" {- List of refs that should not be merged into the git-annex branch. -} gitAnnexIgnoredRefs :: Git.Repo -> FilePath -gitAnnexIgnoredRefs r = gitAnnexDir r "ignoredrefs" +gitAnnexIgnoredRefs r = fromRawFilePath $ gitAnnexDir r P. "ignoredrefs" {- Pid file for daemon mode. -} gitAnnexPidFile :: Git.Repo -> FilePath -gitAnnexPidFile r = gitAnnexDir r "daemon.pid" +gitAnnexPidFile r = fromRawFilePath $ gitAnnexDir r P. "daemon.pid" {- Pid lock file for pidlock mode -} gitAnnexPidLockFile :: Git.Repo -> FilePath -gitAnnexPidLockFile r = gitAnnexDir r "pidlock" +gitAnnexPidLockFile r = fromRawFilePath $ gitAnnexDir r P. "pidlock" {- Status file for daemon mode. -} gitAnnexDaemonStatusFile :: Git.Repo -> FilePath -gitAnnexDaemonStatusFile r = gitAnnexDir r "daemon.status" +gitAnnexDaemonStatusFile r = fromRawFilePath $ + gitAnnexDir r P. "daemon.status" {- Log file for daemon mode. -} gitAnnexLogFile :: Git.Repo -> FilePath -gitAnnexLogFile r = gitAnnexDir r "daemon.log" +gitAnnexLogFile r = fromRawFilePath $ gitAnnexDir r P. "daemon.log" {- Log file for fuzz test. -} gitAnnexFuzzTestLogFile :: Git.Repo -> FilePath -gitAnnexFuzzTestLogFile r = gitAnnexDir r "fuzztest.log" +gitAnnexFuzzTestLogFile r = fromRawFilePath $ + gitAnnexDir r P. "fuzztest.log" {- Html shim file used to launch the webapp. -} gitAnnexHtmlShim :: Git.Repo -> FilePath -gitAnnexHtmlShim r = gitAnnexDir r "webapp.html" +gitAnnexHtmlShim r = fromRawFilePath $ gitAnnexDir r P. "webapp.html" {- File containing the url to the webapp. -} gitAnnexUrlFile :: Git.Repo -> FilePath -gitAnnexUrlFile r = gitAnnexDir r "url" +gitAnnexUrlFile r = fromRawFilePath $ gitAnnexDir r P. "url" {- Temporary file used to edit configuriation from the git-annex branch. -} gitAnnexTmpCfgFile :: Git.Repo -> FilePath -gitAnnexTmpCfgFile r = gitAnnexDir r "config.tmp" +gitAnnexTmpCfgFile r = fromRawFilePath $ gitAnnexDir r P. "config.tmp" {- .git/annex/ssh/ is used for ssh connection caching -} gitAnnexSshDir :: Git.Repo -> FilePath -gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r "ssh" +gitAnnexSshDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "ssh" {- .git/annex/remotes/ is used for remote-specific state. -} gitAnnexRemotesDir :: Git.Repo -> FilePath -gitAnnexRemotesDir r = addTrailingPathSeparator $ gitAnnexDir r "remotes" +gitAnnexRemotesDir r = fromRawFilePath $ + P.addTrailingPathSeparator $ gitAnnexDir r P. "remotes" {- This is the base directory name used by the assistant when making - repositories, by default. -} @@ -557,11 +597,8 @@ - Changing what this function escapes and how is not a good idea, as it - can cause existing objects to get lost. -} -keyFile :: Key -> FilePath -keyFile = fromRawFilePath . keyFile' - -keyFile' :: Key -> RawFilePath -keyFile' k = +keyFile :: Key -> RawFilePath +keyFile k = let b = serializeKey' k in if S8.any (`elem` ['&', '%', ':', '/']) b then S8.concatMap esc b @@ -576,11 +613,8 @@ {- Reverses keyFile, converting a filename fragment (ie, the basename of - the symlink target) into a key. -} -fileKey :: FilePath -> Maybe Key -fileKey = fileKey' . toRawFilePath - -fileKey' :: RawFilePath -> Maybe Key -fileKey' = deserializeKey' . S8.intercalate "/" . map go . S8.split '%' +fileKey :: RawFilePath -> Maybe Key +fileKey = deserializeKey' . S8.intercalate "/" . map go . S8.split '%' where go = S8.concat . unescafterfirst . S8.split '&' unescafterfirst [] = [] @@ -599,8 +633,8 @@ - The file is put in a directory with the same name, this allows - write-protecting the directory to avoid accidental deletion of the file. -} -keyPath :: Key -> Hasher -> FilePath -keyPath key hasher = hasher key f f +keyPath :: Key -> Hasher -> RawFilePath +keyPath key hasher = hasher key P. f P. f where f = keyFile key @@ -610,5 +644,5 @@ - This is compatible with the annexLocations, for interoperability between - special remotes and git-annex repos. -} -keyPaths :: Key -> [FilePath] +keyPaths :: Key -> [RawFilePath] keyPaths key = map (\h -> keyPath key (h def)) dirHashes diff --git a/Annex/MetaData.hs b/Annex/MetaData.hs --- a/Annex/MetaData.hs +++ b/Annex/MetaData.hs @@ -37,7 +37,7 @@ - - Also, can generate new metadata, if configured to do so. -} -genMetaData :: Key -> FilePath -> FileStatus -> Annex () +genMetaData :: Key -> RawFilePath -> FileStatus -> Annex () genMetaData key file status = do catKeyFileHEAD file >>= \case Nothing -> noop @@ -53,8 +53,8 @@ where mtime = posixSecondsToUTCTime $ realToFrac $ modificationTime status warncopied = warning $ - "Copied metadata from old version of " ++ file ++ " to new version. " ++ - "If you don't want this copied metadata, run: git annex metadata --remove-all " ++ file + "Copied metadata from old version of " ++ fromRawFilePath file ++ " to new version. " ++ + "If you don't want this copied metadata, run: git annex metadata --remove-all " ++ fromRawFilePath file -- If the only fields copied were date metadata, and they'll -- be overwritten with the current mtime, no need to warn about -- copying. diff --git a/Annex/Notification.hs b/Annex/Notification.hs --- a/Annex/Notification.hs +++ b/Annex/Notification.hs @@ -60,7 +60,7 @@ wanted <- Annex.getState Annex.desktopnotify when (notifyFinish wanted) $ liftIO $ do client <- DBus.Client.connectSession - void $ Notify.notify client (droppedNote ok f) + void $ Notify.notify client (droppedNote ok (fromRawFilePath f)) #else notifyDrop (AssociatedFile (Just _)) _ = noop #endif diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -72,7 +72,7 @@ getAssociatedFileNumCopies :: AssociatedFile -> Annex NumCopies getAssociatedFileNumCopies (AssociatedFile afile) = - maybe getNumCopies getFileNumCopies afile + maybe getNumCopies getFileNumCopies (fromRawFilePath <$> afile) {- This is the globally visible numcopies value for a file. So it does - not include local configuration in the git config or command line diff --git a/Annex/Perms.hs b/Annex/Perms.hs --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -70,7 +70,7 @@ createAnnexDirectory :: FilePath -> Annex () createAnnexDirectory dir = walk dir [] =<< top where - top = parentDir <$> fromRepo gitAnnexDir + top = parentDir . fromRawFilePath <$> fromRepo gitAnnexDir walk d below stop | d `equalFilePath` stop = done | otherwise = ifM (liftIO $ doesDirectoryExist d) diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs --- a/Annex/SpecialRemote.hs +++ b/Annex/SpecialRemote.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.SpecialRemote ( module Annex.SpecialRemote, module Annex.SpecialRemote.Config @@ -92,7 +94,7 @@ _ -> return () where configured rc = fromMaybe False $ - Git.Config.isTrue =<< M.lookup autoEnableField rc + Git.Config.isTrueFalse =<< M.lookup autoEnableField rc canenable u = (/= DeadTrusted) <$> lookupTrust u getenabledremotes = M.fromList . map (\r -> (getcu r, r)) diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -43,6 +43,7 @@ #endif import Control.Concurrent.STM +import qualified Data.ByteString as S {- Some ssh commands are fed stdin on a pipe and so should be allowed to - consume it. But ssh commands that are not piped stdin should generally @@ -325,7 +326,7 @@ {- Note that this looks at the true length of the path in bytes, as it will - appear on disk. -} valid_unix_socket_path :: FilePath -> Bool -valid_unix_socket_path f = length (decodeW8 f) < sizeof_sockaddr_un_sun_path +valid_unix_socket_path f = S.length (encodeBS f) < sizeof_sockaddr_un_sun_path {- Parses the SSH port, and returns the other OpenSSH options. If - several ports are found, the last one takes precedence. -} diff --git a/Annex/UUID.hs b/Annex/UUID.hs --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -11,7 +11,10 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.UUID ( + configkeyUUID, getUUID, getRepoUUID, getUncachedUUID, @@ -32,6 +35,7 @@ import qualified Annex import qualified Git import qualified Git.Config +import Git.Types import Config import qualified Data.UUID as U @@ -39,8 +43,8 @@ import qualified Data.UUID.V5 as U5 import Data.String -configkey :: ConfigKey -configkey = annexConfig "uuid" +configkeyUUID :: ConfigKey +configkeyUUID = annexConfig "uuid" {- Generates a random UUID, that does not include the MAC address. -} genUUID :: IO UUID @@ -81,20 +85,16 @@ removeRepoUUID :: Annex () removeRepoUUID = do - unsetConfig configkey + unsetConfig configkeyUUID storeUUID NoUUID getUncachedUUID :: Git.Repo -> UUID -getUncachedUUID = toUUID . Git.Config.get key "" - where - (ConfigKey key) = configkey +getUncachedUUID = toUUID . Git.Config.get configkeyUUID "" -- Does the repo's config have a key for the UUID? -- True even when the key has no value. isUUIDConfigured :: Git.Repo -> Bool -isUUIDConfigured = isJust . Git.Config.getMaybe key - where - (ConfigKey key) = configkey +isUUIDConfigured = isJust . Git.Config.getMaybe configkeyUUID {- Make sure that the repo has an annex.uuid setting. -} prepUUID :: Annex () @@ -104,7 +104,7 @@ storeUUID :: UUID -> Annex () storeUUID u = do Annex.changeGitConfig $ \c -> c { annexUUID = u } - storeUUIDIn configkey u + storeUUIDIn configkeyUUID u storeUUIDIn :: ConfigKey -> UUID -> Annex () storeUUIDIn configfield = setConfig configfield . fromUUID @@ -112,7 +112,7 @@ {- Only sets the configkey in the Repo; does not change .git/config -} setUUID :: Git.Repo -> UUID -> IO Git.Repo setUUID r u = do - let s = show configkey ++ "=" ++ fromUUID u + let s = encodeBS' $ show configkeyUUID ++ "=" ++ fromUUID u Git.Config.store s r -- Dummy uuid for the whole web. Do not alter. diff --git a/Annex/VariantFile.hs b/Annex/VariantFile.hs --- a/Annex/VariantFile.hs +++ b/Annex/VariantFile.hs @@ -36,7 +36,7 @@ -} variantFile :: FilePath -> Key -> FilePath variantFile file key - | doubleconflict = mkVariant file (keyFile key) + | doubleconflict = mkVariant file (fromRawFilePath (keyFile key)) | otherwise = mkVariant file (shortHash $ serializeKey' key) where doubleconflict = variantMarker `isInfixOf` file diff --git a/Annex/Version.hs b/Annex/Version.hs --- a/Annex/Version.hs +++ b/Annex/Version.hs @@ -6,11 +6,13 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Annex.Version where import Annex.Common import Config +import Git.Types import Types.RepoVersion import qualified Annex diff --git a/Annex/View.hs b/Annex/View.hs --- a/Annex/View.hs +++ b/Annex/View.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.View where import Annex.Common @@ -80,7 +82,7 @@ ) where mkFilterValues v - | any (`elem` v) "*?" = FilterGlob v + | any (`elem` v) ['*', '?'] = FilterGlob v | otherwise = FilterValues $ S.singleton $ toMetaValue $ encodeBS v mkExcludeValues = ExcludeValues . S.singleton . toMetaValue . encodeBS @@ -358,13 +360,14 @@ go uh topf _sha _mode (Just k) = do metadata <- getCurrentMetaData k - let f = getTopFilePath topf + let f = fromRawFilePath $ getTopFilePath topf let metadata' = getfilemetadata f `unionMetaData` metadata forM_ (genviewedfiles f metadata') $ \fv -> do - f' <- fromRepo $ fromTopFilePath $ asTopFilePath fv + f' <- fromRawFilePath <$> + fromRepo (fromTopFilePath $ asTopFilePath $ toRawFilePath fv) stagesymlink uh f' =<< calcRepo (gitAnnexLink f' k) go uh topf (Just sha) (Just treeitemtype) Nothing - | "." `isPrefixOf` getTopFilePath topf = + | "." `B.isPrefixOf` getTopFilePath topf = liftIO $ Git.UpdateIndex.streamUpdateIndex' uh $ pureStreamer $ updateIndexLine sha treeitemtype topf go _ _ _ _ _ = noop @@ -403,7 +406,7 @@ =<< catKey (DiffTree.dstsha item) | otherwise = noop handlechange item a = maybe noop - (void . commandAction . a (getTopFilePath $ DiffTree.file item)) + (void . commandAction . a (fromRawFilePath $ getTopFilePath $ DiffTree.file item)) {- Runs an action using the view index file. - Note that the file does not necessarily exist, or can contain diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -23,6 +23,7 @@ import qualified Database.Keys import qualified Database.Keys.SQL import Config +import qualified Utility.RawFilePath as R {- Looks up the key corresponding to an annexed file in the work tree, - by examining what the file links to. @@ -33,35 +34,35 @@ - When in an adjusted branch that may have hidden the file, looks for a - pointer to a key in the original branch. -} -lookupFile :: FilePath -> Annex (Maybe Key) +lookupFile :: RawFilePath -> Annex (Maybe Key) lookupFile = lookupFile' catkeyfile where catkeyfile file = - ifM (liftIO $ doesFileExist file) + ifM (liftIO $ doesFileExist $ fromRawFilePath file) ( catKeyFile file , catKeyFileHidden file =<< getCurrentBranch ) -lookupFileNotHidden :: FilePath -> Annex (Maybe Key) +lookupFileNotHidden :: RawFilePath -> Annex (Maybe Key) lookupFileNotHidden = lookupFile' catkeyfile where catkeyfile file = - ifM (liftIO $ doesFileExist file) + ifM (liftIO $ doesFileExist $ fromRawFilePath file) ( catKeyFile file , return Nothing ) -lookupFile' :: (FilePath -> Annex (Maybe Key)) -> FilePath -> Annex (Maybe Key) +lookupFile' :: (RawFilePath -> Annex (Maybe Key)) -> RawFilePath -> Annex (Maybe Key) lookupFile' catkeyfile file = isAnnexLink file >>= \case Just key -> return (Just key) Nothing -> catkeyfile file {- Modifies an action to only act on files that are already annexed, - and passes the key on to it. -} -whenAnnexed :: (FilePath -> Key -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a) +whenAnnexed :: (RawFilePath -> Key -> Annex (Maybe a)) -> RawFilePath -> Annex (Maybe a) whenAnnexed a file = ifAnnexed file (a file) (return Nothing) -ifAnnexed :: FilePath -> (Key -> Annex a) -> Annex a -> Annex a +ifAnnexed :: RawFilePath -> (Key -> Annex a) -> Annex a -> Annex a ifAnnexed file yes no = maybe no yes =<< lookupFile file {- Find all unlocked files and update the keys database for them. @@ -98,14 +99,16 @@ f <- fromRepo $ fromTopFilePath tf liftIO (isPointerFile f) >>= \case Just k' | k' == k -> do - destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f - ic <- replaceFile f $ \tmp -> + destmode <- liftIO $ catchMaybeIO $ + fileMode <$> R.getFileStatus f + ic <- replaceFile (fromRawFilePath f) $ \tmp -> do + let tmp' = toRawFilePath tmp linkFromAnnex k tmp destmode >>= \case LinkAnnexOk -> - withTSDelta (liftIO . genInodeCache tmp) + withTSDelta (liftIO . genInodeCache tmp') LinkAnnexNoop -> return Nothing LinkAnnexFailed -> liftIO $ do - writePointerFile tmp k destmode + writePointerFile tmp' k destmode return Nothing maybe noop (restagePointerFile (Restage True) f) ic _ -> noop diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Assistant.MakeRemote where import Assistant.Common diff --git a/Assistant/MakeRepo.hs b/Assistant/MakeRepo.hs --- a/Assistant/MakeRepo.hs +++ b/Assistant/MakeRepo.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Assistant.MakeRepo where import Assistant.WebApp.Common diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -91,7 +91,7 @@ remoterepair fsckresults = case Remote.repairRepo =<< mrmt of Nothing -> return False Just mkrepair -> do - thisrepopath <- liftIO . absPath + thisrepopath <- liftIO . absPath . fromRawFilePath =<< liftAnnex (fromRepo Git.repoPath) a <- liftAnnex $ mkrepair $ repair fsckresults (Just thisrepopath) @@ -130,7 +130,7 @@ repairStaleLocks lockfiles return $ not $ null lockfiles where - findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir + findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator (fromRawFilePath annexDir)) True . fromRawFilePath . Git.localGitDir islock f | "gc.pid" `isInfixOf` f = False | ".lock" `isSuffixOf` f = True diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Assistant.Sync where import Assistant.Common diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -286,7 +286,7 @@ ks = keySource ld doadd = sanitycheck ks $ do (mkey, _mcache) <- liftAnnex $ do - showStart "add" $ keyFilename ks + showStart "add" $ toRawFilePath $ keyFilename ks ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing maybe (failedingest change) (done change $ keyFilename ks) mkey add _ _ = return Nothing @@ -308,7 +308,7 @@ if M.null m then forM toadd (add cfg) else forM toadd $ \c -> do - mcache <- liftIO $ genInodeCache (changeFile c) delta + mcache <- liftIO $ genInodeCache (toRawFilePath (changeFile c)) delta case mcache of Nothing -> add cfg c Just cache -> @@ -325,7 +325,7 @@ removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key) removedKeysMap ct l = do mks <- forM (filter isRmChange l) $ \c -> - catKeyFile $ changeFile c + catKeyFile $ toRawFilePath $ changeFile c M.fromList . concat <$> mapM mkpairs (catMaybes mks) where mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$> @@ -339,7 +339,7 @@ done change file key = liftAnnex $ do logStatus key InfoPresent mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file - stagePointerFile file mode =<< hashPointerFile key + stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key showEndOk return $ Just $ finishedChange change key @@ -457,5 +457,5 @@ handleDrops "file renamed" present k af [] where f = changeFile change - af = AssociatedFile (Just f) + af = AssociatedFile (Just (toRawFilePath f)) checkChangeContent _ = noop diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -44,7 +44,8 @@ when (old /= new) $ do let changedconfigs = new `S.difference` old debug $ "reloading config" : - map fst (S.toList changedconfigs) + map (fromRawFilePath . fst) + (S.toList changedconfigs) reloadConfigs new {- Record a commit to get this config - change pushed out to remotes. -} @@ -53,10 +54,10 @@ loop new {- Config files, and their checksums. -} -type Configs = S.Set (FilePath, Sha) +type Configs = S.Set (RawFilePath, Sha) {- All git-annex's config files, and actions to run when they change. -} -configFilesActions :: [(FilePath, Assistant ())] +configFilesActions :: [(RawFilePath, Assistant ())] configFilesActions = [ (uuidLog, void $ liftAnnex uuidDescMapLoad) , (remoteLog, void $ liftAnnex remoteListRefresh) @@ -89,5 +90,5 @@ getConfigs = S.fromList . map extract <$> liftAnnex (inRepo $ LsTree.lsTreeFiles Annex.Branch.fullname files) where - files = map fst configFilesActions + files = map (fromRawFilePath . fst) configFilesActions extract treeitem = (getTopFilePath $ LsTree.file treeitem, LsTree.sha treeitem) diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -26,7 +26,7 @@ mergeThread :: NamedThread mergeThread = namedThread "Merger" $ do g <- liftAnnex gitRepo - let dir = Git.localGitDir g "refs" + let dir = fromRawFilePath (Git.localGitDir g) "refs" liftIO $ createDirectoryIfMissing True dir let hook a = Just <$> asIO2 (runHandler a) changehook <- hook onChange diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -159,7 +159,7 @@ -} remotesUnder :: FilePath -> Assistant [Remote] remotesUnder dir = do - repotop <- liftAnnex $ fromRepo Git.repoPath + repotop <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath rs <- liftAnnex remoteList pairs <- liftAnnex $ mapM (checkremote repotop) rs let (waschanged, rs') = unzip pairs diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -119,7 +119,7 @@ pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress] pairAckReceived True (Just pip) msg cache = do stopSending pip - repodir <- repoPath <$> liftAnnex gitRepo + repodir <- fromRawFilePath . repoPath <$> liftAnnex gitRepo liftIO $ setupAuthorizedKeys msg repodir finishedLocalPairing msg (inProgressSshKeyPair pip) startSending pip PairDone $ multicastPairMsg diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -155,10 +155,11 @@ (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g now <- liftIO getPOSIXTime forM_ unstaged $ \file -> do - ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file + let file' = fromRawFilePath file + ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file' case ms of Just s | toonew (statusChangeTime s) now -> noop - | isSymbolicLink s -> addsymlink file ms + | isSymbolicLink s -> addsymlink file' ms _ -> noop liftIO $ void cleanup @@ -268,5 +269,5 @@ checkRepoExists :: Assistant () checkRepoExists = do g <- liftAnnex gitRepo - liftIO $ unlessM (doesDirectoryExist $ Git.repoPath g) $ + liftIO $ unlessM (doesDirectoryExist $ fromRawFilePath $ Git.repoPath g) $ terminateSelf diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -138,8 +138,9 @@ top <- liftAnnex $ fromRepo Git.repoPath (fs, cleanup) <- liftAnnex $ inRepo $ LsFiles.deleted [top] forM_ fs $ \f -> do - liftAnnex $ onDel' f - maybe noop recordChange =<< madeChange f RmChange + let f' = fromRawFilePath f + liftAnnex $ onDel' f' + maybe noop recordChange =<< madeChange f' RmChange void $ liftIO cleanup liftAnnex $ showAction "started" @@ -206,14 +207,14 @@ onAddUnlocked :: Bool -> GetFileMatcher -> Handler onAddUnlocked symlinkssupported matcher f fs = do - mk <- liftIO $ isPointerFile f + mk <- liftIO $ isPointerFile $ toRawFilePath f case mk of Nothing -> onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher f fs Just k -> addlink f k where addassociatedfile key file = Database.Keys.addAssociatedFile key - =<< inRepo (toTopFilePath file) + =<< inRepo (toTopFilePath (toRawFilePath file)) samefilestatus key file status = do cache <- Database.Keys.getInodeCaches key curr <- withTSDelta $ \delta -> liftIO $ toInodeCache delta file status @@ -223,12 +224,12 @@ _ -> return False contentchanged oldkey file = do Database.Keys.removeAssociatedFile oldkey - =<< inRepo (toTopFilePath file) + =<< inRepo (toTopFilePath (toRawFilePath file)) unlessM (inAnnex oldkey) $ logStatus oldkey InfoMissing addlink file key = do mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file - liftAnnex $ stagePointerFile file mode =<< hashPointerFile key + liftAnnex $ stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key madeChange file $ LinkChange (Just key) onAddUnlocked' @@ -240,7 +241,7 @@ -> GetFileMatcher -> Handler onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported matcher file fs = do - v <- liftAnnex $ catKeyFile file + v <- liftAnnex $ catKeyFile (toRawFilePath file) case (v, fs) of (Just key, Just filestatus) -> ifM (liftAnnex $ samefilestatus key file filestatus) @@ -270,7 +271,8 @@ guardSymlinkStandin mk a | symlinkssupported = a | otherwise = do - linktarget <- liftAnnex $ getAnnexLinkTarget file + linktarget <- liftAnnex $ getAnnexLinkTarget $ + toRawFilePath file case linktarget of Nothing -> a Just lt -> do @@ -287,7 +289,7 @@ onAddSymlink :: Handler onAddSymlink file filestatus = unlessIgnored file $ do linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file) - kv <- liftAnnex (lookupFile file) + kv <- liftAnnex (lookupFile (toRawFilePath file)) onAddSymlink' linktarget kv file filestatus onAddSymlink' :: Maybe String -> Maybe Key -> Handler @@ -299,7 +301,7 @@ then ensurestaged (Just link) =<< getDaemonStatus else do liftAnnex $ replaceFile file $ - makeAnnexLink link + makeAnnexLink link . toRawFilePath addLink file link (Just key) -- other symlink, not git-annex go Nothing = ensurestaged linktarget =<< getDaemonStatus @@ -332,8 +334,8 @@ case v of Just (currlink, sha, _type) | s2w8 link == L.unpack currlink -> - stageSymlink file sha - _ -> stageSymlink file =<< hashSymlink link + stageSymlink (toRawFilePath file) sha + _ -> stageSymlink (toRawFilePath file) =<< hashSymlink link madeChange file $ LinkChange mk onDel :: Handler @@ -344,12 +346,12 @@ onDel' :: FilePath -> Annex () onDel' file = do - topfile <- inRepo (toTopFilePath file) + topfile <- inRepo (toTopFilePath (toRawFilePath file)) withkey $ flip Database.Keys.removeAssociatedFile topfile Annex.Queue.addUpdateIndex =<< inRepo (Git.UpdateIndex.unstageFile file) where - withkey a = maybe noop a =<< catKeyFile file + withkey a = maybe noop a =<< catKeyFile (toRawFilePath file) {- A directory has been deleted, or moved, so tell git to remove anything - that was inside it from its cache. Since it could reappear at any time, @@ -360,14 +362,15 @@ onDelDir :: Handler onDelDir dir _ = do debug ["directory deleted", dir] - (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [dir] + (fs, clean) <- liftAnnex $ inRepo $ LsFiles.deleted [toRawFilePath dir] + let fs' = map fromRawFilePath fs - liftAnnex $ mapM_ onDel' fs + liftAnnex $ mapM_ onDel' fs' -- Get the events queued up as fast as possible, so the -- committer sees them all in one block. now <- liftIO getCurrentTime - recordChanges $ map (\f -> Change now f RmChange) fs + recordChanges $ map (\f -> Change now f RmChange) fs' void $ liftIO clean noChange diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -100,7 +100,7 @@ getreldir | noannex = return Nothing | otherwise = Just <$> - (relHome =<< absPath + (relHome =<< absPath . fromRawFilePath =<< getAnnex' (fromRepo repoPath)) go tlssettings addr webapp htmlshim urlfile = do let url = myUrl tlssettings webapp addr diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -161,7 +161,7 @@ AssociatedFile Nothing -> noop AssociatedFile (Just af) -> void $ addAlert $ makeAlertFiller True $ - transferFileAlert direction True af + transferFileAlert direction True (fromRawFilePath af) unless isdownload $ handleDrops ("object uploaded to " ++ show remote) diff --git a/Assistant/Unused.hs b/Assistant/Unused.hs --- a/Assistant/Unused.hs +++ b/Assistant/Unused.hs @@ -64,7 +64,7 @@ sumkeysize s k = s + fromMaybe 0 (fromKey keySize k) - forpath a = inRepo $ liftIO . a . Git.repoPath + forpath a = inRepo $ liftIO . a . fromRawFilePath . Git.repoPath {- With a duration, expires all unused files that are older. - With Nothing, expires *all* unused files. -} diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -87,7 +87,7 @@ hook <- asIO1 $ distributionDownloadComplete d dest cleanup modifyDaemonStatus_ $ \s -> s { transferHook = M.insert k hook (transferHook s) } - maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just f)) t) + maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just (toRawFilePath f))) t) =<< liftAnnex (remoteFromUUID webUUID) startTransfer t k = mkKey $ const $ distributionKey d @@ -113,7 +113,7 @@ | transferDirection t == Download = do debug ["finished downloading git-annex distribution"] maybe (failedupgrade "bad download") go - =<< liftAnnex (withObjectLoc k fsckit) + =<< liftAnnex (withObjectLoc k (fsckit . fromRawFilePath)) | otherwise = cleanup where k = mkKey $ const $ distributionKey d diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -78,7 +78,7 @@ sanityVerifierAForm $ SanityVerifier magicphrase case result of FormSuccess _ -> liftH $ do - dir <- liftAnnex $ fromRepo Git.repoPath + dir <- liftAnnex $ fromRawFilePath <$> fromRepo Git.repoPath liftIO $ removeAutoStartFile dir {- Disable syncing to this repository, and all diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -101,11 +101,12 @@ - there's not. Special remotes don't normally - have that, and don't use it. Temporarily add - it if it's missing. -} - let remotefetch = "remote." ++ T.unpack (repoName oldc) ++ ".fetch" + let remotefetch = Git.ConfigKey $ encodeBS' $ + "remote." ++ T.unpack (repoName oldc) ++ ".fetch" needfetch <- isNothing <$> fromRepo (Git.Config.getMaybe remotefetch) when needfetch $ inRepo $ Git.Command.run - [Param "config", Param remotefetch, Param ""] + [Param "config", Param (Git.fromConfigKey remotefetch), Param ""] inRepo $ Git.Command.run [ Param "remote" , Param "rename" @@ -237,7 +238,7 @@ RepoGroupStandard gr -> case associatedDirectory repoconfig gr of Just d -> inRepo $ \g -> createDirectoryIfMissing True $ - Git.repoPath g d + fromRawFilePath (Git.repoPath g) d Nothing -> noop _ -> noop diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -336,7 +336,7 @@ isnew <- liftIO $ makeRepo dir True {- Removable drives are not reliable media, so enable fsync. -} liftIO $ inDir dir $ - setConfig (ConfigKey "core.fsyncobjectfiles") + setConfig "core.fsyncobjectfiles" (Git.Config.boolConfig True) (u, r) <- a isnew when isnew $ diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -173,7 +173,7 @@ postFinishLocalPairR :: PairMsg -> Handler Html #ifdef WITH_PAIRING postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do - repodir <- liftH $ repoPath <$> liftAnnex gitRepo + repodir <- liftH $ fromRawFilePath . repoPath <$> liftAnnex gitRepo liftIO $ setup repodir startLocalPairing PairAck (cleanup repodir) alert uuid "" secret where diff --git a/Assistant/WebApp/Configurators/Preferences.hs b/Assistant/WebApp/Configurators/Preferences.hs --- a/Assistant/WebApp/Configurators/Preferences.hs +++ b/Assistant/WebApp/Configurators/Preferences.hs @@ -94,7 +94,7 @@ unsetConfig (annexConfig "numcopies") -- deprecated setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p) unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do - here <- fromRepo Git.repoPath + here <- fromRawFilePath <$> fromRepo Git.repoPath liftIO $ if autoStart p then addAutoStartFile here else removeAutoStartFile here @@ -118,5 +118,5 @@ inAutoStartFile :: Annex Bool inAutoStartFile = do - here <- liftIO . absPath =<< fromRepo Git.repoPath + here <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath any (`equalFilePath` here) <$> liftIO readAutoStartFile diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -20,7 +20,7 @@ import Utility.UserInfo import Utility.Gpg import Types.Remote (RemoteConfig) -import Git.Types (RemoteName, fromRef) +import Git.Types (RemoteName, fromRef, fromConfigKey) import qualified Remote.GCrypt as GCrypt import qualified Annex import qualified Git.Command @@ -317,7 +317,8 @@ else T.pack $ "Failed to ssh to the server. Transcript: " ++ s finduuid (k, v) | k == "annex.uuid" = Just $ toUUID v - | k == GCrypt.coreGCryptId = Just $ genUUIDInNameSpace gCryptNameSpace v + | k == fromConfigKey GCrypt.coreGCryptId = + Just $ genUUIDInNameSpace gCryptNameSpace v | otherwise = Nothing checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi" diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -45,7 +45,7 @@ transferPaused info || isNothing (startedTime info) desc transfer info = case associatedFile info of AssociatedFile Nothing -> serializeKey $ transferKey transfer - AssociatedFile (Just af) -> af + AssociatedFile (Just af) -> fromRawFilePath af {- Simplifies a list of transfers, avoiding display of redundant - equivilant transfers. -} @@ -118,7 +118,8 @@ - blocking the response to the browser on it. -} openFileBrowser :: Handler Bool openFileBrowser = do - path <- liftIO . absPath =<< liftAnnex (fromRepo Git.repoPath) + path <- liftIO . absPath . fromRawFilePath + =<< liftAnnex (fromRepo Git.repoPath) #ifdef darwin_HOST_OS let cmd = "open" let p = proc cmd [path] diff --git a/Backend/Hash.hs b/Backend/Hash.hs --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -188,7 +188,7 @@ AssociatedFile Nothing -> Nothing AssociatedFile (Just file) -> Just $ alterKey oldkey $ \d -> d { keyName = keyHash oldkey - <> encodeBS (selectExtension maxextlen file) + <> encodeBS' (selectExtension maxextlen (fromRawFilePath file)) , keyVariety = newvariety } {- Upgrade to fix bad previous migration that created a diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -11,6 +11,7 @@ import Utility.Hash import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L {- 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. @@ -21,11 +22,12 @@ -- Avoid making keys longer than the length of a SHA256 checksum. | bytelen > sha256len = encodeBS' $ truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++ - show (md5 (encodeBL s)) + show (md5 bl) | otherwise = encodeBS' s' where s' = preSanitizeKeyName s - bytelen = length (decodeW8 s') + bl = encodeBL s + bytelen = fromIntegral $ L.length bl sha256len = 64 md5len = 32 diff --git a/Backend/WORM.hs b/Backend/WORM.hs --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -38,7 +38,8 @@ let f = contentLocation source stat <- liftIO $ getFileStatus f sz <- liftIO $ getFileSize' f stat - relf <- getTopFilePath <$> inRepo (toTopFilePath $ keyFilename source) + relf <- fromRawFilePath . getTopFilePath + <$> inRepo (toTopFilePath $ toRawFilePath $ keyFilename source) return $ Just $ mkKey $ \k -> k { keyName = genKeyName relf , keyVariety = WORMKey diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,31 @@ +git-annex (7.20191230) upstream; urgency=medium + + * Optimised processing of many files, especially by commands like find + and whereis that only report on the state of the repository. Commands + like get also sped up in cases where they have to check a lot of + files but only transfer a few files. Speedups range from 30-100%. + * Added build dependency on the filepath-bytestring library. + * Fixed an oversight that had always prevented annex.resolvemerge + from being honored, when it was configured by git-annex config. + * annex.largefiles can be configured by git-annex config, + to more easily set a default that will also be used by clones, + without needing to shoehorn the expression into the gitattributes file. + The git config and gitattributes override that. + * annex.addunlocked can be set to an expression with the same format used by + annex.largefiles, when you want to default to unlocking some files but + not others. + * annex.addunlocked can be configured by git-annex config. + * git-annex-config --set/--unset: No longer change the local git config + setting, except for in the special case of annex.securehashesonly. + * Improve file ordering behavior when one parameter is "." and other + parameters are other directories. + * smudge bugfix: When annex.largefiles=anything, files that were already + stored in git, and have not been modified could sometimes be converted + to being stored in the annex. Changes in 7.20191024 made this more + of a problem. This case is now detected and prevented. + + -- Joey Hess Mon, 30 Dec 2019 12:43:30 -0400 + git-annex (7.20191218) upstream; urgency=medium * git-lfs: The url provided to initremote/enableremote will now be diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -29,6 +29,11 @@ 2013 Michael Snoyman License: Expat +Files: Utility/Attoparsec.hs +Copyright: 2019 Joey Hess + 2007-2015 Bryan O'Sullivan +License: BSD-3-clause + Files: Utility/GitLFS.hs Copyright: © 2019 Joey Hess License: AGPL-3+ @@ -112,7 +117,35 @@ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + +License: BSD-3-clause + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + . + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + . + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + . + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + . + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + License: Expat Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -102,7 +102,8 @@ batchFilesMatching fmt a = do matcher <- getMatcher batchStart fmt $ \f -> - ifM (matcher $ MatchingFile $ FileInfo f f) + let f' = toRawFilePath f + in ifM (matcher $ MatchingFile $ FileInfo f' f') ( a f , return Nothing ) diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -92,7 +92,7 @@ where setnumcopies n = Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n } setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v } - setgitconfig v = Annex.adjustGitRepo $ \r -> Git.Config.store v $ + setgitconfig v = Annex.adjustGitRepo $ \r -> Git.Config.store (encodeBS' v) $ r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] } setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v } diff --git a/CmdLine/GitAnnexShell/Fields.hs b/CmdLine/GitAnnexShell/Fields.hs --- a/CmdLine/GitAnnexShell/Fields.hs +++ b/CmdLine/GitAnnexShell/Fields.hs @@ -30,7 +30,7 @@ associatedFile :: Field associatedFile = Field "associatedfile" $ \f -> -- is the file a safe relative filename? - not (absoluteGitPath f) && not ("../" `isPrefixOf` f) + not (absoluteGitPath (toRawFilePath f)) && not ("../" `isPrefixOf` f) direct :: Field direct = Field "direct" $ \f -> f == "1" diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -33,12 +33,13 @@ import Annex.Content import Annex.InodeSentinal import qualified Database.Keys +import qualified Utility.RawFilePath as R -withFilesInGit :: (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek +withFilesInGit :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesInGit a l = seekActions $ prepFiltered a $ seekHelper LsFiles.inRepo l -withFilesInGitNonRecursive :: String -> (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek +withFilesInGitNonRecursive :: String -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesInGitNonRecursive needforce a l = ifM (Annex.getState Annex.force) ( withFilesInGit a l , if null l @@ -48,7 +49,7 @@ where getfiles c [] = return (reverse c) getfiles c ((WorkTreeItem p):ps) = do - (fs, cleanup) <- inRepo $ LsFiles.inRepo [p] + (fs, cleanup) <- inRepo $ LsFiles.inRepo [toRawFilePath p] case fs of [f] -> do void $ liftIO $ cleanup @@ -58,11 +59,11 @@ getfiles c ps _ -> giveup needforce -withFilesNotInGit :: Bool -> (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek +withFilesNotInGit :: Bool -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesNotInGit skipdotfiles a l | skipdotfiles = do {- dotfiles are not acted on unless explicitly listed -} - files <- filter (not . dotfile) <$> + files <- filter (not . dotfile . fromRawFilePath) <$> seekunless (null ps && not (null l)) ps dotfiles <- seekunless (null dotps) dotps go (files++dotfiles) @@ -74,9 +75,9 @@ force <- Annex.getState Annex.force g <- gitRepo liftIO $ Git.Command.leaveZombie - <$> LsFiles.notInRepo force (map (\(WorkTreeItem f) -> f) l') g + <$> LsFiles.notInRepo force (map (\(WorkTreeItem f) -> toRawFilePath f) l') g go fs = seekActions $ prepFiltered a $ - return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> f) l) fs + return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> toRawFilePath f) l) fs withPathContents :: ((FilePath, FilePath) -> CommandSeek) -> CmdParams -> CommandSeek withPathContents a params = do @@ -93,8 +94,8 @@ , return [(p, takeFileName p)] ) checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo - { currFile = f - , matchFile = relf + { currFile = toRawFilePath f + , matchFile = toRawFilePath relf } withWords :: ([String] -> CommandSeek) -> CmdParams -> CommandSeek @@ -110,30 +111,30 @@ pairs c (x:y:xs) = pairs ((x,y):c) xs pairs _ _ = giveup "expected pairs" -withFilesToBeCommitted :: (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek +withFilesToBeCommitted :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesToBeCommitted a l = seekActions $ prepFiltered a $ seekHelper LsFiles.stagedNotDeleted l -isOldUnlocked :: FilePath -> Annex Bool +isOldUnlocked :: RawFilePath -> Annex Bool isOldUnlocked f = liftIO (notSymlink f) <&&> (isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f) {- unlocked pointer files that are staged, and whose content has not been - modified-} -withUnmodifiedUnlockedPointers :: (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek +withUnmodifiedUnlockedPointers :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withUnmodifiedUnlockedPointers a l = seekActions $ prepFiltered a unlockedfiles where unlockedfiles = filterM isUnmodifiedUnlocked =<< seekHelper LsFiles.typeChangedStaged l -isUnmodifiedUnlocked :: FilePath -> Annex Bool +isUnmodifiedUnlocked :: RawFilePath -> Annex Bool isUnmodifiedUnlocked f = catKeyFile f >>= \case Nothing -> return False Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k {- Finds files that may be modified. -} -withFilesMaybeModified :: (FilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek +withFilesMaybeModified :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek withFilesMaybeModified a params = seekActions $ prepFiltered a $ seekHelper LsFiles.modified params @@ -225,20 +226,21 @@ forM_ ts $ \(t, i) -> keyaction (transferKey t, mkActionItem (t, i)) -prepFiltered :: (FilePath -> CommandSeek) -> Annex [FilePath] -> Annex [CommandSeek] +prepFiltered :: (RawFilePath -> CommandSeek) -> Annex [RawFilePath] -> Annex [CommandSeek] prepFiltered a fs = do matcher <- Limit.getMatcher map (process matcher) <$> fs where - process matcher f = whenM (matcher $ MatchingFile $ FileInfo f f) $ a f + process matcher f = + whenM (matcher $ MatchingFile $ FileInfo f f) $ a f seekActions :: Annex [CommandSeek] -> Annex () seekActions gen = sequence_ =<< gen -seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [WorkTreeItem] -> Annex [FilePath] +seekHelper :: ([RawFilePath] -> Git.Repo -> IO ([RawFilePath], IO Bool)) -> [WorkTreeItem] -> Annex [RawFilePath] seekHelper a l = inRepo $ \g -> concat . concat <$> forM (segmentXargsOrdered l') - (runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g)) + (runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) . map toRawFilePath) where l' = map (\(WorkTreeItem f) -> f) l @@ -264,14 +266,14 @@ unlessM (exists p <||> hidden currbranch p) $ do toplevelWarning False (p ++ " not found") Annex.incError - return (map WorkTreeItem ps) + return (map (WorkTreeItem) ps) where exists p = isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p) hidden currbranch p | allowhidden = do f <- liftIO $ relPathCwdToFile p - isJust <$> catObjectMetaDataHidden f currbranch + isJust <$> catObjectMetaDataHidden (toRawFilePath f) currbranch | otherwise = return False -notSymlink :: FilePath -> IO Bool -notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f +notSymlink :: RawFilePath -> IO Bool +notSymlink f = liftIO $ not . isSymbolicLink <$> R.getSymbolicLinkStatus f diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -19,6 +19,7 @@ import Annex.Tmp import Messages.Progress import Git.FilePath +import qualified Utility.RawFilePath as R cmd :: Command cmd = notBareRepo $ @@ -49,9 +50,10 @@ seek :: AddOptions -> CommandSeek seek o = startConcurrency commandStages $ do - matcher <- largeFilesMatcher - let gofile file = ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force) - ( start file + largematcher <- largeFilesMatcher + addunlockedmatcher <- addUnlockedMatcher + let gofile file = ifM (checkFileMatcher largematcher (fromRawFilePath file) <||> Annex.getState Annex.force) + ( start file addunlockedmatcher , ifM (annexAddSmallFiles <$> Annex.getGitConfig) ( startSmall file , stop @@ -61,7 +63,7 @@ Batch fmt | updateOnly o -> giveup "--update --batch is not supported" - | otherwise -> batchFilesMatching fmt gofile + | otherwise -> batchFilesMatching fmt (gofile . toRawFilePath) NoBatch -> do l <- workTreeItems (addThese o) let go a = a (commandAction . gofile) l @@ -71,28 +73,28 @@ go withUnmodifiedUnlockedPointers {- Pass file off to git-add. -} -startSmall :: FilePath -> CommandStart +startSmall :: RawFilePath -> CommandStart startSmall file = starting "add" (ActionItemWorkTreeFile file) $ next $ addSmall file -addSmall :: FilePath -> Annex Bool +addSmall :: RawFilePath -> Annex Bool addSmall file = do showNote "non-large file; adding content to git repository" addFile file -addFile :: FilePath -> Annex Bool +addFile :: RawFilePath -> Annex Bool addFile file = do ps <- forceParams - Annex.Queue.addCommand "add" (ps++[Param "--"]) [file] + Annex.Queue.addCommand "add" (ps++[Param "--"]) [fromRawFilePath file] return True -start :: FilePath -> CommandStart -start file = do +start :: RawFilePath -> AddUnlockedMatcher -> CommandStart +start file addunlockedmatcher = do mk <- liftIO $ isPointerFile file maybe go fixuppointer mk where go = ifAnnexed file addpresent add - add = liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case + add = liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case Nothing -> stop Just s | not (isRegularFile s) && not (isSymbolicLink s) -> stop @@ -100,15 +102,15 @@ starting "add" (ActionItemWorkTreeFile file) $ if isSymbolicLink s then next $ addFile file - else perform file + else perform file addunlockedmatcher addpresent key = - liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case + liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case Just s | isSymbolicLink s -> fixuplink key _ -> add fixuplink key = starting "add" (ActionItemWorkTreeFile file) $ do -- the annexed symlink is present but not yet added to git - liftIO $ removeFile file - addLink file key Nothing + liftIO $ removeFile (fromRawFilePath file) + addLink (fromRawFilePath file) key Nothing next $ cleanup key =<< inAnnex key fixuppointer key = starting "add" (ActionItemWorkTreeFile file) $ do @@ -116,14 +118,15 @@ Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) next $ addFile file -perform :: FilePath -> CommandPerform -perform file = withOtherTmp $ \tmpdir -> do - lockingfile <- not <$> addUnlocked +perform :: RawFilePath -> AddUnlockedMatcher -> CommandPerform +perform file addunlockedmatcher = withOtherTmp $ \tmpdir -> do + lockingfile <- not <$> addUnlocked addunlockedmatcher + (MatchingFile (FileInfo file file)) let cfg = LockDownConfig { lockingFile = lockingfile , hardlinkFileTmpDir = Just tmpdir } - ld <- lockDown cfg file + ld <- lockDown cfg (fromRawFilePath file) let sizer = keySource <$> ld v <- metered Nothing sizer $ \_meter meterupdate -> ingestAdd meterupdate ld diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -31,7 +31,7 @@ addLink file key Nothing return True where - file = "unused." ++ keyFile key + file = "unused." ++ fromRawFilePath (keyFile key) {- The content is not in the annex, but in another directory, and - it seems better to error out, rather than moving bad/tmp content into diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -94,16 +94,16 @@ seek :: AddUrlOptions -> CommandSeek seek o = startConcurrency commandStages $ do + addunlockedmatcher <- addUnlockedMatcher + let go (o', u) = do + r <- Remote.claimingUrl u + if Remote.uuid r == webUUID || rawOption (downloadOptions o') + then void $ commandAction $ startWeb addunlockedmatcher o' u + else checkUrl addunlockedmatcher r o' u forM_ (addUrls o) (\u -> go (o, u)) case batchOption o of Batch fmt -> batchInput fmt (parseBatchInput o) go NoBatch -> noop - where - go (o', u) = do - r <- Remote.claimingUrl u - if Remote.uuid r == webUUID || rawOption (downloadOptions o') - then void $ commandAction $ startWeb o' u - else checkUrl r o' u parseBatchInput :: AddUrlOptions -> String -> Either String (AddUrlOptions, URLString) parseBatchInput o s @@ -114,8 +114,8 @@ else Right (o { downloadOptions = (downloadOptions o) { fileOption = Just f } }, u) | otherwise = Right (o, s) -checkUrl :: Remote -> AddUrlOptions -> URLString -> Annex () -checkUrl r o u = do +checkUrl :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> Annex () +checkUrl addunlockedmatcher r o u = do pathmax <- liftIO $ fileNameLengthLimit "." let deffile = fromMaybe (urlString2file u (pathdepthOption o) pathmax) (fileOption (downloadOptions o)) go deffile =<< maybe @@ -129,49 +129,49 @@ next $ return False go deffile (Right (UrlContents sz mf)) = do let f = adjustFile o (fromMaybe (maybe deffile fromSafeFilePath mf) (fileOption (downloadOptions o))) - void $ commandAction $ startRemote r o f u sz + void $ commandAction $ startRemote addunlockedmatcher r o f u sz go deffile (Right (UrlMulti l)) = case fileOption (downloadOptions o) of Nothing -> forM_ l $ \(u', sz, f) -> do let f' = adjustFile o (deffile fromSafeFilePath f) - void $ commandAction $ startRemote r o f' u' sz + void $ commandAction $ startRemote addunlockedmatcher r o f' u' sz Just f -> case l of [] -> noop ((u',sz,_):[]) -> do let f' = adjustFile o f - void $ commandAction $ startRemote r o f' u' sz + void $ commandAction $ startRemote addunlockedmatcher r o f' u' sz _ -> giveup $ unwords [ "That url contains multiple files according to the" , Remote.name r , " remote; cannot add it to a single file." ] -startRemote :: Remote -> AddUrlOptions -> FilePath -> URLString -> Maybe Integer -> CommandStart -startRemote r o file uri sz = do +startRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> FilePath -> URLString -> Maybe Integer -> CommandStart +startRemote addunlockedmatcher r o file uri sz = do pathmax <- liftIO $ fileNameLengthLimit "." let file' = joinPath $ map (truncateFilePath pathmax) $ splitDirectories file startingAddUrl uri o $ do showNote $ "from " ++ Remote.name r showDestinationFile file' - performRemote r o uri file' sz + performRemote addunlockedmatcher r o uri file' sz -performRemote :: Remote -> AddUrlOptions -> URLString -> FilePath -> Maybe Integer -> CommandPerform -performRemote r o uri file sz = ifAnnexed file adduri geturi +performRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> FilePath -> Maybe Integer -> CommandPerform +performRemote addunlockedmatcher r o uri file sz = ifAnnexed (toRawFilePath file) adduri geturi where loguri = setDownloader uri OtherDownloader adduri = addUrlChecked o loguri file (Remote.uuid r) checkexistssize checkexistssize key = return $ case sz of Nothing -> (True, True, loguri) Just n -> (True, n == fromMaybe n (fromKey keySize key), loguri) - geturi = next $ isJust <$> downloadRemoteFile r (downloadOptions o) uri file sz + geturi = next $ isJust <$> downloadRemoteFile addunlockedmatcher r (downloadOptions o) uri file sz -downloadRemoteFile :: Remote -> DownloadOptions -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key) -downloadRemoteFile r o uri file sz = checkCanAdd file $ do +downloadRemoteFile :: AddUnlockedMatcher -> Remote -> DownloadOptions -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key) +downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd file $ do let urlkey = Backend.URL.fromUrl uri sz liftIO $ createDirectoryIfMissing True (parentDir file) ifM (Annex.getState Annex.fast <||> pure (relaxedOption o)) ( do - addWorkTree (Remote.uuid r) loguri file urlkey Nothing + addWorkTree addunlockedmatcher (Remote.uuid r) loguri file urlkey Nothing return (Just urlkey) , do -- Set temporary url for the urlkey @@ -180,16 +180,16 @@ setTempUrl urlkey loguri let downloader = \dest p -> fst <$> Remote.retrieveKeyFile r urlkey - (AssociatedFile (Just file)) dest p - ret <- downloadWith downloader urlkey (Remote.uuid r) loguri file + (AssociatedFile (Just (toRawFilePath file))) dest p + ret <- downloadWith addunlockedmatcher downloader urlkey (Remote.uuid r) loguri file removeTempUrl urlkey return ret ) where loguri = setDownloader uri OtherDownloader -startWeb :: AddUrlOptions -> URLString -> CommandStart -startWeb o urlstring = go $ fromMaybe bad $ parseURI urlstring +startWeb :: AddUnlockedMatcher -> AddUrlOptions -> URLString -> CommandStart +startWeb addunlockedmatcher o urlstring = go $ fromMaybe bad $ parseURI urlstring where bad = fromMaybe (giveup $ "bad url " ++ urlstring) $ Url.parseURIRelaxed $ urlstring @@ -209,12 +209,12 @@ ( pure $ url2file url (pathdepthOption o) pathmax , pure f ) - performWeb o urlstring file urlinfo + performWeb addunlockedmatcher o urlstring file urlinfo -performWeb :: AddUrlOptions -> URLString -> FilePath -> Url.UrlInfo -> CommandPerform -performWeb o url file urlinfo = ifAnnexed file addurl geturl +performWeb :: AddUnlockedMatcher -> AddUrlOptions -> URLString -> FilePath -> Url.UrlInfo -> CommandPerform +performWeb addunlockedmatcher o url file urlinfo = ifAnnexed (toRawFilePath file) addurl geturl where - geturl = next $ isJust <$> addUrlFile (downloadOptions o) url urlinfo file + geturl = next $ isJust <$> addUrlFile addunlockedmatcher (downloadOptions o) url urlinfo file addurl = addUrlChecked o url file webUUID $ \k -> ifM (pure (not (rawOption (downloadOptions o))) <&&> youtubeDlSupported url) ( return (True, True, setDownloader url YoutubeDownloader) @@ -249,16 +249,16 @@ - different file, based on the title of the media. Unless the user - specified fileOption, which then forces using the FilePath. -} -addUrlFile :: DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) -addUrlFile o url urlinfo file = +addUrlFile :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) +addUrlFile addunlockedmatcher o url urlinfo file = ifM (Annex.getState Annex.fast <||> pure (relaxedOption o)) - ( nodownloadWeb o url urlinfo file - , downloadWeb o url urlinfo file + ( nodownloadWeb addunlockedmatcher o url urlinfo file + , downloadWeb addunlockedmatcher o url urlinfo file ) -downloadWeb :: DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) -downloadWeb o url urlinfo file = - go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just file)) +downloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) +downloadWeb addunlockedmatcher o url urlinfo file = + go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just (toRawFilePath file))) where urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing downloader f p = downloadUrl urlkey p [url] f @@ -272,13 +272,13 @@ normalfinish tmp = checkCanAdd file $ do showDestinationFile file liftIO $ createDirectoryIfMissing True (parentDir file) - finishDownloadWith tmp webUUID url file + finishDownloadWith addunlockedmatcher tmp webUUID url file tryyoutubedl tmp -- Ask youtube-dl what filename it will download -- first, and check if that is already an annexed file, -- to avoid unnecessary work in that case. | otherwise = youtubeDlFileNameHtmlOnly url >>= \case - Right dest -> ifAnnexed dest + Right dest -> ifAnnexed (toRawFilePath dest) (alreadyannexed dest) (dl dest) Left _ -> normalfinish tmp @@ -298,7 +298,7 @@ cleanuptmp checkCanAdd dest $ do showDestinationFile dest - addWorkTree webUUID mediaurl dest mediakey (Just mediafile) + addWorkTree addunlockedmatcher webUUID mediaurl dest mediakey (Just mediafile) return $ Just mediakey Right Nothing -> normalfinish tmp Left msg -> do @@ -341,13 +341,13 @@ - Downloads the url, sets up the worktree file, and returns the - real key. -} -downloadWith :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> FilePath -> Annex (Maybe Key) -downloadWith downloader dummykey u url file = +downloadWith :: AddUnlockedMatcher -> (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> FilePath -> Annex (Maybe Key) +downloadWith addunlockedmatcher downloader dummykey u url file = go =<< downloadWith' downloader dummykey u url afile where - afile = AssociatedFile (Just file) + afile = AssociatedFile (Just (toRawFilePath file)) go Nothing = return Nothing - go (Just tmp) = finishDownloadWith tmp u url file + go (Just tmp) = finishDownloadWith addunlockedmatcher tmp u url file {- Like downloadWith, but leaves the dummy key content in - the returned location. -} @@ -363,8 +363,8 @@ then return (Just tmp) else return Nothing -finishDownloadWith :: FilePath -> UUID -> URLString -> FilePath -> Annex (Maybe Key) -finishDownloadWith tmp u url file = do +finishDownloadWith :: AddUnlockedMatcher -> FilePath -> UUID -> URLString -> FilePath -> Annex (Maybe Key) +finishDownloadWith addunlockedmatcher tmp u url file = do backend <- chooseBackend file let source = KeySource { keyFilename = file @@ -374,7 +374,7 @@ genKey source nullMeterUpdate backend >>= \case Nothing -> return Nothing Just (key, _) -> do - addWorkTree u url file key (Just tmp) + addWorkTree addunlockedmatcher u url file key (Just tmp) return (Just key) {- Adds the url size to the Key. -} @@ -384,8 +384,8 @@ } {- Adds worktree file to the repository. -} -addWorkTree :: UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex () -addWorkTree u url file key mtmp = case mtmp of +addWorkTree :: AddUnlockedMatcher -> UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex () +addWorkTree addunlockedmatcher u url file key mtmp = case mtmp of Nothing -> go Just tmp -> do -- Move to final location for large file check. @@ -401,21 +401,21 @@ -- than the work tree file. liftIO $ renameFile file tmp go - else void $ Command.Add.addSmall file + else void $ Command.Add.addSmall (toRawFilePath file) where go = do maybeShowJSON $ JSONChunk [("key", serializeKey key)] setUrlPresent key url logChange key u InfoPresent - ifM (addAnnexedFile file key mtmp) + ifM (addAnnexedFile addunlockedmatcher file key mtmp) ( do when (isJust mtmp) $ logStatus key InfoPresent , maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . nukeFile)) mtmp ) -nodownloadWeb :: DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) -nodownloadWeb o url urlinfo file +nodownloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) +nodownloadWeb addunlockedmatcher o url urlinfo file | Url.urlExists urlinfo = if rawOption o then nomedia else either (const nomedia) usemedia @@ -426,20 +426,20 @@ where nomedia = do let key = Backend.URL.fromUrl url (Url.urlSize urlinfo) - nodownloadWeb' url key file + nodownloadWeb' addunlockedmatcher url key file usemedia mediafile = do let dest = if isJust (fileOption o) then file else takeFileName mediafile let mediaurl = setDownloader url YoutubeDownloader let mediakey = Backend.URL.fromUrl mediaurl Nothing - nodownloadWeb' mediaurl mediakey dest + nodownloadWeb' addunlockedmatcher mediaurl mediakey dest -nodownloadWeb' :: URLString -> Key -> FilePath -> Annex (Maybe Key) -nodownloadWeb' url key file = checkCanAdd file $ do +nodownloadWeb' :: AddUnlockedMatcher -> URLString -> Key -> FilePath -> Annex (Maybe Key) +nodownloadWeb' addunlockedmatcher url key file = checkCanAdd file $ do showDestinationFile file liftIO $ createDirectoryIfMissing True (parentDir file) - addWorkTree webUUID url file key Nothing + addWorkTree addunlockedmatcher webUUID url file key Nothing return (Just key) url2file :: URI -> Maybe Int -> Int -> FilePath diff --git a/Command/Config.hs b/Command/Config.hs --- a/Command/Config.hs +++ b/Command/Config.hs @@ -5,21 +5,26 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.Config where import Command import Logs.Config import Config +import Git.Types (ConfigKey(..), fromConfigValue) +import qualified Data.ByteString.Char8 as S8 + cmd :: Command cmd = noMessages $ command "config" SectionSetup "configuration stored in git-annex branch" paramNothing (seek <$$> optParser) data Action - = SetConfig ConfigName ConfigValue - | GetConfig ConfigName - | UnsetConfig ConfigName + = SetConfig ConfigKey ConfigValue + | GetConfig ConfigKey + | UnsetConfig ConfigKey type Name = String type Value = String @@ -48,19 +53,25 @@ ) seek :: Action -> CommandSeek -seek (SetConfig name val) = commandAction $ - startingUsualMessages name (ActionItemOther (Just val)) $ do - setGlobalConfig name val - setConfig (ConfigKey name) val +seek (SetConfig ck@(ConfigKey name) val) = commandAction $ + startingUsualMessages (decodeBS' name) (ActionItemOther (Just (fromConfigValue val))) $ do + setGlobalConfig ck val + when (needLocalUpdate ck) $ + setConfig ck (fromConfigValue val) next $ return True -seek (UnsetConfig name) = commandAction $ - startingUsualMessages name (ActionItemOther (Just "unset")) $do - unsetGlobalConfig name - unsetConfig (ConfigKey name) +seek (UnsetConfig ck@(ConfigKey name)) = commandAction $ + startingUsualMessages (decodeBS' name) (ActionItemOther (Just "unset")) $do + unsetGlobalConfig ck + when (needLocalUpdate ck) $ + unsetConfig ck next $ return True -seek (GetConfig name) = commandAction $ +seek (GetConfig ck) = commandAction $ startingCustomOutput (ActionItemOther Nothing) $ do - getGlobalConfig name >>= \case + getGlobalConfig ck >>= \case Nothing -> return () - Just v -> liftIO $ putStrLn v + Just (ConfigValue v) -> liftIO $ S8.putStrLn v next $ return True + +needLocalUpdate :: ConfigKey -> Bool +needLocalUpdate (ConfigKey "annex.securehashesonly") = True +needLocalUpdate _ = False diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -12,6 +12,7 @@ import Annex.Init import qualified Annex.Branch import qualified Git.Config +import Git.Types import Remote.GCrypt (coreGCryptId) import qualified CmdLine.GitAnnexShell.Fields as Fields import CmdLine.GitAnnexShell.Checks @@ -28,11 +29,12 @@ start :: CommandStart start = do u <- findOrGenUUID - showConfig "annex.uuid" $ fromUUID u - showConfig coreGCryptId =<< fromRepo (Git.Config.get coreGCryptId "") + showConfig configkeyUUID $ fromUUID u + showConfig coreGCryptId . fromConfigValue + =<< fromRepo (Git.Config.get coreGCryptId mempty) stop where - showConfig k v = liftIO $ putStrLn $ k ++ "=" ++ v + showConfig k v = liftIO $ putStrLn $ fromConfigKey k ++ "=" ++ v {- The repository may not yet have a UUID; automatically initialize it - when there's a git-annex branch available or if the autoinit field was diff --git a/Command/ContentLocation.hs b/Command/ContentLocation.hs --- a/Command/ContentLocation.hs +++ b/Command/ContentLocation.hs @@ -9,7 +9,10 @@ import Command import Annex.Content +import qualified Utility.RawFilePath as R +import qualified Data.ByteString.Char8 as B8 + cmd :: Command cmd = noCommit $ noMessages $ command "contentlocation" SectionPlumbing @@ -20,10 +23,10 @@ run :: () -> String -> Annex Bool run _ p = do let k = fromMaybe (giveup "bad key") $ deserializeKey p - maybe (return False) (\f -> liftIO (putStrLn f) >> return True) + maybe (return False) (\f -> liftIO (B8.putStrLn f) >> return True) =<< inAnnex' (pure True) Nothing check k where - check f = ifM (liftIO (doesFileExist f)) + check f = ifM (liftIO (R.doesPathExist f)) ( return (Just f) , return Nothing ) diff --git a/Command/Copy.hs b/Command/Copy.hs --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -47,7 +47,7 @@ seek o = startConcurrency commandStages $ do let go = whenAnnexed $ start o case batchOption o of - Batch fmt -> batchFilesMatching fmt go + Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) (autoMode o) (commandAction . Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever) @@ -57,12 +57,12 @@ {- A copy is just a move that does not delete the source file. - However, auto mode avoids unnecessary copies, and avoids getting or - sending non-preferred content. -} -start :: CopyOptions -> FilePath -> Key -> CommandStart +start :: CopyOptions -> RawFilePath -> Key -> CommandStart start o file key = stopUnless shouldCopy $ Command.Move.start (fromToOptions o) Command.Move.RemoveNever file key where shouldCopy - | autoMode o = want <||> numCopiesCheck file key (<) + | autoMode o = want <||> numCopiesCheck (fromRawFilePath file) key (<) | otherwise = return True want = case fromToOptions o of Right (ToRemote dest) -> diff --git a/Command/DiffDriver.hs b/Command/DiffDriver.hs --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -85,12 +85,13 @@ check rOldFile rOldMode (\r f -> r { rOldFile = f }) req >>= check rNewFile rNewMode (\r f -> r { rNewFile = f }) where - check getfile getmode setfile r = case readTreeItemType (getmode r) of + check getfile getmode setfile r = case readTreeItemType (encodeBS' (getmode r)) of Just TreeSymlink -> do - v <- getAnnexLinkTarget' (getfile r) False + v <- getAnnexLinkTarget' (toRawFilePath (getfile r)) False case parseLinkTargetOrPointer =<< v of Nothing -> return r - Just k -> withObjectLoc k (pure . setfile r) + Just k -> withObjectLoc k $ + pure . setfile r . fromRawFilePath _ -> return r externalDiffer :: String -> [String] -> Differ diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -54,7 +54,7 @@ seek :: DropOptions -> CommandSeek seek o = startConcurrency transferStages $ case batchOption o of - Batch fmt -> batchFilesMatching fmt go + Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) (autoMode o) (commandAction . startKeys o) (withFilesInGit (commandAction . go)) @@ -62,7 +62,7 @@ where go = whenAnnexed $ start o -start :: DropOptions -> FilePath -> Key -> CommandStart +start :: DropOptions -> RawFilePath -> Key -> CommandStart start o file key = start' o key afile ai where afile = AssociatedFile (Just file) diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.EnableRemote where import Command diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -22,5 +22,5 @@ run :: Maybe Utility.Format.Format -> String -> Annex Bool run format p = do let k = fromMaybe (giveup "bad key") $ deserializeKey p - showFormatted format (serializeKey k) (keyVars k) + showFormatted format (serializeKey' k) (keyVars k) return True diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE TupleSections, BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} module Command.Export where @@ -26,7 +27,6 @@ import Annex.Transfer import Annex.CatFile import Annex.FileMatcher -import Types.FileMatcher import Annex.RemoteTrackingBranch import Logs.Location import Logs.Export @@ -70,7 +70,7 @@ -- To handle renames which swap files, the exported file is first renamed -- to a stable temporary name based on the key. exportTempName :: ExportKey -> ExportLocation -exportTempName ek = mkExportLocation $ +exportTempName ek = mkExportLocation $ toRawFilePath $ ".git-annex-tmp-content-" ++ serializeKey (asKey (ek)) seek :: ExportOptions -> CommandSeek @@ -250,7 +250,7 @@ startExport r db cvar allfilledvar ti = do ek <- exportKey (Git.LsTree.sha ti) stopUnless (notrecordedpresent ek) $ - starting ("export " ++ name r) (ActionItemOther (Just f)) $ + starting ("export " ++ name r) (ActionItemOther (Just (fromRawFilePath f))) $ ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc)) ( next $ cleanupExport r db ek loc False , do @@ -313,14 +313,14 @@ eks <- forM (filter (/= nullSha) shas) exportKey if null eks then stop - else starting ("unexport " ++ name r) (ActionItemOther (Just f')) $ + else starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $ performUnexport r db eks loc where loc = mkExportLocation f' f' = getTopFilePath f startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart -startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Just f')) $ +startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $ performUnexport r db [ek] loc where loc = mkExportLocation f' @@ -363,16 +363,15 @@ | otherwise = do ek <- exportKey sha let loc = exportTempName ek - starting ("unexport " ++ name r) (ActionItemOther (Just (fromExportLocation loc))) $ do + starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation loc)))) $ do liftIO $ removeExportedLocation db (asKey ek) oldloc performUnexport r db [ek] loc where - oldloc = mkExportLocation oldf' - oldf' = getTopFilePath oldf + oldloc = mkExportLocation $ getTopFilePath oldf startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart startMoveToTempName r db f ek = starting ("rename " ++ name r) - (ActionItemOther $ Just $ f' ++ " -> " ++ fromExportLocation tmploc) + (ActionItemOther $ Just $ fromRawFilePath f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc)) (performRename r db ek loc tmploc) where loc = mkExportLocation f' @@ -383,7 +382,7 @@ startMoveFromTempName r db ek f = do let tmploc = exportTempName ek stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $ - starting ("rename " ++ name r) (ActionItemOther (Just (fromExportLocation tmploc ++ " -> " ++ f'))) $ + starting ("rename " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ fromRawFilePath f'))) $ performRename r db ek tmploc loc where loc = mkExportLocation f' diff --git a/Command/Find.hs b/Command/Find.hs --- a/Command/Find.hs +++ b/Command/Find.hs @@ -9,6 +9,8 @@ import Data.Default import qualified Data.Map as M +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import Command import Annex.Content @@ -57,17 +59,17 @@ (commandAction . startKeys o) (withFilesInGit (commandAction . go)) =<< workTreeItems (findThese o) - Batch fmt -> batchFilesMatching fmt go + Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) where go = whenAnnexed $ start o -- only files inAnnex are shown, unless the user has requested -- others via a limit -start :: FindOptions -> FilePath -> Key -> CommandStart +start :: FindOptions -> RawFilePath -> Key -> CommandStart start o file key = stopUnless (limited <||> inAnnex key) $ startingCustomOutput key $ do - showFormatted (formatOption o) file $ ("file", file) : keyVars key + showFormatted (formatOption o) file $ ("file", fromRawFilePath file) : keyVars key next $ return True startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart @@ -75,11 +77,11 @@ start o (getTopFilePath topf) key startKeys _ _ = stop -showFormatted :: Maybe Utility.Format.Format -> String -> [(String, String)] -> Annex () +showFormatted :: Maybe Utility.Format.Format -> S.ByteString -> [(String, String)] -> Annex () showFormatted format unformatted vars = unlessM (showFullJSON $ JSONChunk vars) $ case format of - Nothing -> liftIO $ putStrLn unformatted + Nothing -> liftIO $ S8.putStrLn unformatted Just formatter -> liftIO $ putStr $ Utility.Format.format formatter $ M.fromList vars @@ -91,8 +93,8 @@ , ("bytesize", size show) , ("humansize", size $ roughSize storageUnits True) , ("keyname", decodeBS $ fromKey keyName key) - , ("hashdirlower", hashDirLower def key) - , ("hashdirmixed", hashDirMixed def key) + , ("hashdirlower", fromRawFilePath $ hashDirLower def key) + , ("hashdirmixed", fromRawFilePath $ hashDirMixed def key) , ("mtime", whenavail show $ fromKey keyMtime key) ] where diff --git a/Command/Fix.hs b/Command/Fix.hs --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -17,6 +17,7 @@ import Annex.Perms import qualified Annex.Queue import qualified Database.Keys +import qualified Utility.RawFilePath as R #if ! defined(mingw32_HOST_OS) import Utility.Touch @@ -37,13 +38,14 @@ data FixWhat = FixSymlinks | FixAll -start :: FixWhat -> FilePath -> Key -> CommandStart +start :: FixWhat -> RawFilePath -> Key -> CommandStart start fixwhat file key = do - currlink <- liftIO $ catchMaybeIO $ readSymbolicLink file - wantlink <- calcRepo $ gitAnnexLink file key + currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file + wantlink <- calcRepo $ gitAnnexLink (fromRawFilePath file) key case currlink of Just l - | l /= wantlink -> fixby $ fixSymlink file wantlink + | l /= toRawFilePath wantlink -> fixby $ + fixSymlink (fromRawFilePath file) wantlink | otherwise -> stop Nothing -> case fixwhat of FixAll -> fixthin @@ -51,11 +53,11 @@ where fixby = starting "fix" (mkActionItem (key, file)) fixthin = do - obj <- calcRepo $ gitAnnexLocation key + obj <- calcRepo (gitAnnexLocation key) stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do thin <- annexThin <$> Annex.getGitConfig - fs <- liftIO $ catchMaybeIO $ getFileStatus file - os <- liftIO $ catchMaybeIO $ getFileStatus obj + fs <- liftIO $ catchMaybeIO $ R.getFileStatus file + os <- liftIO $ catchMaybeIO $ R.getFileStatus obj case (linkCount <$> fs, linkCount <$> os, thin) of (Just 1, Just 1, True) -> fixby $ makeHardLink file key @@ -63,21 +65,22 @@ fixby $ breakHardLink file key obj _ -> stop -breakHardLink :: FilePath -> Key -> FilePath -> CommandPerform +breakHardLink :: RawFilePath -> Key -> RawFilePath -> CommandPerform breakHardLink file key obj = do - replaceFile file $ \tmp -> do - mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file - unlessM (checkedCopyFile key obj tmp mode) $ + replaceFile (fromRawFilePath file) $ \tmp -> do + mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file + let obj' = fromRawFilePath obj + unlessM (checkedCopyFile key obj' tmp mode) $ error "unable to break hard link" thawContent tmp - modifyContent obj $ freezeContent obj + modifyContent obj' $ freezeContent obj' Database.Keys.storeInodeCaches key [file] next $ return True -makeHardLink :: FilePath -> Key -> CommandPerform +makeHardLink :: RawFilePath -> Key -> CommandPerform makeHardLink file key = do - replaceFile file $ \tmp -> do - mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file + replaceFile (fromRawFilePath file) $ \tmp -> do + mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file linkFromAnnex key tmp mode >>= \case LinkAnnexFailed -> error "unable to make hard link" _ -> noop diff --git a/Command/FromKey.hs b/Command/FromKey.hs --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -51,7 +51,7 @@ in if not (null keyname) && not (null file) then Right $ go file (keyOpt keyname) else Left "Expected pairs of key and filename" - go file key = starting "fromkey" (mkActionItem (key, file)) $ + go file key = starting "fromkey" (mkActionItem (key, toRawFilePath file)) $ perform key file start :: Bool -> (String, FilePath) -> CommandStart @@ -61,7 +61,7 @@ inbackend <- inAnnex key unless inbackend $ giveup $ "key ("++ keyname ++") is not present in backend (use --force to override this sanity check)" - starting "fromkey" (mkActionItem (key, file)) $ + starting "fromkey" (mkActionItem (key, toRawFilePath file)) $ perform key file -- From user input to a Key. @@ -80,7 +80,7 @@ Nothing -> giveup $ "bad key/url " ++ s perform :: Key -> FilePath -> CommandPerform -perform key file = lookupFileNotHidden file >>= \case +perform key file = lookupFileNotHidden (toRawFilePath file) >>= \case Nothing -> ifM (liftIO $ doesFileExist file) ( hasothercontent , do diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -35,6 +35,7 @@ import Types.CleanupActions import Types.Key import Types.ActionItem +import qualified Utility.RawFilePath as R import Data.Time.Clock.POSIX import System.Posix.Types (EpochTime) @@ -102,11 +103,11 @@ whenM ((==) DeadTrusted <$> lookupTrust u) $ earlyWarning "Warning: Fscking a repository that is currently marked as dead." -start :: Maybe Remote -> Incremental -> FilePath -> Key -> CommandStart -start from inc file key = Backend.getBackend file key >>= \case +start :: Maybe Remote -> Incremental -> RawFilePath -> Key -> CommandStart +start from inc file key = Backend.getBackend (fromRawFilePath file) key >>= \case Nothing -> stop Just backend -> do - numcopies <- getFileNumCopies file + numcopies <- getFileNumCopies (fromRawFilePath file) case from of Nothing -> go $ perform key file backend numcopies Just r -> go $ performRemote key afile backend numcopies r @@ -114,9 +115,9 @@ go = runFsck inc (mkActionItem (key, afile)) key afile = AssociatedFile (Just file) -perform :: Key -> FilePath -> Backend -> NumCopies -> Annex Bool +perform :: Key -> RawFilePath -> Backend -> NumCopies -> Annex Bool perform key file backend numcopies = do - keystatus <- getKeyFileStatus key file + keystatus <- getKeyFileStatus key (fromRawFilePath file) check -- order matters [ fixLink key file @@ -163,7 +164,7 @@ pid <- liftIO getPID t <- fromRepo gitAnnexTmpObjectDir createAnnexDirectory t - let tmp = t "fsck" ++ show pid ++ "." ++ keyFile key + let tmp = t "fsck" ++ show pid ++ "." ++ fromRawFilePath (keyFile key) let cleanup = liftIO $ catchIO (removeFile tmp) (const noop) cleanup cleanup `after` a tmp @@ -203,18 +204,18 @@ check cs = and <$> sequence cs {- Checks that symlinks points correctly to the annexed content. -} -fixLink :: Key -> FilePath -> Annex Bool +fixLink :: Key -> RawFilePath -> Annex Bool fixLink key file = do - want <- calcRepo $ gitAnnexLink file key + want <- calcRepo $ gitAnnexLink (fromRawFilePath file) key have <- getAnnexLinkTarget file maybe noop (go want) have return True where go want have - | want /= fromInternalGitPath (fromRawFilePath have) = do + | want /= fromRawFilePath (fromInternalGitPath have) = do showNote "fixing link" - liftIO $ createDirectoryIfMissing True (parentDir file) - liftIO $ removeFile file + liftIO $ createDirectoryIfMissing True (parentDir (fromRawFilePath file)) + liftIO $ removeFile (fromRawFilePath file) addAnnexLink want file | otherwise = noop @@ -222,7 +223,7 @@ - in this repository only. -} verifyLocationLog :: Key -> KeyStatus -> ActionItem -> Annex Bool verifyLocationLog key keystatus ai = do - obj <- calcRepo $ gitAnnexLocation key + obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) present <- if isKeyUnlockedThin keystatus then liftIO (doesFileExist obj) else inAnnex key @@ -267,7 +268,7 @@ fix InfoMissing warning $ "** Based on the location log, " ++ - actionItemDesc ai ++ + decodeBS' (actionItemDesc ai) ++ "\n** was expected to be present, " ++ "but its content is missing." return False @@ -302,14 +303,14 @@ missingrequired <- Remote.prettyPrintUUIDs "missingrequired" missinglocs warning $ "** Required content " ++ - actionItemDesc ai ++ + decodeBS' (actionItemDesc ai) ++ " is missing from these repositories:\n" ++ missingrequired return False verifyRequiredContent _ _ = return True {- Verifies the associated file records. -} -verifyAssociatedFiles :: Key -> KeyStatus -> FilePath -> Annex Bool +verifyAssociatedFiles :: Key -> KeyStatus -> RawFilePath -> Annex Bool verifyAssociatedFiles key keystatus file = do when (isKeyUnlockedThin keystatus) $ do f <- inRepo $ toTopFilePath file @@ -318,7 +319,7 @@ Database.Keys.addAssociatedFile key f return True -verifyWorkTree :: Key -> FilePath -> Annex Bool +verifyWorkTree :: Key -> RawFilePath -> Annex Bool verifyWorkTree key file = do {- Make sure that a pointer file is replaced with its content, - when the content is available. -} @@ -326,12 +327,12 @@ case mk of Just k | k == key -> whenM (inAnnex key) $ do showNote "fixing worktree content" - replaceFile file $ \tmp -> do - mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file + replaceFile (fromRawFilePath file) $ \tmp -> do + mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file ifM (annexThin <$> Annex.getGitConfig) ( void $ linkFromAnnex key tmp mode , do - obj <- calcRepo $ gitAnnexLocation key + obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) void $ checkedCopyFile key obj tmp mode thawContent tmp ) @@ -348,8 +349,8 @@ checkKeySize _ KeyUnlockedThin _ = return True checkKeySize key _ ai = do file <- calcRepo $ gitAnnexLocation key - ifM (liftIO $ doesFileExist file) - ( checkKeySizeOr badContent key file ai + ifM (liftIO $ R.doesPathExist file) + ( checkKeySizeOr badContent key (fromRawFilePath file) ai , return True ) @@ -375,7 +376,7 @@ badsize a b = do msg <- bad key warning $ concat - [ actionItemDesc ai + [ decodeBS' (actionItemDesc ai) , ": Bad file size (" , compareSizes storageUnits True a b , "); " @@ -393,11 +394,11 @@ case Types.Backend.canUpgradeKey backend of Just a | a key -> do warning $ concat - [ actionItemDesc ai + [ decodeBS' (actionItemDesc ai) , ": Can be upgraded to an improved key format. " , "You can do so by running: git annex migrate --backend=" , decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " " - , file + , decodeBS' file ] return True _ -> return True @@ -416,10 +417,10 @@ -} checkBackend :: Backend -> Key -> KeyStatus -> AssociatedFile -> Annex Bool checkBackend backend key keystatus afile = do - content <- calcRepo $ gitAnnexLocation key + content <- calcRepo (gitAnnexLocation key) ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content)) ( nocheck - , checkBackendOr badContent backend key content ai + , checkBackendOr badContent backend key (fromRawFilePath content) ai ) where nocheck = return True @@ -448,7 +449,7 @@ unless ok $ do msg <- bad key warning $ concat - [ actionItemDesc ai + [ decodeBS' (actionItemDesc ai) , ": Bad file content; " , msg ] @@ -460,7 +461,7 @@ checkKeyNumCopies key afile numcopies = do let (desc, hasafile) = case afile of AssociatedFile Nothing -> (serializeKey key, False) - AssociatedFile (Just af) -> (af, True) + AssociatedFile (Just af) -> (fromRawFilePath af, True) locs <- loggedLocations key (untrustedlocations, otherlocations) <- trustPartition UnTrusted locs (deadlocations, safelocations) <- trustPartition DeadTrusted otherlocations @@ -515,7 +516,7 @@ badContentRemote :: Remote -> FilePath -> Key -> Annex String badContentRemote remote localcopy key = do bad <- fromRepo gitAnnexBadDir - let destbad = bad keyFile key + let destbad = bad fromRawFilePath (keyFile key) movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad)) ( return False , do @@ -669,8 +670,8 @@ getKeyStatus :: Key -> Annex KeyStatus getKeyStatus key = catchDefaultIO KeyMissing $ do afs <- not . null <$> Database.Keys.getAssociatedFiles key - obj <- calcRepo $ gitAnnexLocation key - multilink <- ((> 1) . linkCount <$> liftIO (getFileStatus obj)) + obj <- calcRepo (gitAnnexLocation key) + multilink <- ((> 1) . linkCount <$> liftIO (R.getFileStatus obj)) return $ if multilink && afs then KeyUnlockedThin else KeyPresent @@ -680,7 +681,7 @@ s <- getKeyStatus key case s of KeyUnlockedThin -> catchDefaultIO KeyUnlockedThin $ - ifM (isJust <$> isAnnexLink file) + ifM (isJust <$> isAnnexLink (toRawFilePath file)) ( return KeyLockedThin , return KeyUnlockedThin ) diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.FuzzTest where import Command @@ -13,6 +15,7 @@ import Config import Utility.ThreadScheduler import Utility.DiskFree +import Git.Types (fromConfigKey) import Data.Time.Clock import System.Random (getStdRandom, random, randomR) @@ -32,25 +35,23 @@ start = do guardTest logf <- fromRepo gitAnnexFuzzTestLogFile - showStart "fuzztest" logf + showStart "fuzztest" (toRawFilePath logf) logh <- liftIO $ openFile logf WriteMode void $ forever $ fuzz logh stop guardTest :: Annex () -guardTest = unlessM (fromMaybe False . Git.Config.isTrue <$> getConfig key "") $ +guardTest = unlessM (fromMaybe False . Git.Config.isTrueFalse' <$> getConfig key mempty) $ giveup $ unlines [ "Running fuzz tests *writes* to and *deletes* files in" , "this repository, and pushes those changes to other" , "repositories! This is a developer tool, not something" , "to play with." , "" - , "Refusing to run fuzz tests, since " ++ keyname ++ " is not set!" + , "Refusing to run fuzz tests, since " ++ fromConfigKey key ++ " is not set!" ] where key = annexConfig "eat-my-repository" - (ConfigKey keyname) = key - fuzz :: Handle -> Annex () fuzz logh = do diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -42,19 +42,19 @@ from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o) let go = whenAnnexed $ start o from case batchOption o of - Batch fmt -> batchFilesMatching fmt go + Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) (autoMode o) (commandAction . startKeys from) (withFilesInGit (commandAction . go)) =<< workTreeItems (getFiles o) -start :: GetOptions -> Maybe Remote -> FilePath -> Key -> CommandStart +start :: GetOptions -> Maybe Remote -> RawFilePath -> Key -> CommandStart start o from file key = start' expensivecheck from key afile ai where afile = AssociatedFile (Just file) ai = mkActionItem (key, afile) expensivecheck - | autoMode o = numCopiesCheck file key (<) + | autoMode o = numCopiesCheck (fromRawFilePath file) key (<) <||> wantGet False (Just key) afile | otherwise = return True diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -97,12 +97,13 @@ seek :: ImportOptions -> CommandSeek seek o@(LocalImportOptions {}) = startConcurrency commandStages $ do - repopath <- liftIO . absPath =<< fromRepo Git.repoPath + repopath <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath (importFiles o) unless (null inrepops) $ do giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops largematcher <- largeFilesMatcher - (commandAction . startLocal largematcher (duplicateMode o)) + addunlockedmatcher <- addUnlockedMatcher + (commandAction . startLocal addunlockedmatcher largematcher (duplicateMode o)) `withPathContents` importFiles o seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do r <- getParsed (importFromRemote o) @@ -110,14 +111,14 @@ giveup "That remote does not support imports." subdir <- maybe (pure Nothing) - (Just <$$> inRepo . toTopFilePath) + (Just <$$> inRepo . toTopFilePath . toRawFilePath) (importToSubDir o) seekRemote r (importToBranch o) subdir -startLocal :: GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart -startLocal largematcher mode (srcfile, destfile) = +startLocal :: AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart +startLocal addunlockedmatcher largematcher mode (srcfile, destfile) = ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile) - ( starting "import" (ActionItemWorkTreeFile destfile) + ( starting "import" (ActionItemWorkTreeFile (toRawFilePath destfile)) pickaction , stop ) @@ -181,7 +182,7 @@ -- weakly the same as the origianlly locked down file's -- inode cache. (Since the file may have been copied, -- its inodes may not be the same.) - newcache <- withTSDelta $ liftIO . genInodeCache destfile + newcache <- withTSDelta $ liftIO . genInodeCache (toRawFilePath destfile) let unchanged = case (newcache, inodeCache (keySource ld)) of (_, Nothing) -> True (Just newc, Just c) | compareWeak c newc -> True @@ -202,13 +203,17 @@ >>= maybe stop (\addedk -> next $ Command.Add.cleanup addedk True) - , next $ Command.Add.addSmall destfile + , next $ Command.Add.addSmall $ toRawFilePath destfile ) notoverwriting why = do warning $ "not overwriting existing " ++ destfile ++ " " ++ why stop lockdown a = do - lockingfile <- not <$> addUnlocked + let mi = MatchingFile $ FileInfo + { currFile = toRawFilePath srcfile + , matchFile = toRawFilePath destfile + } + lockingfile <- not <$> addUnlocked addunlockedmatcher mi -- Minimal lock down with no hard linking so nothing -- has to be done to clean up from it. let cfg = LockDownConfig diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -38,6 +38,7 @@ import Types.MetaData import Logs.MetaData import Annex.MetaData +import Annex.FileMatcher import Command.AddUrl (addWorkTree) cmd :: Command @@ -62,12 +63,13 @@ seek :: ImportFeedOptions -> CommandSeek seek o = do + addunlockedmatcher <- addUnlockedMatcher cache <- getCache (templateOption o) - forM_ (feedUrls o) (getFeed o cache) + forM_ (feedUrls o) (getFeed addunlockedmatcher o cache) -getFeed :: ImportFeedOptions -> Cache -> URLString -> CommandSeek -getFeed opts cache url = do - showStart "importfeed" url +getFeed :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> URLString -> CommandSeek +getFeed addunlockedmatcher opts cache url = do + showStart' "importfeed" (Just url) downloadFeed url >>= \case Nothing -> showEndResult =<< feedProblem url "downloading the feed failed" @@ -77,7 +79,7 @@ [] -> debugfeedcontent feedcontent "bad feed content; no enclosures to download" l -> do showEndOk - ifM (and <$> mapM (performDownload opts cache) l) + ifM (and <$> mapM (performDownload addunlockedmatcher opts cache) l) ( clearFeedProblem url , void $ feedProblem url "problem downloading some item(s) from feed" @@ -153,8 +155,8 @@ , return Nothing ) -performDownload :: ImportFeedOptions -> Cache -> ToDownload -> Annex Bool -performDownload opts cache todownload = case location todownload of +performDownload :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> ToDownload -> Annex Bool +performDownload addunlockedmatcher opts cache todownload = case location todownload of Enclosure url -> checkknown url $ rundownload url (takeWhile (/= '?') $ takeExtension url) $ \f -> do r <- Remote.claimingUrl url @@ -171,7 +173,7 @@ -- don't use youtube-dl , rawOption = True } - maybeToList <$> addUrlFile dlopts url urlinfo f + maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f else do res <- tryNonAsync $ maybe (error $ "unable to checkUrl of " ++ Remote.name r) @@ -181,10 +183,10 @@ Left _ -> return [] Right (UrlContents sz _) -> maybeToList <$> - downloadRemoteFile r (downloadOptions opts) url f sz + downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url f sz Right (UrlMulti l) -> do kl <- forM l $ \(url', sz, subf) -> - downloadRemoteFile r (downloadOptions opts) url' (f fromSafeFilePath subf) sz + downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url' (f fromSafeFilePath subf) sz return $ if all isJust kl then catMaybes kl else [] @@ -222,7 +224,7 @@ case dest of Nothing -> return True Just f -> do - showStart "addurl" url + showStart' "addurl" (Just url) ks <- getter f if null ks then do @@ -244,7 +246,7 @@ - to be re-downloaded. -} makeunique url n file = ifM alreadyexists ( ifM forced - ( ifAnnexed f checksameurl tryanother + ( ifAnnexed (toRawFilePath f) checksameurl tryanother , tryanother ) , return $ Just f @@ -273,7 +275,7 @@ [] -> ".m" s -> s ok <- rundownload linkurl ext $ \f -> do - addWorkTree webUUID mediaurl f mediakey (Just mediafile) + addWorkTree addunlockedmatcher webUUID mediaurl f mediakey (Just mediafile) return [mediakey] return (Just ok) -- youtude-dl didn't support it, so @@ -285,16 +287,16 @@ return Nothing return (fromMaybe False r) where - downloadlink = performDownload opts cache todownload + downloadlink = performDownload addunlockedmatcher opts cache todownload { location = Enclosure linkurl } addmediafast linkurl mediaurl mediakey = ifM (pure (not (rawOption (downloadOptions opts))) <&&> youtubeDlSupported linkurl) ( rundownload linkurl ".m" $ \f -> do - addWorkTree webUUID mediaurl f mediakey Nothing + addWorkTree addunlockedmatcher webUUID mediaurl f mediakey Nothing return [mediakey] - , performDownload opts cache todownload + , performDownload addunlockedmatcher opts cache todownload { location = Enclosure linkurl } ) diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -152,7 +152,7 @@ v' <- Remote.nameToUUID' p case v' of Right u -> uuidInfo o u - Left _ -> ifAnnexed p + Left _ -> ifAnnexed (toRawFilePath p) (fileInfo o p) (treeishInfo o p) ) @@ -161,7 +161,7 @@ noInfo :: String -> Annex () noInfo s = do - showStart "info" s + showStart "info" (encodeBS' s) showNote $ "not a directory or an annexed file or a treeish or a remote or a uuid" showEndFail @@ -311,8 +311,8 @@ showStat s = maybe noop calc =<< s where calc (desc, a) = do - (lift . showHeader) desc - lift . showRaw =<< a + (lift . showHeader . encodeBS') desc + lift . showRaw . encodeBS' =<< a repo_list :: TrustLevel -> Stat repo_list level = stat n $ nojson $ lift $ do @@ -435,7 +435,7 @@ desc = "transfers in progress" line uuidmap t i = unwords [ formatDirection (transferDirection t) ++ "ing" - , actionItemDesc $ mkActionItem + , fromRawFilePath $ actionItemDesc $ mkActionItem (transferKey t, associatedFile i) , if transferDirection t == Upload then "to" else "from" , maybe (fromUUID $ transferUUID t) Remote.name $ @@ -444,7 +444,7 @@ jsonify t i = object $ map (\(k, v) -> (packString k, v)) $ [ ("transfer", toJSON' (formatDirection (transferDirection t))) , ("key", toJSON' (transferKey t)) - , ("file", toJSON' afile) + , ("file", toJSON' (fromRawFilePath <$> afile)) , ("remote", toJSON' (fromUUID (transferUUID t) :: String)) ] where @@ -454,7 +454,7 @@ disk_size = simpleStat "available local disk space" $ calcfree <$> (lift $ annexDiskReserve <$> Annex.getGitConfig) - <*> (lift $ inRepo $ getDiskFree . gitAnnexDir) + <*> (lift $ inRepo $ getDiskFree . fromRawFilePath . gitAnnexDir) <*> mkSizer where calcfree reserve (Just have) sizer = unwords @@ -577,7 +577,7 @@ then return (numcopiesstats, repodata) else do locs <- Remote.keyLocations key - nc <- updateNumCopiesStats file numcopiesstats locs + nc <- updateNumCopiesStats (fromRawFilePath file) numcopiesstats locs return (nc, updateRepoData key locs repodata) return $! (presentdata', referenceddata', numcopiesstats', repodata') , return vs @@ -674,7 +674,7 @@ keysizes keys = do dir <- lift $ fromRepo dirspec liftIO $ forM keys $ \k -> catchDefaultIO 0 $ - getFileSize (dir keyFile k) + getFileSize (dir fromRawFilePath (keyFile k)) aside :: String -> String aside s = " (" ++ s ++ ")" diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.InitRemote where import qualified Data.Map as M diff --git a/Command/Inprogress.hs b/Command/Inprogress.hs --- a/Command/Inprogress.hs +++ b/Command/Inprogress.hs @@ -42,7 +42,7 @@ (commandAction . (whenAnnexed (start s))) =<< workTreeItems (inprogressFiles o) -start :: S.Set Key -> FilePath -> Key -> CommandStart +start :: S.Set Key -> RawFilePath -> Key -> CommandStart start s _file k | S.member k s = start' k | otherwise = stop diff --git a/Command/List.hs b/Command/List.hs --- a/Command/List.hs +++ b/Command/List.hs @@ -72,7 +72,7 @@ printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex () printHeader l = liftIO $ putStrLn $ lheader $ map (\(_, n, t) -> (n, t)) l -start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> Key -> CommandStart +start :: [(UUID, RemoteName, TrustLevel)] -> RawFilePath -> Key -> CommandStart start l file key = do ls <- S.fromList <$> keyLocations key liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file @@ -88,8 +88,8 @@ trust UnTrusted = " (untrusted)" trust _ = "" -format :: [(TrustLevel, Present)] -> FilePath -> String -format remotes file = thereMap ++ " " ++ file +format :: [(TrustLevel, Present)] -> RawFilePath -> String +format remotes file = thereMap ++ " " ++ fromRawFilePath file where thereMap = concatMap there remotes there (UnTrusted, True) = "x" diff --git a/Command/Lock.hs b/Command/Lock.hs --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -20,6 +20,7 @@ import Annex.Ingest import Logs.Location import Git.FilePath +import qualified Utility.RawFilePath as R cmd :: Command cmd = withGlobalOptions [jsonOptions, annexedMatchingOptions] $ @@ -32,7 +33,7 @@ l <- workTreeItems ps withFilesInGit (commandAction . (whenAnnexed startNew)) l -startNew :: FilePath -> Key -> CommandStart +startNew :: RawFilePath -> Key -> CommandStart startNew file key = ifM (isJust <$> isAnnexLink file) ( stop , starting "lock" (mkActionItem (key, file)) $ @@ -43,7 +44,7 @@ | key' == key = cont | otherwise = errorModified go Nothing = - ifM (isUnmodified key file) + ifM (isUnmodified key file) ( cont , ifM (Annex.getState Annex.force) ( cont @@ -52,28 +53,29 @@ ) cont = performNew file key -performNew :: FilePath -> Key -> CommandPerform +performNew :: RawFilePath -> Key -> CommandPerform performNew file key = do lockdown =<< calcRepo (gitAnnexLocation key) - addLink file key + addLink (fromRawFilePath file) key =<< withTSDelta (liftIO . genInodeCache file) next $ cleanupNew file key where lockdown obj = do ifM (isUnmodified key obj) ( breakhardlink obj - , repopulate obj + , repopulate (fromRawFilePath obj) ) - whenM (liftIO $ doesFileExist obj) $ - freezeContent obj + whenM (liftIO $ R.doesPathExist obj) $ + freezeContent $ fromRawFilePath obj -- It's ok if the file is hard linked to obj, but if some other -- associated file is, we need to break that link to lock down obj. - breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (getFileStatus obj)) $ do + breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (R.getFileStatus obj)) $ do mfc <- withTSDelta (liftIO . genInodeCache file) unlessM (sameInodeCache obj (maybeToList mfc)) $ do - modifyContent obj $ replaceFile obj $ \tmp -> do - unlessM (checkedCopyFile key obj tmp Nothing) $ + let obj' = fromRawFilePath obj + modifyContent obj' $ replaceFile obj' $ \tmp -> do + unlessM (checkedCopyFile key obj' tmp Nothing) $ giveup "unable to lock file" Database.Keys.storeInodeCaches key [obj] @@ -86,27 +88,27 @@ liftIO $ nukeFile obj case mfile of Just unmodified -> - unlessM (checkedCopyFile key unmodified obj Nothing) + unlessM (checkedCopyFile key (fromRawFilePath unmodified) obj Nothing) lostcontent Nothing -> lostcontent lostcontent = logStatus key InfoMissing -cleanupNew :: FilePath -> Key -> CommandCleanup +cleanupNew :: RawFilePath -> Key -> CommandCleanup cleanupNew file key = do Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file) return True -startOld :: FilePath -> CommandStart +startOld :: RawFilePath -> CommandStart startOld file = do unlessM (Annex.getState Annex.force) errorModified starting "lock" (ActionItemWorkTreeFile file) $ performOld file -performOld :: FilePath -> CommandPerform +performOld :: RawFilePath -> CommandPerform performOld file = do - Annex.Queue.addCommand "checkout" [Param "--"] [file] + Annex.Queue.addCommand "checkout" [Param "--"] [fromRawFilePath file] next $ return True errorModified :: a diff --git a/Command/Log.hs b/Command/Log.hs --- a/Command/Log.hs +++ b/Command/Log.hs @@ -92,10 +92,10 @@ ([], True) -> commandAction (startAll o outputter) (_, True) -> giveup "Cannot specify both files and --all" -start :: LogOptions -> (FilePath -> Outputter) -> FilePath -> Key -> CommandStart +start :: LogOptions -> (FilePath -> Outputter) -> RawFilePath -> Key -> CommandStart start o outputter file key = do (changes, cleanup) <- getKeyLog key (passthruOptions o) - showLogIncremental (outputter file) changes + showLogIncremental (outputter (fromRawFilePath file)) changes void $ liftIO cleanup stop @@ -199,9 +199,9 @@ getKeyLog :: Key -> [CommandParam] -> Annex ([RefChange], IO Bool) getKeyLog key os = do top <- fromRepo Git.repoPath - p <- liftIO $ relPathCwdToFile top + p <- liftIO $ relPathCwdToFile $ fromRawFilePath top config <- Annex.getGitConfig - let logfile = p locationLogFile config key + let logfile = p fromRawFilePath (locationLogFile config key) getGitLog [logfile] (Param "--remove-empty" : os) {- Streams the git log for all git-annex branch changes. -} @@ -220,7 +220,7 @@ [ Param $ Git.fromRef Annex.Branch.fullname , Param "--" ] ++ map Param fs - return (parseGitRawLog ls, cleanup) + return (parseGitRawLog (map decodeBL' ls), cleanup) -- Parses chunked git log --raw output, which looks something like: -- @@ -250,7 +250,7 @@ (tss, cl') -> (parseTimeStamp tss, cl') mrc = do (old, new) <- parseRawChangeLine cl - key <- locationLogFileKey c2 + key <- locationLogFileKey (toRawFilePath c2) return $ RefChange { changetime = ts , oldref = old diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -29,11 +29,12 @@ -- To support absolute filenames, pass through git ls-files. -- But, this plumbing command does not recurse through directories. -seekSingleGitFile :: FilePath -> Annex (Maybe FilePath) +seekSingleGitFile :: FilePath -> Annex (Maybe RawFilePath) seekSingleGitFile file = do - (l, cleanup) <- inRepo (Git.LsFiles.inRepo [file]) + (l, cleanup) <- inRepo (Git.LsFiles.inRepo [toRawFilePath file]) r <- case l of - (f:[]) | takeFileName f == takeFileName file -> return (Just f) + (f:[]) | takeFileName (fromRawFilePath f) == takeFileName file -> + return (Just f) _ -> return Nothing void $ liftIO cleanup return r diff --git a/Command/Map.hs b/Command/Map.hs --- a/Command/Map.hs +++ b/Command/Map.hs @@ -46,7 +46,9 @@ umap <- uuidDescMap trustmap <- trustMapLoad - file <- () <$> fromRepo gitAnnexDir <*> pure "map.dot" + file <- () + <$> fromRepo (fromRawFilePath . gitAnnexDir) + <*> pure "map.dot" liftIO $ writeFile file (drawMap rs trustmap umap) next $ @@ -176,7 +178,8 @@ | Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r | Git.repoIsUrl r = return r | otherwise = liftIO $ do - r' <- Git.Construct.fromAbsPath =<< absPath (Git.repoPath r) + r' <- Git.Construct.fromAbsPath + =<< absPath (fromRawFilePath (Git.repoPath r)) r'' <- safely $ flip Annex.eval Annex.gitRepo =<< Annex.new r' return (fromMaybe r' r'') @@ -234,7 +237,7 @@ where remotecmd = "sh -c " ++ shellEscape (cddir ++ " && " ++ "git config --null --list") - dir = Git.repoPath r + dir = fromRawFilePath $ Git.repoPath r cddir | "/~" `isPrefixOf` dir = let (userhome, reldir) = span (/= '/') (drop 1 dir) diff --git a/Command/MatchExpression.hs b/Command/MatchExpression.hs --- a/Command/MatchExpression.hs +++ b/Command/MatchExpression.hs @@ -9,7 +9,6 @@ import Command import Annex.FileMatcher -import Types.FileMatcher import Utility.DataUnits import Utility.Matcher import Annex.UUID @@ -75,7 +74,7 @@ seek :: MatchExpressionOptions -> CommandSeek seek o = do parser <- if largeFilesExpression o - then mkLargeFilesParser + then mkMatchExpressionParser else do u <- getUUID pure $ preferredContentParser $ preferredContentTokens $ PCD diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -92,7 +92,7 @@ ) _ -> giveup "--batch is currently only supported in --json mode" -start :: VectorClock -> MetaDataOptions -> FilePath -> Key -> CommandStart +start :: VectorClock -> MetaDataOptions -> RawFilePath -> Key -> CommandStart start c o file k = startKeys c o (k, mkActionItem (k, afile)) where afile = AssociatedFile (Just file) @@ -147,7 +147,7 @@ fieldsField :: T.Text fieldsField = T.pack "fields" -parseJSONInput :: String -> Either String (Either FilePath Key, MetaData) +parseJSONInput :: String -> Either String (Either RawFilePath Key, MetaData) parseJSONInput i = do v <- eitherDecode (BU.fromString i) let m = case itemAdded v of @@ -155,16 +155,16 @@ Just (MetaDataFields m') -> m' case (itemKey v, itemFile v) of (Just k, _) -> Right (Right k, m) - (Nothing, Just f) -> Right (Left f, m) + (Nothing, Just f) -> Right (Left (toRawFilePath f), m) (Nothing, Nothing) -> Left "JSON input is missing either file or key" -startBatch :: (Either FilePath Key, MetaData) -> CommandStart +startBatch :: (Either RawFilePath Key, MetaData) -> CommandStart startBatch (i, (MetaData m)) = case i of Left f -> do mk <- lookupFile f case mk of Just k -> go k (mkActionItem (k, AssociatedFile (Just f))) - Nothing -> giveup $ "not an annexed file: " ++ f + Nothing -> giveup $ "not an annexed file: " ++ fromRawFilePath f Right k -> go k (mkActionItem k) where go k ai = starting "metadata" ai $ do diff --git a/Command/Migrate.hs b/Command/Migrate.hs --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -28,16 +28,16 @@ seek :: CmdParams -> CommandSeek seek = withFilesInGit (commandAction . (whenAnnexed start)) <=< workTreeItems -start :: FilePath -> Key -> CommandStart +start :: RawFilePath -> Key -> CommandStart start file key = do forced <- Annex.getState Annex.force - v <- Backend.getBackend file key + v <- Backend.getBackend (fromRawFilePath file) key case v of Nothing -> stop Just oldbackend -> do exists <- inAnnex key newbackend <- maybe defaultBackend return - =<< chooseBackend file + =<< chooseBackend (fromRawFilePath file) if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists then starting "migrate" (mkActionItem (key, file)) $ perform file key oldbackend newbackend @@ -63,7 +63,7 @@ - data cannot get corrupted after the fsck but before the new key is - generated. -} -perform :: FilePath -> Key -> Backend -> Backend -> CommandPerform +perform :: RawFilePath -> Key -> Backend -> Backend -> CommandPerform perform file oldkey oldbackend newbackend = go =<< genkey (fastMigrate oldbackend) where go Nothing = stop @@ -85,8 +85,8 @@ genkey Nothing = do content <- calcRepo $ gitAnnexLocation oldkey let source = KeySource - { keyFilename = file - , contentLocation = content + { keyFilename = fromRawFilePath file + , contentLocation = fromRawFilePath content , inodeCache = Nothing } v <- genKey source nullMeterUpdate (Just newbackend) diff --git a/Command/Mirror.hs b/Command/Mirror.hs --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -47,7 +47,7 @@ (withFilesInGit (commandAction . (whenAnnexed $ start o))) =<< workTreeItems (mirrorFiles o) -start :: MirrorOptions -> FilePath -> Key -> CommandStart +start :: MirrorOptions -> RawFilePath -> Key -> CommandStart start o file k = startKey o afile (k, ai) where afile = AssociatedFile (Just file) @@ -75,4 +75,4 @@ where getnumcopies = case afile of AssociatedFile Nothing -> getNumCopies - AssociatedFile (Just af) -> getFileNumCopies af + AssociatedFile (Just af) -> getFileNumCopies (fromRawFilePath af) diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -57,13 +57,13 @@ seek o = startConcurrency transferStages $ do let go = whenAnnexed $ start (fromToOptions o) (removeWhen o) case batchOption o of - Batch fmt -> batchFilesMatching fmt go + Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) False (commandAction . startKey (fromToOptions o) (removeWhen o)) (withFilesInGit (commandAction . go)) =<< workTreeItems (moveFiles o) -start :: FromToHereOptions -> RemoveWhen -> FilePath -> Key -> CommandStart +start :: FromToHereOptions -> RemoveWhen -> RawFilePath -> Key -> CommandStart start fromto removewhen f k = start' fromto removewhen afile k ai where afile = AssociatedFile (Just f) diff --git a/Command/Multicast.hs b/Command/Multicast.hs --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -137,7 +137,8 @@ mk <- lookupFile f case mk of Nothing -> noop - Just k -> withObjectLoc k (addlist f) + Just k -> withObjectLoc k $ + addlist f . fromRawFilePath liftIO $ hClose h serverkey <- uftpKey diff --git a/Command/P2P.hs b/Command/P2P.hs --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.P2P where import Command diff --git a/Command/PostReceive.hs b/Command/PostReceive.hs --- a/Command/PostReceive.hs +++ b/Command/PostReceive.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.PostReceive where import Command diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -53,11 +53,11 @@ (removeViewMetaData v) addViewMetaData :: View -> ViewedFile -> Key -> CommandStart -addViewMetaData v f k = starting "metadata" (mkActionItem (k, f)) $ +addViewMetaData v f k = starting "metadata" (mkActionItem (k, toRawFilePath f)) $ next $ changeMetaData k $ fromView v f removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart -removeViewMetaData v f k = starting "metadata" (mkActionItem (k, f)) $ +removeViewMetaData v f k = starting "metadata" (mkActionItem (k, toRawFilePath f)) $ next $ changeMetaData k $ unsetMetaData $ fromView v f changeMetaData :: Key -> MetaData -> CommandCleanup diff --git a/Command/ReKey.hs b/Command/ReKey.hs --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -19,6 +19,7 @@ import qualified Database.Keys import Annex.InodeSentinal import Utility.InodeCache +import qualified Utility.RawFilePath as R cmd :: Command cmd = command "rekey" SectionPlumbing @@ -38,13 +39,13 @@ -- Split on the last space, since a FilePath can contain whitespace, -- but a Key very rarely does. -batchParser :: String -> Either String (FilePath, Key) +batchParser :: String -> Either String (RawFilePath, Key) batchParser s = case separate (== ' ') (reverse s) of (rk, rf) | null rk || null rf -> Left "Expected: \"file key\"" | otherwise -> case deserializeKey (reverse rk) of Nothing -> Left "bad key" - Just k -> Right (reverse rf, k) + Just k -> Right (toRawFilePath (reverse rf), k) seek :: ReKeyOptions -> CommandSeek seek o = case batchOption o of @@ -52,9 +53,9 @@ NoBatch -> withPairs (commandAction . start . parsekey) (reKeyThese o) where parsekey (file, skey) = - (file, fromMaybe (giveup "bad key") (deserializeKey skey)) + (toRawFilePath file, fromMaybe (giveup "bad key") (deserializeKey skey)) -start :: (FilePath, Key) -> CommandStart +start :: (RawFilePath, Key) -> CommandStart start (file, newkey) = ifAnnexed file go stop where go oldkey @@ -62,19 +63,19 @@ | otherwise = starting "rekey" (ActionItemWorkTreeFile file) $ perform file oldkey newkey -perform :: FilePath -> Key -> Key -> CommandPerform +perform :: RawFilePath -> Key -> Key -> CommandPerform perform file oldkey newkey = do ifM (inAnnex oldkey) ( unlessM (linkKey file oldkey newkey) $ giveup "failed creating link from old to new key" , unlessM (Annex.getState Annex.force) $ - giveup $ file ++ " is not available (use --force to override)" + giveup $ fromRawFilePath file ++ " is not available (use --force to override)" ) next $ cleanup file oldkey newkey {- Make a hard link to the old key content (when supported), - to avoid wasting disk space. -} -linkKey :: FilePath -> Key -> Key -> Annex Bool +linkKey :: RawFilePath -> Key -> Key -> Annex Bool linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file) {- If the object file is already hardlinked to elsewhere, a hard - link won't be made by getViaTmpFromDisk, but a copy instead. @@ -82,17 +83,17 @@ - unlocked file, which would leave the new key unlocked - and vulnerable to corruption. -} ( getViaTmpFromDisk RetrievalAllKeysSecure DefaultVerify newkey $ \tmp -> unVerified $ do - oldobj <- calcRepo (gitAnnexLocation oldkey) + oldobj <- fromRawFilePath <$> calcRepo (gitAnnexLocation oldkey) isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing , do {- The file being rekeyed is itself an unlocked file; if - it's hard linked to the old key, that link must be broken. -} - oldobj <- calcRepo (gitAnnexLocation oldkey) + oldobj <- fromRawFilePath <$> calcRepo (gitAnnexLocation oldkey) v <- tryNonAsync $ do - st <- liftIO $ getFileStatus file + st <- liftIO $ R.getFileStatus file when (linkCount st > 1) $ do freezeContent oldobj - replaceFile file $ \tmp -> do + replaceFile (fromRawFilePath file) $ \tmp -> do unlessM (checkedCopyFile oldkey oldobj tmp Nothing) $ error "can't lock old key" thawContent tmp @@ -102,22 +103,22 @@ warning (show e) return False Right () -> do - r <- linkToAnnex newkey file ic + r <- linkToAnnex newkey (fromRawFilePath file) ic return $ case r of LinkAnnexFailed -> False LinkAnnexOk -> True LinkAnnexNoop -> True ) -cleanup :: FilePath -> Key -> Key -> CommandCleanup +cleanup :: RawFilePath -> Key -> Key -> CommandCleanup cleanup file oldkey newkey = do ifM (isJust <$> isAnnexLink file) ( do -- Update symlink to use the new key. - liftIO $ removeFile file - addLink file newkey Nothing + liftIO $ removeFile (fromRawFilePath file) + addLink (fromRawFilePath file) newkey Nothing , do - mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file + mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file liftIO $ whenM (isJust <$> isPointerFile file) $ writePointerFile file newkey mode stagePointerFile file mode =<< hashPointerFile newkey diff --git a/Command/Reinject.hs b/Command/Reinject.hs --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -42,7 +42,7 @@ startSrcDest :: [FilePath] -> CommandStart startSrcDest (src:dest:[]) | src == dest = stop - | otherwise = notAnnexed src $ ifAnnexed dest go stop + | otherwise = notAnnexed src $ ifAnnexed (toRawFilePath dest) go stop where go key = starting "reinject" (ActionItemOther (Just src)) $ ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src) @@ -65,7 +65,7 @@ ) notAnnexed :: FilePath -> CommandStart -> CommandStart -notAnnexed src = ifAnnexed src $ +notAnnexed src = ifAnnexed (toRawFilePath src) $ giveup $ "cannot used annexed file as src: " ++ src perform :: FilePath -> Key -> CommandPerform diff --git a/Command/ResolveMerge.hs b/Command/ResolveMerge.hs --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -24,7 +24,7 @@ start :: CommandStart start = starting "resolvemerge" (ActionItemOther Nothing) $ do us <- fromMaybe nobranch <$> inRepo Git.Branch.current - d <- fromRepo Git.localGitDir + d <- fromRawFilePath <$> fromRepo Git.localGitDir let merge_head = d "MERGE_HEAD" them <- fromMaybe (error nomergehead) . extractSha <$> liftIO (readFile merge_head) diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -42,9 +42,11 @@ | otherwise -> Right (reverse rf, reverse ru) start :: (FilePath, URLString) -> CommandStart -start (file, url) = flip whenAnnexed file $ \_ key -> - starting "rmurl" (mkActionItem (key, AssociatedFile (Just file))) $ +start (file, url) = flip whenAnnexed file' $ \_ key -> + starting "rmurl" (mkActionItem (key, AssociatedFile (Just file'))) $ next $ cleanup url key + where + file' = toRawFilePath file cleanup :: String -> Key -> CommandCleanup cleanup url key = do diff --git a/Command/SendKey.hs b/Command/SendKey.hs --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -46,7 +46,8 @@ fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart fieldTransfer direction key a = do liftIO $ debugM "fieldTransfer" "transfer start" - afile <- AssociatedFile <$> Fields.getField Fields.associatedFile + afile <- AssociatedFile . (fmap toRawFilePath) + <$> Fields.getField Fields.associatedFile ok <- maybe (a $ const noop) -- Using noRetry here because we're the sender. (\u -> runner (Transfer direction (toUUID u) (fromKey id key)) afile noRetry a) diff --git a/Command/Smudge.hs b/Command/Smudge.hs --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -18,7 +18,10 @@ import qualified Database.Keys import qualified Git.BuildVersion import Git.FilePath +import Git.Types +import Git.HashObject import qualified Git +import qualified Git.Ref import qualified Annex import Backend import Utility.Metered @@ -70,7 +73,7 @@ case parseLinkTargetOrPointerLazy b of Nothing -> noop Just k -> do - topfile <- inRepo (toTopFilePath file) + topfile <- inRepo (toTopFilePath (toRawFilePath file)) Database.Keys.addAssociatedFile k topfile void $ smudgeLog k topfile liftIO $ L.putStr b @@ -86,13 +89,16 @@ ( liftIO $ L.hPut stdout b , case parseLinkTargetOrPointerLazy b of Just k -> do - getMoveRaceRecovery k file + getMoveRaceRecovery k (toRawFilePath file) liftIO $ L.hPut stdout b - Nothing -> go b =<< catKeyFile file + Nothing -> do + let fileref = Git.Ref.fileRef (toRawFilePath file) + indexmeta <- catObjectMetaData fileref + go b indexmeta =<< catKey' fileref indexmeta ) stop where - go b oldkey = ifM (shouldAnnex file oldkey) + go b indexmeta oldkey = ifM (shouldAnnex file indexmeta oldkey) ( do -- Before git 2.5, failing to consume all stdin here -- would cause a SIGPIPE and crash it. @@ -108,7 +114,7 @@ -- annexed and is unmodified. case oldkey of Nothing -> doingest oldkey - Just ko -> ifM (isUnmodifiedCheap ko file) + Just ko -> ifM (isUnmodifiedCheap ko (toRawFilePath file)) ( liftIO $ emitPointer ko , doingest oldkey ) @@ -141,7 +147,8 @@ -- git diff can run the clean filter on files outside the -- repository; can't annex those fileoutsiderepo = do - repopath <- liftIO . absPath =<< fromRepo Git.repoPath + repopath <- liftIO . absPath . fromRawFilePath + =<< fromRepo Git.repoPath filepath <- liftIO $ absPath file return $ not $ dirContains repopath filepath @@ -152,17 +159,17 @@ -- added to the annex, so will be added to git. But some heuristics -- are used to avoid bad behavior: -- --- If the index already contains the file, preserve its annexed/not annexed --- state. This prevents accidental conversions. +-- If the file is annexed in the index, keep it annexed. +-- This prevents accidental conversions. -- -- Otherwise, when the file's inode is the same as one that was used for -- annexed content before, annex it. This handles cases such as renaming an -- unlocked annexed file followed by git add, which the user naturally -- expects to behave the same as git mv. -shouldAnnex :: FilePath -> Maybe Key -> Annex Bool -shouldAnnex file moldkey = ifM (annexGitAddToAnnex <$> Annex.getGitConfig) - ( checkmatcher checkheuristics - , checkheuristics +shouldAnnex :: FilePath -> Maybe (Sha, FileSize, ObjectType) -> Maybe Key -> Annex Bool +shouldAnnex file indexmeta moldkey = ifM (annexGitAddToAnnex <$> Annex.getGitConfig) + ( checkunchangedgitfile $ checkmatcher checkheuristics + , checkunchangedgitfile checkheuristics ) where checkmatcher d = do @@ -173,10 +180,35 @@ Just _ -> return True Nothing -> checkknowninode - checkknowninode = withTSDelta (liftIO . genInodeCache file) >>= \case + checkknowninode = withTSDelta (liftIO . genInodeCache (toRawFilePath file)) >>= \case Nothing -> pure False Just ic -> Database.Keys.isInodeKnown ic =<< sentinalStatus + -- This checks for a case where the file had been added to git + -- previously, not to the annex before, and its content is not + -- changed, but git is running the clean filter again on it + -- (eg because its mtime or inode changed, or just because git feels + -- like it). Such a file should not be added to the annex, even if + -- annex.largefiles now matches it, because the content is not + -- changed. + checkunchangedgitfile cont = case (moldkey, indexmeta) of + (Nothing, Just (sha, sz, _)) -> liftIO (catchMaybeIO (getFileSize file)) >>= \case + Just sz' | sz' == sz -> do + -- The size is the same, so the file + -- is not much larger than what was stored + -- in git before, so it won't be out of + -- line to hash it. However, the content + -- is prevented from being stored in git + -- when hashing. + h <- inRepo $ hashObjectStart False + sha' <- liftIO $ hashFile h file + liftIO $ hashObjectStop h + if sha' == sha + then return False + else cont + _ -> cont + _ -> cont + emitPointer :: Key -> IO () emitPointer = S.putStr . formatPointer @@ -187,7 +219,7 @@ -- This also handles the case where a copy of a pointer file is made, -- then git-annex gets the content, and later git add is run on -- the pointer copy. It will then be populated with the content. -getMoveRaceRecovery :: Key -> FilePath -> Annex () +getMoveRaceRecovery :: Key -> RawFilePath -> Annex () getMoveRaceRecovery k file = void $ tryNonAsync $ whenM (inAnnex k) $ do obj <- calcRepo (gitAnnexLocation k) @@ -204,11 +236,11 @@ updateSmudged :: Restage -> Annex () updateSmudged restage = streamSmudged $ \k topf -> do - f <- fromRepo $ fromTopFilePath topf + f <- fromRepo (fromTopFilePath topf) whenM (inAnnex k) $ do obj <- calcRepo (gitAnnexLocation k) unlessM (isJust <$> populatePointerFile restage k obj f) $ liftIO (isPointerFile f) >>= \case Just k' | k' == k -> toplevelWarning False $ - "unable to populate worktree file " ++ f + "unable to populate worktree file " ++ fromRawFilePath f _ -> noop diff --git a/Command/Status.hs b/Command/Status.hs --- a/Command/Status.hs +++ b/Command/Status.hs @@ -61,6 +61,6 @@ displayStatus s = do let c = statusChar s absf <- fromRepo $ fromTopFilePath (statusFile s) - f <- liftIO $ relPathCwdToFile absf + f <- liftIO $ relPathCwdToFile $ fromRawFilePath absf unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", f)]) $ liftIO $ putStrLn $ [c] ++ " " ++ f diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -7,6 +7,7 @@ -} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} module Command.Sync ( cmd, @@ -225,7 +226,7 @@ - of the repo. This also means that sync always acts on all files in the - repository, not just on a subdirectory. -} prepMerge :: Annex () -prepMerge = Annex.changeDirectory =<< fromRepo Git.repoPath +prepMerge = Annex.changeDirectory . fromRawFilePath =<< fromRepo Git.repoPath mergeConfig :: [Git.Merge.MergeConfig] mergeConfig = @@ -408,7 +409,7 @@ let branch = Git.Ref b let subdir = if null s then Nothing - else Just (asTopFilePath s) + else Just (asTopFilePath (toRawFilePath s)) Command.Import.seekRemote remote branch subdir void $ mergeRemote remote currbranch mergeconfig (resolveMergeOverride o) @@ -467,7 +468,7 @@ ( liftIO $ do p <- readProgramFile boolSystem' p [Param "post-receive"] - (\cp -> cp { cwd = Just wt }) + (\cp -> cp { cwd = Just (fromRawFilePath wt) }) , return True ) where diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -168,7 +168,7 @@ get , Just $ check "fsck downloaded object" fsck , Just $ check "retrieveKeyFile resume from 33%" $ do - loc <- Annex.calcRepo (gitAnnexLocation k) + loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) tmp <- prepTmp k partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do sz <- hFileSize h @@ -184,7 +184,7 @@ get , Just $ check "fsck downloaded object" fsck , Just $ check "retrieveKeyFile resume from end" $ do - loc <- Annex.calcRepo (gitAnnexLocation k) + loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) tmp <- prepTmp k void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp lockContentForRemoval k removeAnnex @@ -236,11 +236,11 @@ ] where testexportdirectory = "testremote-export" - testexportlocation = mkExportLocation (testexportdirectory "location") + testexportlocation = mkExportLocation (toRawFilePath (testexportdirectory "location")) check desc a = testCase desc $ Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed" storeexport k = do - loc <- Annex.calcRepo (gitAnnexLocation k) + loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) Remote.storeExport ea loc k testexportlocation nullMeterUpdate retrieveexport k = withTmpFile "exported" $ \tmp h -> do liftIO $ hClose h @@ -252,7 +252,7 @@ removeexport k = Remote.removeExport ea k testexportlocation removeexportdirectory = case Remote.removeExportDirectory ea of Nothing -> return True - Just a -> a (mkExportDirectory testexportdirectory) + Just a -> a (mkExportDirectory (toRawFilePath testexportdirectory)) testUnavailable :: Annex.AnnexState -> Remote -> Key -> [TestTree] testUnavailable st r k = @@ -326,7 +326,7 @@ return k getReadonlyKey :: Remote -> FilePath -> Annex Key -getReadonlyKey r f = lookupFile f >>= \case +getReadonlyKey r f = lookupFile (toRawFilePath f) >>= \case Nothing -> giveup $ f ++ " is not an annexed file" Just k -> do unlessM (inAnnex k) $ diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -41,7 +41,8 @@ case deserializeKey k of Nothing -> error "bad key" (Just key) -> whenM (inAnnex key) $ do - afile <- AssociatedFile <$> Fields.getField Fields.associatedFile + afile <- AssociatedFile . (fmap toRawFilePath) + <$> Fields.getField Fields.associatedFile u <- maybe (error "missing remoteuuid") toUUID <$> Fields.getField Fields.remoteUUID let t = Transfer diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -116,10 +116,10 @@ deserialize _ = Nothing instance TCSerialized AssociatedFile where - serialize (AssociatedFile (Just f)) = f + serialize (AssociatedFile (Just f)) = fromRawFilePath f serialize (AssociatedFile Nothing) = "" deserialize "" = Just (AssociatedFile Nothing) - deserialize f = Just (AssociatedFile (Just f)) + deserialize f = Just (AssociatedFile (Just (toRawFilePath f))) instance TCSerialized RemoteName where serialize n = n diff --git a/Command/Unannex.hs b/Command/Unannex.hs --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -25,28 +25,28 @@ seek :: CmdParams -> CommandSeek seek ps = (withFilesInGit $ commandAction . whenAnnexed start) =<< workTreeItems ps -start :: FilePath -> Key -> CommandStart +start :: RawFilePath -> Key -> CommandStart start file key = stopUnless (inAnnex key) $ starting "unannex" (mkActionItem (key, file)) $ perform file key -perform :: FilePath -> Key -> CommandPerform +perform :: RawFilePath -> Key -> CommandPerform perform file key = do - liftIO $ removeFile file + liftIO $ removeFile (fromRawFilePath file) inRepo $ Git.Command.run [ Param "rm" , Param "--cached" , Param "--force" , Param "--quiet" , Param "--" - , File file + , File (fromRawFilePath file) ] next $ cleanup file key -cleanup :: FilePath -> Key -> CommandCleanup +cleanup :: RawFilePath -> Key -> CommandCleanup cleanup file key = do Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file) - src <- calcRepo $ gitAnnexLocation key + src <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) ifM (Annex.getState Annex.fast) ( do -- Only make a hard link if the annexed file does not @@ -61,11 +61,12 @@ , copyfrom src ) where + file' = fromRawFilePath file copyfrom src = - thawContent file `after` liftIO (copyFileExternal CopyAllMetaData src file) + thawContent file' `after` liftIO (copyFileExternal CopyAllMetaData src file') hardlinkfrom src = -- creating a hard link could fall; fall back to copying - ifM (liftIO $ catchBoolIO $ createLink src file >> return True) + ifM (liftIO $ catchBoolIO $ createLink src file' >> return True) ( return True , copyfrom src ) diff --git a/Command/Undo.hs b/Command/Undo.hs --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -27,9 +27,9 @@ seek ps = do -- Safety first; avoid any undo that would touch files that are not -- in the index. - (fs, cleanup) <- inRepo $ LsFiles.notInRepo False ps + (fs, cleanup) <- inRepo $ LsFiles.notInRepo False (map toRawFilePath ps) unless (null fs) $ - giveup $ "Cannot undo changes to files that are not checked into git: " ++ unwords fs + giveup $ "Cannot undo changes to files that are not checked into git: " ++ unwords (map fromRawFilePath fs) void $ liftIO $ cleanup -- Committing staged changes before undo allows later @@ -51,7 +51,7 @@ -- Get the reversed diff that needs to be applied to undo. (diff, cleanup) <- inRepo $ diffLog [Param "-R", Param "--", Param p] - top <- inRepo $ toTopFilePath p + top <- inRepo $ toTopFilePath $ toRawFilePath p let diff' = filter (`isDiffOf` top) diff liftIO $ streamUpdateIndex g (map stageDiffTreeItem diff') @@ -59,7 +59,8 @@ -- and then any adds. This order is necessary to handle eg, removing -- a directory and replacing it with a file. let (removals, adds) = partition (\di -> dstsha di == nullSha) diff' - let mkrel di = liftIO $ relPathCwdToFile $ fromTopFilePath (file di) g + let mkrel di = liftIO $ relPathCwdToFile $ fromRawFilePath $ + fromTopFilePath (file di) g forM_ removals $ \di -> do f <- mkrel di diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -17,6 +17,7 @@ import Annex.Content import Annex.Init import Utility.FileMode +import qualified Utility.RawFilePath as R cmd :: Command cmd = addCheck check $ @@ -29,19 +30,19 @@ b <- current_branch when (b == Annex.Branch.name) $ giveup $ "cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out" - top <- fromRepo Git.repoPath + top <- fromRawFilePath <$> fromRepo Git.repoPath currdir <- liftIO getCurrentDirectory whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $ giveup "can only run uninit from the top of the git repository" where - current_branch = Git.Ref . Prelude.head . lines <$> revhead + current_branch = Git.Ref . Prelude.head . lines . decodeBS' <$> revhead revhead = inRepo $ Git.Command.pipeReadStrict [Param "rev-parse", Param "--abbrev-ref", Param "HEAD"] seek :: CmdParams -> CommandSeek seek ps = do l <- workTreeItems ps - withFilesNotInGit False (commandAction . whenAnnexed startCheckIncomplete) l + withFilesNotInGit False (commandAction . whenAnnexed (startCheckIncomplete . fromRawFilePath)) l Annex.changeState $ \s -> s { Annex.fast = True } withFilesInGit (commandAction . whenAnnexed Command.Unannex.start) l finish @@ -57,7 +58,7 @@ finish :: Annex () finish = do - annexdir <- fromRepo gitAnnexDir + annexdir <- fromRawFilePath <$> fromRepo gitAnnexDir annexobjectdir <- fromRepo gitAnnexObjectDir leftovers <- removeUnannexed =<< listKeys InAnnex prepareRemoveAnnexDir annexdir @@ -117,5 +118,5 @@ , go (k:c) ks ) enoughlinks f = catchBoolIO $ do - s <- getFileStatus f + s <- R.getFileStatus f return $ linkCount s > 1 diff --git a/Command/Unlock.hs b/Command/Unlock.hs --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -14,6 +14,7 @@ import Annex.ReplaceFile import Git.FilePath import qualified Database.Keys +import qualified Utility.RawFilePath as R cmd :: Command cmd = mkcmd "unlock" "unlock files for modification" @@ -31,17 +32,17 @@ {- Before v6, the unlock subcommand replaces the symlink with a copy of - the file's content. In v6 and above, it converts the file from a symlink - to a pointer. -} -start :: FilePath -> Key -> CommandStart +start :: RawFilePath -> Key -> CommandStart start file key = ifM (isJust <$> isAnnexLink file) ( starting "unlock" (mkActionItem (key, AssociatedFile (Just file))) $ perform file key , stop ) -perform :: FilePath -> Key -> CommandPerform +perform :: RawFilePath -> Key -> CommandPerform perform dest key = do - destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus dest - replaceFile dest $ \tmp -> + destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus dest + replaceFile (fromRawFilePath dest) $ \tmp -> ifM (inAnnex key) ( do r <- linkFromAnnex key tmp destmode @@ -49,11 +50,11 @@ LinkAnnexOk -> return () LinkAnnexNoop -> return () LinkAnnexFailed -> error "unlock failed" - , liftIO $ writePointerFile tmp key destmode + , liftIO $ writePointerFile (toRawFilePath tmp) key destmode ) next $ cleanup dest key destmode -cleanup :: FilePath -> Key -> Maybe FileMode -> CommandCleanup +cleanup :: RawFilePath -> Key -> Maybe FileMode -> CommandCleanup cleanup dest key destmode = do stagePointerFile dest destmode =<< hashPointerFile key Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath dest) diff --git a/Command/Unused.hs b/Command/Unused.hs --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -192,10 +192,10 @@ calla k _ _ = a k {- Folds an action over keys and files referenced in a particular directory. -} -withKeysFilesReferencedIn :: FilePath -> v -> (Key -> FilePath -> v -> Annex v) -> Annex v +withKeysFilesReferencedIn :: FilePath -> v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v withKeysFilesReferencedIn = withKeysReferenced' . Just -withKeysReferenced' :: Maybe FilePath -> v -> (Key -> FilePath -> v -> Annex v) -> Annex v +withKeysReferenced' :: Maybe FilePath -> v -> (Key -> RawFilePath -> v -> Annex v) -> Annex v withKeysReferenced' mdir initial a = do (files, clean) <- getfiles r <- go initial files @@ -209,7 +209,7 @@ top <- fromRepo Git.repoPath inRepo $ LsFiles.allFiles [top] ) - Just dir -> inRepo $ LsFiles.inRepo [dir] + Just dir -> inRepo $ LsFiles.inRepo [toRawFilePath dir] go v [] = return v go v (f:fs) = do mk <- lookupFile f @@ -221,7 +221,8 @@ withKeysReferencedDiffGitRefs :: RefSpec -> (Key -> Annex ()) -> Annex () withKeysReferencedDiffGitRefs refspec a = do - rs <- relevantrefs <$> inRepo (Git.Command.pipeReadStrict [Param "show-ref"]) + rs <- relevantrefs . decodeBS' + <$> inRepo (Git.Command.pipeReadStrict [Param "show-ref"]) shaHead <- maybe (return Nothing) (inRepo . Git.Ref.sha) =<< inRepo Git.Branch.currentUnsafe let haveHead = any (\(shaRef, _) -> Just shaRef == shaHead) rs diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -31,6 +31,7 @@ import Types.ScheduledActivity import Types.NumCopies import Remote +import Git.Types (ConfigKey(..), fromConfigKey, fromConfigValue) cmd :: Command cmd = command "vicfg" SectionSetup "edit configuration in git-annex branch" @@ -70,7 +71,7 @@ , cfgRequiredContentMap :: M.Map UUID PreferredContentExpression , cfgGroupPreferredContentMap :: M.Map Group PreferredContentExpression , cfgScheduleMap :: M.Map UUID [ScheduledActivity] - , cfgGlobalConfigs :: M.Map ConfigName ConfigValue + , cfgGlobalConfigs :: M.Map ConfigKey ConfigValue , cfgNumCopies :: Maybe NumCopies } @@ -218,9 +219,9 @@ [ com "Other global configuration" ] (\(s, g) -> gline g s) - (\g -> gline g "") + (\g -> gline g mempty) where - gline g val = [ unwords ["config", g, "=", val] ] + gline k v = [ unwords ["config", fromConfigKey k, "=", fromConfigValue v] ] line setting u val = [ com $ "(for " ++ fromUUIDDesc (fromMaybe mempty (M.lookup u descs)) ++ ")" @@ -308,7 +309,7 @@ let m = M.insert u l (cfgScheduleMap cfg) in Right $ cfg { cfgScheduleMap = m } | setting == "config" = - let m = M.insert f val (cfgGlobalConfigs cfg) + let m = M.insert (ConfigKey (encodeBS' f)) (ConfigValue (encodeBS' val)) (cfgGlobalConfigs cfg) in Right $ cfg { cfgGlobalConfigs = m } | setting == "numcopies" = case readish val of Nothing -> Left "parse error (expected an integer)" diff --git a/Command/View.hs b/Command/View.hs --- a/Command/View.hs +++ b/Command/View.hs @@ -99,9 +99,10 @@ - and this pollutes the view, so remove them. - (However, emptry directories used by submodules are not - removed.) -} - top <- liftIO . absPath =<< fromRepo Git.repoPath + top <- liftIO . absPath . fromRawFilePath =<< fromRepo Git.repoPath (l, cleanup) <- inRepo $ - LsFiles.notInRepoIncludingEmptyDirectories False [top] + LsFiles.notInRepoIncludingEmptyDirectories False + [toRawFilePath top] forM_ l (removeemptydir top) liftIO $ void cleanup unlessM (liftIO $ doesDirectoryExist here) $ do @@ -110,7 +111,7 @@ where removeemptydir top d = do p <- inRepo $ toTopFilePath d - liftIO $ tryIO $ removeDirectory (top getTopFilePath p) + liftIO $ tryIO $ removeDirectory (top fromRawFilePath (getTopFilePath p)) cwdmissing top = unlines [ "This view does not include the subdirectory you are currently in." , "Perhaps you should: cd " ++ top diff --git a/Command/WebApp.hs b/Command/WebApp.hs --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Command.WebApp where @@ -22,6 +23,7 @@ import Utility.UserInfo import Annex.Init import qualified Git +import Git.Types (fromConfigValue) import qualified Git.Config import qualified Git.CurrentRepo import qualified Annex @@ -229,7 +231,7 @@ {- web.browser is a generic git config setting for a web browser program -} webBrowser :: Git.Repo -> Maybe FilePath -webBrowser = Git.Config.getMaybe "web.browser" +webBrowser = fmap fromConfigValue <$> Git.Config.getMaybe "web.browser" fileUrl :: FilePath -> String fileUrl file = "file://" ++ file diff --git a/Command/Whereis.hs b/Command/Whereis.hs --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -40,14 +40,14 @@ m <- remoteMap id let go = whenAnnexed $ start m case batchOption o of - Batch fmt -> batchFilesMatching fmt go + Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) False (commandAction . startKeys m) (withFilesInGit (commandAction . go)) =<< workTreeItems (whereisFiles o) -start :: M.Map UUID Remote -> FilePath -> Key -> CommandStart +start :: M.Map UUID Remote -> RawFilePath -> Key -> CommandStart start remotemap file key = startKeys remotemap (key, mkActionItem (key, afile)) where afile = AssociatedFile (Just file) diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Config where @@ -22,25 +23,26 @@ import qualified Annex.SpecialRemote.Config as SpecialRemote import qualified Data.Map as M - -type UnqualifiedConfigKey = String -data ConfigKey = ConfigKey String +import qualified Data.ByteString as S -instance Show ConfigKey where - show (ConfigKey s) = s +type UnqualifiedConfigKey = S.ByteString {- Looks up a setting in git config. This is not as efficient as using the - GitConfig type. -} -getConfig :: ConfigKey -> String -> Annex String -getConfig (ConfigKey key) d = fromRepo $ Git.Config.get key d +getConfig :: ConfigKey -> ConfigValue -> Annex ConfigValue +getConfig key d = fromRepo $ Git.Config.get key d -getConfigMaybe :: ConfigKey -> Annex (Maybe String) -getConfigMaybe (ConfigKey key) = fromRepo $ Git.Config.getMaybe key +getConfigMaybe :: ConfigKey -> Annex (Maybe ConfigValue) +getConfigMaybe key = fromRepo $ Git.Config.getMaybe key {- Changes a git config setting in both internal state and .git/config -} setConfig :: ConfigKey -> String -> Annex () setConfig (ConfigKey key) value = do - inRepo $ Git.Command.run [Param "config", Param key, Param value] + inRepo $ Git.Command.run + [ Param "config" + , Param (decodeBS' key) + , Param value + ] reloadConfig reloadConfig :: Annex () @@ -48,7 +50,7 @@ {- Unsets a git config setting. (Leaves it in state.) -} unsetConfig :: ConfigKey -> Annex () -unsetConfig (ConfigKey key) = void $ inRepo $ Git.Config.unset key +unsetConfig key = void $ inRepo $ Git.Config.unset key class RemoteNameable r where getRemoteName :: r -> RemoteName @@ -68,11 +70,11 @@ {- A per-remote config setting in git config. -} remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey remoteConfig r key = ConfigKey $ - "remote." ++ getRemoteName r ++ ".annex-" ++ key + "remote." <> encodeBS' (getRemoteName r) <> ".annex-" <> key {- A global annex setting in git config. -} annexConfig :: UnqualifiedConfigKey -> ConfigKey -annexConfig key = ConfigKey $ "annex." ++ key +annexConfig key = ConfigKey ("annex." <> key) {- Calculates cost for a remote. Either the specific default, or as configured - by remote..annex-cost, or if remote..annex-cost-command diff --git a/Config/GitConfig.hs b/Config/GitConfig.hs --- a/Config/GitConfig.hs +++ b/Config/GitConfig.hs @@ -1,6 +1,6 @@ {- git-annex configuration - - - Copyright 2017 Joey Hess + - Copyright 2017-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -15,22 +15,26 @@ {- Gets a specific setting from GitConfig. If necessary, loads the - repository-global defaults when the GitConfig does not yet - - have a value. -} + - have a value. + - + - Note: Be sure to add the config value to mergeGitConfig. + -} getGitConfigVal :: (GitConfig -> Configurable a) -> Annex a -getGitConfigVal f = do - v <- f <$> Annex.getGitConfig - case v of - HasConfig c -> return c - DefaultConfig _ -> do - r <- Annex.gitRepo - m <- loadGlobalConfig - let globalgc = extractGitConfig (r { config = m }) - -- This merge of the repo-global config and the git - -- config makes all repository-global default - -- values populate the GitConfig with HasConfig - -- values, so it will only need to be done once. - Annex.changeGitConfig (\gc -> mergeGitConfig gc globalgc) - v' <- f <$> Annex.getGitConfig - case v' of - HasConfig c -> return c - DefaultConfig d -> return d +getGitConfigVal f = getGitConfigVal' f >>= \case + HasGlobalConfig c -> return c + DefaultConfig d -> return d + HasGitConfig c -> return c + +getGitConfigVal' :: (GitConfig -> Configurable a) -> Annex (Configurable a) +getGitConfigVal' f = (f <$> Annex.getGitConfig) >>= \case + DefaultConfig _ -> do + r <- Annex.gitRepo + m <- loadGlobalConfig + let globalgc = extractGitConfig FromGlobalConfig (r { config = m }) + -- This merge of the repo-global config and the git + -- config makes all repository-global default + -- values populate the GitConfig with HasGlobalConfig + -- values, so it will only need to be done once. + Annex.changeGitConfig (\gc -> mergeGitConfig gc globalgc) + f <$> Annex.getGitConfig + c -> return c diff --git a/Config/Smudge.hs b/Config/Smudge.hs --- a/Config/Smudge.hs +++ b/Config/Smudge.hs @@ -5,12 +5,15 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Config.Smudge where import Annex.Common import qualified Annex import qualified Git import qualified Git.Command +import Git.Types import Config configureSmudgeFilter :: Annex () diff --git a/Database/Export.hs b/Database/Export.hs --- a/Database/Export.hs +++ b/Database/Export.hs @@ -128,28 +128,28 @@ addExportedLocation h k el = queueDb h $ do void $ insertUnique $ Exported ik ef let edirs = map - (\ed -> ExportedDirectory (toSFilePath (fromExportDirectory ed)) ef) + (\ed -> ExportedDirectory (toSFilePath (fromRawFilePath (fromExportDirectory ed))) ef) (exportDirectories el) putMany edirs where ik = toIKey k - ef = toSFilePath (fromExportLocation el) + ef = toSFilePath $ fromRawFilePath $ fromExportLocation el removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () removeExportedLocation h k el = queueDb h $ do deleteWhere [ExportedKey ==. ik, ExportedFile ==. ef] - let subdirs = map (toSFilePath . fromExportDirectory) + let subdirs = map (toSFilePath . fromRawFilePath . fromExportDirectory) (exportDirectories el) deleteWhere [ExportedDirectoryFile ==. ef, ExportedDirectorySubdir <-. subdirs] where ik = toIKey k - ef = toSFilePath (fromExportLocation el) + ef = toSFilePath $ fromRawFilePath $ fromExportLocation el {- Note that this does not see recently queued changes. -} getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation] getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do l <- selectList [ExportedKey ==. ik] [] - return $ map (mkExportLocation . fromSFilePath . exportedFile . entityVal) l + return $ map (mkExportLocation . toRawFilePath . fromSFilePath . exportedFile . entityVal) l where ik = toIKey k @@ -159,13 +159,13 @@ l <- selectList [ExportedDirectorySubdir ==. ed] [] return $ null l where - ed = toSFilePath $ fromExportDirectory d + ed = toSFilePath $ fromRawFilePath $ fromExportDirectory d {- Get locations in the export that might contain a key. -} getExportTree :: ExportHandle -> Key -> IO [ExportLocation] getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do l <- selectList [ExportTreeKey ==. ik] [] - return $ map (mkExportLocation . fromSFilePath . exportTreeFile . entityVal) l + return $ map (mkExportLocation . toRawFilePath . fromSFilePath . exportTreeFile . entityVal) l where ik = toIKey k @@ -181,21 +181,21 @@ map (fromIKey . exportTreeKey . entityVal) <$> selectList [ExportTreeFile ==. ef] [] where - ef = toSFilePath (fromExportLocation el) + ef = toSFilePath (fromRawFilePath $ fromExportLocation el) addExportTree :: ExportHandle -> Key -> ExportLocation -> IO () addExportTree h k loc = queueDb h $ void $ insertUnique $ ExportTree ik ef where ik = toIKey k - ef = toSFilePath (fromExportLocation loc) + ef = toSFilePath (fromRawFilePath $ fromExportLocation loc) removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO () removeExportTree h k loc = queueDb h $ deleteWhere [ExportTreeKey ==. ik, ExportTreeFile ==. ef] where ik = toIKey k - ef = toSFilePath (fromExportLocation loc) + ef = toSFilePath (fromRawFilePath $ fromExportLocation loc) -- An action that is passed the old and new values that were exported, -- and updates state. diff --git a/Database/Keys.hs b/Database/Keys.hs --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -43,6 +43,9 @@ import Git.Types import Git.Index +import qualified Data.ByteString as S +import qualified System.FilePath.ByteString as P + {- Runs an action that reads from the database. - - If the database doesn't already exist, it's not created; mempty is @@ -169,13 +172,13 @@ removeAssociatedFile k = runWriterIO . SQL.removeAssociatedFile (toIKey k) {- Stats the files, and stores their InodeCaches. -} -storeInodeCaches :: Key -> [FilePath] -> Annex () +storeInodeCaches :: Key -> [RawFilePath] -> Annex () storeInodeCaches k fs = storeInodeCaches' k fs [] -storeInodeCaches' :: Key -> [FilePath] -> [InodeCache] -> Annex () +storeInodeCaches' :: Key -> [RawFilePath] -> [InodeCache] -> Annex () storeInodeCaches' k fs ics = withTSDelta $ \d -> addInodeCaches k . (++ ics) . catMaybes - =<< liftIO (mapM (`genInodeCache` d) fs) + =<< liftIO (mapM (\f -> genInodeCache f d) fs) addInodeCaches :: Key -> [InodeCache] -> Annex () addInodeCaches k is = runWriterIO $ SQL.addInodeCaches (toIKey k) is @@ -223,7 +226,7 @@ reconcileStaged qh = do gitindex <- inRepo currentIndexFile indexcache <- fromRepo gitAnnexKeysDbIndexCache - withTSDelta (liftIO . genInodeCache gitindex) >>= \case + withTSDelta (liftIO . genInodeCache (toRawFilePath gitindex)) >>= \case Just cur -> liftIO (maybe Nothing readInodeCache <$> catchMaybeIO (readFile indexcache)) >>= \case Nothing -> go cur indexcache @@ -235,7 +238,7 @@ where go cur indexcache = do (l, cleanup) <- inRepo $ pipeNullSplit diff - changed <- procdiff l False + changed <- procdiff (map decodeBL' l) False void $ liftIO cleanup -- Flush database changes immediately -- so other processes can see them. @@ -262,7 +265,8 @@ -- perfect. A file could start with this and not be a -- pointer file. And a pointer file that is replaced with -- a non-pointer file will match this. - , Param $ "-G^" ++ toInternalGitPath (pathSeparator:objectDir) + , Param $ "-G^" ++ fromRawFilePath (toInternalGitPath $ + P.pathSeparator `S.cons` objectDir') -- Don't include files that were deleted, because this only -- wants to update information for files that are present -- in the index. @@ -277,8 +281,8 @@ procdiff (info:file:rest) changed = case words info of ((':':_srcmode):dstmode:_srcsha:dstsha:_change:[]) -- Only want files, not symlinks - | dstmode /= fmtTreeItemType TreeSymlink -> do - maybe noop (reconcile (asTopFilePath file)) + | dstmode /= decodeBS' (fmtTreeItemType TreeSymlink) -> do + maybe noop (reconcile (asTopFilePath (toRawFilePath file))) =<< catKey (Ref dstsha) procdiff rest True | otherwise -> procdiff rest changed diff --git a/Database/Keys/SQL.hs b/Database/Keys/SQL.hs --- a/Database/Keys/SQL.hs +++ b/Database/Keys/SQL.hs @@ -17,6 +17,7 @@ import Database.Handle import qualified Database.Queue as H import Utility.InodeCache +import Utility.FileSystemEncoding import Git.FilePath import Database.Persist.Sql @@ -69,7 +70,7 @@ deleteWhere [AssociatedFile ==. af, AssociatedKey !=. ik] void $ insertUnique $ Associated ik af where - af = toSFilePath (getTopFilePath f) + af = toSFilePath (fromRawFilePath (getTopFilePath f)) -- Does not remove any old association for a file, but less expensive -- than addAssociatedFile. Calling dropAllAssociatedFiles first and then @@ -77,7 +78,7 @@ addAssociatedFileFast :: IKey -> TopFilePath -> WriteHandle -> IO () addAssociatedFileFast ik f = queueDb $ void $ insertUnique $ Associated ik af where - af = toSFilePath (getTopFilePath f) + af = toSFilePath (fromRawFilePath (getTopFilePath f)) dropAllAssociatedFiles :: WriteHandle -> IO () dropAllAssociatedFiles = queueDb $ @@ -88,7 +89,7 @@ getAssociatedFiles :: IKey -> ReadHandle -> IO [TopFilePath] getAssociatedFiles ik = readDb $ do l <- selectList [AssociatedKey ==. ik] [] - return $ map (asTopFilePath . fromSFilePath . associatedFile . entityVal) l + return $ map (asTopFilePath . toRawFilePath . fromSFilePath . associatedFile . entityVal) l {- Gets any keys that are on record as having a particular associated file. - (Should be one or none but the database doesn't enforce that.) -} @@ -97,13 +98,13 @@ l <- selectList [AssociatedFile ==. af] [] return $ map (associatedKey . entityVal) l where - af = toSFilePath (getTopFilePath f) + af = toSFilePath (fromRawFilePath (getTopFilePath f)) removeAssociatedFile :: IKey -> TopFilePath -> WriteHandle -> IO () removeAssociatedFile ik f = queueDb $ deleteWhere [AssociatedKey ==. ik, AssociatedFile ==. af] where - af = toSFilePath (getTopFilePath f) + af = toSFilePath (fromRawFilePath (getTopFilePath f)) addInodeCaches :: IKey -> [InodeCache] -> WriteHandle -> IO () addInodeCaches ik is = queueDb $ diff --git a/Git.hs b/Git.hs --- a/Git.hs +++ b/Git.hs @@ -51,35 +51,35 @@ repoDescribe :: Repo -> String repoDescribe Repo { remoteName = Just name } = name repoDescribe Repo { location = Url url } = show url -repoDescribe Repo { location = Local { worktree = Just dir } } = dir -repoDescribe Repo { location = Local { gitdir = dir } } = dir -repoDescribe Repo { location = LocalUnknown dir } = dir +repoDescribe Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir +repoDescribe Repo { location = Local { gitdir = dir } } = fromRawFilePath dir +repoDescribe Repo { location = LocalUnknown dir } = fromRawFilePath dir repoDescribe Repo { location = Unknown } = "UNKNOWN" {- Location of the repo, either as a path or url. -} repoLocation :: Repo -> String repoLocation Repo { location = Url url } = show url -repoLocation Repo { location = Local { worktree = Just dir } } = dir -repoLocation Repo { location = Local { gitdir = dir } } = dir -repoLocation Repo { location = LocalUnknown dir } = dir +repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir +repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir +repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir repoLocation Repo { location = Unknown } = error "unknown repoLocation" {- Path to a repository. For non-bare, this is the worktree, for bare, - it's the gitdir, and for URL repositories, is the path on the remote - host. -} -repoPath :: Repo -> FilePath -repoPath Repo { location = Url u } = unEscapeString $ uriPath u +repoPath :: Repo -> RawFilePath +repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u repoPath Repo { location = Local { worktree = Just d } } = d repoPath Repo { location = Local { gitdir = d } } = d repoPath Repo { location = LocalUnknown dir } = dir repoPath Repo { location = Unknown } = error "unknown repoPath" -repoWorkTree :: Repo -> Maybe FilePath +repoWorkTree :: Repo -> Maybe RawFilePath repoWorkTree Repo { location = Local { worktree = Just d } } = Just d repoWorkTree _ = Nothing {- Path to a local repository's .git directory. -} -localGitDir :: Repo -> FilePath +localGitDir :: Repo -> RawFilePath localGitDir Repo { location = Local { gitdir = d } } = d localGitDir _ = error "unknown localGitDir" @@ -132,16 +132,17 @@ attributes :: Repo -> FilePath attributes repo | repoIsLocalBare repo = attributesLocal repo - | otherwise = repoPath repo ".gitattributes" + | otherwise = fromRawFilePath (repoPath repo) ".gitattributes" attributesLocal :: Repo -> FilePath -attributesLocal repo = localGitDir repo "info" "attributes" +attributesLocal repo = fromRawFilePath (localGitDir repo) + "info" "attributes" {- Path to a given hook script in a repository, only if the hook exists - and is executable. -} hookPath :: String -> Repo -> IO (Maybe FilePath) hookPath script repo = do - let hook = localGitDir repo "hooks" script + let hook = fromRawFilePath (localGitDir repo) "hooks" script ifM (catchBoolIO $ isexecutable hook) ( return $ Just hook , return Nothing ) where @@ -157,22 +158,22 @@ where torel p = do p' <- relPathCwdToFile p - if null p' - then return "." - else return p' + return $ if null p' then "." else p' {- Adusts the path to a local Repo using the provided function. -} adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do - d' <- f d - w' <- maybe (pure Nothing) (Just <$$> f) w + d' <- f' d + w' <- maybe (pure Nothing) (Just <$$> f') w return $ r { location = l { gitdir = d' , worktree = w' } } + where + f' v = toRawFilePath <$> f (fromRawFilePath v) adjustPath f r@(Repo { location = LocalUnknown d }) = do - d' <- f d + d' <- toRawFilePath <$> f (fromRawFilePath d) return $ r { location = LocalUnknown d' } adjustPath _ r = pure r diff --git a/Git/AutoCorrect.hs b/Git/AutoCorrect.hs --- a/Git/AutoCorrect.hs +++ b/Git/AutoCorrect.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.AutoCorrect where import Common @@ -44,7 +46,7 @@ -} prepare :: String -> (c -> String) -> [c] -> Maybe Repo -> IO () prepare input showmatch matches r = - case readish . Git.Config.get "help.autocorrect" "0" =<< r of + case readish . fromConfigValue . Git.Config.get "help.autocorrect" "0" =<< r of Just n | n == 0 -> list | n < 0 -> warn Nothing diff --git a/Git/Branch.hs b/Git/Branch.hs --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} module Git.Branch where @@ -16,6 +17,8 @@ import qualified Git.Config import qualified Git.Ref +import qualified Data.ByteString as B + {- The currently checked out branch. - - In a just initialized git repo before the first commit, @@ -29,19 +32,19 @@ case v of Nothing -> return Nothing Just branch -> - ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r) + ifM (B.null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r) ( return Nothing , return v ) {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Branch) -currentUnsafe r = parse . firstLine +currentUnsafe r = parse . firstLine' <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r where - parse l - | null l = Nothing - | otherwise = Just $ Git.Ref l + parse b + | B.null b = Nothing + | otherwise = Just $ Git.Ref $ decodeBS b {- Checks if the second branch has any commits not present on the first - branch. -} @@ -53,7 +56,8 @@ where changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String -changed' origbranch newbranch extraps repo = pipeReadStrict ps repo +changed' origbranch newbranch extraps repo = + decodeBS <$> pipeReadStrict ps repo where ps = [ Param "log" @@ -72,7 +76,7 @@ - - This requires there to be a path from the old to the new. -} fastForwardable :: Ref -> Ref -> Repo -> IO Bool -fastForwardable old new repo = not . null <$> +fastForwardable old new repo = not . B.null <$> pipeReadStrict [ Param "log" , Param $ fromRef old ++ ".." ++ fromRef new @@ -132,8 +136,8 @@ applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam] applyCommitModeForCommitTree commitmode ps r | commitmode == ManualCommit = - case (Git.Config.getMaybe "commit.gpgsign" r) of - Just s | Git.Config.isTrue s == Just True -> + case Git.Config.getMaybe "commit.gpgsign" r of + Just s | Git.Config.isTrueFalse' s == Just True -> Param "-S":ps _ -> ps' | otherwise = ps' @@ -160,7 +164,7 @@ commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) commit commitmode allowempty message branch parentrefs repo = do tree <- getSha "write-tree" $ - pipeReadStrict [Param "write-tree"] repo + decodeBS' <$> pipeReadStrict [Param "write-tree"] repo ifM (cancommit tree) ( do sha <- commitTree commitmode message parentrefs tree repo diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,6 +1,6 @@ {- git cat-file interface - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -33,6 +33,7 @@ import Common import Git import Git.Sha +import qualified Git.Ref import Git.Command import Git.Types import Git.FilePath @@ -66,13 +67,13 @@ CoProcess.stop (checkFileProcess h) {- Reads a file from a specified branch. -} -catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString +catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString catFile h branch file = catObject h $ Ref $ - fromRef branch ++ ":" ++ toInternalGitPath file + fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) -catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) +catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails h branch file = catObjectDetails h $ Ref $ - fromRef branch ++ ":" ++ toInternalGitPath file + fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} @@ -109,22 +110,23 @@ return (Just (content, sha, objtype)) {- Gets the size and type of an object, without reading its content. -} -catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Integer, ObjectType)) +catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType)) catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do resp <- hGetLine from case parseResp object resp of - Just (ParsedResp _ size objtype) -> - return $ Just (size, objtype) + Just (ParsedResp sha size objtype) -> + return $ Just (sha, size, objtype) Just DNE -> return Nothing Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object) where -- Slow fallback path for filenames containing newlines. newlinefallback = do + sha <- Git.Ref.sha object (gitRepo h) sz <- querySize object (gitRepo h) objtype <- queryObjectType object (gitRepo h) - return $ (,) <$> sz <*> objtype + return $ (,,) <$> sha <*> sz <*> objtype -data ParsedResp = ParsedResp Sha Integer ObjectType | DNE +data ParsedResp = ParsedResp Sha FileSize ObjectType | DNE query :: CoProcess.CoProcessHandle -> Ref -> IO a -> (Handle -> IO a) -> IO a query hdl object newlinefallback receive @@ -148,7 +150,7 @@ | otherwise = case words l of [sha, objtype, size] | length sha == shaSize -> - case (readObjectType objtype, reads size) of + case (readObjectType (encodeBS objtype), reads size) of (Just t, [(bytes, "")]) -> Just $ ParsedResp (Ref sha) bytes t _ -> Nothing @@ -180,12 +182,12 @@ , return Nothing ) -querySize :: Ref -> Repo -> IO (Maybe Integer) +querySize :: Ref -> Repo -> IO (Maybe FileSize) querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n')) <$> querySingle (Param "-s") r repo hGetContentsStrict queryObjectType :: Ref -> Repo -> IO (Maybe ObjectType) -queryObjectType r repo = maybe Nothing (readObjectType . takeWhile (/= '\n')) +queryObjectType r repo = maybe Nothing (readObjectType . encodeBS . takeWhile (/= '\n')) <$> querySingle (Param "-t") r repo hGetContentsStrict queryContent :: Ref -> Repo -> IO (Maybe L.ByteString) diff --git a/Git/Command.hs b/Git/Command.hs --- a/Git/Command.hs +++ b/Git/Command.hs @@ -14,6 +14,9 @@ import Git.Types import qualified Utility.CoProcess as CoProcess +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S + {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] gitCommandLine params r@(Repo { location = l@(Local { } ) }) = @@ -21,10 +24,10 @@ where setdir | gitEnvOverridesGitDir r = [] - | otherwise = [Param $ "--git-dir=" ++ gitdir l] + | otherwise = [Param $ "--git-dir=" ++ fromRawFilePath (gitdir l)] settree = case worktree l of Nothing -> [] - Just t -> [Param $ "--work-tree=" ++ t] + Just t -> [Param $ "--work-tree=" ++ fromRawFilePath t] gitCommandLine _ repo = assertLocal repo $ error "internal" {- Runs git in the specified repo. -} @@ -50,10 +53,10 @@ - read, that will wait on the command, and - return True if it succeeded. Failure to wait will result in zombies. -} -pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool) +pipeReadLazy :: [CommandParam] -> Repo -> IO (L.ByteString, IO Bool) pipeReadLazy params repo = assertLocal repo $ do (_, Just h, _, pid) <- createProcess p { std_out = CreatePipe } - c <- hGetContents h + c <- L.hGetContents h return (c, checkSuccessProcess pid) where p = gitCreateProcess params repo @@ -62,8 +65,8 @@ - - Nonzero exit status is ignored. -} -pipeReadStrict :: [CommandParam] -> Repo -> IO String -pipeReadStrict = pipeReadStrict' hGetContentsStrict +pipeReadStrict :: [CommandParam] -> Repo -> IO S.ByteString +pipeReadStrict = pipeReadStrict' S.hGetContents {- The reader action must be strict. -} pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a @@ -93,22 +96,29 @@ {- Reads null terminated output of a git command (as enabled by the -z - parameter), and splits it. -} -pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool) +pipeNullSplit :: [CommandParam] -> Repo -> IO ([L.ByteString], IO Bool) pipeNullSplit params repo = do (s, cleanup) <- pipeReadLazy params repo - return (filter (not . null) $ splitc sep s, cleanup) - where - sep = '\0' + return (filter (not . L.null) $ L.split 0 s, cleanup) -pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String] +{- Reads lazily, but copies each part to a strict ByteString for + - convenience. + -} +pipeNullSplit' :: [CommandParam] -> Repo -> IO ([S.ByteString], IO Bool) +pipeNullSplit' params repo = do + (s, cleanup) <- pipeNullSplit params repo + return (map L.toStrict s, cleanup) + +pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [S.ByteString] pipeNullSplitStrict params repo = do s <- pipeReadStrict params repo - return $ filter (not . null) $ splitc sep s - where - sep = '\0' + return $ filter (not . S.null) $ S.split 0 s -pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String] +pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString] pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo + +pipeNullSplitZombie' :: [CommandParam] -> Repo -> IO [S.ByteString] +pipeNullSplitZombie' params repo = leaveZombie <$> pipeNullSplit' params repo {- Doesn't run the cleanup action. A zombie results. -} leaveZombie :: (a, IO Bool) -> a diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -1,14 +1,19 @@ {- git repository configuration handling - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Config where import qualified Data.Map as M +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import Data.Char +import qualified System.FilePath.ByteString as P import Common import Git @@ -17,16 +22,16 @@ import qualified Git.Construct import Utility.UserInfo -{- Returns a single git config setting, or a default value if not set. -} -get :: String -> String -> Repo -> String -get key defaultValue repo = M.findWithDefault defaultValue key (config repo) +{- Returns a single git config setting, or a fallback value if not set. -} +get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue +get key fallback repo = M.findWithDefault fallback key (config repo) -{- Returns a list with each line of a multiline config setting. -} -getList :: String -> Repo -> [String] +{- Returns a list of values. -} +getList :: ConfigKey -> Repo -> [ConfigValue] getList key repo = M.findWithDefault [] key (fullconfig repo) {- Returns a single git config setting, if set. -} -getMaybe :: String -> Repo -> Maybe String +getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue getMaybe key repo = M.lookup key (config repo) {- Runs git config and populates a repo with its config. @@ -57,7 +62,7 @@ where params = ["config", "--null", "--list"] p = (proc "git" params) - { cwd = Just d + { cwd = Just (fromRawFilePath d) , env = gitEnv repo } @@ -79,14 +84,14 @@ {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo hRead repo h = do - val <- hGetContentsStrict h + val <- S.hGetContents h store val repo {- Stores a git config into a Repo, returning the new version of the Repo. - The git config may be multiple lines, or a single line. - Config settings can be updated incrementally. -} -store :: String -> Repo -> IO Repo +store :: S.ByteString -> Repo -> IO Repo store s repo = do let c = parse s updateLocation $ repo @@ -96,7 +101,7 @@ {- Stores a single config setting in a Repo, returning the new version of - the Repo. Config settings can be updated incrementally. -} -store' :: String -> String -> Repo -> Repo +store' :: ConfigKey -> ConfigValue -> Repo -> Repo store' k v repo = repo { config = M.singleton k v `M.union` config repo , fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo) @@ -110,13 +115,13 @@ -} updateLocation :: Repo -> IO Repo updateLocation r@(Repo { location = LocalUnknown d }) - | isBare r = ifM (doesDirectoryExist dotgit) + | isBare r = ifM (doesDirectoryExist (fromRawFilePath dotgit)) ( updateLocation' r $ Local dotgit Nothing , updateLocation' r $ Local d Nothing ) | otherwise = updateLocation' r $ Local dotgit (Just d) where - dotgit = (d ".git") + dotgit = d P. ".git" updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l updateLocation r = return r @@ -124,52 +129,66 @@ updateLocation' r l = do l' <- case getMaybe "core.worktree" r of Nothing -> return l - Just d -> do + Just (ConfigValue d) -> do {- core.worktree is relative to the gitdir -} - top <- absPath $ gitdir l - return $ l { worktree = Just $ absPathFrom top d } + top <- absPath $ fromRawFilePath (gitdir l) + let p = absPathFrom top (fromRawFilePath d) + return $ l { worktree = Just (toRawFilePath p) } return $ r { location = l' } {- Parses git config --list or git config --null --list output into a - config map. -} -parse :: String -> M.Map String [String] -parse [] = M.empty +parse :: S.ByteString -> M.Map ConfigKey [ConfigValue] parse s - -- --list output will have an = in the first line - | all ('=' `elem`) (take 1 ls) = sep '=' ls + | S.null s = M.empty + -- --list output will have a '=' in the first line + -- (The first line of --null --list output is the name of a key, + -- which is assumed to never contain '='.) + | S.elem eq firstline = sep eq $ S.split nl s -- --null --list output separates keys from values with newlines - | otherwise = sep '\n' $ splitc '\0' s + | otherwise = sep nl $ S.split 0 s where - ls = lines s - sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) . - map (separate (== c)) + nl = fromIntegral (ord '\n') + eq = fromIntegral (ord '=') + firstline = S.takeWhile (/= nl) s -{- Checks if a string from git config is a true value. -} -isTrue :: String -> Maybe Bool -isTrue s + sep c = M.fromListWith (++) + . map (\(k,v) -> (ConfigKey k, [ConfigValue (S.drop 1 v)])) + . map (S.break (== c)) + +{- Checks if a string from git config is a true/false value. -} +isTrueFalse :: String -> Maybe Bool +isTrueFalse = isTrueFalse' . ConfigValue . encodeBS' + +isTrueFalse' :: ConfigValue -> Maybe Bool +isTrueFalse' (ConfigValue s) | s' == "true" = Just True | s' == "false" = Just False | otherwise = Nothing where - s' = map toLower s + s' = S8.map toLower s boolConfig :: Bool -> String boolConfig True = "true" boolConfig False = "false" +boolConfig' :: Bool -> S.ByteString +boolConfig' True = "true" +boolConfig' False = "false" + isBare :: Repo -> Bool -isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r +isBare r = fromMaybe False $ isTrueFalse' =<< getMaybe coreBare r -coreBare :: String +coreBare :: ConfigKey coreBare = "core.bare" {- Runs a command to get the configuration of a repo, - and returns a repo populated with the configuration, as well as the raw - output of the command. -} -fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String)) +fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString)) fromPipe r cmd params = try $ withHandle StdoutHandle createProcessSuccess p $ \h -> do - val <- hGetContentsStrict h + val <- S.hGetContents h r' <- store val r return (r', val) where @@ -177,7 +196,7 @@ {- Reads git config from a specified file and returns the repo populated - with the configuration. -} -fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String)) +fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString)) fromFile r f = fromPipe r "git" [ Param "config" , Param "--file" @@ -187,13 +206,13 @@ {- Changes a git config setting in the specified config file. - (Creates the file if it does not already exist.) -} -changeFile :: FilePath -> String -> String -> IO Bool -changeFile f k v = boolSystem "git" +changeFile :: FilePath -> ConfigKey -> S.ByteString -> IO Bool +changeFile f (ConfigKey k) v = boolSystem "git" [ Param "config" , Param "--file" , File f - , Param k - , Param v + , Param (decodeBS' k) + , Param (decodeBS' v) ] {- Unsets a git config setting, in both the git repo, @@ -202,10 +221,10 @@ - If unsetting the config fails, including in a read-only repo, or - when the config is not set, returns Nothing. -} -unset :: String -> Repo -> IO (Maybe Repo) -unset k r = ifM (Git.Command.runBool ps r) - ( return $ Just $ r { config = M.delete k (config r) } +unset :: ConfigKey -> Repo -> IO (Maybe Repo) +unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r) + ( return $ Just $ r { config = M.delete ck (config r) } , return Nothing ) where - ps = [Param "config", Param "--unset-all", Param k] + ps = [Param "config", Param "--unset-all", Param (decodeBS' k)] diff --git a/Git/ConfigTypes.hs b/Git/ConfigTypes.hs --- a/Git/ConfigTypes.hs +++ b/Git/ConfigTypes.hs @@ -5,12 +5,16 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.ConfigTypes where import Data.Char +import qualified Data.ByteString.Char8 as S8 import Common import Git +import Git.Types import qualified Git.Config data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int @@ -18,23 +22,27 @@ getSharedRepository :: Repo -> SharedRepository getSharedRepository r = - case map toLower $ Git.Config.get "core.sharedrepository" "" r of - "1" -> GroupShared - "2" -> AllShared - "group" -> GroupShared - "true" -> GroupShared - "all" -> AllShared - "world" -> AllShared - "everybody" -> AllShared - v -> maybe UnShared UmaskShared (readish v) + case Git.Config.getMaybe "core.sharedrepository" r of + Nothing -> UnShared + Just (ConfigValue v) -> case S8.map toLower v of + "1" -> GroupShared + "2" -> AllShared + "group" -> GroupShared + "true" -> GroupShared + "all" -> AllShared + "world" -> AllShared + "everybody" -> AllShared + _ -> maybe UnShared UmaskShared (readish (decodeBS' v)) data DenyCurrentBranch = UpdateInstead | RefusePush | WarnPush | IgnorePush deriving (Eq) getDenyCurrentBranch :: Repo -> DenyCurrentBranch -getDenyCurrentBranch r = - case map toLower $ Git.Config.get "receive.denycurrentbranch" "" r of - "updateinstead" -> UpdateInstead - "warn" -> WarnPush - "ignore" -> IgnorePush - _ -> RefusePush +getDenyCurrentBranch r = + case Git.Config.getMaybe "receive.denycurrentbranch" r of + Just (ConfigValue v) -> case S8.map toLower v of + "updateinstead" -> UpdateInstead + "warn" -> WarnPush + "ignore" -> IgnorePush + _ -> RefusePush + Nothing -> RefusePush diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -58,11 +58,11 @@ - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir - | absoluteGitPath dir = hunt + | absoluteGitPath (encodeBS dir) = hunt | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" where - ret = pure . newFrom . LocalUnknown + ret = pure . newFrom . LocalUnknown . toRawFilePath canondir = dropTrailingPathSeparator dir {- When dir == "foo/.git", git looks for "foo/.git/.git", - and failing that, uses "foo" as the repository. -} @@ -117,7 +117,7 @@ [ Url.scheme reference , "//" , auth - , repoPath r + , fromRawFilePath (repoPath r) ] in r { location = Url $ fromJust $ parseURI absurl } @@ -128,7 +128,7 @@ filterconfig f = filter f $ M.toList $ config repo filterkeys f = filterconfig (\(k,_) -> f k) remotepairs = filterkeys isRemoteKey - construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo + construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo) {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo @@ -138,7 +138,7 @@ {- Sets the name of a remote based on the git config key, such as - "remote.foo.url". -} -remoteNamedFromKey :: String -> IO Repo -> IO Repo +remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName {- Constructs a new Repo for one of a Repo's remotes using a given @@ -154,7 +154,7 @@ fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromPath $ repoPath repo dir' + fromPath $ fromRawFilePath (repoPath repo) dir' {- Git remotes can have a directory that is specified relative - to the user's home directory, or that contains tilde expansions. @@ -204,7 +204,7 @@ where check test cont = maybe cont (return . Just) =<< test checkdir c = ifM c - ( return $ Just $ LocalUnknown dir + ( return $ Just $ LocalUnknown $ toRawFilePath dir , return Nothing ) isRepo = checkdir $ @@ -224,9 +224,9 @@ catchDefaultIO "" (readFile $ dir ".git") return $ if gitdirprefix `isPrefixOf` c then Just $ Local - { gitdir = absPathFrom dir $ + { gitdir = toRawFilePath $ absPathFrom dir $ drop (length gitdirprefix) c - , worktree = Just dir + , worktree = Just (toRawFilePath dir) } else Nothing where diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -37,7 +37,7 @@ gd <- getpathenv "GIT_DIR" r <- configure gd =<< fromCwd prefix <- getpathenv "GIT_PREFIX" - wt <- maybe (worktree $ location r) Just + wt <- maybe (fromRawFilePath <$> worktree (location r)) Just <$> getpathenvprefix "GIT_WORK_TREE" prefix case wt of Nothing -> return r @@ -68,13 +68,18 @@ absd <- absPath d curr <- getCurrentDirectory r <- Git.Config.read $ newFrom $ - Local { gitdir = absd, worktree = Just curr } + Local + { gitdir = toRawFilePath absd + , worktree = Just (toRawFilePath curr) + } return $ if Git.Config.isBare r then r { location = (location r) { worktree = Nothing } } else r configure Nothing Nothing = giveup "Not in a git repository." - addworktree w r = changelocation r $ - Local { gitdir = gitdir (location r), worktree = w } + addworktree w r = changelocation r $ Local + { gitdir = gitdir (location r) + , worktree = fmap toRawFilePath w + } changelocation r l = r { location = l } diff --git a/Git/DiffTree.hs b/Git/DiffTree.hs --- a/Git/DiffTree.hs +++ b/Git/DiffTree.hs @@ -31,9 +31,9 @@ {- Checks if the DiffTreeItem modifies a file with a given name - or under a directory by that name. -} isDiffOf :: DiffTreeItem -> TopFilePath -> Bool -isDiffOf diff f = case getTopFilePath f of +isDiffOf diff f = case fromRawFilePath (getTopFilePath f) of "" -> True -- top of repo contains all - d -> d `dirContains` getTopFilePath (file diff) + d -> d `dirContains` fromRawFilePath (getTopFilePath (file diff)) {- Diffs two tree Refs. -} diffTree :: Ref -> Ref -> Repo -> IO ([DiffTreeItem], IO Bool) @@ -89,7 +89,7 @@ getdiff :: CommandParam -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool) getdiff command params repo = do (diff, cleanup) <- pipeNullSplit ps repo - return (parseDiffRaw diff, cleanup) + return (parseDiffRaw (map decodeBL diff), cleanup) where ps = command : @@ -113,7 +113,7 @@ , srcsha = fromMaybe (error "bad srcsha") $ extractSha ssha , dstsha = fromMaybe (error "bad dstsha") $ extractSha dsha , status = s - , file = asTopFilePath $ fromInternalGitPath $ Git.Filename.decode f + , file = asTopFilePath $ fromInternalGitPath $ Git.Filename.decode $ toRawFilePath f } where readmode = fst . Prelude.head . readOct diff --git a/Git/Env.hs b/Git/Env.hs --- a/Git/Env.hs +++ b/Git/Env.hs @@ -30,8 +30,10 @@ - and a copy of the rest of the system environment. -} propGitEnv :: Repo -> IO [(String, String)] propGitEnv g = do - g' <- addGitEnv g "GIT_DIR" (localGitDir g) - g'' <- maybe (pure g') (addGitEnv g' "GIT_WORK_TREE") (repoWorkTree g) + g' <- addGitEnv g "GIT_DIR" (fromRawFilePath (localGitDir g)) + g'' <- maybe (pure g') + (addGitEnv g' "GIT_WORK_TREE" . fromRawFilePath) + (repoWorkTree g) return $ fromMaybe [] (gitEnv g'') {- Use with any action that makes a commit to set metadata. -} diff --git a/Git/FilePath.hs b/Git/FilePath.hs --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -5,13 +5,14 @@ - top of the repository even when run in a subdirectory. Adding some - types helps keep that straight. - - - Copyright 2012-2013 Joey Hess + - Copyright 2012-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Git.FilePath ( TopFilePath, @@ -30,12 +31,14 @@ import Common import Git -import qualified System.FilePath.Posix +import qualified System.FilePath.ByteString as P +import qualified System.FilePath.Posix.ByteString import GHC.Generics import Control.DeepSeq +import qualified Data.ByteString as S -{- A FilePath, relative to the top of the git repository. -} -newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } +{- A RawFilePath, relative to the top of the git repository. -} +newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath } deriving (Show, Eq, Ord, Generic) instance NFData TopFilePath @@ -45,20 +48,22 @@ deriving (Show, Eq, Ord) {- Git uses the branch:file form to refer to a BranchFilePath -} -descBranchFilePath :: BranchFilePath -> String -descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : getTopFilePath f +descBranchFilePath :: BranchFilePath -> S.ByteString +descBranchFilePath (BranchFilePath b f) = + encodeBS' (fromRef b) <> ":" <> getTopFilePath f {- Path to a TopFilePath, within the provided git repo. -} -fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath -fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p) +fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath +fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p) {- The input FilePath can be absolute, or relative to the CWD. -} -toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath -toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file +toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath +toTopFilePath file repo = TopFilePath . toRawFilePath + <$> relPathDirToFile (fromRawFilePath (repoPath repo)) (fromRawFilePath file) -{- The input FilePath must already be relative to the top of the git +{- The input RawFilePath must already be relative to the top of the git - repository -} -asTopFilePath :: FilePath -> TopFilePath +asTopFilePath :: RawFilePath -> TopFilePath asTopFilePath file = TopFilePath file {- Git may use a different representation of a path when storing @@ -68,25 +73,25 @@ - despite Windows using '\'. - -} -type InternalGitPath = String +type InternalGitPath = RawFilePath -toInternalGitPath :: FilePath -> InternalGitPath +toInternalGitPath :: RawFilePath -> InternalGitPath #ifndef mingw32_HOST_OS toInternalGitPath = id #else -toInternalGitPath = replace "\\" "/" +toInternalGitPath = encodeBS . replace "\\" "/" . decodeBS #endif -fromInternalGitPath :: InternalGitPath -> FilePath +fromInternalGitPath :: InternalGitPath -> RawFilePath #ifndef mingw32_HOST_OS fromInternalGitPath = id #else -fromInternalGitPath = replace "/" "\\" +fromInternalGitPath = encodeBS . replace "/" "\\" . decodeBS #endif {- isAbsolute on Windows does not think "/foo" or "\foo" is absolute, - so try posix paths. -} -absoluteGitPath :: FilePath -> Bool -absoluteGitPath p = isAbsolute p || - System.FilePath.Posix.isAbsolute (toInternalGitPath p) +absoluteGitPath :: RawFilePath -> Bool +absoluteGitPath p = P.isAbsolute p || + System.FilePath.Posix.ByteString.isAbsolute (toInternalGitPath p) diff --git a/Git/Filename.hs b/Git/Filename.hs --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -12,23 +12,44 @@ import Utility.Format (decode_c, encode_c) import Data.Char +import Data.Word +import qualified Data.ByteString as S -decode :: String -> FilePath -decode [] = [] -decode f@(c:s) - -- encoded strings will be inside double quotes - | c == '"' && end s == ['"'] = decode_c $ beginning s - | otherwise = f +-- encoded filenames will be inside double quotes +decode :: S.ByteString -> RawFilePath +decode b = case S.uncons b of + Nothing -> b + Just (h, t) + | h /= q -> b + | otherwise -> case S.unsnoc t of + Nothing -> b + Just (i, l) + | l /= q -> b + | otherwise -> + encodeBS $ decode_c $ decodeBS i + where + q :: Word8 + q = fromIntegral (ord '"') {- Should not need to use this, except for testing decode. -} -encode :: FilePath -> String -encode s = "\"" ++ encode_c s ++ "\"" +encode :: RawFilePath -> S.ByteString +encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\"" -{- For quickcheck. - - - - See comment on Utility.Format.prop_encode_c_decode_c_roundtrip for - - why this only tests chars < 256 -} -prop_encode_decode_roundtrip :: String -> Bool -prop_encode_decode_roundtrip s = s' == decode (encode s') +prop_encode_decode_roundtrip :: FilePath -> Bool +prop_encode_decode_roundtrip s = s' == + fromRawFilePath (decode (encode (toRawFilePath s'))) where - s' = filter (\c -> ord c < 256) s + s' = nonul (nohigh s) + -- Encoding and then decoding roundtrips only when + -- the string does not contain high unicode, because eg, + -- both "\12345" and "\227\128\185" are encoded to + -- "\343\200\271". + -- + -- This property papers over the problem, by only + -- testing ascii + nohigh = filter isAscii + -- A String can contain a NUL, but toRawFilePath + -- truncates on the NUL, which is generally fine + -- because unix filenames cannot contain NUL. + -- So the encoding only roundtrips when there is no nul. + nonul = filter (/= '\NUL') diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs --- a/Git/GCrypt.hs +++ b/Git/GCrypt.hs @@ -7,6 +7,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.GCrypt where import Common @@ -16,6 +18,8 @@ import qualified Git.Command as Command import Utility.Gpg +import qualified Data.ByteString as S + urlScheme :: String urlScheme = "gcrypt:" @@ -75,9 +79,9 @@ - which is stored in the repository (in encrypted form) - and cached in a per-remote gcrypt-id configuration setting. -} remoteRepoId :: Repo -> Maybe RemoteName -> Maybe GCryptId -remoteRepoId = getRemoteConfig "gcrypt-id" +remoteRepoId r n = fromConfigValue <$> getRemoteConfig "gcrypt-id" r n -getRemoteConfig :: String -> Repo -> Maybe RemoteName -> Maybe String +getRemoteConfig :: S.ByteString -> Repo -> Maybe RemoteName -> Maybe ConfigValue getRemoteConfig field repo remotename = do n <- remotename Config.getMaybe (remoteConfigKey field n) repo @@ -92,18 +96,19 @@ ] where defaultkey = "gcrypt.participants" - parse (Just "simple") = [] - parse (Just l) = words l + parse (Just (ConfigValue "simple")) = [] + parse (Just (ConfigValue b)) = words (decodeBS' b) parse Nothing = [] -remoteParticipantConfigKey :: RemoteName -> String +remoteParticipantConfigKey :: RemoteName -> ConfigKey remoteParticipantConfigKey = remoteConfigKey "gcrypt-participants" -remotePublishParticipantConfigKey :: RemoteName -> String +remotePublishParticipantConfigKey :: RemoteName -> ConfigKey remotePublishParticipantConfigKey = remoteConfigKey "gcrypt-publish-participants" -remoteSigningKey :: RemoteName -> String +remoteSigningKey :: RemoteName -> ConfigKey remoteSigningKey = remoteConfigKey "gcrypt-signingkey" -remoteConfigKey :: String -> RemoteName -> String -remoteConfigKey key remotename = "remote." ++ remotename ++ "." ++ key +remoteConfigKey :: S.ByteString -> RemoteName -> ConfigKey +remoteConfigKey key remotename = ConfigKey $ + "remote." <> encodeBS' remotename <> "." <> key diff --git a/Git/HashObject.hs b/Git/HashObject.hs --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -23,12 +23,12 @@ type HashObjectHandle = CoProcess.CoProcessHandle -hashObjectStart :: Repo -> IO HashObjectHandle -hashObjectStart = gitCoProcessStart True - [ Param "hash-object" - , Param "-w" - , Param "--stdin-paths" - , Param "--no-filters" +hashObjectStart :: Bool -> Repo -> IO HashObjectHandle +hashObjectStart writeobject = gitCoProcessStart True $ catMaybes + [ Just (Param "hash-object") + , if writeobject then Just (Param "-w") else Nothing + , Just (Param "--stdin-paths") + , Just (Param "--no-filters") ] hashObjectStop :: HashObjectHandle -> IO () @@ -73,4 +73,4 @@ pipeWriteRead (map Param params) (Just writer) repo where subcmd = "hash-object" - params = [subcmd, "-t", show objtype, "-w", "--stdin", "--no-filters"] + params = [subcmd, "-t", decodeBS (fmtObjectType objtype), "-w", "--stdin", "--no-filters"] diff --git a/Git/Hook.hs b/Git/Hook.hs --- a/Git/Hook.hs +++ b/Git/Hook.hs @@ -28,7 +28,7 @@ a == b = hookName a == hookName b hookFile :: Hook -> Repo -> FilePath -hookFile h r = localGitDir r "hooks" hookName h +hookFile h r = fromRawFilePath (localGitDir r) "hooks" hookName h {- Writes a hook. Returns False if the hook already exists with a different - content. Upgrades old scripts. diff --git a/Git/Index.hs b/Git/Index.hs --- a/Git/Index.hs +++ b/Git/Index.hs @@ -49,7 +49,7 @@ {- The normal index file. Does not check GIT_INDEX_FILE. -} indexFile :: Repo -> FilePath -indexFile r = localGitDir r "index" +indexFile r = fromRawFilePath (localGitDir r) "index" {- The index file git will currently use, checking GIT_INDEX_FILE. -} currentIndexFile :: Repo -> IO FilePath diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -34,37 +34,40 @@ import Numeric import System.Posix.Types +import qualified Data.ByteString.Lazy as L {- Scans for files that are checked into git's index at the specified locations. -} -inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) inRepo = inRepo' [] -inRepo' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) -inRepo' ps l = pipeNullSplit $ - Param "ls-files" : - Param "--cached" : - Param "-z" : - ps ++ - (Param "--" : map File l) +inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +inRepo' ps l repo = pipeNullSplit' params repo + where + params = + Param "ls-files" : + Param "--cached" : + Param "-z" : + ps ++ + (Param "--" : map (File . fromRawFilePath) l) {- Files that are checked into the index or have been committed to a - branch. -} -inRepoOrBranch :: Branch -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) +inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b] {- Scans for files at the specified locations that are not checked into git. -} -notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) +notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) notInRepo = notInRepo' [] -notInRepo' :: [CommandParam] -> Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) -notInRepo' ps include_ignored l repo = pipeNullSplit params repo +notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +notInRepo' ps include_ignored l repo = pipeNullSplit' params repo where params = concat [ [ Param "ls-files", Param "--others"] , ps , exclude , [ Param "-z", Param "--" ] - , map File l + , map (File . fromRawFilePath) l ] exclude | include_ignored = [] @@ -72,48 +75,48 @@ {- Scans for files at the specified locations that are not checked into - git. Empty directories are included in the result. -} -notInRepoIncludingEmptyDirectories :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) +notInRepoIncludingEmptyDirectories :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"] {- Finds all files in the specified locations, whether checked into git or - not. -} -allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -allFiles l = pipeNullSplit $ +allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +allFiles l = pipeNullSplit' $ Param "ls-files" : Param "--cached" : Param "--others" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Returns a list of files in the specified locations that have been - deleted. -} -deleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -deleted l repo = pipeNullSplit params repo +deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +deleted l repo = pipeNullSplit' params repo where params = Param "ls-files" : Param "--deleted" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Returns a list of files in the specified locations that have been - modified. -} -modified :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -modified l repo = pipeNullSplit params repo +modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +modified l repo = pipeNullSplit' params repo where params = Param "ls-files" : Param "--modified" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Files that have been modified or are not checked into git (and are not - ignored). -} -modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) -modifiedOthers l repo = pipeNullSplit params repo +modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +modifiedOthers l repo = pipeNullSplit' params repo where params = Param "ls-files" : @@ -122,69 +125,69 @@ Param "--exclude-standard" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l {- Returns a list of all files that are staged for commit. -} -staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +staged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) staged = staged' [] {- Returns a list of the files, staged for commit, that are being added, - moved, or changed (but not deleted), from the specified locations. -} -stagedNotDeleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +stagedNotDeleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] -staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) -staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix +staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) +staged' ps l repo = pipeNullSplit' (prefix ++ ps ++ suffix) repo where prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] - suffix = Param "--" : map File l + suffix = Param "--" : map (File . fromRawFilePath) l -type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode) +type StagedDetails = (RawFilePath, Maybe Sha, Maybe FileMode) {- Returns details about files that are staged in the index, - as well as files not yet in git. Skips ignored files. -} -stagedOthersDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedOthersDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"] {- Returns details about all files that are staged in the index. -} -stagedDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails = stagedDetails' [] {- Gets details about staged files, including the Sha of their staged - contents. -} -stagedDetails' :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedDetails], IO Bool) +stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails' ps l repo = do (ls, cleanup) <- pipeNullSplit params repo return (map parse ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ - Param "--" : map File l + Param "--" : map (File . fromRawFilePath) l parse s - | null file = (s, Nothing, Nothing) - | otherwise = (file, extractSha $ take shaSize rest, readmode mode) + | null file = (L.toStrict s, Nothing, Nothing) + | otherwise = (toRawFilePath file, extractSha $ take shaSize rest, readmode mode) where - (metadata, file) = separate (== '\t') s + (metadata, file) = separate (== '\t') (decodeBL' s) (mode, rest) = separate (== ' ') metadata readmode = fst <$$> headMaybe . readOct {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} -typeChangedStaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChangedStaged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChangedStaged = typeChanged' [Param "--cached"] {- Returns a list of the files in the specified locations whose type has - changed. Files only staged for commit will not be included. -} -typeChanged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChanged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged = typeChanged' [] -typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool) +typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged' ps l repo = do (fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files. - top <- absPath (repoPath repo) + top <- absPath (fromRawFilePath (repoPath repo)) currdir <- getCurrentDirectory - return (map (\f -> relPathDirToFileAbs currdir $ top f) fs, cleanup) + return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top decodeBL' f)) fs, cleanup) where prefix = [ Param "diff" @@ -192,7 +195,7 @@ , Param "--diff-filter=T" , Param "-z" ] - suffix = Param "--" : (if null l then [File "."] else map File l) + suffix = Param "--" : (if null l then [File "."] else map (File . fromRawFilePath) l) {- A item in conflict has two possible values. - Either can be Nothing, when that side deleted the file. -} @@ -202,7 +205,7 @@ } deriving (Show) data Unmerged = Unmerged - { unmergedFile :: FilePath + { unmergedFile :: RawFilePath , unmergedTreeItemType :: Conflicting TreeItemType , unmergedSha :: Conflicting Sha } @@ -217,21 +220,21 @@ - 3 = them - If a line is omitted, that side removed the file. -} -unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool) +unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool) unmerged l repo = do (fs, cleanup) <- pipeNullSplit params repo - return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup) + return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup) where params = Param "ls-files" : Param "--unmerged" : Param "-z" : Param "--" : - map File l + map (File . fromRawFilePath) l data InternalUnmerged = InternalUnmerged { isus :: Bool - , ifile :: FilePath + , ifile :: RawFilePath , itreeitemtype :: Maybe TreeItemType , isha :: Maybe Sha } @@ -245,9 +248,9 @@ if stage /= 2 && stage /= 3 then Nothing else do - treeitemtype <- readTreeItemType rawtreeitemtype + treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype) sha <- extractSha rawsha - return $ InternalUnmerged (stage == 2) file + return $ InternalUnmerged (stage == 2) (toRawFilePath file) (Just treeitemtype) (Just sha) _ -> Nothing where diff --git a/Git/LsTree.hs b/Git/LsTree.hs --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -24,14 +24,19 @@ import Git.Sha import Git.FilePath import qualified Git.Filename +import Utility.Attoparsec import Numeric -import Data.Char +import Data.Either import System.Posix.Types +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString.Lazy as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 data TreeItem = TreeItem { mode :: FileMode - , typeobj :: String + , typeobj :: S.ByteString , sha :: Ref , file :: TopFilePath } deriving Show @@ -45,7 +50,7 @@ lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool) lsTree' ps lsmode t repo = do (l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo - return (map parseLsTree l, cleanup) + return (rights (map parseLsTree l), cleanup) lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam] lsTreeParams lsmode r ps = @@ -63,7 +68,8 @@ {- Lists specified files in a tree. -} lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem] -lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo +lsTreeFiles t fs repo = rights . map (parseLsTree . L.fromStrict) + <$> pipeNullSplitStrict ps repo where ps = [ Param "ls-tree" @@ -73,30 +79,34 @@ , File $ fromRef t ] ++ map File fs +parseLsTree :: L.ByteString -> Either String TreeItem +parseLsTree b = case A.parse parserLsTree b of + A.Done _ r -> Right r + A.Fail _ _ err -> Left err + {- Parses a line of ls-tree output, in format: - mode SP type SP sha TAB file - - (The --long format is not currently supported.) -} -parseLsTree :: String -> TreeItem -parseLsTree l = TreeItem - { mode = smode - , typeobj = t - , sha = Ref s - , file = sfile - } - where - (m, past_m) = splitAt 7 l -- mode is 6 bytes - (!t, past_t) = separate isSpace past_m - (!s, past_s) = splitAt shaSize past_t - !f = drop 1 past_s - !smode = fst $ Prelude.head $ readOct m - !sfile = asTopFilePath $ Git.Filename.decode f +parserLsTree :: A.Parser TreeItem +parserLsTree = TreeItem + -- mode + <$> octal + <* A8.char ' ' + -- type + <*> A.takeTill (== 32) + <* A8.char ' ' + -- sha + <*> (Ref . decodeBS' <$> A.take shaSize) + <* A8.char '\t' + -- file + <*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString) {- Inverse of parseLsTree -} formatLsTree :: TreeItem -> String formatLsTree ti = unwords [ showOct (mode ti) "" - , typeobj ti + , decodeBS (typeobj ti) , fromRef (sha ti) - , getTopFilePath (file ti) + , fromRawFilePath (getTopFilePath (file ti)) ] diff --git a/Git/Objects.hs b/Git/Objects.hs --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -12,7 +12,7 @@ import Git.Sha objectsDir :: Repo -> FilePath -objectsDir r = localGitDir r "objects" +objectsDir r = fromRawFilePath (localGitDir r) "objects" packDir :: Repo -> FilePath packDir r = objectsDir r "pack" diff --git a/Git/Ref.hs b/Git/Ref.hs --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Ref where import Common @@ -13,13 +15,14 @@ import Git.Sha import Git.Types -import Data.Char (chr) +import Data.Char (chr, ord) +import qualified Data.ByteString as S headRef :: Ref headRef = Ref "HEAD" headFile :: Repo -> FilePath -headFile r = localGitDir r "HEAD" +headFile r = fromRawFilePath (localGitDir r) "HEAD" setHeadRef :: Ref -> Repo -> IO () setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref) @@ -62,8 +65,8 @@ - Prefixing the file with ./ makes this work even if in a subdirectory - of a repo. -} -fileRef :: FilePath -> Ref -fileRef f = Ref $ ":./" ++ f +fileRef :: RawFilePath -> Ref +fileRef f = Ref $ ":./" ++ fromRawFilePath f {- Converts a Ref to refer to the content of the Ref on a given date. -} dateRef :: Ref -> RefDate -> Ref @@ -71,7 +74,7 @@ {- A Ref that can be used to refer to a file in the repository as it - appears in a given Ref. -} -fileFromRef :: Ref -> FilePath -> Ref +fileFromRef :: Ref -> RawFilePath -> Ref fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr) {- Checks if a ref exists. -} @@ -82,14 +85,16 @@ {- The file used to record a ref. (Git also stores some refs in a - packed-refs file.) -} file :: Ref -> Repo -> FilePath -file ref repo = localGitDir repo fromRef ref +file ref repo = fromRawFilePath (localGitDir repo) fromRef ref {- Checks if HEAD exists. It generally will, except for in a repository - that was just created. -} headExists :: Repo -> IO Bool headExists repo = do - ls <- lines <$> pipeReadStrict [Param "show-ref", Param "--head"] repo - return $ any (" HEAD" `isSuffixOf`) ls + ls <- S.split nl <$> pipeReadStrict [Param "show-ref", Param "--head"] repo + return $ any (" HEAD" `S.isSuffixOf`) ls + where + nl = fromIntegral (ord '\n') {- Get the sha of a fully qualified git ref, if it exists. -} sha :: Branch -> Repo -> IO (Maybe Sha) @@ -100,8 +105,9 @@ , Param "--hash" -- get the hash , Param $ fromRef branch ] - process [] = Nothing - process s = Just $ Ref $ firstLine s + process s + | S.null s = Nothing + | otherwise = Just $ Ref $ decodeBS' $ firstLine' s headSha :: Repo -> IO (Maybe Sha) headSha = sha headRef @@ -116,7 +122,7 @@ {- List of (shas, branches) matching a given ref spec. -} matching' :: [String] -> Repo -> IO [(Sha, Branch)] -matching' ps repo = map gen . lines <$> +matching' ps repo = map gen . lines . decodeBS' <$> pipeReadStrict (Param "show-ref" : map Param ps) repo where gen l = let (r, b) = separate (== ' ') l @@ -148,7 +154,7 @@ - The ref may be something like a branch name, and it could contain - ":subdir" if a subtree is wanted. -} tree :: Ref -> Repo -> IO (Maybe Sha) -tree (Ref ref) = extractSha <$$> pipeReadStrict +tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict [ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ] where ref' = if ":" `isInfixOf` ref diff --git a/Git/RefLog.hs b/Git/RefLog.hs --- a/Git/RefLog.hs +++ b/Git/RefLog.hs @@ -21,7 +21,7 @@ getMulti bs = get' (map (Param . fromRef) bs) get' :: [CommandParam] -> Repo -> IO [Sha] -get' ps = mapMaybe extractSha . lines <$$> pipeReadStrict ps' +get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps' where ps' = catMaybes [ Just $ Param "log" diff --git a/Git/Remote.hs b/Git/Remote.hs --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Git.Remote where @@ -15,18 +16,21 @@ import Data.Char import qualified Data.Map as M +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import Network.URI #ifdef mingw32_HOST_OS import Git.FilePath #endif {- Is a git config key one that specifies the location of a remote? -} -isRemoteKey :: String -> Bool -isRemoteKey k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k +isRemoteKey :: ConfigKey -> Bool +isRemoteKey (ConfigKey k) = "remote." `S.isPrefixOf` k && ".url" `S.isSuffixOf` k {- Get a remote's name from the config key that specifies its location. -} -remoteKeyToRemoteName :: String -> RemoteName -remoteKeyToRemoteName k = intercalate "." $ dropFromEnd 1 $ drop 1 $ splitc '.' k +remoteKeyToRemoteName :: ConfigKey -> RemoteName +remoteKeyToRemoteName (ConfigKey k) = decodeBS' $ + S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k {- Construct a legal git remote name out of an arbitrary input string. - @@ -76,16 +80,16 @@ -- insteadof config can rewrite remote location calcloc l | null insteadofs = l - | otherwise = replacement ++ drop (length bestvalue) l + | otherwise = replacement ++ drop (S.length bestvalue) l where - replacement = drop (length prefix) $ - take (length bestkey - length suffix) bestkey - (bestkey, bestvalue) = maximumBy longestvalue insteadofs + replacement = decodeBS' $ S.drop (S.length prefix) $ + S.take (S.length bestkey - S.length suffix) bestkey + (ConfigKey bestkey, ConfigValue bestvalue) = maximumBy longestvalue insteadofs longestvalue (_, a) (_, b) = compare b a - insteadofs = filterconfig $ \(k, v) -> - prefix `isPrefixOf` k && - suffix `isSuffixOf` k && - v `isPrefixOf` l + insteadofs = filterconfig $ \(ConfigKey k, ConfigValue v) -> + prefix `S.isPrefixOf` k && + suffix `S.isSuffixOf` k && + v `S.isPrefixOf` encodeBS l filterconfig f = filter f $ concatMap splitconfigs $ M.toList $ fullconfig repo splitconfigs (k, vs) = map (\v -> (k, v)) vs diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -227,7 +227,7 @@ - Relies on packed refs being exploded before it's called. -} getAllRefs :: Repo -> IO [Ref] -getAllRefs r = getAllRefs' (localGitDir r "refs") +getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) "refs") getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do @@ -245,13 +245,13 @@ nukeFile f where makeref (sha, ref) = do - let dest = localGitDir r fromRef ref + let dest = fromRawFilePath (localGitDir r) fromRef ref createDirectoryIfMissing True (parentDir dest) unlessM (doesFileExist dest) $ writeFile dest (fromRef sha) packedRefsFile :: Repo -> FilePath -packedRefsFile r = localGitDir r "packed-refs" +packedRefsFile r = fromRawFilePath (localGitDir r) "packed-refs" parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of @@ -263,7 +263,7 @@ {- git-branch -d cannot be used to remove a branch that is directly - pointing to a corrupt commit. -} nukeBranchRef :: Branch -> Repo -> IO () -nukeBranchRef b r = nukeFile $ localGitDir r fromRef b +nukeBranchRef b r = nukeFile $ fromRawFilePath (localGitDir r) fromRef b {- Finds the most recent commit to a branch that does not need any - of the missing objects. If the input branch is good as-is, returns it. @@ -284,7 +284,7 @@ , Param "--format=%H" , Param (fromRef branch) ] r - let branchshas = catMaybes $ map extractSha ls + let branchshas = catMaybes $ map (extractSha . decodeBL) ls reflogshas <- RefLog.get branch r -- XXX Could try a bit harder here, and look -- for uncorrupted old commits in branches in the @@ -313,7 +313,7 @@ , Param "--format=%H %T" , Param (fromRef commit) ] r - let committrees = map parse ls + let committrees = map (parse . decodeBL) ls if any isNothing committrees || null committrees then do void cleanup @@ -342,7 +342,7 @@ | S.member treesha missing = return False | otherwise = do (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive treesha []) r - let objshas = map (LsTree.sha . LsTree.parseLsTree) ls + let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree) ls if any (`S.member` missing) objshas then do void cleanup @@ -370,7 +370,7 @@ length indexcontents `seq` cleanup missingIndex :: Repo -> IO Bool -missingIndex r = not <$> doesFileExist (localGitDir r "index") +missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) "index") {- Finds missing and ok files staged in the index. -} partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) @@ -394,12 +394,12 @@ UpdateIndex.streamUpdateIndex r =<< (catMaybes <$> mapM reinject good) void cleanup - return $ map fst3 bad + return $ map (fromRawFilePath . fst3) bad where reinject (file, Just sha, Just mode) = case toTreeItemType mode of Nothing -> return Nothing Just treeitemtype -> Just <$> - UpdateIndex.stageFile sha treeitemtype file r + UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r reinject _ = return Nothing newtype GoodCommits = GoodCommits (S.Set Sha) @@ -446,7 +446,7 @@ let f = indexFile g void $ tryIO $ allowWrite f where - headfile = localGitDir g "HEAD" + headfile = fromRawFilePath (localGitDir g) "HEAD" validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s) {- Put it all together. -} diff --git a/Git/Status.hs b/Git/Status.hs --- a/Git/Status.hs +++ b/Git/Status.hs @@ -57,19 +57,19 @@ in go (v : c) xs' _ -> go c xs - cparse 'M' f _ = (Just (Modified (asTopFilePath f)), Nothing) - cparse 'A' f _ = (Just (Added (asTopFilePath f)), Nothing) - cparse 'D' f _ = (Just (Deleted (asTopFilePath f)), Nothing) - cparse 'T' f _ = (Just (TypeChanged (asTopFilePath f)), Nothing) - cparse '?' f _ = (Just (Untracked (asTopFilePath f)), Nothing) + cparse 'M' f _ = (Just (Modified (asTopFilePath (toRawFilePath f))), Nothing) + cparse 'A' f _ = (Just (Added (asTopFilePath (toRawFilePath f))), Nothing) + cparse 'D' f _ = (Just (Deleted (asTopFilePath (toRawFilePath f))), Nothing) + cparse 'T' f _ = (Just (TypeChanged (asTopFilePath (toRawFilePath f))), Nothing) + cparse '?' f _ = (Just (Untracked (asTopFilePath (toRawFilePath f))), Nothing) cparse 'R' f (oldf:xs) = - (Just (Renamed (asTopFilePath oldf) (asTopFilePath f)), Just xs) + (Just (Renamed (asTopFilePath (toRawFilePath oldf)) (asTopFilePath (toRawFilePath f))), Just xs) cparse _ _ _ = (Nothing, Nothing) getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedUnstaged Status], IO Bool) getStatus ps fs r = do (ls, cleanup) <- pipeNullSplit ps' r - return (parseStatusZ ls, cleanup) + return (parseStatusZ (map decodeBL ls), cleanup) where ps' = concat [ [Param "status"] diff --git a/Git/Tree.hs b/Git/Tree.hs --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -115,11 +115,11 @@ mkTreeOutput fm ot s f = concat [ showOct fm "" , " " - , show ot + , decodeBS (fmtObjectType ot) , " " , fromRef s , "\t" - , takeFileName (getTopFilePath f) + , takeFileName (fromRawFilePath (getTopFilePath f)) , "\NUL" ] @@ -134,7 +134,7 @@ treeItemToLsTreeItem :: TreeItem -> LsTree.TreeItem treeItemToLsTreeItem (TreeItem f mode sha) = LsTree.TreeItem { LsTree.mode = mode - , LsTree.typeobj = show BlobObject + , LsTree.typeobj = fmtObjectType BlobObject , LsTree.sha = sha , LsTree.file = f } @@ -156,7 +156,7 @@ Just (NewSubTree d l) -> go (addsubtree idir m (NewSubTree d (c:l))) is _ -> - go (addsubtree idir m (NewSubTree (asTopFilePath idir) [c])) is + go (addsubtree idir m (NewSubTree (asTopFilePath (toRawFilePath idir)) [c])) is where p = gitPath i idir = takeDirectory p @@ -169,7 +169,7 @@ Just (NewSubTree d' l) -> let l' = filter (\ti -> gitPath ti /= d) l in addsubtree parent m' (NewSubTree d' (t:l')) - _ -> addsubtree parent m' (NewSubTree (asTopFilePath parent) [t]) + _ -> addsubtree parent m' (NewSubTree (asTopFilePath (toRawFilePath parent)) [t]) | otherwise = M.insert d t m where parent = takeDirectory d @@ -239,7 +239,7 @@ Just CommitObject -> do let ti = TreeCommit (LsTree.file i) (LsTree.mode i) (LsTree.sha i) go h wasmodified (ti:c) depth intree is - _ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") + _ -> error ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"") | otherwise = return (c, wasmodified, i:is) adjustlist h depth ishere underhere l = do @@ -328,7 +328,7 @@ -- For a graftloc of "foo/bar/baz", this generates -- ["foo", "foo/bar", "foo/bar/baz"] - graftdirs = map (asTopFilePath . toInternalGitPath) $ + graftdirs = map (asTopFilePath . toInternalGitPath . encodeBS) $ mkpaths [] $ splitDirectories $ gitPath graftloc mkpaths _ [] = [] mkpaths base (d:rest) = (joinPath base d) : mkpaths (base ++ [d]) rest @@ -355,7 +355,7 @@ Just CommitObject -> let c = TreeCommit (LsTree.file i) (LsTree.mode i) (LsTree.sha i) in go (c:t) intree is - _ -> parseerr ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") + _ -> parseerr ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"") | otherwise = Right (t, i:is) parseerr = Left @@ -366,7 +366,7 @@ gitPath = id instance GitPath TopFilePath where - gitPath = getTopFilePath + gitPath = fromRawFilePath . getTopFilePath instance GitPath TreeItem where gitPath (TreeItem f _ _) = gitPath f diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -1,16 +1,23 @@ {- git data types - - - Copyright 2010-2018 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Git.Types where import Network.URI +import Data.String +import Data.Default import qualified Data.Map as M +import qualified Data.ByteString as S import System.Posix.Types import Utility.SafeCommand +import Utility.FileSystemEncoding {- Support repositories on local disk, and repositories accessed via an URL. - @@ -23,17 +30,17 @@ - else known about it. -} data RepoLocation - = Local { gitdir :: FilePath, worktree :: Maybe FilePath } - | LocalUnknown FilePath + = Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath } + | LocalUnknown RawFilePath | Url URI | Unknown deriving (Show, Eq, Ord) data Repo = Repo { location :: RepoLocation - , config :: M.Map String String + , config :: M.Map ConfigKey ConfigValue -- a given git config key can actually have multiple values - , fullconfig :: M.Map String [String] + , fullconfig :: M.Map ConfigKey [ConfigValue] -- remoteName holds the name used for this repo in some other -- repo's list of remotes, when this repo is such a remote , remoteName :: Maybe RemoteName @@ -44,6 +51,33 @@ , gitGlobalOpts :: [CommandParam] } deriving (Show, Eq, Ord) +newtype ConfigKey = ConfigKey S.ByteString + deriving (Ord, Eq) + +newtype ConfigValue = ConfigValue S.ByteString + deriving (Ord, Eq, Semigroup, Monoid) + +instance Default ConfigValue where + def = ConfigValue mempty + +fromConfigKey :: ConfigKey -> String +fromConfigKey (ConfigKey s) = decodeBS' s + +instance Show ConfigKey where + show = fromConfigKey + +fromConfigValue :: ConfigValue -> String +fromConfigValue (ConfigValue s) = decodeBS' s + +instance Show ConfigValue where + show = fromConfigValue + +instance IsString ConfigKey where + fromString = ConfigKey . encodeBS' + +instance IsString ConfigValue where + fromString = ConfigValue . encodeBS' + type RemoteName = String {- A git ref. Can be a sha1, or a branch or tag name. -} @@ -64,32 +98,31 @@ {- Types of objects that can be stored in git. -} data ObjectType = BlobObject | CommitObject | TreeObject - deriving (Eq) -instance Show ObjectType where - show BlobObject = "blob" - show CommitObject = "commit" - show TreeObject = "tree" - -readObjectType :: String -> Maybe ObjectType +readObjectType :: S.ByteString -> Maybe ObjectType readObjectType "blob" = Just BlobObject readObjectType "commit" = Just CommitObject readObjectType "tree" = Just TreeObject readObjectType _ = Nothing +fmtObjectType :: ObjectType -> S.ByteString +fmtObjectType BlobObject = "blob" +fmtObjectType CommitObject = "commit" +fmtObjectType TreeObject = "tree" + {- Types of items in a tree. -} data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule - deriving (Eq) + deriving (Eq, Show) {- Git uses magic numbers to denote the type of a tree item. -} -readTreeItemType :: String -> Maybe TreeItemType +readTreeItemType :: S.ByteString -> Maybe TreeItemType readTreeItemType "100644" = Just TreeFile readTreeItemType "100755" = Just TreeExecutable readTreeItemType "120000" = Just TreeSymlink readTreeItemType "160000" = Just TreeSubmodule readTreeItemType _ = Nothing -fmtTreeItemType :: TreeItemType -> String +fmtTreeItemType :: TreeItemType -> S.ByteString fmtTreeItemType TreeFile = "100644" fmtTreeItemType TreeExecutable = "100755" fmtTreeItemType TreeSymlink = "120000" diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -10,6 +10,7 @@ mergeIndex ) where +import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.Set as S @@ -30,7 +31,7 @@ -} merge :: Ref -> Ref -> Repo -> IO () merge x y repo = do - hashhandle <- hashObjectStart repo + hashhandle <- hashObjectStart True repo ch <- catFileStart repo streamUpdateIndex repo [ lsTree x repo @@ -73,14 +74,14 @@ void $ cleanup where go [] = noop - go (info:file:rest) = mergeFile info file hashhandle ch >>= + go (info:file:rest) = mergeFile (decodeBL' info) (L.toStrict file) hashhandle ch >>= maybe (go rest) (\l -> streamer l >> go rest) go (_:[]) = error $ "parse error " ++ show differ {- Given an info line from a git raw diff, and the filename, generates - a line suitable for update-index that union merges the two sides of the - diff. -} -mergeFile :: String -> FilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe String) +mergeFile :: String -> RawFilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString) mergeFile info file hashhandle h = case filter (/= nullSha) [Ref asha, Ref bsha] of [] -> return Nothing (sha:[]) -> use sha diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -1,11 +1,11 @@ {- git-update-index library - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns, CPP #-} +{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-} module Git.UpdateIndex ( Streamer, @@ -32,12 +32,14 @@ import Git.Sha import qualified Git.DiffTreeItem as Diff +import qualified Data.ByteString.Lazy as L + {- Streamers are passed a callback and should feed it lines in the form - read by update-index, and generated by ls-tree. -} -type Streamer = (String -> IO ()) -> IO () +type Streamer = (L.ByteString -> IO ()) -> IO () {- A streamer with a precalculated value. -} -pureStreamer :: String -> Streamer +pureStreamer :: L.ByteString -> Streamer pureStreamer !s = \streamer -> streamer s {- Streams content into update-index from a list of Streamers. -} @@ -49,8 +51,8 @@ streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO () streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do - hPutStr h s - hPutStr h "\0" + L.hPutStr h s + L.hPutStr h "\0" startUpdateIndex :: Repo -> IO UpdateIndexHandle startUpdateIndex repo = do @@ -84,28 +86,31 @@ {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -} -updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> String -updateIndexLine sha treeitemtype file = concat - [ fmtTreeItemType treeitemtype - , " blob " - , fromRef sha - , "\t" - , indexPath file - ] +updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString +updateIndexLine sha treeitemtype file = L.fromStrict $ + fmtTreeItemType treeitemtype + <> " blob " + <> encodeBS (fromRef sha) + <> "\t" + <> indexPath file stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer stageFile sha treeitemtype file repo = do - p <- toTopFilePath file repo + p <- toTopFilePath (toRawFilePath file) repo return $ pureStreamer $ updateIndexLine sha treeitemtype p {- A streamer that removes a file from the index. -} unstageFile :: FilePath -> Repo -> IO Streamer unstageFile file repo = do - p <- toTopFilePath file repo + p <- toTopFilePath (toRawFilePath file) repo return $ unstageFile' p unstageFile' :: TopFilePath -> Streamer -unstageFile' p = pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p +unstageFile' p = pureStreamer $ L.fromStrict $ + "0 " + <> encodeBS' (fromRef nullSha) + <> "\t" + <> indexPath p {- A streamer that adds a symlink to the index. -} stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer @@ -113,7 +118,7 @@ !line <- updateIndexLine <$> pure sha <*> pure TreeSymlink - <*> toTopFilePath file repo + <*> toTopFilePath (toRawFilePath file) repo return $ pureStreamer line {- A streamer that applies a DiffTreeItem to the index. -} diff --git a/Key.hs b/Key.hs --- a/Key.hs +++ b/Key.hs @@ -78,6 +78,13 @@ <*> ((abs <$>) <$> arbitrary) -- chunksize cannot be negative <*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative +-- AssociatedFile cannot be empty, and cannot contain a NUL +-- (but can be Nothing) +instance Arbitrary AssociatedFile where + arbitrary = (AssociatedFile . fmap toRawFilePath <$> arbitrary) + `suchThat` (/= AssociatedFile (Just S.empty)) + `suchThat` (\(AssociatedFile f) -> maybe True (S.notElem 0) f) + instance Arbitrary Key where arbitrary = mkKey . const <$> arbitrary diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -33,6 +33,7 @@ import Utility.Glob import Utility.HumanTime import Utility.DataUnits +import qualified Utility.RawFilePath as R import Data.Time.Clock.POSIX import qualified Data.Set as S @@ -94,10 +95,10 @@ matchGlobFile glob = go where cglob = compileGlob glob CaseSensative -- memoized - go (MatchingFile fi) = pure $ matchGlob cglob (matchFile fi) + go (MatchingFile fi) = pure $ matchGlob cglob (fromRawFilePath (matchFile fi)) go (MatchingInfo p) = matchGlob cglob <$> getInfo (providedFilePath p) go (MatchingKey _ (AssociatedFile Nothing)) = pure False - go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob af + go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob (fromRawFilePath af) addMimeType :: String -> Annex () addMimeType = addMagicLimit "mimetype" getMagicMimeType providedMimeType @@ -110,14 +111,15 @@ magic <- liftIO initMagicMime addLimit $ matchMagic limitname querymagic' selectprovidedinfo magic glob where - querymagic' magic f = liftIO (isPointerFile f) >>= \case + querymagic' magic f = liftIO (isPointerFile (toRawFilePath f)) >>= \case -- Avoid getting magic of a pointer file, which would -- wrongly be detected as text. Just _ -> return Nothing -- When the file is an annex symlink, get magic of the -- object file. - Nothing -> isAnnexLink f >>= \case - Just k -> withObjectLoc k $ querymagic magic + Nothing -> isAnnexLink (toRawFilePath f) >>= \case + Just k -> withObjectLoc k $ + querymagic magic . fromRawFilePath Nothing -> querymagic magic f matchMagic :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> Maybe Magic -> MkLimit Annex @@ -127,7 +129,7 @@ go (MatchingKey _ _) = pure False go (MatchingFile fi) = catchBoolIO $ maybe False (matchGlob cglob) - <$> querymagic magic (currFile fi) + <$> querymagic magic (fromRawFilePath (currFile fi)) go (MatchingInfo p) = matchGlob cglob <$> getInfo (selectprovidedinfo p) matchMagic limitname _ _ Nothing _ = @@ -146,7 +148,7 @@ islocked <- isPointerFile (currFile fi) >>= \case Just _key -> return False Nothing -> isSymbolicLink - <$> getSymbolicLinkStatus (currFile fi) + <$> getSymbolicLinkStatus (fromRawFilePath (currFile fi)) return (islocked == wantlocked) {- Adds a limit to skip files not believed to be present @@ -190,9 +192,9 @@ limitInDir :: FilePath -> MatchFiles Annex limitInDir dir = const go where - go (MatchingFile fi) = checkf $ matchFile fi + go (MatchingFile fi) = checkf $ fromRawFilePath $ matchFile fi go (MatchingKey _ (AssociatedFile Nothing)) = return False - go (MatchingKey _ (AssociatedFile (Just af))) = checkf af + go (MatchingKey _ (AssociatedFile (Just af))) = checkf (fromRawFilePath af) go (MatchingInfo p) = checkf =<< getInfo (providedFilePath p) checkf = return . elem dir . splitPath . takeDirectory @@ -239,7 +241,8 @@ NumCopies numcopies <- if approx then approxNumCopies else case mi of - MatchingFile fi -> getGlobalFileNumCopies $ matchFile fi + MatchingFile fi -> getGlobalFileNumCopies $ + fromRawFilePath $ matchFile fi MatchingKey _ _ -> approxNumCopies MatchingInfo {} -> approxNumCopies us <- filter (`S.notMember` notpresent) @@ -321,7 +324,8 @@ Just key -> checkkey sz key Nothing -> return False LimitDiskFiles -> do - filesize <- liftIO $ catchMaybeIO $ getFileSize (currFile fi) + filesize <- liftIO $ catchMaybeIO $ + getFileSize (fromRawFilePath (currFile fi)) return $ filesize `vs` Just sz go sz _ (MatchingKey key _) = checkkey sz key go sz _ (MatchingInfo p) = @@ -361,7 +365,7 @@ where check now k = inAnnexCheck k $ \f -> liftIO $ catchDefaultIO False $ do - s <- getFileStatus f + s <- R.getFileStatus f let accessed = realToFrac (accessTime s) let delta = now - accessed return $ delta <= secs diff --git a/Logs.hs b/Logs.hs --- a/Logs.hs +++ b/Logs.hs @@ -5,11 +5,16 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Logs where import Annex.Common import Annex.DirHashes +import qualified Data.ByteString as S +import qualified System.FilePath.ByteString as P + {- There are several varieties of log file formats. -} data LogVariety = OldUUIDBasedLog @@ -22,7 +27,7 @@ {- Converts a path from the git-annex branch into one of the varieties - of logs used by git-annex, if it's a known path. -} -getLogVariety :: FilePath -> Maybe LogVariety +getLogVariety :: RawFilePath -> Maybe LogVariety getLogVariety f | f `elem` topLevelOldUUIDBasedLogs = Just OldUUIDBasedLog | f `elem` topLevelNewUUIDBasedLogs = Just NewUUIDBasedLog @@ -34,7 +39,7 @@ | otherwise = PresenceLog <$> firstJust (presenceLogs f) {- All the old-format uuid-based logs stored in the top of the git-annex branch. -} -topLevelOldUUIDBasedLogs :: [FilePath] +topLevelOldUUIDBasedLogs :: [RawFilePath] topLevelOldUUIDBasedLogs = [ uuidLog , remoteLog @@ -49,161 +54,172 @@ ] {- All the new-format uuid-based logs stored in the top of the git-annex branch. -} -topLevelNewUUIDBasedLogs :: [FilePath] +topLevelNewUUIDBasedLogs :: [RawFilePath] topLevelNewUUIDBasedLogs = [ exportLog ] {- All the ways to get a key from a presence log file -} -presenceLogs :: FilePath -> [Maybe Key] +presenceLogs :: RawFilePath -> [Maybe Key] presenceLogs f = [ urlLogFileKey f , locationLogFileKey f ] {- Top-level logs that are neither UUID based nor presence logs. -} -otherLogs :: [FilePath] +otherLogs :: [RawFilePath] otherLogs = [ numcopiesLog , groupPreferredContentLog ] -uuidLog :: FilePath +uuidLog :: RawFilePath uuidLog = "uuid.log" -numcopiesLog :: FilePath +numcopiesLog :: RawFilePath numcopiesLog = "numcopies.log" -configLog :: FilePath +configLog :: RawFilePath configLog = "config.log" -remoteLog :: FilePath +remoteLog :: RawFilePath remoteLog = "remote.log" -trustLog :: FilePath +trustLog :: RawFilePath trustLog = "trust.log" -groupLog :: FilePath +groupLog :: RawFilePath groupLog = "group.log" -preferredContentLog :: FilePath +preferredContentLog :: RawFilePath preferredContentLog = "preferred-content.log" -requiredContentLog :: FilePath +requiredContentLog :: RawFilePath requiredContentLog = "required-content.log" -groupPreferredContentLog :: FilePath +groupPreferredContentLog :: RawFilePath groupPreferredContentLog = "group-preferred-content.log" -scheduleLog :: FilePath +scheduleLog :: RawFilePath scheduleLog = "schedule.log" -activityLog :: FilePath +activityLog :: RawFilePath activityLog = "activity.log" -differenceLog :: FilePath +differenceLog :: RawFilePath differenceLog = "difference.log" -multicastLog :: FilePath +multicastLog :: RawFilePath multicastLog = "multicast.log" -exportLog :: FilePath +exportLog :: RawFilePath exportLog = "export.log" {- The pathname of the location log file for a given key. -} -locationLogFile :: GitConfig -> Key -> String -locationLogFile config key = branchHashDir config key keyFile key ++ ".log" +locationLogFile :: GitConfig -> Key -> RawFilePath +locationLogFile config key = + branchHashDir config key P. keyFile key <> ".log" {- The filename of the url log for a given key. -} -urlLogFile :: GitConfig -> Key -> FilePath -urlLogFile config key = branchHashDir config key keyFile key ++ urlLogExt +urlLogFile :: GitConfig -> Key -> RawFilePath +urlLogFile config key = + branchHashDir config key P. keyFile key <> urlLogExt {- Old versions stored the urls elsewhere. -} -oldurlLogs :: GitConfig -> Key -> [FilePath] +oldurlLogs :: GitConfig -> Key -> [RawFilePath] oldurlLogs config key = - [ "remote/web" hdir serializeKey key ++ ".log" - , "remote/web" hdir keyFile key ++ ".log" + [ "remote/web" P. hdir P. serializeKey' key <> ".log" + , "remote/web" P. hdir P. keyFile key <> ".log" ] where hdir = branchHashDir config key -urlLogExt :: String +urlLogExt :: S.ByteString urlLogExt = ".log.web" {- Does not work on oldurllogs. -} -isUrlLog :: FilePath -> Bool -isUrlLog file = urlLogExt `isSuffixOf` file +isUrlLog :: RawFilePath -> Bool +isUrlLog file = urlLogExt `S.isSuffixOf` file {- The filename of the remote state log for a given key. -} -remoteStateLogFile :: GitConfig -> Key -> FilePath -remoteStateLogFile config key = branchHashDir config key - keyFile key ++ remoteStateLogExt +remoteStateLogFile :: GitConfig -> Key -> RawFilePath +remoteStateLogFile config key = + (branchHashDir config key P. keyFile key) + <> remoteStateLogExt -remoteStateLogExt :: String +remoteStateLogExt :: S.ByteString remoteStateLogExt = ".log.rmt" -isRemoteStateLog :: FilePath -> Bool -isRemoteStateLog path = remoteStateLogExt `isSuffixOf` path +isRemoteStateLog :: RawFilePath -> Bool +isRemoteStateLog path = remoteStateLogExt `S.isSuffixOf` path {- The filename of the chunk log for a given key. -} -chunkLogFile :: GitConfig -> Key -> FilePath -chunkLogFile config key = branchHashDir config key keyFile key ++ chunkLogExt +chunkLogFile :: GitConfig -> Key -> RawFilePath +chunkLogFile config key = + (branchHashDir config key P. keyFile key) + <> chunkLogExt -chunkLogExt :: String +chunkLogExt :: S.ByteString chunkLogExt = ".log.cnk" -isChunkLog :: FilePath -> Bool -isChunkLog path = chunkLogExt `isSuffixOf` path +isChunkLog :: RawFilePath -> Bool +isChunkLog path = chunkLogExt `S.isSuffixOf` path {- The filename of the metadata log for a given key. -} -metaDataLogFile :: GitConfig -> Key -> FilePath -metaDataLogFile config key = branchHashDir config key keyFile key ++ metaDataLogExt +metaDataLogFile :: GitConfig -> Key -> RawFilePath +metaDataLogFile config key = + (branchHashDir config key P. keyFile key) + <> metaDataLogExt -metaDataLogExt :: String +metaDataLogExt :: S.ByteString metaDataLogExt = ".log.met" -isMetaDataLog :: FilePath -> Bool -isMetaDataLog path = metaDataLogExt `isSuffixOf` path +isMetaDataLog :: RawFilePath -> Bool +isMetaDataLog path = metaDataLogExt `S.isSuffixOf` path {- The filename of the remote metadata log for a given key. -} -remoteMetaDataLogFile :: GitConfig -> Key -> FilePath -remoteMetaDataLogFile config key = branchHashDir config key keyFile key ++ remoteMetaDataLogExt +remoteMetaDataLogFile :: GitConfig -> Key -> RawFilePath +remoteMetaDataLogFile config key = + (branchHashDir config key P. keyFile key) + <> remoteMetaDataLogExt -remoteMetaDataLogExt :: String +remoteMetaDataLogExt :: S.ByteString remoteMetaDataLogExt = ".log.rmet" -isRemoteMetaDataLog :: FilePath -> Bool -isRemoteMetaDataLog path = remoteMetaDataLogExt `isSuffixOf` path +isRemoteMetaDataLog :: RawFilePath -> Bool +isRemoteMetaDataLog path = remoteMetaDataLogExt `S.isSuffixOf` path {- The filename of the remote content identifier log for a given key. -} -remoteContentIdentifierLogFile :: GitConfig -> Key -> FilePath -remoteContentIdentifierLogFile config key = branchHashDir config key keyFile key ++ remoteContentIdentifierExt +remoteContentIdentifierLogFile :: GitConfig -> Key -> RawFilePath +remoteContentIdentifierLogFile config key = + (branchHashDir config key P. keyFile key) + <> remoteContentIdentifierExt -remoteContentIdentifierExt :: String +remoteContentIdentifierExt :: S.ByteString remoteContentIdentifierExt = ".log.cid" -isRemoteContentIdentifierLog :: FilePath -> Bool -isRemoteContentIdentifierLog path = remoteContentIdentifierExt `isSuffixOf` path +isRemoteContentIdentifierLog :: RawFilePath -> Bool +isRemoteContentIdentifierLog path = remoteContentIdentifierExt `S.isSuffixOf` path {- From an extension and a log filename, get the key that it's a log for. -} -extLogFileKey :: String -> FilePath -> Maybe Key +extLogFileKey :: S.ByteString -> RawFilePath -> Maybe Key extLogFileKey expectedext path - | ext == expectedext = fileKey base + | encodeBS' ext == expectedext = fileKey (toRawFilePath base) | otherwise = Nothing where - file = takeFileName path + file = takeFileName (fromRawFilePath path) (base, ext) = splitAt (length file - extlen) file - extlen = length expectedext + extlen = S.length expectedext {- Converts a url log file into a key. - (Does not work on oldurlLogs.) -} -urlLogFileKey :: FilePath -> Maybe Key +urlLogFileKey :: RawFilePath -> Maybe Key urlLogFileKey = extLogFileKey urlLogExt {- Converts a pathname into a key if it's a location log. -} -locationLogFileKey :: FilePath -> Maybe Key +locationLogFileKey :: RawFilePath -> Maybe Key locationLogFileKey path -- Want only xx/yy/foo.log, not .log files in other places. - | length (splitDirectories path) /= 3 = Nothing + | length (splitDirectories (fromRawFilePath path)) /= 3 = Nothing | otherwise = extLogFileKey ".log" path diff --git a/Logs/Config.hs b/Logs/Config.hs --- a/Logs/Config.hs +++ b/Logs/Config.hs @@ -6,8 +6,8 @@ -} module Logs.Config ( - ConfigName, - ConfigValue, + ConfigKey(..), + ConfigValue(..), setGlobalConfig, unsetGlobalConfig, getGlobalConfig, @@ -18,48 +18,52 @@ import Logs import Logs.MapLog import qualified Annex.Branch +import Git.Types (ConfigKey(..), ConfigValue(..)) import qualified Data.Map as M +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Attoparsec.ByteString.Lazy as A import Data.ByteString.Builder -type ConfigName = String -type ConfigValue = String - -setGlobalConfig :: ConfigName -> ConfigValue -> Annex () +setGlobalConfig :: ConfigKey -> ConfigValue -> Annex () setGlobalConfig name new = do curr <- getGlobalConfig name when (curr /= Just new) $ setGlobalConfig' name new -setGlobalConfig' :: ConfigName -> ConfigValue -> Annex () +setGlobalConfig' :: ConfigKey -> ConfigValue -> Annex () setGlobalConfig' name new = do c <- liftIO currentVectorClock Annex.Branch.change configLog $ buildGlobalConfig . changeMapLog c name new . parseGlobalConfig -unsetGlobalConfig :: ConfigName -> Annex () +unsetGlobalConfig :: ConfigKey -> Annex () unsetGlobalConfig name = do curr <- getGlobalConfig name when (curr /= Nothing) $ - setGlobalConfig' name "" -- set to empty string to unset + -- set to empty string to unset + setGlobalConfig' name (ConfigValue mempty) -- Reads the global config log every time. -getGlobalConfig :: ConfigName -> Annex (Maybe ConfigValue) +-- It's more efficient to use Config.GitConfig. +getGlobalConfig :: ConfigKey -> Annex (Maybe ConfigValue) getGlobalConfig name = M.lookup name <$> loadGlobalConfig -buildGlobalConfig :: MapLog ConfigName ConfigValue -> Builder -buildGlobalConfig = buildMapLog fieldbuilder valuebuilder +buildGlobalConfig :: MapLog ConfigKey ConfigValue -> Builder +buildGlobalConfig = buildMapLog configkeybuilder valuebuilder where - fieldbuilder = byteString . encodeBS - valuebuilder = byteString . encodeBS + configkeybuilder (ConfigKey k) = byteString k + valuebuilder (ConfigValue v) = byteString v -parseGlobalConfig :: L.ByteString -> MapLog ConfigName ConfigValue -parseGlobalConfig = parseMapLog string string +parseGlobalConfig :: L.ByteString -> MapLog ConfigKey ConfigValue +parseGlobalConfig = parseMapLog configkeyparser valueparser where - string = decodeBS <$> A.takeByteString + configkeyparser = ConfigKey <$> A.takeByteString + valueparser = ConfigValue <$> A.takeByteString -loadGlobalConfig :: Annex (M.Map ConfigName ConfigValue) -loadGlobalConfig = M.filter (not . null) . simpleMap . parseGlobalConfig +loadGlobalConfig :: Annex (M.Map ConfigKey ConfigValue) +loadGlobalConfig = M.filter (\(ConfigValue v) -> not (S.null v)) + . simpleMap + . parseGlobalConfig <$> Annex.Branch.get configLog diff --git a/Logs/Export.hs b/Logs/Export.hs --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Logs.Export ( Exported, mkExported, @@ -37,6 +39,8 @@ import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.Attoparsec.ByteString.Char8 as A8 import Data.ByteString.Builder +import Data.Either +import Data.Char -- This constuctor is not itself exported to other modules, to enforce -- consistent use of exportedTreeishes. @@ -176,8 +180,9 @@ getExportExcluded :: UUID -> Annex [Git.Tree.TreeItem] getExportExcluded u = do logf <- fromRepo $ gitAnnexExportExcludeLog u - liftIO $ catchDefaultIO [] $ - (map parser . lines) - <$> readFile logf + liftIO $ catchDefaultIO [] $ parser <$> L.readFile logf where - parser = Git.Tree.lsTreeItemToTreeItem . Git.LsTree.parseLsTree + parser = map Git.Tree.lsTreeItemToTreeItem + . rights + . map Git.LsTree.parseLsTree + . L.split (fromIntegral $ ord '\n') diff --git a/Logs/Location.hs b/Logs/Location.hs --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -71,7 +71,7 @@ loggedLocationsRef :: Ref -> Annex [UUID] loggedLocationsRef ref = map (toUUID . fromLogInfo) . getLog <$> catObject ref -getLoggedLocations :: (FilePath -> Annex [LogInfo]) -> Key -> Annex [UUID] +getLoggedLocations :: (RawFilePath -> Annex [LogInfo]) -> Key -> Annex [UUID] getLoggedLocations getter key = do config <- Annex.getGitConfig map (toUUID . fromLogInfo) <$> getter (locationLogFile config key) diff --git a/Logs/MetaData.hs b/Logs/MetaData.hs --- a/Logs/MetaData.hs +++ b/Logs/MetaData.hs @@ -57,7 +57,7 @@ getCurrentMetaData :: Key -> Annex MetaData getCurrentMetaData = getCurrentMetaData' metaDataLogFile -getCurrentMetaData' :: (GitConfig -> Key -> FilePath) -> Key -> Annex MetaData +getCurrentMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> Annex MetaData getCurrentMetaData' getlogfile k = do config <- Annex.getGitConfig ls <- S.toAscList <$> readLog (getlogfile config k) @@ -95,7 +95,7 @@ addMetaData :: Key -> MetaData -> Annex () addMetaData = addMetaData' metaDataLogFile -addMetaData' :: (GitConfig -> Key -> FilePath) -> Key -> MetaData -> Annex () +addMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> Annex () addMetaData' getlogfile k metadata = addMetaDataClocked' getlogfile k metadata =<< liftIO currentVectorClock @@ -106,7 +106,7 @@ addMetaDataClocked :: Key -> MetaData -> VectorClock -> Annex () addMetaDataClocked = addMetaDataClocked' metaDataLogFile -addMetaDataClocked' :: (GitConfig -> Key -> FilePath) -> Key -> MetaData -> VectorClock -> Annex () +addMetaDataClocked' :: (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> VectorClock -> Annex () addMetaDataClocked' getlogfile k d@(MetaData m) c | d == emptyMetaData = noop | otherwise = do @@ -151,5 +151,5 @@ const $ buildLog l return True -readLog :: FilePath -> Annex (Log MetaData) +readLog :: RawFilePath -> Annex (Log MetaData) readLog = parseLog <$$> Annex.Branch.get diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -42,7 +42,6 @@ import Types.Remote (RemoteConfig) import Logs.Group import Logs.Remote -import Types.FileMatcher import Types.StandardGroups import Limit diff --git a/Logs/PreferredContent/Raw.hs b/Logs/PreferredContent/Raw.hs --- a/Logs/PreferredContent/Raw.hs +++ b/Logs/PreferredContent/Raw.hs @@ -28,7 +28,7 @@ requiredContentSet :: UUID -> PreferredContentExpression -> Annex () requiredContentSet = setLog requiredContentLog -setLog :: FilePath -> UUID -> PreferredContentExpression -> Annex () +setLog :: RawFilePath -> UUID -> PreferredContentExpression -> Annex () setLog logfile uuid@(UUID _) val = do c <- liftIO currentVectorClock Annex.Branch.change logfile $ diff --git a/Logs/Presence.hs b/Logs/Presence.hs --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -30,7 +30,7 @@ {- Adds a LogLine to the log, removing any LogLines that are obsoleted by - adding it. -} -addLog :: FilePath -> LogLine -> Annex () +addLog :: RawFilePath -> LogLine -> Annex () addLog file line = Annex.Branch.change file $ \b -> buildLog $ compactLog (line : parseLog b) @@ -38,14 +38,14 @@ - older timestamp, that LogLine is preserved, rather than updating the log - with a newer timestamp. -} -maybeAddLog :: FilePath -> LogLine -> Annex () +maybeAddLog :: RawFilePath -> LogLine -> Annex () maybeAddLog file line = Annex.Branch.maybeChange file $ \s -> do m <- insertNewStatus line $ logMap $ parseLog s return $ buildLog $ mapLog m {- Reads a log file. - Note that the LogLines returned may be in any order. -} -readLog :: FilePath -> Annex [LogLine] +readLog :: RawFilePath -> Annex [LogLine] readLog = parseLog <$$> Annex.Branch.get {- Generates a new LogLine with the current time. -} @@ -55,10 +55,10 @@ return $ LogLine c s i {- Reads a log and returns only the info that is still in effect. -} -currentLogInfo :: FilePath -> Annex [LogInfo] +currentLogInfo :: RawFilePath -> Annex [LogInfo] currentLogInfo file = map info <$> currentLog file -currentLog :: FilePath -> Annex [LogLine] +currentLog :: RawFilePath -> Annex [LogLine] currentLog file = filterPresent <$> readLog file {- Reads a historical version of a log and returns the info that was in @@ -66,6 +66,6 @@ - - The date is formatted as shown in gitrevisions man page. -} -historicalLogInfo :: RefDate -> FilePath -> Annex [LogInfo] +historicalLogInfo :: RefDate -> RawFilePath -> Annex [LogInfo] historicalLogInfo refdate file = map info . filterPresent . parseLog <$> Annex.Branch.getHistorical refdate file diff --git a/Logs/SingleValue.hs b/Logs/SingleValue.hs --- a/Logs/SingleValue.hs +++ b/Logs/SingleValue.hs @@ -25,13 +25,13 @@ import qualified Data.Set as S -readLog :: (Ord v, SingleValueSerializable v) => FilePath -> Annex (Log v) +readLog :: (Ord v, SingleValueSerializable v) => RawFilePath -> Annex (Log v) readLog = parseLog <$$> Annex.Branch.get -getLog :: (Ord v, SingleValueSerializable v) => FilePath -> Annex (Maybe v) +getLog :: (Ord v, SingleValueSerializable v) => RawFilePath -> Annex (Maybe v) getLog = newestValue <$$> readLog -setLog :: (SingleValueSerializable v) => FilePath -> v -> Annex () +setLog :: (SingleValueSerializable v) => RawFilePath -> v -> Annex () setLog f v = do c <- liftIO currentVectorClock let ent = LogEntry c v diff --git a/Logs/Smudge.hs b/Logs/Smudge.hs --- a/Logs/Smudge.hs +++ b/Logs/Smudge.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Logs.Smudge where import Annex.Common @@ -15,8 +17,8 @@ smudgeLog :: Key -> TopFilePath -> Annex () smudgeLog k f = do logf <- fromRepo gitAnnexSmudgeLog - appendLogFile logf gitAnnexSmudgeLock $ - serializeKey k ++ " " ++ getTopFilePath f + appendLogFile logf gitAnnexSmudgeLock $ fromRawFilePath $ + serializeKey' k <> " " <> getTopFilePath f -- | Streams all smudged files, and then empties the log at the end. -- @@ -37,4 +39,4 @@ let (ks, f) = separate (== ' ') l in do k <- deserializeKey ks - return (k, asTopFilePath f) + return (k, asTopFilePath (toRawFilePath f)) diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -31,7 +31,7 @@ describeTransfer t info = unwords [ show $ transferDirection t , show $ transferUUID t - , actionItemDesc $ ActionItemAssociatedFile + , decodeBS' $ actionItemDesc $ ActionItemAssociatedFile (associatedFile info) (transferKey t) , show $ bytesComplete info @@ -195,12 +195,12 @@ transferFile :: Transfer -> Git.Repo -> FilePath transferFile (Transfer direction u kd) r = transferDir direction r filter (/= '/') (fromUUID u) - keyFile (mkKey (const kd)) + fromRawFilePath (keyFile (mkKey (const kd))) {- The transfer information file to use to record a failed Transfer -} failedTransferFile :: Transfer -> Git.Repo -> FilePath failedTransferFile (Transfer direction u kd) r = failedTransferDir u direction r - keyFile (mkKey (const kd)) + fromRawFilePath (keyFile (mkKey (const kd))) {- The transfer lock file corresponding to a given transfer info file. -} transferLockFile :: FilePath -> FilePath @@ -215,7 +215,7 @@ [direction, u, key] -> Transfer <$> parseDirection direction <*> pure (toUUID u) - <*> fmap (fromKey id) (fileKey key) + <*> fmap (fromKey id) (fileKey (toRawFilePath key)) _ -> Nothing where bits = splitDirectories file @@ -245,7 +245,7 @@ #endif -- comes last; arbitrary content , let AssociatedFile afile = associatedFile info - in fromMaybe "" afile + in maybe "" fromRawFilePath afile ] readTransferInfoFile :: Maybe PID -> FilePath -> IO (Maybe TransferInfo) @@ -263,7 +263,7 @@ <*> pure Nothing <*> pure Nothing <*> bytes - <*> pure (AssociatedFile (if null filename then Nothing else Just filename)) + <*> pure (AssociatedFile (if null filename then Nothing else Just (toRawFilePath filename))) <*> pure False where #ifdef mingw32_HOST_OS diff --git a/Logs/Transitions.hs b/Logs/Transitions.hs --- a/Logs/Transitions.hs +++ b/Logs/Transitions.hs @@ -12,6 +12,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Logs.Transitions where import Annex.Common @@ -26,7 +28,7 @@ import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.Attoparsec.ByteString.Char8 as A8 -transitionsLog :: FilePath +transitionsLog :: RawFilePath transitionsLog = "transitions.log" data Transition @@ -94,6 +96,6 @@ {- Typically ran with Annex.Branch.change, but we can't import Annex.Branch - here since it depends on this module. -} -recordTransitions :: (FilePath -> (L.ByteString -> Builder) -> Annex ()) -> Transitions -> Annex () +recordTransitions :: (RawFilePath -> (L.ByteString -> Builder) -> Annex ()) -> Transitions -> Annex () recordTransitions changer t = changer transitionsLog $ buildTransitions . S.union t . parseTransitionsStrictly "local" diff --git a/Messages.hs b/Messages.hs --- a/Messages.hs +++ b/Messages.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Messages ( showStart, showStart', @@ -53,6 +55,7 @@ import System.Log.Handler (setFormatter) import System.Log.Handler.Simple import Control.Concurrent +import qualified Data.ByteString as S import Common import Types @@ -66,21 +69,21 @@ import qualified Messages.JSON as JSON import qualified Annex -showStart :: String -> FilePath -> Annex () +showStart :: String -> RawFilePath -> Annex () showStart command file = outputMessage json $ - command ++ " " ++ file ++ " " + encodeBS' command <> " " <> file <> " " where json = JSON.start command (Just file) Nothing showStart' :: String -> Maybe String -> Annex () -showStart' command mdesc = outputMessage json $ +showStart' command mdesc = outputMessage json $ encodeBS' $ command ++ (maybe "" (" " ++) mdesc) ++ " " where json = JSON.start command Nothing Nothing showStartKey :: String -> Key -> ActionItem -> Annex () showStartKey command key i = outputMessage json $ - command ++ " " ++ actionItemDesc i ++ " " + encodeBS' command <> " " <> actionItemDesc i <> " " where json = JSON.start command (actionItemWorkTreeFile i) (Just key) @@ -112,7 +115,7 @@ showEndMessage (CustomOutput _) = const noop showNote :: String -> Annex () -showNote s = outputMessage (JSON.note s) $ "(" ++ s ++ ") " +showNote s = outputMessage (JSON.note s) $ encodeBS' $ "(" ++ s ++ ") " showAction :: String -> Annex () showAction s = showNote $ s ++ "..." @@ -127,7 +130,7 @@ Annex.changeState $ \s -> s { Annex.output = st' } | sideActionBlock st == InBlock = return () | otherwise = p - p = outputMessage JSON.none $ "(" ++ m ++ "...)\n" + p = outputMessage JSON.none $ encodeBS' $ "(" ++ m ++ "...)\n" showStoringStateAction :: Annex () showStoringStateAction = showSideAction "recording state in git" @@ -171,7 +174,7 @@ outputMessage JSON.none "\n" showLongNote :: String -> Annex () -showLongNote s = outputMessage (JSON.note s) (formatLongNote s) +showLongNote s = outputMessage (JSON.note s) (encodeBS' (formatLongNote s)) formatLongNote :: String -> String formatLongNote s = '\n' : indent s ++ "\n" @@ -179,7 +182,8 @@ -- Used by external special remote, displayed same as showLongNote -- to console, but json object containing the info is emitted immediately. showInfo :: String -> Annex () -showInfo s = outputMessage' outputJSON (JSON.info s) (formatLongNote s) +showInfo s = outputMessage' outputJSON (JSON.info s) $ + encodeBS' (formatLongNote s) showEndOk :: Annex () showEndOk = showEndResult True @@ -188,9 +192,9 @@ showEndFail = showEndResult False showEndResult :: Bool -> Annex () -showEndResult ok = outputMessage (JSON.end ok) $ endResult ok ++ "\n" +showEndResult ok = outputMessage (JSON.end ok) $ endResult ok <> "\n" -endResult :: Bool -> String +endResult :: Bool -> S.ByteString endResult True = "ok" endResult False = "failed" @@ -238,11 +242,11 @@ r <- a outputMessage (JSON.end r) "" -showHeader :: String -> Annex () -showHeader h = outputMessage JSON.none $ (h ++ ": ") +showHeader :: S.ByteString -> Annex () +showHeader h = outputMessage JSON.none (h <> ": ") -showRaw :: String -> Annex () -showRaw s = outputMessage JSON.none (s ++ "\n") +showRaw :: S.ByteString -> Annex () +showRaw s = outputMessage JSON.none (s <> "\n") setupConsole :: IO () setupConsole = do diff --git a/Messages/Internal.hs b/Messages/Internal.hs --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -14,17 +14,19 @@ import qualified Messages.JSON as JSON import Messages.JSON (JSONBuilder) +import qualified Data.ByteString as S + withMessageState :: (MessageState -> Annex a) -> Annex a withMessageState a = Annex.getState Annex.output >>= a -outputMessage :: JSONBuilder -> String -> Annex () +outputMessage :: JSONBuilder -> S.ByteString -> Annex () outputMessage = outputMessage' bufferJSON -outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> String -> Annex () +outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> S.ByteString -> Annex () outputMessage' jsonoutputter jsonbuilder msg = withMessageState $ \s -> case outputType s of NormalOutput - | concurrentOutputEnabled s -> concurrentMessage s False msg q - | otherwise -> liftIO $ flushed $ putStr msg + | concurrentOutputEnabled s -> concurrentMessage s False (decodeBS msg) q + | otherwise -> liftIO $ flushed $ S.putStr msg JSONOutput _ -> void $ jsonoutputter jsonbuilder s QuietOutput -> q diff --git a/Messages/JSON.hs b/Messages/JSON.hs --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -43,6 +43,7 @@ import Utility.Metered import Utility.Percentage import Utility.Aeson +import Utility.FileSystemEncoding -- A global lock to avoid concurrent threads emitting json at the same time. {-# NOINLINE emitLock #-} @@ -63,13 +64,13 @@ none :: JSONBuilder none = id -start :: String -> Maybe FilePath -> Maybe Key -> JSONBuilder +start :: String -> Maybe RawFilePath -> Maybe Key -> JSONBuilder start command file key _ = Just (o, False) where Object o = toJSON' $ JSONActionItem { itemCommand = Just command , itemKey = key - , itemFile = file + , itemFile = fromRawFilePath <$> file , itemAdded = Nothing } diff --git a/Messages/Progress.hs b/Messages/Progress.hs --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Messages.Progress where diff --git a/P2P/Annex.hs b/P2P/Annex.hs --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -47,7 +47,7 @@ size <- liftIO $ catchDefaultIO 0 $ getFileSize f runner (next (Len size)) ContentSize k next -> do - let getsize = liftIO . catchMaybeIO . getFileSize + let getsize = liftIO . catchMaybeIO . getFileSize . fromRawFilePath size <- inAnnex' isJust Nothing getsize k runner (next (Len <$> size)) ReadContent k af o sender next -> do diff --git a/P2P/IO.hs b/P2P/IO.hs --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -293,7 +293,7 @@ serviceproc = gitCreateProcess [ Param cmd - , File (repoPath (connRepo conn)) + , File (fromRawFilePath (repoPath (connRepo conn))) ] (connRepo conn) setup = do diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -22,6 +22,7 @@ import Utility.Applicative import Utility.PartialPrelude import Utility.Metered +import Utility.FileSystemEncoding import Git.FilePath import Annex.ChangedRefs (ChangedRefs) @@ -166,17 +167,17 @@ instance Proto.Serializable AssociatedFile where serialize (AssociatedFile Nothing) = "" serialize (AssociatedFile (Just af)) = - toInternalGitPath $ concatMap esc af + decodeBS' $ toInternalGitPath $ encodeBS' $ concatMap esc $ fromRawFilePath af where esc '%' = "%%" esc c | isSpace c = "%" | otherwise = [c] - deserialize s = case fromInternalGitPath $ deesc [] s of + deserialize s = case fromRawFilePath $ fromInternalGitPath $ toRawFilePath $ deesc [] s of [] -> Just (AssociatedFile Nothing) f - | isRelative f -> Just (AssociatedFile (Just f)) + | isRelative f -> Just $ AssociatedFile $ Just $ toRawFilePath f | otherwise -> Nothing where deesc b [] = reverse b diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -74,7 +74,7 @@ import Remote.List import Config import Config.DynamicConfig -import Git.Types (RemoteName) +import Git.Types (RemoteName, ConfigKey(..), fromConfigValue) import Utility.Aeson {- Map from UUIDs of Remotes to a calculated value. -} @@ -147,10 +147,12 @@ {- Finds the remote or remote group matching the name. -} byNameOrGroup :: RemoteName -> Annex [Remote] -byNameOrGroup n = go =<< getConfigMaybe (ConfigKey ("remotes." ++ n)) +byNameOrGroup n = go =<< getConfigMaybe (ConfigKey ("remotes." <> encodeBS' n)) where - go (Just l) = catMaybes <$> mapM (byName . Just) (splitc ' ' l) - go Nothing = maybeToList <$> byName (Just n) + go (Just l) = catMaybes + <$> mapM (byName . Just) (splitc ' ' (fromConfigValue l)) + go Nothing = maybeToList + <$> byName (Just n) {- Only matches remote name, not UUID -} byNameOnly :: RemoteName -> Annex (Maybe Remote) diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -212,7 +212,7 @@ androidHashDir adir k = AndroidPath $ fromAndroidPath adir ++ "/" ++ hdir where - hdir = replace [pathSeparator] "/" (hashDirLower def k) + hdir = replace [pathSeparator] "/" (fromRawFilePath (hashDirLower def k)) storeExportM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool storeExportM serial adir src _k loc _p = store' serial dest src @@ -269,7 +269,7 @@ let (stat, fn) = separate (== '\t') l sz = fromMaybe 0 (readish (takeWhile (/= ' ') stat)) cid = ContentIdentifier (encodeBS' stat) - loc = mkImportLocation $ + loc = mkImportLocation $ toRawFilePath $ Posix.makeRelative (fromAndroidPath adir) fn in Just (loc, (cid, sz)) mk _ = Nothing @@ -331,7 +331,7 @@ androidExportLocation :: AndroidPath -> ExportLocation -> AndroidPath androidExportLocation adir loc = AndroidPath $ - fromAndroidPath adir ++ "/" ++ fromExportLocation loc + fromAndroidPath adir ++ "/" ++ fromRawFilePath (fromExportLocation loc) -- | List all connected Android devices. enumerateAdbConnected :: IO [AndroidSerial] diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -195,7 +195,7 @@ createAnnexDirectory (parentDir torrent) if isTorrentMagnetUrl u then withOtherTmp $ \othertmp -> do - kf <- keyFile <$> torrentUrlKey u + kf <- fromRawFilePath . keyFile <$> torrentUrlKey u let metadir = othertmp "torrentmeta" kf createAnnexDirectory metadir showOutput @@ -239,7 +239,7 @@ downloadTorrentContent k u dest filenum p = do torrent <- tmpTorrentFile u withOtherTmp $ \othertmp -> do - kf <- keyFile <$> torrentUrlKey u + kf <- fromRawFilePath . keyFile <$> torrentUrlKey u let downloaddir = othertmp "torrent" kf createAnnexDirectory downloaddir f <- wantedfile torrent diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -1,6 +1,6 @@ {- Using bup as a remote. - - - Copyright 2011-2014 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -8,6 +8,7 @@ module Remote.Bup (remote) where import qualified Data.Map as M +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.UTF8 (fromString) @@ -15,6 +16,7 @@ import qualified Annex import Types.Remote import Types.Creds +import Git.Types (ConfigValue(..), fromConfigKey) import qualified Git import qualified Git.Command import qualified Git.Config @@ -207,12 +209,12 @@ then do showAction "storing uuid" unlessM (onBupRemote r boolSystem "git" - [Param "config", Param "annex.uuid", Param v]) $ + [Param "config", Param (fromConfigKey configkeyUUID), Param v]) $ giveup "ssh failed" else liftIO $ do r' <- Git.Config.read r - let olduuid = Git.Config.get "annex.uuid" "" r' - when (olduuid == "") $ + let ConfigValue olduuid = Git.Config.get configkeyUUID mempty r' + when (S.null olduuid) $ Git.Command.run [ Param "config" , Param "annex.uuid" @@ -228,7 +230,7 @@ (sshcmd, sshparams) <- Ssh.toRepo NoConsumeStdin r c remotecmd liftIO $ runner sshcmd sshparams where - path = Git.repoPath r + path = fromRawFilePath $ Git.repoPath r base = fromMaybe path (stripPrefix "/~/" path) dir = shellEscape base @@ -248,7 +250,7 @@ | otherwise = liftIO $ do ret <- tryIO $ Git.Config.read r case ret of - Right r' -> return (toUUID $ Git.Config.get "annex.uuid" "" r', r') + Right r' -> return (toUUID $ Git.Config.get configkeyUUID mempty r', r') Left _ -> return (NoUUID, r) {- Converts a bup remote path spec into a Git.Repo. There are some diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -127,7 +127,7 @@ - We try more than one since we used to write to different hash - directories. -} locations :: FilePath -> Key -> [FilePath] -locations d k = map (d ) (keyPaths k) +locations d k = map (\f -> d fromRawFilePath f) (keyPaths k) {- Returns the location off a Key in the directory. If the key is - present, returns the location that is actually used, otherwise @@ -139,7 +139,8 @@ {- Directory where the file(s) for a key are stored. -} storeDir :: FilePath -> Key -> FilePath -storeDir d k = addTrailingPathSeparator $ d hashDirLower def k keyFile k +storeDir d k = addTrailingPathSeparator $ + d fromRawFilePath (hashDirLower def k) fromRawFilePath (keyFile k) {- Check if there is enough free disk space in the remote's directory to - store the key. Note that the unencrypted key size is checked. -} @@ -163,12 +164,13 @@ case chunkconfig of LegacyChunks chunksize -> Legacy.store chunksize finalizeStoreGeneric k b p tmpdir destdir _ -> do - let tmpf = tmpdir keyFile k + let tmpf = tmpdir kf meteredWriteFile p tmpf b finalizeStoreGeneric tmpdir destdir return True where - tmpdir = addTrailingPathSeparator $ d "tmp" keyFile k + tmpdir = addTrailingPathSeparator $ d "tmp" kf + kf = fromRawFilePath (keyFile k) destdir = storeDir d k {- Passed a temp directory that contains the files that should be placed @@ -295,18 +297,18 @@ dest = exportPath d newloc exportPath :: FilePath -> ExportLocation -> FilePath -exportPath d loc = d fromExportLocation loc +exportPath d loc = d fromRawFilePath (fromExportLocation loc) {- Removes the ExportLocation's parent directory and its parents, so long as - they're empty, up to but not including the topdir. -} removeExportLocation :: FilePath -> ExportLocation -> IO () removeExportLocation topdir loc = - go (Just $ takeDirectory $ fromExportLocation loc) (Right ()) + go (Just $ takeDirectory $ fromRawFilePath $ fromExportLocation loc) (Right ()) where go _ (Left _e) = return () go Nothing _ = return () go (Just loc') _ = go (upFrom loc') - =<< tryIO (removeDirectory $ exportPath topdir (mkExportLocation loc')) + =<< tryIO (removeDirectory $ exportPath topdir (mkExportLocation (toRawFilePath loc'))) listImportableContentsM :: FilePath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) listImportableContentsM dir = catchMaybeIO $ liftIO $ do @@ -319,7 +321,7 @@ mkContentIdentifier f st >>= \case Nothing -> return Nothing Just cid -> do - relf <- relPathDirToFile dir f + relf <- toRawFilePath <$> relPathDirToFile dir f sz <- getFileSize' f st return $ Just (mkImportLocation relf, (cid, sz)) diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -91,7 +91,7 @@ retrieve :: (FilePath -> Key -> [FilePath]) -> FilePath -> Preparer Retriever retrieve locations d basek a = withOtherTmp $ \tmpdir -> do showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow." - let tmp = tmpdir keyFile basek ++ ".directorylegacy.tmp" + let tmp = tmpdir fromRawFilePath (keyFile basek) ++ ".directorylegacy.tmp" a $ Just $ byteRetriever $ \k sink -> do liftIO $ void $ withStoredFiles d locations k $ \fs -> do forM_ fs $ diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Remote.External (remote) where import Remote.External.Types @@ -16,7 +18,7 @@ import Types.UrlContents import qualified Git import Config -import Git.Config (isTrue, boolConfig) +import Git.Config (isTrueFalse, boolConfig) import Git.Env import Remote.Helper.Special import Remote.Helper.ExportImport @@ -155,7 +157,7 @@ (c', _encsetup) <- encryptionSetup c gc c'' <- case M.lookup "readonly" c of - Just v | isTrue v == Just True -> do + Just v | isTrueFalse v == Just True -> do setConfig (remoteConfig (fromJust (lookupName c)) "readonly") (boolConfig True) return c' _ -> do @@ -381,9 +383,9 @@ handleRemoteRequest (PROGRESS bytesprocessed) = maybe noop (\a -> liftIO $ a bytesprocessed) mp handleRemoteRequest (DIRHASH k) = - send $ VALUE $ hashDirMixed def k + send $ VALUE $ fromRawFilePath $ hashDirMixed def k handleRemoteRequest (DIRHASH_LOWER k) = - send $ VALUE $ hashDirLower def k + send $ VALUE $ fromRawFilePath $ hashDirLower def k handleRemoteRequest (SETCONFIG setting value) = liftIO $ atomically $ modifyTVar' (externalConfig st) $ M.insert setting value @@ -407,7 +409,8 @@ send $ CREDS (fst creds) (snd creds) handleRemoteRequest GETUUID = send $ VALUE $ fromUUID $ externalUUID external - handleRemoteRequest GETGITDIR = send . VALUE =<< fromRepo Git.localGitDir + handleRemoteRequest GETGITDIR = + send . VALUE . fromRawFilePath =<< fromRepo Git.localGitDir handleRemoteRequest (SETWANTED expr) = preferredContentSet (externalUUID external) expr handleRemoteRequest GETWANTED = do diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -384,12 +384,12 @@ deserialize = parseURI instance Proto.Serializable ExportLocation where - serialize = fromExportLocation - deserialize = Just . mkExportLocation + serialize = fromRawFilePath . fromExportLocation + deserialize = Just . mkExportLocation . toRawFilePath instance Proto.Serializable ExportDirectory where - serialize = fromExportDirectory - deserialize = Just . mkExportDirectory + serialize = fromRawFilePath . fromExportDirectory + deserialize = Just . mkExportDirectory . toRawFilePath instance Proto.Serializable ExtensionList where serialize (ExtensionList l) = unwords l diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Remote.GCrypt ( remote, chainGen, @@ -16,6 +18,7 @@ ) where import qualified Data.Map as M +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Control.Exception import Data.Default @@ -27,6 +30,7 @@ import Types.Crypto import Types.Creds import Types.Transfer +import Git.Types (ConfigKey(..), fromConfigKey, fromConfigValue) import qualified Git import qualified Git.Command import qualified Git.Config @@ -96,7 +100,7 @@ (Just remotename, Just c') -> do setGcryptEncryption c' remotename storeUUIDIn (remoteConfig baser "uuid") u' - setConfig (ConfigKey $ Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid + setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid gen' r u' c' gc rs _ -> do warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r @@ -159,11 +163,12 @@ rsyncTransport :: Git.Repo -> RemoteGitConfig -> Annex (Annex [CommandParam], String, AccessMethod) rsyncTransport r gc - | "ssh://" `isPrefixOf` loc = sshtransport $ break (== '/') $ drop (length "ssh://") loc + | sshprefix `isPrefixOf` loc = sshtransport $ break (== '/') $ drop (length sshprefix) loc | "//:" `isInfixOf` loc = othertransport | ":" `isInfixOf` loc = sshtransport $ separate (== ':') loc | otherwise = othertransport where + sshprefix = "ssh://" :: String loc = Git.repoLocation r sshtransport (host, path) = do let rsyncpath = if "/~/" `isPrefixOf` path @@ -252,7 +257,7 @@ | otherwise = localsetup r where localsetup r' = do - let setconfig k v = liftIO $ Git.Command.run [Param "config", Param k, Param v] r' + let setconfig k v = liftIO $ Git.Command.run [Param "config", Param (fromConfigKey k), Param v] r' setconfig coreGCryptId gcryptid setconfig denyNonFastForwards (Git.Config.boolConfig False) return AccessDirect @@ -272,8 +277,8 @@ , Param tmpconfig ] liftIO $ do - void $ Git.Config.changeFile tmpconfig coreGCryptId gcryptid - void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig False) + void $ Git.Config.changeFile tmpconfig coreGCryptId (encodeBS' gcryptid) + void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig' False) ok <- liftIO $ rsync $ opts ++ [ Param "--recursive" , Param $ tmp ++ "/" @@ -289,7 +294,7 @@ (\f p -> liftIO (boolSystem f p), return False) "gcryptsetup" [ Param gcryptid ] [] - denyNonFastForwards = "receive.denyNonFastForwards" + denyNonFastForwards = ConfigKey "receive.denyNonFastForwards" accessShell :: Remote -> Bool accessShell = accessShellConfig . gitconfig @@ -326,7 +331,7 @@ Nothing -> noop Just (KeyIds { keyIds = ks}) -> do setConfig participants (unwords ks) - let signingkey = ConfigKey $ Git.GCrypt.remoteSigningKey remotename + let signingkey = Git.GCrypt.remoteSigningKey remotename cmd <- gpgCmd <$> Annex.getGitConfig skeys <- M.keys <$> liftIO (secretKeys cmd) case filter (`elem` ks) skeys of @@ -335,7 +340,7 @@ setConfig (remoteconfig Git.GCrypt.remotePublishParticipantConfigKey) (Git.Config.boolConfig True) where - remoteconfig n = ConfigKey $ n remotename + remoteconfig n = n remotename store :: Remote -> Remote.Rsync.RsyncOpts -> Storer store r rsyncopts k s p = do @@ -346,9 +351,9 @@ store' repo r rsyncopts | not $ Git.repoIsUrl repo = byteStorer $ \k b p -> guardUsable repo (return False) $ liftIO $ do - let tmpdir = Git.repoLocation repo "tmp" keyFile k + let tmpdir = Git.repoLocation repo "tmp" fromRawFilePath (keyFile k) void $ tryIO $ createDirectoryIfMissing True tmpdir - let tmpf = tmpdir keyFile k + let tmpf = tmpdir fromRawFilePath (keyFile k) meteredWriteFile p tmpf b let destdir = parentDir $ gCryptLocation repo k Remote.Directory.finalizeStoreGeneric tmpdir destdir @@ -417,7 +422,8 @@ {- Annexed objects are hashed using lower-case directories for max - portability. -} gCryptLocation :: Git.Repo -> Key -> FilePath -gCryptLocation repo key = Git.repoLocation repo objectDir keyPath key (hashDirLower def) +gCryptLocation repo key = Git.repoLocation repo objectDir + fromRawFilePath (keyPath key (hashDirLower def)) data AccessMethod = AccessDirect | AccessShell @@ -435,7 +441,7 @@ (genUUIDInNameSpace gCryptNameSpace <$>) . fst <$> getGCryptId fast r dummycfg -coreGCryptId :: String +coreGCryptId :: ConfigKey coreGCryptId = "core.gcrypt-id" {- gcrypt repos set up by git-annex as special remotes have a @@ -457,9 +463,9 @@ | otherwise = return (Nothing, r) where extract Nothing = (Nothing, r) - extract (Just r') = (Git.Config.getMaybe coreGCryptId r', r') + extract (Just r') = (fromConfigValue <$> Git.Config.getMaybe coreGCryptId r', r') -getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, String)) +getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, S.ByteString)) getConfigViaRsync r gc = do (rsynctransport, rsyncurl, _) <- rsyncTransport r gc opts <- rsynctransport diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Remote.Git ( remote, @@ -60,6 +61,7 @@ import Types.NumCopies import Annex.Action import Messages.Progress +import qualified Utility.RawFilePath as R #ifndef mingw32_HOST_OS import Utility.FileMode @@ -68,6 +70,7 @@ import Control.Concurrent import Control.Concurrent.MSampleVar import qualified Data.Map as M +import qualified Data.ByteString as S import Network.URI remote :: RemoteType @@ -86,14 +89,14 @@ rs <- mapM (tweakurl c) =<< Annex.getGitRemotes mapM (configRead autoinit) rs where - annexurl n = "remote." ++ n ++ ".annexurl" + annexurl n = Git.ConfigKey ("remote." <> encodeBS' n <> ".annexurl") tweakurl c r = do let n = fromJust $ Git.remoteName r case M.lookup (annexurl n) c of Nothing -> return r Just url -> inRepo $ \g -> Git.Construct.remoteNamed n $ - Git.Construct.fromRemoteLocation url g + Git.Construct.fromRemoteLocation (Git.fromConfigValue url) g {- Git remotes are normally set up using standard git command, not - git-annex initremote and enableremote. @@ -254,7 +257,7 @@ v <- liftIO $ Git.Config.fromPipe r cmd params case v of Right (r', val) -> do - unless (isUUIDConfigured r' || null val) $ do + unless (isUUIDConfigured r' || S.null val) $ do warning $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r warning $ "Instead, got: " ++ show val warning $ "This is unexpected; please check the network transport!" @@ -391,9 +394,9 @@ | remoteAnnexBare remoteconfig == Just False = reverse (annexLocations gc key) | otherwise = annexLocations gc key #ifndef mingw32_HOST_OS - locs' = locs + locs' = map fromRawFilePath locs #else - locs' = map (replace "\\" "/") locs + locs' = map (replace "\\" "/" . fromRawFilePath) locs #endif remoteconfig = gitconfig r @@ -549,7 +552,7 @@ u <- getUUID let AssociatedFile afile = file let fields = (Fields.remoteUUID, fromUUID u) - : maybe [] (\f -> [(Fields.associatedFile, f)]) afile + : maybe [] (\f -> [(Fields.associatedFile, fromRawFilePath f)]) afile Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin repo "transferinfo" [Param $ serializeKey key] fields @@ -597,9 +600,9 @@ | not $ Git.repoIsUrl repo = guardUsable repo (return False) $ do gc <- getGitConfigFromState st loc <- liftIO $ gitAnnexLocation key repo gc - liftIO $ ifM (doesFileExist loc) + liftIO $ ifM (R.doesPathExist loc) ( do - absloc <- absPath loc + absloc <- absPath (fromRawFilePath loc) catchBoolIO $ do createSymbolicLink absloc file return True @@ -678,8 +681,8 @@ r' <- Git.Config.read r environ <- getEnvironment let environ' = addEntries - [ ("GIT_WORK_TREE", Git.repoPath r') - , ("GIT_DIR", Git.localGitDir r') + [ ("GIT_WORK_TREE", fromRawFilePath $ Git.repoPath r') + , ("GIT_DIR", fromRawFilePath $ Git.localGitDir r') ] environ batchCommandEnv program (Param "fsck" : params) (Just environ') @@ -854,13 +857,13 @@ where go | remoteAnnexCheckUUID gc = return - (return True, return (r, extractGitConfig r)) + (return True, return (r, extractGitConfig FromGitConfig r)) | otherwise = do rv <- liftIO newEmptyMVar let getrepo = ifM (liftIO $ isEmptyMVar rv) ( do r' <- tryGitConfigRead False r - let t = (r', extractGitConfig r') + let t = (r', extractGitConfig FromGitConfig r') void $ liftIO $ tryPutMVar rv t return t , liftIO $ readMVar rv diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Remote.GitLFS (remote, gen, configKnownUrl) where import Annex.Common @@ -153,7 +155,7 @@ -- (so it's also usable by git as a non-special remote), -- and set remote.name.annex-git-lfs = true gitConfigSpecialRemote u c' [("git-lfs", "true")] - setConfig (ConfigKey ("remote." ++ getRemoteName c ++ ".url")) url + setConfig (Git.ConfigKey ("remote." <> encodeBS' (getRemoteName c) <> ".url")) url return (c', u) where url = fromMaybe (giveup "Specify url=") (M.lookup "url" c) @@ -185,9 +187,9 @@ set "config-uuid" (fromUUID cu) r' Nothing -> return r' set k v r' = do - let ck@(ConfigKey k') = remoteConfig r' k - setConfig ck v - return $ Git.Config.store' k' v r' + let k' = remoteConfig r' k + setConfig k' v + return $ Git.Config.store' k' (Git.ConfigValue (encodeBS' v)) r' data LFSHandle = LFSHandle { downloadEndpoint :: Maybe LFS.Endpoint diff --git a/Remote/Helper/Chunked/Legacy.hs b/Remote/Helper/Chunked/Legacy.hs --- a/Remote/Helper/Chunked/Legacy.hs +++ b/Remote/Helper/Chunked/Legacy.hs @@ -77,7 +77,7 @@ warningIO (show e) return False - basef = tmp ++ keyFile key + basef = tmp ++ fromRawFilePath (keyFile key) tmpdests = map (basef ++ ) chunkStream {- Given a list of destinations to use, chunks the data according to the diff --git a/Remote/Helper/Git.hs b/Remote/Helper/Git.hs --- a/Remote/Helper/Git.hs +++ b/Remote/Helper/Git.hs @@ -20,7 +20,7 @@ localpathCalc :: Git.Repo -> Maybe FilePath localpathCalc r | availabilityCalc r == GloballyAvailable = Nothing - | otherwise = Just $ Git.repoPath r + | otherwise = Just $ fromRawFilePath $ Git.repoPath r availabilityCalc :: Git.Repo -> Availability availabilityCalc r @@ -36,7 +36,7 @@ gitRepoInfo :: Remote -> Annex [(String, String)] gitRepoInfo r = do - d <- fromRepo Git.localGitDir + d <- fromRawFilePath <$> fromRepo Git.localGitDir mtimes <- liftIO $ mapM (modificationTime <$$> getFileStatus) =<< dirContentsRecursive (d "refs" "remotes" Remote.name r) let lastsynctime = case mtimes of diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Remote.Helper.Special ( findSpecialRemotes, gitConfigSpecialRemote, @@ -51,7 +53,9 @@ import Messages.Progress import qualified Git import qualified Git.Construct +import Git.Types +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Map as M @@ -65,14 +69,17 @@ liftIO $ mapM construct $ remotepairs m where remotepairs = M.toList . M.filterWithKey match - construct (k,_) = Git.Construct.remoteNamedFromKey k (pure Git.Construct.fromUnknown) - match k _ = "remote." `isPrefixOf` k && (".annex-"++s) `isSuffixOf` k + construct (k,_) = Git.Construct.remoteNamedFromKey k + (pure Git.Construct.fromUnknown) + match (ConfigKey k) _ = + "remote." `S.isPrefixOf` k + && (".annex-" <> encodeBS' s) `S.isSuffixOf` k {- Sets up configuration for a special remote in .git/config. -} gitConfigSpecialRemote :: UUID -> RemoteConfig -> [(String, String)] -> Annex () gitConfigSpecialRemote u c cfgs = do forM_ cfgs $ \(k, v) -> - setConfig (remoteConfig c k) v + setConfig (remoteConfig c (encodeBS' k)) v storeUUIDIn (remoteConfig c "uuid") u -- RetrievalVerifiableKeysSecure unless overridden by git config. diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -65,7 +65,7 @@ let params' = if debug then Param "--debug" : params else params - return (Param command : File dir : params') + return (Param command : File (fromRawFilePath dir) : params') uuidcheck NoUUID = [] uuidcheck u@(UUID _) = ["--uuid", fromUUID u] fieldopts @@ -137,7 +137,7 @@ -- Send direct field for unlocked content, for backwards -- compatability. : (Fields.direct, if unlocked then "1" else "") - : maybe [] (\f -> [(Fields.associatedFile, f)]) afile + : maybe [] (\f -> [(Fields.associatedFile, fromRawFilePath f)]) afile repo <- getRepo r Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin repo (if direction == Download then "sendkey" else "recvkey") diff --git a/Remote/Hook.hs b/Remote/Hook.hs --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -11,6 +11,7 @@ import Types.Remote import Types.Creds import qualified Git +import Git.Types (fromConfigKey, fromConfigValue) import Config import Config.Cost import Annex.UUID @@ -103,23 +104,24 @@ ] fileenv Nothing = [] fileenv (Just file) = [envvar "FILE" file] - hashbits = map takeDirectory $ splitPath $ hashDirMixed def k + hashbits = map takeDirectory $ splitPath $ + fromRawFilePath $ hashDirMixed def k lookupHook :: HookName -> Action -> Annex (Maybe String) lookupHook hookname action = do - command <- getConfig (annexConfig hook) "" + command <- fromConfigValue <$> getConfig hook mempty if null command then do - fallback <- getConfig (annexConfig hookfallback) "" + fallback <- fromConfigValue <$> getConfig hookfallback mempty if null fallback then do - warning $ "missing configuration for " ++ hook ++ " or " ++ hookfallback + warning $ "missing configuration for " ++ fromConfigKey hook ++ " or " ++ fromConfigKey hookfallback return Nothing else return $ Just fallback else return $ Just command where - hook = hookname ++ "-" ++ action ++ "-hook" - hookfallback = hookname ++ "-hook" + hook = annexConfig $ encodeBS' $ hookname ++ "-" ++ action ++ "-hook" + hookfallback = annexConfig $ encodeBS' $ hookname ++ "-hook" runHook :: HookName -> Action -> Key -> Maybe FilePath -> Annex Bool -> Annex Bool runHook hook action k f a = maybe (return False) run =<< lookupHook hook action diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -183,7 +183,7 @@ store :: RsyncOpts -> Key -> FilePath -> MeterUpdate -> Annex Bool store o k src meterupdate = storeGeneric o meterupdate basedest populatedest where - basedest = Prelude.head (keyPaths k) + basedest = fromRawFilePath $ Prelude.head (keyPaths k) populatedest dest = liftIO $ if canrename then do rename src dest @@ -222,11 +222,11 @@ remove o k = removeGeneric o includes where includes = concatMap use dirHashes - use h = let dir = h def k in + use h = let dir = fromRawFilePath (h def k) in [ parentDir dir , dir -- match content directory and anything in it - , dir keyFile k "***" + , dir fromRawFilePath (keyFile k) "***" ] {- An empty directory is rsynced to make it delete. Everything is excluded, @@ -268,22 +268,22 @@ storeExportM o src _k loc meterupdate = storeGeneric o meterupdate basedest populatedest where - basedest = fromExportLocation loc + basedest = fromRawFilePath (fromExportLocation loc) populatedest = liftIO . createLinkOrCopy src retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool retrieveExportM o _k loc dest p = rsyncRetrieve o [rsyncurl] dest (Just p) where - rsyncurl = mkRsyncUrl o (fromExportLocation loc) + rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc)) checkPresentExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool checkPresentExportM o _k loc = checkPresentGeneric o [rsyncurl] where - rsyncurl = mkRsyncUrl o (fromExportLocation loc) + rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc)) removeExportM :: RsyncOpts -> Key -> ExportLocation -> Annex Bool removeExportM o _k loc = - removeGeneric o (includes (fromExportLocation loc)) + removeGeneric o $ includes $ fromRawFilePath $ fromExportLocation loc where includes f = f : case upFrom f of Nothing -> [] @@ -292,7 +292,7 @@ removeExportDirectoryM :: RsyncOpts -> ExportDirectory -> Annex Bool removeExportDirectoryM o ed = removeGeneric o (allbelow d : includes d) where - d = fromExportDirectory ed + d = fromRawFilePath $ fromExportDirectory ed allbelow f = f "***" includes f = f : case upFrom f of Nothing -> [] diff --git a/Remote/Rsync/RsyncUrl.hs b/Remote/Rsync/RsyncUrl.hs --- a/Remote/Rsync/RsyncUrl.hs +++ b/Remote/Rsync/RsyncUrl.hs @@ -13,14 +13,15 @@ import Annex.Locations import Utility.Rsync import Utility.SafeCommand - -import Data.Default -import System.FilePath.Posix +import Utility.FileSystemEncoding +import Annex.DirHashes #ifdef mingw32_HOST_OS import Utility.Split #endif -import Annex.DirHashes +import Data.Default +import System.FilePath.Posix + type RsyncUrl = String data RsyncOpts = RsyncOpts @@ -42,8 +43,8 @@ rsyncUrls :: RsyncOpts -> Key -> [RsyncUrl] rsyncUrls o k = map use dirHashes where - use h = rsyncUrl o hash h rsyncEscape o (f f) - f = keyFile k + use h = rsyncUrl o fromRawFilePath (hash h) rsyncEscape o (f f) + f = fromRawFilePath (keyFile k) #ifndef mingw32_HOST_OS hash h = h def k #else diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -881,7 +881,8 @@ _ -> getFilePrefix c ++ s getBucketExportLocation :: RemoteConfig -> ExportLocation -> BucketObject -getBucketExportLocation c loc = getFilePrefix c ++ fromExportLocation loc +getBucketExportLocation c loc = + getFilePrefix c ++ fromRawFilePath (fromExportLocation loc) getBucketImportLocation :: RemoteConfig -> BucketObject -> Maybe ImportLocation getBucketImportLocation c obj @@ -889,7 +890,8 @@ | obj == uuidfile = Nothing -- Only import files that are under the fileprefix, when -- one is configured. - | prefix `isPrefixOf` obj = Just $ mkImportLocation $ drop prefixlen obj + | prefix `isPrefixOf` obj = Just $ mkImportLocation $ + toRawFilePath $ drop prefixlen obj | otherwise = Nothing where prefix = getFilePrefix c diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -229,7 +229,7 @@ removeExportDirectoryDav :: Remote -> ExportDirectory -> Annex Bool removeExportDirectoryDav r dir = withDAVHandle r $ \mh -> runExport mh $ \_dav -> do - let d = fromExportDirectory dir + let d = fromRawFilePath $ fromExportDirectory dir debugDav $ "delContent " ++ d safely (inLocation d delContentM) >>= maybe (return False) (const $ return True) diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs --- a/Remote/WebDAV/DavLocation.hs +++ b/Remote/WebDAV/DavLocation.hs @@ -17,6 +17,7 @@ #ifdef mingw32_HOST_OS import Utility.Split #endif +import Utility.FileSystemEncoding import System.FilePath.Posix -- for manipulating url paths import Network.Protocol.HTTP.DAV (inDAVLocation, DAVT) @@ -35,29 +36,31 @@ {- The directory where files(s) for a key are stored. -} keyDir :: Key -> DavLocation -keyDir k = addTrailingPathSeparator $ hashdir keyFile k +keyDir k = addTrailingPathSeparator $ hashdir fromRawFilePath (keyFile k) where #ifndef mingw32_HOST_OS - hashdir = hashDirLower def k + hashdir = fromRawFilePath $ hashDirLower def k #else - hashdir = replace "\\" "/" (hashDirLower def k) + hashdir = replace "\\" "/" (fromRawFilePath $ hashDirLower def k) #endif keyLocation :: Key -> DavLocation -keyLocation k = keyDir k ++ keyFile k +keyLocation k = keyDir k ++ fromRawFilePath (keyFile k) {- Paths containing # or ? cannot be represented in an url, so fails on - those. -} exportLocation :: ExportLocation -> Either String DavLocation exportLocation l = - let p = fromExportLocation l - in if any (`elem` p) ['#', '?'] + let p = fromRawFilePath $ fromExportLocation l + in if any (`elem` p) illegalinurl then Left ("Cannot store file containing '#' or '?' on webdav: " ++ p) else Right p + where + illegalinurl = ['#', '?'] :: [Char] {- Where we store temporary data for a key as it's being uploaded. -} keyTmpLocation :: Key -> DavLocation -keyTmpLocation = tmpLocation . keyFile +keyTmpLocation = tmpLocation . fromRawFilePath . keyFile tmpLocation :: FilePath -> DavLocation tmpLocation f = "git-annex-webdav-tmp-" ++ f diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -624,7 +624,7 @@ git_annex "get" [annexedfile] @? "get of file failed" git_annex "unlock" [annexedfile] @? "unlock failed" annexeval $ do - Just k <- Annex.WorkTree.lookupFile annexedfile + Just k <- Annex.WorkTree.lookupFile (toRawFilePath annexedfile) Database.Keys.removeInodeCaches k Database.Keys.closeDb liftIO . nukeFile =<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache @@ -1146,7 +1146,7 @@ @? (what ++ " too many variant files in: " ++ show v) indir d $ do git_annex "get" (conflictor:v) @? ("get failed in " ++ what) - git_annex_expectoutput "find" [conflictor] [Git.FilePath.toInternalGitPath subfile] + git_annex_expectoutput "find" [conflictor] [fromRawFilePath (Git.FilePath.toInternalGitPath (toRawFilePath subfile))] git_annex_expectoutput "find" v v {- Check merge conflict resolution when both repos start with an annexed @@ -1343,7 +1343,7 @@ where conflictor = "conflictor" check_is_link f what = do - git_annex_expectoutput "find" ["--include=*", f] [Git.FilePath.toInternalGitPath f] + git_annex_expectoutput "find" ["--include=*", f] [fromRawFilePath (Git.FilePath.toInternalGitPath (toRawFilePath f))] l <- annexeval $ Annex.inRepo $ Git.LsTree.lsTreeFiles Git.Ref.headRef [f] all (\i -> Git.Types.toTreeItemType (Git.LsTree.mode i) == Just Git.Types.TreeSymlink) l @? (what ++ " " ++ f ++ " lost symlink bit after merge: " ++ show l) @@ -1598,7 +1598,7 @@ (c,k) <- annexeval $ do uuid <- Remote.nameToUUID "foo" rs <- Logs.Remote.readRemoteLog - Just k <- Annex.WorkTree.lookupFile annexedfile + Just k <- Annex.WorkTree.lookupFile (toRawFilePath annexedfile) return (fromJust $ M.lookup uuid rs, k) let key = if scheme `elem` ["hybrid","pubkey"] then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId] @@ -1638,7 +1638,8 @@ checkFile mvariant filename = Utility.Gpg.checkEncryptionFile gpgcmd filename $ if mvariant == Just Types.Crypto.PubKey then ks else Nothing - serializeKeys cipher = Annex.Locations.keyPaths . + serializeKeys cipher = map fromRawFilePath . + Annex.Locations.keyPaths . Crypto.encryptKey Types.Crypto.HmacSha1 cipher #else test_crypto = putStrLn "gpg testing not implemented on Windows" diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -23,6 +23,7 @@ import qualified Backend import qualified Git.CurrentRepo import qualified Git.Construct +import qualified Git.Types import qualified Types.KeySource import qualified Types.Backend import qualified Types @@ -88,8 +89,9 @@ with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion) with_ssh_origin cloner a = cloner $ do - origindir <- absPath - =<< annexeval (Config.getConfig (Config.ConfigKey config) "/dev/null") + let k = Git.Types.ConfigKey (encodeBS' config) + let v = Git.Types.ConfigValue (toRawFilePath "/dev/null") + origindir <- absPath . Git.Types.fromConfigValue =<< annexeval (Config.getConfig k v) let originurl = "localhost:" ++ origindir boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed" a @@ -254,7 +256,7 @@ checklink :: FilePath -> Assertion checklink f = ifM (annexeval Config.crippledFileSystem) - ( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget f)) + ( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget (toRawFilePath f))) @? f ++ " is not a (crippled) symlink" , do s <- getSymbolicLinkStatus f @@ -312,7 +314,7 @@ checklocationlog :: FilePath -> Bool -> Assertion checklocationlog f expected = do thisuuid <- annexeval Annex.UUID.getUUID - r <- annexeval $ Annex.WorkTree.lookupFile f + r <- annexeval $ Annex.WorkTree.lookupFile (toRawFilePath f) case r of Just k -> do uuids <- annexeval $ Remote.keyLocations k @@ -323,11 +325,11 @@ checkbackend :: FilePath -> Types.Backend -> Assertion checkbackend file expected = do b <- annexeval $ maybe (return Nothing) (Backend.getBackend file) - =<< Annex.WorkTree.lookupFile file + =<< Annex.WorkTree.lookupFile (toRawFilePath file) assertEqual ("backend for " ++ file) (Just expected) b checkispointerfile :: FilePath -> Assertion -checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile f) $ +checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile (toRawFilePath f)) $ assertFailure $ f ++ " is not a pointer file" inlocationlog :: FilePath -> Assertion diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs --- a/Types/ActionItem.hs +++ b/Types/ActionItem.hs @@ -12,15 +12,17 @@ import Key import Types.Transfer import Git.FilePath +import Utility.FileSystemEncoding import Data.Maybe +import qualified Data.ByteString as S data ActionItem = ActionItemAssociatedFile AssociatedFile Key | ActionItemKey Key | ActionItemBranchFilePath BranchFilePath Key | ActionItemFailedTransfer Transfer TransferInfo - | ActionItemWorkTreeFile FilePath + | ActionItemWorkTreeFile RawFilePath | ActionItemOther (Maybe String) -- Use to avoid more than one thread concurrently processing the -- same Key. @@ -39,10 +41,10 @@ instance MkActionItem (Key, AssociatedFile) where mkActionItem = uncurry $ flip ActionItemAssociatedFile -instance MkActionItem (Key, FilePath) where +instance MkActionItem (Key, RawFilePath) where mkActionItem (key, file) = ActionItemAssociatedFile (AssociatedFile (Just file)) key -instance MkActionItem (FilePath, Key) where +instance MkActionItem (RawFilePath, Key) where mkActionItem (file, key) = mkActionItem (key, file) instance MkActionItem Key where @@ -54,16 +56,16 @@ instance MkActionItem (Transfer, TransferInfo) where mkActionItem = uncurry ActionItemFailedTransfer -actionItemDesc :: ActionItem -> String +actionItemDesc :: ActionItem -> S.ByteString actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = f actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) = - serializeKey k -actionItemDesc (ActionItemKey k) = serializeKey k + serializeKey' k +actionItemDesc (ActionItemKey k) = serializeKey' k actionItemDesc (ActionItemBranchFilePath bfp _) = descBranchFilePath bfp actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $ ActionItemAssociatedFile (associatedFile i) (transferKey t) actionItemDesc (ActionItemWorkTreeFile f) = f -actionItemDesc (ActionItemOther s) = fromMaybe "" s +actionItemDesc (ActionItemOther s) = encodeBS' (fromMaybe "" s) actionItemDesc (OnlyActionOn _ ai) = actionItemDesc ai actionItemKey :: ActionItem -> Maybe Key @@ -75,7 +77,7 @@ actionItemKey (ActionItemOther _) = Nothing actionItemKey (OnlyActionOn _ ai) = actionItemKey ai -actionItemWorkTreeFile :: ActionItem -> Maybe FilePath +actionItemWorkTreeFile :: ActionItem -> Maybe RawFilePath actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af) _) = af actionItemWorkTreeFile (ActionItemWorkTreeFile f) = Just f actionItemWorkTreeFile (OnlyActionOn _ ai) = actionItemWorkTreeFile ai diff --git a/Types/Difference.hs b/Types/Difference.hs --- a/Types/Difference.hs +++ b/Types/Difference.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Types.Difference ( Difference(..), Differences(..), @@ -20,9 +22,11 @@ import Utility.PartialPrelude import qualified Git import qualified Git.Config +import Git.Types import Data.Maybe import Data.Monoid +import qualified Data.ByteString as B import qualified Data.Set as S import qualified Data.Semigroup as Sem import Prelude @@ -92,11 +96,11 @@ getDifferences r = mkDifferences $ S.fromList $ mapMaybe getmaybe [minBound .. maxBound] where - getmaybe d = case Git.Config.isTrue =<< Git.Config.getMaybe (differenceConfigKey d) r of + getmaybe d = case Git.Config.isTrueFalse' =<< Git.Config.getMaybe (differenceConfigKey d) r of Just True -> Just d _ -> Nothing -differenceConfigKey :: Difference -> String +differenceConfigKey :: Difference -> ConfigKey differenceConfigKey ObjectHashLower = tunable "objecthashlower" differenceConfigKey OneLevelObjectHash = tunable "objecthash1" differenceConfigKey OneLevelBranchHash = tunable "branchhash1" @@ -104,8 +108,8 @@ differenceConfigVal :: Difference -> String differenceConfigVal _ = Git.Config.boolConfig True -tunable :: String -> String -tunable k = "annex.tune." ++ k +tunable :: B.ByteString -> ConfigKey +tunable k = ConfigKey ("annex.tune." <> k) hasDifference :: Difference -> Differences -> Bool hasDifference _ UnknownDifferences = False diff --git a/Types/Distribution.hs b/Types/Distribution.hs --- a/Types/Distribution.hs +++ b/Types/Distribution.hs @@ -12,7 +12,7 @@ import Types.Key import Key import Data.Time.Clock -import Git.Config (isTrue, boolConfig) +import Git.Config (isTrueFalse, boolConfig) import Control.Applicative import Prelude @@ -71,7 +71,7 @@ toAutoUpgrade Nothing = AskUpgrade toAutoUpgrade (Just s) | s == "ask" = AskUpgrade - | isTrue s == Just True = AutoUpgrade + | isTrueFalse s == Just True = AutoUpgrade | otherwise = NoAutoUpgrade fromAutoUpgrade :: AutoUpgrade -> String diff --git a/Types/Export.hs b/Types/Export.hs --- a/Types/Export.hs +++ b/Types/Export.hs @@ -17,38 +17,39 @@ import Git.FilePath import Utility.Split +import Utility.FileSystemEncoding import qualified System.FilePath.Posix as Posix -- A location on a remote that a key can be exported to. --- The FilePath will be relative to the top of the remote, +-- The RawFilePath will be relative to the top of the remote, -- and uses unix-style path separators. -newtype ExportLocation = ExportLocation FilePath +newtype ExportLocation = ExportLocation RawFilePath deriving (Show, Eq) -mkExportLocation :: FilePath -> ExportLocation +mkExportLocation :: RawFilePath -> ExportLocation mkExportLocation = ExportLocation . toInternalGitPath -fromExportLocation :: ExportLocation -> FilePath +fromExportLocation :: ExportLocation -> RawFilePath fromExportLocation (ExportLocation f) = f -newtype ExportDirectory = ExportDirectory FilePath +newtype ExportDirectory = ExportDirectory RawFilePath deriving (Show, Eq) -mkExportDirectory :: FilePath -> ExportDirectory +mkExportDirectory :: RawFilePath -> ExportDirectory mkExportDirectory = ExportDirectory . toInternalGitPath -fromExportDirectory :: ExportDirectory -> FilePath +fromExportDirectory :: ExportDirectory -> RawFilePath fromExportDirectory (ExportDirectory f) = f -- | All subdirectories down to the ExportLocation, with the deepest ones -- last. Does not include the top of the export. exportDirectories :: ExportLocation -> [ExportDirectory] exportDirectories (ExportLocation f) = - map (ExportDirectory . Posix.joinPath . reverse) (subs [] dirs) + map (ExportDirectory . encodeBS . Posix.joinPath . reverse) (subs [] dirs) where subs _ [] = [] subs ps (d:ds) = (d:ps) : subs (d:ps) ds dirs = map Posix.dropTrailingPathSeparator $ - dropFromEnd 1 $ Posix.splitPath f + dropFromEnd 1 $ Posix.splitPath $ decodeBS f diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -12,6 +12,7 @@ import Types.Mime import Utility.Matcher (Matcher, Token) import Utility.FileSize +import Utility.FileSystemEncoding import Control.Monad.IO.Class import qualified Data.Map as M @@ -24,9 +25,9 @@ | MatchingInfo ProvidedInfo data FileInfo = FileInfo - { currFile :: FilePath + { currFile :: RawFilePath -- ^ current path to the file, for operations that examine it - , matchFile :: FilePath + , matchFile :: RawFilePath -- ^ filepath to match on; may be relative to top of repo or cwd } diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -5,8 +5,11 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Types.GitConfig ( Configurable(..), + ConfigSource(..), GitConfig(..), extractGitConfig, mergeGitConfig, @@ -44,13 +47,17 @@ -- | A configurable value, that may not be fully determined yet because -- the global git config has not yet been loaded. data Configurable a - = HasConfig a - -- ^ Value is fully determined. + = HasGitConfig a + -- ^ The git config has a value. + | HasGlobalConfig a + -- ^ The global config has a value (and the git config does not). | DefaultConfig a -- ^ A default value is known, but not all config sources -- have been read yet. deriving (Show) +data ConfigSource = FromGitConfig | FromGlobalConfig + {- Main git-annex settings. Each setting corresponds to a git-config key - such as annex.foo -} data GitConfig = GitConfig @@ -78,7 +85,7 @@ , annexYoutubeDlOptions :: [String] , annexAriaTorrentOptions :: [String] , annexCrippledFileSystem :: Bool - , annexLargeFiles :: Maybe String + , annexLargeFiles :: Configurable (Maybe String) , annexGitAddToAnnex :: Bool , annexAddSmallFiles :: Bool , annexFsckNudge :: Bool @@ -95,7 +102,7 @@ , annexVerify :: Bool , annexPidLock :: Bool , annexPidLockTimeout :: Seconds - , annexAddUnlocked :: Bool + , annexAddUnlocked :: Configurable (Maybe String) , annexSecureHashesOnly :: Bool , annexRetry :: Maybe Integer , annexRetryDelay :: Maybe Seconds @@ -114,8 +121,8 @@ , gpgCmd :: GpgCmd } -extractGitConfig :: Git.Repo -> GitConfig -extractGitConfig r = GitConfig +extractGitConfig :: ConfigSource -> Git.Repo -> GitConfig +extractGitConfig configsource r = GitConfig { annexVersion = RepoVersion <$> getmayberead (annex "version") , annexUUID = maybe NoUUID toUUID $ getmaybe (annex "uuid") , annexNumCopies = NumCopies <$> getmayberead (annex "numcopies") @@ -149,7 +156,8 @@ , annexYoutubeDlOptions = getwords (annex "youtube-dl-options") , annexAriaTorrentOptions = getwords (annex "aria-torrent-options") , annexCrippledFileSystem = getbool (annex "crippledfilesystem") False - , annexLargeFiles = getmaybe (annex "largefiles") + , annexLargeFiles = configurable Nothing $ + fmap Just $ getmaybe (annex "largefiles") , annexGitAddToAnnex = getbool (annex "gitaddtoannex") True , annexAddSmallFiles = getbool (annex "addsmallfiles") True , annexFsckNudge = getbool (annex "fscknudge") True @@ -169,7 +177,8 @@ , annexPidLock = getbool (annex "pidlock") False , annexPidLockTimeout = Seconds $ fromMaybe 300 $ getmayberead (annex "pidlocktimeout") - , annexAddUnlocked = getbool (annex "addunlocked") False + , annexAddUnlocked = configurable Nothing $ + fmap Just $ getmaybe (annex "addunlocked") , annexSecureHashesOnly = getbool (annex "securehashesonly") False , annexRetry = getmayberead (annex "retry") , annexRetryDelay = Seconds @@ -199,16 +208,19 @@ } where getbool k d = fromMaybe d $ getmaybebool k - getmaybebool k = Git.Config.isTrue =<< getmaybe k + getmaybebool k = Git.Config.isTrueFalse' =<< getmaybe' k getmayberead k = readish =<< getmaybe k - getmaybe k = Git.Config.getMaybe k r - getlist k = Git.Config.getList k r + getmaybe = fmap fromConfigValue . getmaybe' + getmaybe' k = Git.Config.getMaybe k r + getlist k = map fromConfigValue $ Git.Config.getList k r getwords k = fromMaybe [] $ words <$> getmaybe k configurable d Nothing = DefaultConfig d - configurable _ (Just v) = HasConfig v + configurable _ (Just v) = case configsource of + FromGitConfig -> HasGitConfig v + FromGlobalConfig -> HasGlobalConfig v - annex k = "annex." ++ k + annex k = ConfigKey $ "annex." <> k onemegabyte = 1000000 @@ -218,13 +230,17 @@ mergeGitConfig gitconfig repoglobals = gitconfig { annexAutoCommit = merge annexAutoCommit , annexSyncContent = merge annexSyncContent + , annexResolveMerge = merge annexResolveMerge + , annexLargeFiles = merge annexLargeFiles + , annexAddUnlocked = merge annexAddUnlocked } where merge f = case f gitconfig of - HasConfig v -> HasConfig v + HasGitConfig v -> HasGitConfig v DefaultConfig d -> case f repoglobals of - HasConfig v -> HasConfig v - DefaultConfig _ -> HasConfig d + HasGlobalConfig v -> HasGlobalConfig v + _ -> HasGitConfig d + HasGlobalConfig v -> HasGlobalConfig v {- Per-remote git-annex settings. Each setting corresponds to a git-config - key such as .annex-foo, or if that is not set, a default from @@ -340,14 +356,16 @@ } where getbool k d = fromMaybe d $ getmaybebool k - getmaybebool k = Git.Config.isTrue =<< getmaybe k + getmaybebool k = Git.Config.isTrueFalse' =<< getmaybe' k getmayberead k = readish =<< getmaybe k - getmaybe k = mplus (Git.Config.getMaybe (key k) r) + getmaybe = fmap fromConfigValue . getmaybe' + getmaybe' k = mplus (Git.Config.getMaybe (key k) r) (Git.Config.getMaybe (remotekey k) r) getoptions k = fromMaybe [] $ words <$> getmaybe k - key k = "annex." ++ k - remotekey k = "remote." ++ remotename ++ ".annex-" ++ k + key k = ConfigKey $ "annex." <> k + remotekey k = ConfigKey $ + "remote." <> encodeBS' remotename <> ".annex-" <> k notempty :: Maybe String -> Maybe String notempty Nothing = Nothing diff --git a/Types/Import.hs b/Types/Import.hs --- a/Types/Import.hs +++ b/Types/Import.hs @@ -19,10 +19,10 @@ - location on the remote. -} type ImportLocation = ExportLocation -mkImportLocation :: FilePath -> ImportLocation +mkImportLocation :: RawFilePath -> ImportLocation mkImportLocation = mkExportLocation -fromImportLocation :: ImportLocation -> FilePath +fromImportLocation :: ImportLocation -> RawFilePath fromImportLocation = fromExportLocation {- An identifier for content stored on a remote that has been imported into diff --git a/Types/Key.hs b/Types/Key.hs --- a/Types/Key.hs +++ b/Types/Key.hs @@ -36,6 +36,7 @@ import Data.ByteString.Builder.Extra import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString.Char8 as A8 +import Utility.FileSystemEncoding import Data.List import System.Posix.Types import Foreign.C.Types @@ -200,7 +201,7 @@ splitKeyNameExtension' keyname = S8.span (/= '.') keyname {- A filename may be associated with a Key. -} -newtype AssociatedFile = AssociatedFile (Maybe FilePath) +newtype AssociatedFile = AssociatedFile (Maybe RawFilePath) deriving (Show, Eq, Ord) {- There are several different varieties of keys. -} diff --git a/Types/Transfer.hs b/Types/Transfer.hs --- a/Types/Transfer.hs +++ b/Types/Transfer.hs @@ -15,6 +15,7 @@ import Utility.PID import Utility.QuickCheck import Utility.Url +import Utility.FileSystemEncoding import Data.Time.Clock.POSIX import Control.Concurrent @@ -71,9 +72,8 @@ <*> pure Nothing -- cannot generate a ThreadID <*> pure Nothing -- remote not needed <*> arbitrary - -- associated file cannot be empty (but can be Nothing) - <*> (AssociatedFile <$> arbitrary `suchThat` (/= Just "")) <*> arbitrary + <*> arbitrary class Observable a where observeBool :: a -> Bool @@ -101,7 +101,7 @@ descTransfrerrable :: t -> Maybe String instance Transferrable AssociatedFile where - descTransfrerrable (AssociatedFile af) = af + descTransfrerrable (AssociatedFile af) = fromRawFilePath <$> af instance Transferrable URLString where descTransfrerrable = Just diff --git a/Types/UUID.hs b/Types/UUID.hs --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -17,6 +17,7 @@ import Data.ByteString.Builder import qualified Data.Semigroup as Sem +import Git.Types (ConfigValue(..)) import Utility.FileSystemEncoding import Utility.QuickCheck import qualified Utility.SimpleProtocol as Proto @@ -51,6 +52,12 @@ instance ToUUID String where toUUID s = toUUID (encodeBS' s) + +instance FromUUID ConfigValue where + fromUUID s = (ConfigValue (fromUUID s)) + +instance ToUUID ConfigValue where + toUUID (ConfigValue v) = toUUID v -- There is no matching FromUUID U.UUID because a git-annex UUID may -- be NoUUID or perhaps contain something not allowed in a canonical UUID. diff --git a/Upgrade.hs b/Upgrade.hs --- a/Upgrade.hs +++ b/Upgrade.hs @@ -48,7 +48,7 @@ where err msg = do g <- Annex.gitRepo - p <- liftIO $ absPath $ Git.repoPath g + p <- liftIO $ absPath $ fromRawFilePath $ Git.repoPath g return $ Just $ unwords [ "Repository", p , "is at unsupported version" @@ -85,4 +85,3 @@ up (RepoVersion 5) = Upgrade.V5.upgrade automatic up (RepoVersion 6) = Upgrade.V6.upgrade automatic up _ = return True - diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -16,7 +16,7 @@ showAction "v0 to v1" -- do the reorganisation of the key files - olddir <- fromRepo gitAnnexDir + olddir <- fromRawFilePath <$> fromRepo gitAnnexDir keys <- getKeysPresent0 olddir forM_ keys $ \k -> moveAnnex k $ olddir keyFile0 k diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -85,7 +85,7 @@ showAction "updating symlinks" top <- fromRepo Git.repoPath (files, cleanup) <- inRepo $ LsFiles.inRepo [top] - forM_ files fixlink + forM_ files (fixlink . fromRawFilePath) void $ liftIO cleanup where fixlink f = do @@ -236,12 +236,13 @@ logFile2 :: Key -> Git.Repo -> String logFile2 = logFile' (hashDirLower def) -logFile' :: (Key -> FilePath) -> Key -> Git.Repo -> String +logFile' :: (Key -> RawFilePath) -> Key -> Git.Repo -> String logFile' hasher key repo = - gitStateDir repo ++ hasher key ++ keyFile key ++ ".log" + gitStateDir repo ++ fromRawFilePath (hasher key) ++ fromRawFilePath (keyFile key) ++ ".log" stateDir :: FilePath stateDir = addTrailingPathSeparator ".git-annex" gitStateDir :: Git.Repo -> FilePath -gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo stateDir +gitStateDir repo = addTrailingPathSeparator $ + fromRawFilePath (Git.repoPath repo) stateDir diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -50,7 +50,7 @@ e <- liftIO $ doesDirectoryExist old when e $ do config <- Annex.getGitConfig - mapM_ (\(k, f) -> inject f $ locationLogFile config k) =<< locationLogs + mapM_ (\(k, f) -> inject f $ fromRawFilePath $ locationLogFile config k) =<< locationLogs mapM_ (\f -> inject f f) =<< logFiles old saveState False @@ -76,13 +76,13 @@ where tryDirContents d = catchDefaultIO [] $ dirContents d islogfile f = maybe Nothing (\k -> Just (k, f)) $ - locationLogFileKey f + locationLogFileKey (toRawFilePath f) inject :: FilePath -> FilePath -> Annex () inject source dest = do old <- fromRepo olddir new <- liftIO (readFile $ old source) - Annex.Branch.change dest $ \prev -> + Annex.Branch.change (toRawFilePath dest) $ \prev -> encodeBL $ unlines $ nub $ lines (decodeBL prev) ++ lines new logFiles :: FilePath -> Annex [FilePath] @@ -139,5 +139,7 @@ stateDir :: FilePath stateDir = addTrailingPathSeparator ".git-annex" + gitStateDir :: Git.Repo -> FilePath -gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo stateDir +gitStateDir repo = addTrailingPathSeparator $ + fromRawFilePath (Git.repoPath repo) stateDir diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Upgrade.V5 where import Annex.Common @@ -119,8 +121,8 @@ Just k -> do stagePointerFile f Nothing =<< hashPointerFile k ifM (isJust <$> getAnnexLinkTarget f) - ( writepointer f k - , fromdirect f k + ( writepointer (fromRawFilePath f) k + , fromdirect (fromRawFilePath f) k ) Database.Keys.addAssociatedFile k =<< inRepo (toTopFilePath f) @@ -133,7 +135,7 @@ -- is just not populated with it. Since the work tree -- file is recorded as an associated file, things will -- still work that way, it's just not ideal. - ic <- withTSDelta (liftIO . genInodeCache f) + ic <- withTSDelta (liftIO . genInodeCache (toRawFilePath f)) void $ Content.linkToAnnex k f ic , unlessM (Content.inAnnex k) $ do -- Worktree file was deleted or modified; diff --git a/Upgrade/V5/Direct.hs b/Upgrade/V5/Direct.hs --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -7,6 +7,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Upgrade.V5.Direct ( switchHEADBack, setIndirect, @@ -44,12 +46,12 @@ -- unset it when enabling direct mode, caching in -- core.indirect-worktree moveconfig indirectworktree coreworktree - setConfig (ConfigKey Git.Config.coreBare) val + setConfig Git.Config.coreBare val moveconfig src dest = getConfigMaybe src >>= \case Nothing -> noop Just wt -> do unsetConfig src - setConfig dest wt + setConfig dest (fromConfigValue wt) reloadConfig {- Converts a directBranch back to the original branch. @@ -79,7 +81,7 @@ associatedFiles :: Key -> Annex [FilePath] associatedFiles key = do files <- associatedFilesRelative key - top <- fromRepo Git.repoPath + top <- fromRawFilePath <$> fromRepo Git.repoPath return $ map (top ) files {- List of files in the tree that are associated with a key, relative to @@ -105,7 +107,9 @@ - expected mtime and inode. -} goodContent :: Key -> FilePath -> Annex Bool -goodContent key file = sameInodeCache file =<< recordedInodeCache key +goodContent key file = + sameInodeCache (toRawFilePath file) + =<< recordedInodeCache key {- Gets the recorded inode cache for a key. - diff --git a/Utility/Attoparsec.hs b/Utility/Attoparsec.hs new file mode 100644 --- /dev/null +++ b/Utility/Attoparsec.hs @@ -0,0 +1,21 @@ +{- attoparsec utility functions + - + - Copyright 2019 Joey Hess + - Copyright 2007-2015 Bryan O'Sullivan + - + - License: BSD-3-clause + -} + +module Utility.Attoparsec where + +import qualified Data.Attoparsec.ByteString as A +import qualified Data.ByteString as B + +-- | Parse and decode an unsigned octal number. +-- +-- This parser does not accept a leading @\"0o\"@ string. +octal :: Integral a => A.Parser a +octal = B.foldl' step 0 `fmap` A.takeWhile1 isOctDigit + where + isOctDigit w = w >= 48 && w <= 55 + step a w = a * 8 + fromIntegral (w - 48) diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -33,7 +33,10 @@ getFileSize f = bracket (openFile f ReadMode) hClose hFileSize #endif -{- Gets the size of the file, when its FileStatus is already known. -} +{- Gets the size of the file, when its FileStatus is already known. + - + - On windows, uses getFileSize. Otherwise, the FileStatus contains the + - size, so this does not do any work. -} getFileSize' :: FilePath -> FileStatus -> IO FileSize #ifndef mingw32_HOST_OS getFileSize' _ s = return $ fromIntegral $ fileSize s diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -23,10 +23,6 @@ encodeBL', decodeBS', encodeBS', - decodeW8, - encodeW8, - encodeW8NUL, - decodeW8NUL, truncateFilePath, s2w8, w82s, @@ -148,16 +144,32 @@ {- Faster version that assumes the string does not contain NUL; - if it does it will be truncated before the NUL. -} decodeBS' :: S.ByteString -> FilePath +#ifndef mingw32_HOST_OS decodeBS' = encodeW8 . S.unpack +#else +decodeBS' = S8.toString +#endif encodeBS' :: FilePath -> S.ByteString +#ifndef mingw32_HOST_OS encodeBS' = S.pack . decodeW8 +#else +encodeBS' = S8.fromString +#endif decodeBL' :: L.ByteString -> FilePath +#ifndef mingw32_HOST_OS decodeBL' = encodeW8 . L.unpack +#else +decodeBL' = L8.toString +#endif encodeBL' :: FilePath -> L.ByteString +#ifndef mingw32_HOST_OS encodeBL' = L.pack . decodeW8 +#else +encodeBL' = L8.fromString +#endif {- Recent versions of the unix package have this alias; defined here - for backwards compatibility. -} diff --git a/Utility/Format.hs b/Utility/Format.hs --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -15,7 +15,7 @@ ) where import Text.Printf (printf) -import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord) +import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord, isAscii) import Data.Maybe (fromMaybe) import Data.Word (Word8) import Data.List (isPrefixOf) @@ -176,12 +176,12 @@ {- For quickcheck. - - Encoding and then decoding roundtrips only when - - the string does not contain high unicode, because eg, - - both "\12345" and "\227\128\185" are encoded to "\343\200\271". + - the string is ascii because eg, both "\12345" and + - "\227\128\185" are encoded to "\343\200\271". - - - This property papers over the problem, by only testing chars < 256. + - This property papers over the problem, by only testing ascii. -} prop_encode_c_decode_c_roundtrip :: String -> Bool prop_encode_c_decode_c_roundtrip s = s' == decode_c (encode_c s') where - s' = filter (\c -> ord c < 256) s + s' = filter isAscii s diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -43,6 +43,7 @@ import Common import Utility.TimeStamp import Utility.QuickCheck +import qualified Utility.RawFilePath as R import System.PosixCompat.Types import Data.Time.Clock.POSIX @@ -180,9 +181,9 @@ return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t) _ -> Nothing -genInodeCache :: FilePath -> TSDelta -> IO (Maybe InodeCache) +genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache) genInodeCache f delta = catchDefaultIO Nothing $ - toInodeCache delta f =<< getFileStatus f + toInodeCache delta (fromRawFilePath f) =<< R.getFileStatus f toInodeCache :: TSDelta -> FilePath -> FileStatus -> IO (Maybe InodeCache) toInodeCache (TSDelta getdelta) f s @@ -202,8 +203,8 @@ - Its InodeCache at the time of its creation is written to the cache file, - so changes can later be detected. -} data SentinalFile = SentinalFile - { sentinalFile :: FilePath - , sentinalCacheFile :: FilePath + { sentinalFile :: RawFilePath + , sentinalCacheFile :: RawFilePath } deriving (Show) @@ -220,8 +221,8 @@ writeSentinalFile :: SentinalFile -> IO () writeSentinalFile s = do - writeFile (sentinalFile s) "" - maybe noop (writeFile (sentinalCacheFile s) . showInodeCache) + writeFile (fromRawFilePath (sentinalFile s)) "" + maybe noop (writeFile (fromRawFilePath (sentinalCacheFile s)) . showInodeCache) =<< genInodeCache (sentinalFile s) noTSDelta data SentinalStatus = SentinalStatus @@ -250,7 +251,7 @@ Just new -> return $ calc old new where loadoldcache = catchDefaultIO Nothing $ - readInodeCache <$> readFile (sentinalCacheFile s) + readInodeCache <$> readFile (fromRawFilePath (sentinalCacheFile s)) gennewcache = genInodeCache (sentinalFile s) noTSDelta calc (InodeCache (InodeCachePrim oldinode oldsize oldmtime)) (InodeCache (InodeCachePrim newinode newsize newmtime)) = SentinalStatus (not unchanged) tsdelta @@ -275,7 +276,7 @@ dummy = SentinalStatus True noTSDelta sentinalFileExists :: SentinalFile -> IO Bool -sentinalFileExists s = allM doesFileExist [sentinalCacheFile s, sentinalFile s] +sentinalFileExists s = allM R.doesPathExist [sentinalCacheFile s, sentinalFile s] instance Arbitrary InodeCache where arbitrary = diff --git a/Utility/MD5.hs b/Utility/MD5.hs --- a/Utility/MD5.hs +++ b/Utility/MD5.hs @@ -8,13 +8,14 @@ import Data.Bits import Data.Word +import Data.Char -display_32bits_as_dir :: Word32 -> String +display_32bits_as_dir :: Word32 -> [Word8] display_32bits_as_dir w = trim $ swap_pairs cs where -- Need 32 characters to use. To avoid inaverdently making -- a real word, use letters that appear less frequently. - chars = ['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF" + chars = map (fromIntegral . ord) (['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF") cs = map (\x -> getc $ (shiftR w (6*x)) .&. 31) [0..7] getc n = chars !! fromIntegral n swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs diff --git a/Utility/Metered.hs b/Utility/Metered.hs --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -258,7 +258,7 @@ unless (quietMode oh) $ do S.hPut stdout b hFlush stdout - let s = encodeW8 (S.unpack b) + let s = decodeBS b let (mbytes, buf') = progressparser (buf++s) case mbytes of Nothing -> feedprogress prev buf' h diff --git a/Utility/Misc.hs b/Utility/Misc.hs --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -12,6 +12,7 @@ readFileStrict, separate, firstLine, + firstLine', segment, segmentDelim, massReplace, @@ -28,6 +29,7 @@ import Data.List import System.Exit import Control.Applicative +import qualified Data.ByteString as S import Prelude {- A version of hgetContents that is not lazy. Ensures file is @@ -55,6 +57,11 @@ {- Breaks out the first line. -} firstLine :: String -> String firstLine = takeWhile (/= '\n') + +firstLine' :: S.ByteString -> S.ByteString +firstLine' = S.takeWhile (/= nl) + where + nl = fromIntegral (ord '\n') {- Splits a list into segments that are delimited by items matching - a predicate. (The delimiters are not included in the segments.) diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -43,6 +43,7 @@ import Utility.UserInfo import Utility.Directory import Utility.Split +import Utility.FileSystemEncoding {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. @@ -112,7 +113,10 @@ - are all equivilant. -} dirContains :: FilePath -> FilePath -> Bool -dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b' +dirContains a b = a == b + || a' == b' + || (addTrailingPathSeparator a') `isPrefixOf` b' + || a' == "." && normalise ("." b') == b' where a' = norm a b' = norm b @@ -200,20 +204,21 @@ - we stop preserving ordering at that point. Presumably a user passing - that many paths in doesn't care too much about order of the later ones. -} -segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]] +segmentPaths :: [RawFilePath] -> [RawFilePath] -> [[RawFilePath]] segmentPaths [] new = [new] segmentPaths [_] new = [new] -- optimisation segmentPaths (l:ls) new = found : segmentPaths ls rest where (found, rest) = if length ls < 100 - then partition (l `dirContains`) new - else break (\p -> not (l `dirContains` p)) new + then partition inl new + else break (not . inl) new + inl f = fromRawFilePath l `dirContains` fromRawFilePath f {- This assumes that it's cheaper to call segmentPaths on the result, - than it would be to run the action separately with each path. In - the case of git file list commands, that assumption tends to hold. -} -runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]] +runSegmentPaths :: ([RawFilePath] -> IO [RawFilePath]) -> [RawFilePath] -> IO [[RawFilePath]] runSegmentPaths a paths = segmentPaths paths <$> a paths {- Converts paths in the home directory to use ~/ -} diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -1,5 +1,12 @@ {- Portability shim around System.Posix.Files.ByteString - + - On unix, this makes syscalls using RawFilesPaths as efficiently as + - possible. + - + - On Windows, filenames are in unicode, so RawFilePaths have to be + - decoded. So this library will work, but less efficiently than using + - FilePath would. + - - Copyright 2019 Joey Hess - - License: BSD-2-clause @@ -10,19 +17,33 @@ module Utility.RawFilePath ( RawFilePath, readSymbolicLink, + getFileStatus, + getSymbolicLinkStatus, + doesPathExist, ) where #ifndef mingw32_HOST_OS +import Utility.FileSystemEncoding (RawFilePath) import System.Posix.Files.ByteString -import System.Posix.ByteString.FilePath + +doesPathExist :: RawFilePath -> IO Bool +doesPathExist = fileExist + #else import qualified Data.ByteString as B -import System.IO.Error - -type RawFilePath = B.ByteString +import qualified System.PosixCompat as P +import qualified System.Directory as D +import Utility.FileSystemEncoding readSymbolicLink :: RawFilePath -> IO RawFilePath -readSymbolicLink _ = ioError $ mkIOError illegalOperationErrorType x Nothing Nothing - where - x = "Utility.RawFilePath.readSymbolicLink: not supported" +readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f) + +getFileStatus :: RawFilePath -> IO FileStatus +getFileStatus = P.getFileStatus . fromRawFilePath + +getSymbolicLinkStatus :: RawFilePath -> IO FileStatus +getSymbolicLinkStatus = P.getSymbolicLinkStatus . fromRawFilePath + +doesPathExist :: RawFilePath -> IO Bool +doesPathExist = D.doesPathExist . fromRawFilePath #endif diff --git a/Utility/Split.hs b/Utility/Split.hs --- a/Utility/Split.hs +++ b/Utility/Split.hs @@ -34,6 +34,6 @@ replace :: Eq a => [a] -> [a] -> [a] -> [a] replace old new = intercalate new . split old --- | Only traverses the list once while dropping the last n characters. +-- | Only traverses the list once while dropping the last n items. dropFromEnd :: Int -> [a] -> [a] dropFromEnd n l = zipWith const l (drop n l) diff --git a/doc/git-annex-matchexpression.mdwn b/doc/git-annex-matchexpression.mdwn --- a/doc/git-annex-matchexpression.mdwn +++ b/doc/git-annex-matchexpression.mdwn @@ -59,6 +59,8 @@ [[git-annex-preferred-content]](1) +[[git-annex-matching-expression]](1) + # AUTHOR Joey Hess diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -891,9 +891,13 @@ Used to configure which files are large enough to be added to the annex. It is an expression that matches the large files, eg - "*.mp3 or largerthan(500kb)" + "include=*.mp3 or largerthan(500kb)" + See [[git-annex-matching-expression]](1) for details on the syntax. Overrides any annex.largefiles attributes in `.gitattributes` files. + + To configure a default annex.largefiles for all clones of the repository, + this can be set in [[git-annex-config]](1). This configures the behavior of both git-annex and git when adding files to the repository. By default, `git-annex add` adds all files @@ -906,13 +910,10 @@ `git annex import`, `git annex addurl`, `git annex importfeed` and the assistant. - See for syntax - documentation and more. - * `annex.gitaddtoannex` - Setting this to false will prevent `git add` from honoring the - annex.largefiles configuration. + Setting this to false will prevent `git add` from adding + files to the annex, despite the annex.largefiles configuration. * `annex.addsmallfiles` @@ -922,15 +923,23 @@ * `annex.addunlocked` - Set to true to make commands like `git-annex add` that add files to the - repository add them in unlocked form. The default is for these commands - to add files in locked form. + Commands like `git-annex add` default to adding files to the repository + in locked form. This can make them add the files in unlocked form, + the same as if [[git-annex-unlock]](1) were run on the files. + + This can be set to "true" to add everything unlocked, or it can be a more + complicated expression that matches files by name, size, or content. See + [[git-annex-matching-expression]](1) for details. + To configure a default annex.addunlocked for all clones of the repository, + this can be set in [[git-annex-config]](1). + (Using `git add` always adds files in unlocked form and it is not affected by this setting.) - - When a repository has core.symlinks set to false, it implicitly - sets annex.addunlocked to true. + + When a repository has core.symlinks set to false, or has an adjusted + unlocked branch checked out, this setting is ignored, and files are + always added to the repository in unlocked form. * `annex.numcopies` @@ -1695,9 +1704,11 @@ *.ogg annex.backend=SHA256E There is a annex.largefiles attribute, which is used to configure which -files are large enough to be added to the annex. -See the documentation above of the annex.largefiles git config -and for details. +files are large enough to be added to the annex. Since attributes cannot +contain spaces, it is difficult to use for more complex annex.largefiles +settings. Setting annex.largefiles in [[git-annex-config]](1) is an easier +way to configure it across all clones of the repository. +See [[git-annex-matching-expression]](1) for details on the syntax. The numcopies setting can also be configured on a per-file-type basis via the `annex.numcopies` attribute in `.gitattributes` files. This overrides diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 7.20191218 +Version: 7.20191230 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess @@ -296,6 +296,7 @@ custom-setup Setup-Depends: base (>= 4.11.1.0), hslogger, split, unix-compat, process, filepath, exceptions, bytestring, directory, IfElse, data-default, + filepath-bytestring (>= 1.4.2.1.0), utf8-string, transformers, Cabal Executable git-annex @@ -320,6 +321,7 @@ directory (>= 1.2), disk-free-space, filepath, + filepath-bytestring (>= 1.4.2.1.0), IfElse, hslogger, monad-logger, @@ -1020,6 +1022,7 @@ Utility.Aeson Utility.Android Utility.Applicative + Utility.Attoparsec Utility.AuthToken Utility.Base64 Utility.Batch diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -24,6 +24,7 @@ - sandi-0.5 - http-client-0.5.14 - silently-1.2.5.1 +- filepath-bytestring-1.4.2.1.1 explicit-setup-deps: git-annex: true resolver: lts-13.29