diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -74,6 +74,7 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM +import qualified Control.Monad.Fail as Fail import qualified Control.Concurrent.SSem as SSem import qualified Data.Map.Strict as M import qualified Data.Set as S @@ -93,6 +94,7 @@ MonadCatch, MonadThrow, MonadMask, + Fail.MonadFail, Functor, Applicative ) @@ -122,7 +124,7 @@ , globalnumcopies :: Maybe NumCopies , forcenumcopies :: Maybe NumCopies , limit :: ExpandableMatcher Annex - , uuidmap :: Maybe UUIDMap + , uuiddescmap :: Maybe UUIDDescMap , preferredcontentmap :: Maybe (FileMatcherMap Annex) , requiredcontentmap :: Maybe (FileMatcherMap Annex) , forcetrust :: TrustMap @@ -181,7 +183,7 @@ , globalnumcopies = Nothing , forcenumcopies = Nothing , limit = BuildingMatcher [] - , uuidmap = Nothing + , uuiddescmap = Nothing , preferredcontentmap = Nothing , requiredcontentmap = Nothing , forcetrust = M.empty diff --git a/Annex/Action.hs b/Annex/Action.hs --- a/Annex/Action.hs +++ b/Annex/Action.hs @@ -11,7 +11,6 @@ import qualified Data.Map as M #ifndef mingw32_HOST_OS -import System.Posix.Signals import System.Posix.Process (getAnyProcessStatus) import Utility.Exception #endif @@ -26,12 +25,7 @@ {- Actions to perform each time ran. -} startup :: Annex () -startup = -#ifndef mingw32_HOST_OS - liftIO $ void $ installHandler sigINT Default Nothing -#else - return () -#endif +startup = return () {- Cleanup actions. -} shutdown :: Bool -> Annex () diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -55,7 +55,7 @@ import Annex.Link import Annex.AutoMerge import Annex.Content -import Annex.Perms +import Annex.Tmp import Annex.GitOverlay import Utility.Tmp.Dir import Utility.CopyFile @@ -356,12 +356,10 @@ - (Doing the merge this way also lets it run even though the main - index file is currently locked.) -} - changestomerge (Just updatedorig) = do - misctmpdir <- fromRepo gitAnnexTmpMiscDir - void $ createAnnexDirectory misctmpdir + changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do tmpwt <- fromRepo gitAnnexMergeDir git_dir <- fromRepo Git.localGitDir - withTmpDirIn misctmpdir "git" $ \tmpgit -> withWorkTreeRelated tmpgit $ + withTmpDirIn othertmpdir "git" $ \tmpgit -> withWorkTreeRelated tmpgit $ withemptydir tmpwt $ withWorkTree tmpwt $ do liftIO $ writeFile (tmpgit "HEAD") (fromRef updatedorig) -- Copy in refs and packed-refs, to work diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -34,12 +34,14 @@ import qualified Data.Map as M import Data.Function import Data.Char +import Data.ByteString.Builder import Control.Concurrent (threadDelay) import Annex.Common import Annex.BranchState import Annex.Journal import Annex.GitOverlay +import Annex.Tmp import qualified Git import qualified Git.Command import qualified Git.Ref @@ -65,7 +67,6 @@ import Annex.Branch.Transitions import qualified Annex import Annex.Hook -import Utility.FileSystemEncoding import Utility.Directory.Stream {- Name of the branch that is used to store git-annex's information. -} @@ -210,7 +211,7 @@ - content is returned. - - Returns an empty string if the file doesn't exist yet. -} -get :: FilePath -> Annex String +get :: FilePath -> Annex L.ByteString get file = do update getLocal file @@ -219,21 +220,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 String +getLocal :: FilePath -> 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 String +getStaged :: FilePath -> 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 String +getHistorical :: RefDate -> FilePath -> Annex L.ByteString getHistorical date file = -- This check avoids some ugly error messages when the reflog -- is empty. @@ -242,27 +243,29 @@ , getRef (Git.Ref.dateRef fullname date) file ) -getRef :: Ref -> FilePath -> Annex String -getRef ref file = withIndex $ decodeBS <$> catFile ref file +getRef :: Ref -> FilePath -> Annex L.ByteString +getRef ref file = withIndex $ catFile ref file {- Applies a function to modify the content of a file. - - Note that this does not cause the branch to be merged, it only - modifes the current content of the file on the branch. -} -change :: FilePath -> (String -> String) -> Annex () +change :: Journalable content => FilePath -> (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 :: FilePath -> (String -> Maybe String) -> Annex () +maybeChange :: Journalable content => FilePath -> (L.ByteString -> Maybe content) -> Annex () maybeChange file f = lockJournal $ \jl -> do v <- getLocal file case f v of - Just v' | v' /= v -> set jl file v' + Just jv -> + let b = journalableByteString jv + in when (v /= b) $ set jl file b _ -> noop {- Records new content of a file into the journal -} -set :: JournalLocked -> FilePath -> String -> Annex () +set :: Journalable content => JournalLocked -> FilePath -> content -> Annex () set = setJournalFile {- Commit message used when making a commit of whatever data has changed @@ -320,7 +323,7 @@ where -- look for "parent ref" lines and return the refs commitparents = map (Git.Ref . snd) . filter isparent . - map (toassoc . decodeBS) . L.split newline + map (toassoc . decodeBL) . L.split newline newline = fromIntegral (ord '\n') toassoc = separate (== ' ') isparent (k,_) = k == "parent" @@ -486,9 +489,7 @@ mapM_ (removeFile . (dir )) stagedfs hClose jlogh nukeFile jlogf - openjlog = do - tmpdir <- fromRepo gitAnnexTmpMiscDir - createAnnexDirectory tmpdir + openjlog = withOtherTmp $ \tmpdir -> liftIO $ openTempFile tmpdir "jlog" {- This is run after the refs have been merged into the index, @@ -522,7 +523,7 @@ return True where getreftransition ref = do - ts <- parseTransitionsStrictly "remote" . decodeBS + ts <- parseTransitionsStrictly "remote" <$> catFile ref transitionsLog return (ref, ts) @@ -558,7 +559,7 @@ | neednewlocalbranch && null transitionedrefs = "new branch for transition " ++ tdesc | otherwise = "continuing transition " ++ tdesc tdesc = show $ map describeTransition tlist - tlist = transitionList ts + tlist = knownTransitionList ts {- The changes to make to the branch are calculated and applied to - the branch directly, rather than going through the journal, @@ -585,7 +586,8 @@ -- File is deleted; can't run any other -- transitions on it. return () - ChangeFile content' -> do + ChangeFile builder -> do + let content' = toLazyByteString builder sha <- hashBlob content' Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $ Git.UpdateIndex.updateIndexLine sha TreeFile (asTopFilePath file) @@ -595,7 +597,7 @@ checkBranchDifferences :: Git.Ref -> Annex () checkBranchDifferences ref = do - theirdiffs <- allDifferences . parseDifferencesLog . decodeBS + theirdiffs <- allDifferences . parseDifferencesLog <$> catFile ref differenceLog mydiffs <- annexDifferences <$> Annex.getGitConfig when (theirdiffs /= mydiffs) $ diff --git a/Annex/Branch/Transitions.hs b/Annex/Branch/Transitions.hs --- a/Annex/Branch/Transitions.hs +++ b/Annex/Branch/Transitions.hs @@ -1,6 +1,6 @@ {- git-annex branch transitions - - - Copyright 2013-2018 Joey Hess + - Copyright 2013-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -10,6 +10,7 @@ getTransitionCalculator ) where +import Common import Logs import Logs.Transitions import qualified Logs.UUIDBased as UUIDBased @@ -22,41 +23,49 @@ import qualified Data.Map as M import qualified Data.Set as S -import Data.Default +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString.Lazy as A +import Data.ByteString.Builder data FileTransition - = ChangeFile String + = ChangeFile Builder | RemoveFile | PreserveFile -type TransitionCalculator = FilePath -> String -> TrustMap -> FileTransition +type TransitionCalculator = FilePath -> L.ByteString -> TrustMap -> FileTransition getTransitionCalculator :: Transition -> Maybe TransitionCalculator getTransitionCalculator ForgetGitHistory = Nothing getTransitionCalculator ForgetDeadRemotes = Just dropDead -dropDead :: FilePath -> String -> TrustMap -> FileTransition +dropDead :: FilePath -> L.ByteString -> TrustMap -> FileTransition dropDead f content trustmap = case getLogVariety f of Just UUIDBasedLog -- Don't remove the dead repo from the trust log, -- because git remotes may still exist, and they need -- to still know it's dead. | f == trustLog -> PreserveFile - | otherwise -> ChangeFile $ UUIDBased.showLog id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLog Just content + | otherwise -> ChangeFile $ + UUIDBased.buildLog byteString $ + dropDeadFromMapLog trustmap id $ + UUIDBased.parseLog A.takeByteString content Just NewUUIDBasedLog -> ChangeFile $ - UUIDBased.showLogNew id $ dropDeadFromMapLog trustmap id $ UUIDBased.parseLogNew Just content + UUIDBased.buildLogNew byteString $ + dropDeadFromMapLog trustmap id $ + UUIDBased.parseLogNew A.takeByteString content Just (ChunkLog _) -> ChangeFile $ - Chunk.showLog $ dropDeadFromMapLog trustmap fst $ Chunk.parseLog content + Chunk.buildLog $ dropDeadFromMapLog trustmap fst $ Chunk.parseLog content Just (PresenceLog _) -> - let newlog = Presence.compactLog $ dropDeadFromPresenceLog trustmap $ Presence.parseLog content + let newlog = Presence.compactLog $ + dropDeadFromPresenceLog trustmap $ Presence.parseLog content in if null newlog then RemoveFile - else ChangeFile $ Presence.showLog newlog + else ChangeFile $ Presence.buildLog newlog Just RemoteMetaDataLog -> let newlog = dropDeadFromRemoteMetaDataLog trustmap $ MetaData.simplifyLog $ MetaData.parseLog content in if S.null newlog then RemoveFile - else ChangeFile $ MetaData.showLog newlog + else ChangeFile $ MetaData.buildLog newlog Just OtherLog -> PreserveFile Nothing -> PreserveFile @@ -68,7 +77,7 @@ - a dead uuid is dropped; any other values are passed through. -} dropDeadFromPresenceLog :: TrustMap -> [Presence.LogLine] -> [Presence.LogLine] dropDeadFromPresenceLog trustmap = - filter $ notDead trustmap (toUUID . Presence.info) + filter $ notDead trustmap (toUUID . Presence.fromLogInfo . Presence.info) dropDeadFromRemoteMetaDataLog :: TrustMap -> MetaData.Log MetaData -> MetaData.Log MetaData dropDeadFromRemoteMetaDataLog trustmap = diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -38,7 +38,6 @@ import Annex.Link import Annex.CurrentBranch import Types.AdjustedBranch -import Utility.FileSystemEncoding catFile :: Git.Branch -> FilePath -> Annex L.ByteString catFile branch file = do @@ -106,12 +105,12 @@ -- 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 = parseLinkOrPointer <$> catObject ref + | sz <= maxPointerSz = parseLinkTargetOrPointer . L.toStrict <$> catObject ref go _ = return Nothing {- Gets a symlink target. -} catSymLinkTarget :: Sha -> Annex String -catSymLinkTarget sha = fromInternalGitPath . decodeBS <$> get +catSymLinkTarget sha = fromInternalGitPath . decodeBL <$> get where -- Avoid buffering the whole file content, which might be large. -- 8192 is enough if it really is a symlink. diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -405,7 +405,7 @@ , "this safety check.)" ] where - kv = formatKeyVariety (keyVariety k) + kv = decodeBS (formatKeyVariety (keyVariety k)) data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify @@ -544,7 +544,7 @@ | cryptographicallySecure (keyVariety key) = return True | otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig) ( do - warning $ "annex.securehashesonly blocked adding " ++ formatKeyVariety (keyVariety key) ++ " key to annex objects" + warning $ "annex.securehashesonly blocked adding " ++ decodeBS (formatKeyVariety (keyVariety key)) ++ " key to annex objects" return False , return True ) @@ -880,7 +880,8 @@ whenM (annexAlwaysCommit <$> Annex.getGitConfig) $ Annex.Branch.commit =<< Annex.Branch.commitMessage -{- Downloads content from any of a list of urls. -} +{- Downloads content from any of a list of urls, displaying a progress + - meter. -} downloadUrl :: Key -> MeterUpdate -> [Url.URLString] -> FilePath -> Annex Bool downloadUrl k p urls file = -- Poll the file to handle configurations where an external diff --git a/Annex/Difference.hs b/Annex/Difference.hs --- a/Annex/Difference.hs +++ b/Annex/Difference.hs @@ -41,7 +41,7 @@ warning "Cannot change tunable parameters in already initialized repository." return oldds , if otherds == mempty - then ifM (any (/= u) . M.keys <$> uuidMap) + then ifM (any (/= u) . M.keys <$> uuidDescMap) ( do warning "Cannot change tunable parameters in a clone of an existing repository." return mempty diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs --- a/Annex/DirHashes.hs +++ b/Annex/DirHashes.hs @@ -26,7 +26,6 @@ import Key import Types.GitConfig import Types.Difference -import Utility.FileSystemEncoding import Utility.Hash type Hasher = Key -> FilePath @@ -66,15 +65,14 @@ hashDirs _ sz s = addTrailingPathSeparator $ take sz s drop sz s hashDirLower :: HashLevels -> Hasher -hashDirLower n k = hashDirs n 3 $ take 6 $ show $ md5 $ - encodeBS $ key2file $ nonChunkKey k +hashDirLower n k = hashDirs n 3 $ take 6 $ show $ md5 $ serializeKey' $ nonChunkKey k {- 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.md5 $ encodeBS $ key2file $ nonChunkKey k + Utility.Hash.md5 $ 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 @@ -11,11 +11,12 @@ import qualified Annex import Logs.Trust import Annex.NumCopies -import Types.Remote (uuid, appendonly) +import Types.Remote (uuid, appendonly, config) import qualified Remote import qualified Command.Drop import Command import Annex.Wanted +import Annex.Export import Config import Annex.Content.Direct import qualified Database.Keys @@ -30,7 +31,8 @@ - and numcopies settings. - - Skips trying to drop from remotes that are appendonly, since those drops - - would presumably fail. + - would presumably fail. Also skips dropping from exporttree remotes, + - which don't allow dropping individual keys. - - The UUIDs are ones where the content is believed to be present. - The Remote list can include other remotes that do not have the content; @@ -61,10 +63,9 @@ AssociatedFile (Just f) -> nub (f : l) AssociatedFile Nothing -> l n <- getcopies fs - let rs' = filter (not . appendonly) rs void $ if fromhere && checkcopies n Nothing - then go fs rs' n >>= dropl fs - else go fs rs' n + then go fs rs n >>= dropl fs + else go fs rs n where getcopies fs = do (untrusted, have) <- trustPartition UnTrusted locs @@ -91,6 +92,8 @@ go _ [] n = pure n go fs (r:rest) n | uuid r `S.notMember` slocs = go fs rest n + | appendonly r = go fs rest n + | exportTree (config r) = go fs rest n | checkcopies n (Just $ Remote.uuid r) = dropr fs r n >>= go fs rest | otherwise = pure n @@ -112,7 +115,7 @@ liftIO $ debugM "drop" $ unwords [ "dropped" , case afile of - AssociatedFile Nothing -> key2file key + AssociatedFile Nothing -> serializeKey key AssociatedFile (Just af) -> af , "(from " ++ maybe "here" show u ++ ")" , "(copies now " ++ show (fromNumCopies have - 1) ++ ")" diff --git a/Annex/Export.hs b/Annex/Export.hs --- a/Annex/Export.hs +++ b/Annex/Export.hs @@ -15,6 +15,7 @@ import qualified Types.Remote as Remote import Config import Messages +import Utility.FileSystemEncoding import qualified Data.Map as M import Control.Applicative @@ -35,7 +36,7 @@ where mk (Just k) = AnnexKey k mk Nothing = GitKey $ Key - { keyName = Git.fromRef sha + { keyName = encodeBS $ Git.fromRef sha , keyVariety = SHA1Key (HasExt False) , keySize = Nothing , keyMtime = Nothing diff --git a/Annex/HashObject.hs b/Annex/HashObject.hs --- a/Annex/HashObject.hs +++ b/Annex/HashObject.hs @@ -41,7 +41,7 @@ {- Note that the content will be written to a temp file. - So it may be faster to use Git.HashObject.hashObject for large - blob contents. -} -hashBlob :: String -> Annex Sha +hashBlob :: Git.HashObject.HashableBlob b => b -> Annex Sha hashBlob content = do h <- hashObjectHandle liftIO $ Git.HashObject.hashBlob h content diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -30,6 +30,7 @@ import Annex.Content import Annex.Content.Direct import Annex.Perms +import Annex.Tmp import Annex.Link import Annex.MetaData import Annex.CurrentBranch @@ -84,14 +85,12 @@ lockDown' :: LockDownConfig -> FilePath -> Annex (Either IOException LockedDown) lockDown' cfg file = ifM (pure (not (hardlinkFileTmp cfg)) <||> crippledFileSystem) ( withTSDelta $ liftIO . tryIO . nohardlink - , tryIO $ do - tmp <- fromRepo gitAnnexTmpMiscDir - createAnnexDirectory tmp + , tryIO $ withOtherTmp $ \tmp -> do when (lockingFile cfg) $ freezeContent file withTSDelta $ \delta -> liftIO $ do (tmpfile, h) <- openTempFile tmp $ - relatedTemplate $ takeFileName file + relatedTemplate $ "ingest-" ++ takeFileName file hClose h nukeFile tmpfile withhardlink delta tmpfile `catchIO` const (nohardlink delta) diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -44,6 +44,7 @@ import Annex.InodeSentinal import Upgrade import Annex.Perms +import Annex.Tmp import Utility.UserInfo #ifndef mingw32_HOST_OS import Utility.FileMode @@ -68,14 +69,14 @@ giveup "Not initialized." ) -genDescription :: Maybe String -> Annex String -genDescription (Just d) = return d +genDescription :: Maybe String -> Annex UUIDDesc +genDescription (Just d) = return $ UUIDDesc $ encodeBS d genDescription Nothing = do reldir <- liftIO . relHome =<< liftIO . absPath =<< fromRepo Git.repoPath hostname <- fromMaybe "" <$> liftIO getHostname let at = if null hostname then "" else "@" v <- liftIO myUserName - return $ concat $ case v of + return $ UUIDDesc $ encodeBS $ concat $ case v of Right username -> [username, at, hostname, ":", reldir] Left _ -> [hostname, ":", reldir] @@ -109,7 +110,10 @@ hookWrite postReceiveHook setDifferences unlessM (isJust <$> getVersion) $ - setVersion (fromMaybe defaultVersion mversion) + ifM (crippledFileSystem <&&> (not <$> isBareRepo)) + ( setVersion (fromMaybe versionForCrippledFilesystem mversion) + , setVersion (fromMaybe defaultVersion mversion) + ) whenM versionSupportsUnlockedPointers $ do configureSmudgeFilter scanUnlockedFiles @@ -160,9 +164,7 @@ {- A crippled filesystem is one that does not allow making symlinks, - or removing write access from files. -} probeCrippledFileSystem :: Annex Bool -probeCrippledFileSystem = do - tmp <- fromRepo gitAnnexTmpMiscDir - createAnnexDirectory tmp +probeCrippledFileSystem = withOtherTmp $ \tmp -> do (r, warnings) <- liftIO $ probeCrippledFileSystem' tmp mapM_ warning warnings return r @@ -219,17 +221,16 @@ #ifdef mingw32_HOST_OS return True #else - tmp <- fromRepo gitAnnexTmpMiscDir - let f = tmp "lockprobe" - createAnnexDirectory tmp - mode <- annexFileMode - liftIO $ do - nukeFile f - ok <- catchBoolIO $ do - Posix.dropLock =<< Posix.lockExclusive (Just mode) f - return True - nukeFile f - return ok + withOtherTmp $ \tmp -> do + let f = tmp "lockprobe" + mode <- annexFileMode + liftIO $ do + nukeFile f + ok <- catchBoolIO $ do + Posix.dropLock =<< Posix.lockExclusive (Just mode) f + return True + nukeFile f + return ok #endif probeFifoSupport :: Annex Bool @@ -237,20 +238,19 @@ #ifdef mingw32_HOST_OS return False #else - tmp <- fromRepo gitAnnexTmpMiscDir - let f = tmp "gaprobe" - let f2 = tmp "gaprobe2" - createAnnexDirectory tmp - liftIO $ do - nukeFile f - nukeFile f2 - ms <- tryIO $ do - createNamedPipe f ownerReadMode - createLink f f2 - getFileStatus f - nukeFile f - nukeFile f2 - return $ either (const False) isNamedPipe ms + withOtherTmp $ \tmp -> do + let f = tmp "gaprobe" + let f2 = tmp "gaprobe2" + liftIO $ do + nukeFile f + nukeFile f2 + ms <- tryIO $ do + createNamedPipe f ownerReadMode + createLink f f2 + getFileStatus f + nukeFile f + nukeFile f2 + return $ either (const False) isNamedPipe ms #endif checkLockSupport :: Annex () @@ -286,11 +286,12 @@ =<< getGlobalConfig "annex.securehashesonly" adjustToCrippledFilesystem :: Annex () -adjustToCrippledFilesystem = ifM (liftIO $ AdjustedBranch.isGitVersionSupported) - ( do - void $ upgrade True versionForCrippledFilesystem - AdjustedBranch.adjustToCrippledFileSystem - , enableDirectMode +adjustToCrippledFilesystem = ifM versionSupportsAdjustedBranch + ( ifM (liftIO $ AdjustedBranch.isGitVersionSupported) + ( AdjustedBranch.adjustToCrippledFileSystem + , enableDirectMode + ) + , enableDirectMode ) enableDirectMode :: Annex () diff --git a/Annex/Journal.hs b/Annex/Journal.hs --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -4,21 +4,37 @@ - git-annex branch. Among other things, it ensures that if git-annex is - interrupted, its recorded data is not lost. - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module Annex.Journal where import Annex.Common import qualified Git import Annex.Perms +import Annex.Tmp import Annex.LockFile import Utility.Directory.Stream +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S +import Data.ByteString.Builder + +class Journalable t where + writeJournalHandle :: Handle -> t -> IO () + journalableByteString :: t -> L.ByteString + +instance Journalable L.ByteString where + writeJournalHandle = L.hPut + journalableByteString = id + +-- This is more efficient than the ByteString instance. +instance Journalable Builder where + writeJournalHandle = hPutBuilder + journalableByteString = toLazyByteString + {- Records content for a file in the branch to the journal. - - Using the journal, rather than immediatly staging content to the index @@ -28,32 +44,34 @@ - getJournalFileStale to always return a consistent journal file - content, although possibly not the most current one. -} -setJournalFile :: JournalLocked -> FilePath -> String -> Annex () -setJournalFile _jl file content = do - tmp <- fromRepo gitAnnexTmpMiscDir +setJournalFile :: Journalable content => JournalLocked -> FilePath -> content -> Annex () +setJournalFile _jl file content = withOtherTmp $ \tmp -> do createAnnexDirectory =<< fromRepo gitAnnexJournalDir - createAnnexDirectory tmp -- journal file is written atomically jfile <- fromRepo $ journalFile file let tmpfile = tmp takeFileName jfile liftIO $ do - withFile tmpfile WriteMode $ \h -> do -#ifdef mingw32_HOST_OS - hSetNewlineMode h noNewlineTranslation -#endif - hPutStr h content + 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 String) +getJournalFile :: JournalLocked -> FilePath -> Annex (Maybe L.ByteString) getJournalFile _jl = getJournalFileStale {- Without locking, this is not guaranteed to be the most recent - version of the file in the journal, so should not be used as a basis for - - changes. -} -getJournalFileStale :: FilePath -> Annex (Maybe String) + - changes. + - + - The file is read strictly so that its content can safely be fed into + - an operation that modifies the file. While setJournalFile doesn't + - write directly to journal files and so probably avoids problems with + - writing to the same file that's being read, but there could be + - 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 file = inRepo $ \g -> catchMaybeIO $ - readFileStrict $ journalFile file g + L.fromStrict <$> S.readFile (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 diff --git a/Annex/Link.hs b/Annex/Link.hs --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -7,7 +7,7 @@ - - Pointer files are used instead of symlinks for unlocked files. - - - Copyright 2013-2018 Joey Hess + - Copyright 2013-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -30,18 +30,20 @@ import Annex.HashObject import Annex.InodeSentinal import Utility.FileMode -import Utility.FileSystemEncoding import Utility.InodeCache import Utility.Tmp.Dir import Utility.CopyFile +import qualified Utility.RawFilePath as R +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L type LinkTarget = String {- Checks if a file is a link to a key. -} isAnnexLink :: FilePath -> Annex (Maybe Key) -isAnnexLink file = maybe Nothing (fileKey . takeFileName) <$> getAnnexLinkTarget file +isAnnexLink file = maybe Nothing parseLinkTargetOrPointer <$> getAnnexLinkTarget file {- Gets the link target of a symlink. - @@ -51,40 +53,42 @@ - Returns Nothing if the file is not a symlink, or not a link to annex - content. -} -getAnnexLinkTarget :: FilePath -> Annex (Maybe LinkTarget) +getAnnexLinkTarget :: FilePath -> Annex (Maybe S.ByteString) getAnnexLinkTarget f = getAnnexLinkTarget' f =<< (coreSymlinks <$> Annex.getGitConfig) -{- Pass False to force looking inside file. -} -getAnnexLinkTarget' :: FilePath -> Bool -> Annex (Maybe LinkTarget) +{- Pass False to force looking inside file, for when git checks out + - symlinks as plain files. -} +getAnnexLinkTarget' :: FilePath -> Bool -> Annex (Maybe S.ByteString) getAnnexLinkTarget' file coresymlinks = if coresymlinks - then check readSymbolicLink $ + then check probesymlink $ return Nothing - else check readSymbolicLink $ + else check probesymlink $ check probefilecontent $ return Nothing where check getlinktarget fallback = - liftIO (catchMaybeIO $ getlinktarget file) >>= \case + liftIO (catchMaybeIO getlinktarget) >>= \case Just l - | isLinkToAnnex (fromInternalGitPath l) -> return (Just l) + | isLinkToAnnex l -> return (Just l) | otherwise -> return Nothing Nothing -> fallback - probefilecontent f = withFile f ReadMode $ \h -> do - -- The first 8k is more than enough to read; link - -- files are small. - s <- take 8192 <$> hGetContents h - -- If we got the full 8k, the file is too large - if length s == 8192 - then return "" + probesymlink = R.readSymbolicLink $ toRawFilePath file + + probefilecontent = withFile 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. + return $ if S.length s == unpaddedMaxPointerSz + then mempty else -- If there are any NUL or newline -- characters, or whitespace, we - -- certianly don't have a link to a + -- certianly don't have a symlink to a -- git-annex key. - return $ if any (`elem` s) "\0\n\r \t" - then "" + if any (`S8.elem` s) "\0\n\r \t" + then mempty else s makeAnnexLink :: LinkTarget -> FilePath -> Annex () @@ -113,7 +117,7 @@ {- Injects a symlink target into git, returning its Sha. -} hashSymlink :: LinkTarget -> Annex Sha -hashSymlink linktarget = hashBlob (toInternalGitPath linktarget) +hashSymlink linktarget = hashBlob $ toRawFilePath $ toInternalGitPath linktarget {- Stages a symlink to an annexed object, using a Sha of its target. -} stageSymlink :: FilePath -> Sha -> Annex () @@ -123,7 +127,7 @@ {- Injects a pointer file content into git, returning its Sha. -} hashPointerFile :: Key -> Annex Sha -hashPointerFile key = hashBlob (formatPointer key) +hashPointerFile key = hashBlob $ formatPointer key {- Stages a pointer file, using a Sha of its content -} stagePointerFile :: FilePath -> Maybe FileMode -> Sha -> Annex () @@ -137,7 +141,7 @@ writePointerFile :: FilePath -> Key -> Maybe FileMode -> IO () writePointerFile file k mode = do - writeFile file (formatPointer k) + S.writeFile file (formatPointer k) maybe noop (setFileMode file) mode newtype Restage = Restage Bool @@ -223,49 +227,58 @@ , "git update-index -q --refresh " ++ fromMaybe "" mf ] -{- Parses a symlink target or a pointer file to a Key. - - Only looks at the first line, as pointer files can have subsequent - - lines. -} -parseLinkOrPointer :: L.ByteString -> Maybe Key -parseLinkOrPointer = parseLinkOrPointer' - . decodeBS . L.take (fromIntegral maxPointerSz) +{- Parses a symlink target or a pointer file to a Key. -} +parseLinkTargetOrPointer :: S.ByteString -> Maybe Key +parseLinkTargetOrPointer = parseLinkTarget . S8.takeWhile (not . lineend) where + lineend '\n' = True + lineend '\r' = True + lineend _ = False -{- Want to avoid buffering really big files in git into +{- Avoid looking at more of the lazy ByteString than necessary since it + - could be reading from a large file that is not a pointer file. -} +parseLinkTargetOrPointerLazy :: L.ByteString -> Maybe Key +parseLinkTargetOrPointerLazy b = + let b' = L.take (fromIntegral maxPointerSz) b + in parseLinkTargetOrPointer (L.toStrict b') + +{- Parses a symlink target to a Key. -} +parseLinkTarget :: S.ByteString -> Maybe Key +parseLinkTarget l + | isLinkToAnnex l = fileKey' $ snd $ S8.breakEnd pathsep l + | otherwise = Nothing + where + pathsep '/' = True +#ifdef mingw32_HOST_OS + pathsep '\\' = True +#endif + pathsep _ = False + +formatPointer :: Key -> S.ByteString +formatPointer k = prefix <> keyFile' k <> nl + where + prefix = toRawFilePath $ toInternalGitPath (pathSeparator:objectDir) + nl = S8.singleton '\n' + +{- Maximum size of a file that could be a pointer to a key. + - Check to avoid buffering really big files in git into - memory when reading files that may be pointers. - - - 8192 bytes is plenty for a pointer to a key. - - Pad some more to allow for any pointer files that might have + - 8192 bytes is plenty for a pointer to a key. This adds some additional + - padding to allow for any pointer files that might have - lines after the key explaining what the file is used for. -} maxPointerSz :: Integer maxPointerSz = 81920 -parseLinkOrPointer' :: String -> Maybe Key -parseLinkOrPointer' = go . fromInternalGitPath . takeWhile (not . lineend) - where - go l - | isLinkToAnnex l = fileKey $ takeFileName l - | otherwise = Nothing - lineend '\n' = True - lineend '\r' = True - lineend _ = False - -formatPointer :: Key -> String -formatPointer k = - toInternalGitPath (pathSeparator:objectDir keyFile k) ++ "\n" +unpaddedMaxPointerSz :: Int +unpaddedMaxPointerSz = 8192 {- 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 $ bracket open close $ \h -> do - b <- take (fromIntegral maxPointerSz) <$> hGetContents h - -- strict so it reads before the file handle is closed - let !mk = parseLinkOrPointer' b - return mk - where - open = openBinaryFile f ReadMode - close = hClose +isPointerFile f = catchDefaultIO Nothing $ withFile f ReadMode $ \h -> + parseLinkTargetOrPointer <$> S.hGet h unpaddedMaxPointerSz {- Checks a symlink target or pointer file first line to see if it - appears to point to annexed content. @@ -274,10 +287,15 @@ - directory itself, because GIT_DIR may cause a directory name other - than .git to be used. -} -isLinkToAnnex :: FilePath -> Bool -isLinkToAnnex s = (pathSeparator:objectDir) `isInfixOf` s +isLinkToAnnex :: S.ByteString -> Bool +isLinkToAnnex s = p `S.isInfixOf` s #ifdef mingw32_HOST_OS -- '/' is still used inside pointer files on Windows, not the native -- '\' - || ('/':objectDir) `isInfixOf` s + || p' `S.isInfixOf` s +#endif + where + p = toRawFilePath (pathSeparator:objectDir) +#ifdef mingw32_HOST_OS + p' = toRawFilePath ('/':objectDir) #endif diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -1,13 +1,17 @@ {- git-annex file locations - - - Copyright 2010-2017 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.Locations ( keyFile, + keyFile', fileKey, + fileKey', keyPaths, keyPath, annexDir, @@ -24,7 +28,9 @@ annexLocations, gitAnnexDir, gitAnnexObjectDir, - gitAnnexTmpMiscDir, + gitAnnexTmpOtherDir, + gitAnnexTmpOtherLock, + gitAnnexTmpOtherDirOld, gitAnnexTmpObjectDir, gitAnnexTmpObjectLocation, gitAnnexTmpWorkDir, @@ -76,16 +82,15 @@ hashDirLower, preSanitizeKeyName, reSanitizeKeyName, - - prop_isomorphic_fileKey ) where import Data.Char import Data.Default +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L import Common import Key -import Types.Key import Types.UUID import Types.GitConfig import Types.Difference @@ -243,14 +248,22 @@ gitAnnexObjectDir :: Git.Repo -> FilePath gitAnnexObjectDir r = addTrailingPathSeparator $ Git.localGitDir r objectDir -{- .git/annex/misctmp/ is used for random temp files -} -gitAnnexTmpMiscDir :: Git.Repo -> FilePath -gitAnnexTmpMiscDir r = addTrailingPathSeparator $ gitAnnexDir r "misctmp" - {- .git/annex/tmp/ is used for temp files for key's contents -} gitAnnexTmpObjectDir :: Git.Repo -> FilePath gitAnnexTmpObjectDir r = addTrailingPathSeparator $ gitAnnexDir r "tmp" +{- .git/annex/othertmp/ is used for other temp files -} +gitAnnexTmpOtherDir :: Git.Repo -> FilePath +gitAnnexTmpOtherDir r = addTrailingPathSeparator $ gitAnnexDir r "othertmp" + +{- Lock file for gitAnnexTmpOtherDir. -} +gitAnnexTmpOtherLock :: Git.Repo -> FilePath +gitAnnexTmpOtherLock r = gitAnnexDir r "othertmp.lck" + +{- Directory used by old versions of git-annex. -} +gitAnnexTmpOtherDirOld :: Git.Repo -> FilePath +gitAnnexTmpOtherDirOld r = addTrailingPathSeparator $ gitAnnexDir r "misctmp" + {- The temp file to use for a given key's content. -} gitAnnexTmpObjectLocation :: Key -> Git.Repo -> FilePath gitAnnexTmpObjectLocation key r = gitAnnexTmpObjectDir r keyFile key @@ -479,8 +492,8 @@ where escape c | isAsciiUpper c || isAsciiLower c || isDigit c = [c] - | c `elem` ".-_" = [c] -- common, assumed safe - | c `elem` "/%:" = [c] -- handled by keyFile + | c `elem` ['.', '-', '_'] = [c] -- common, assumed safe + | c `elem` ['/', '%', ':'] = [c] -- handled by keyFile -- , is safe and uncommon, so will be used to escape -- other characters. By itself, it is escaped to -- doubled form. @@ -509,33 +522,38 @@ - can cause existing objects to get lost. -} keyFile :: Key -> FilePath -keyFile = concatMap esc . key2file +keyFile = fromRawFilePath . keyFile' + +keyFile' :: Key -> RawFilePath +keyFile' k = + let b = L.toStrict (serializeKey' k) + in if any (`S8.elem` b) ['&', '%', ':', '/'] + then S8.concatMap esc b + else b where esc '&' = "&a" esc '%' = "&s" esc ':' = "&c" esc '/' = "%" - esc c = [c] + esc c = S8.singleton c {- Reverses keyFile, converting a filename fragment (ie, the basename of - the symlink target) into a key. -} fileKey :: FilePath -> Maybe Key -fileKey = file2key . unesc [] - where - unesc r [] = reverse r - unesc r ('%':cs) = unesc ('/':r) cs - unesc r ('&':'c':cs) = unesc (':':r) cs - unesc r ('&':'s':cs) = unesc ('%':r) cs - unesc r ('&':'a':cs) = unesc ('&':r) cs - unesc r (c:cs) = unesc (c:r) cs +fileKey = fileKey' . toRawFilePath -{- for quickcheck -} -prop_isomorphic_fileKey :: String -> Bool -prop_isomorphic_fileKey s - | null s = True -- it's not legal for a key to have no keyName - | otherwise= Just k == fileKey (keyFile k) +fileKey' :: RawFilePath -> Maybe Key +fileKey' = deserializeKey' . S8.intercalate "/" . map go . S8.split '%' where - k = stubKey { keyName = s, keyVariety = OtherKey "test" } + go = S8.concat . unescafterfirst . S8.split '&' + unescafterfirst [] = [] + unescafterfirst (b:bs) = b : map (unesc . S8.uncons) bs + unesc :: Maybe (Char, S8.ByteString) -> S8.ByteString + unesc Nothing = mempty + unesc (Just ('c', b)) = S8.cons ':' b + unesc (Just ('s', b)) = S8.cons '%' b + unesc (Just ('a', b)) = S8.cons '&' b + unesc (Just (c, b)) = S8.cons c b {- A location to store a key on a special remote that uses a filesystem. - A directory hash is used, to protect against filesystems that dislike diff --git a/Annex/LockFile.hs b/Annex/LockFile.hs --- a/Annex/LockFile.hs +++ b/Annex/LockFile.hs @@ -1,6 +1,6 @@ {- git-annex lock files. - - - Copyright 2012-2015 Joey Hess + - Copyright 2012-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -12,6 +12,7 @@ unlockFile, getLockCache, fromLockCache, + withSharedLock, withExclusiveLock, tryExclusiveLock, ) where @@ -57,6 +58,21 @@ changeLockCache a = do m <- getLockCache changeState $ \s -> s { lockcache = a m } + +{- Runs an action with a shared lock held. If an exclusive lock is held, + - blocks until it becomes free. -} +withSharedLock :: (Git.Repo -> FilePath) -> Annex a -> Annex a +withSharedLock getlockfile a = debugLocks $ do + lockfile <- fromRepo getlockfile + createAnnexDirectory $ takeDirectory lockfile + mode <- annexFileMode + bracket (lock mode lockfile) (liftIO . dropLock) (const a) + where +#ifndef mingw32_HOST_OS + lock mode = noUmask mode . lockShared (Just mode) +#else + lock _mode = liftIO . waitToLock . lockShared +#endif {- Runs an action with an exclusive lock held. If the lock is already - held, blocks until it becomes free. -} diff --git a/Annex/MetaData.hs b/Annex/MetaData.hs --- a/Annex/MetaData.hs +++ b/Annex/MetaData.hs @@ -22,6 +22,7 @@ import Utility.Glob import qualified Data.Set as S +import qualified Data.Text as T import Data.Time.Calendar import Data.Time.Clock import Data.Time.Clock.POSIX @@ -71,30 +72,30 @@ - only changes to add the date fields. -} dateMetaData :: UTCTime -> MetaData -> MetaData dateMetaData mtime old = modMeta old $ - (SetMeta yearMetaField $ S.singleton $ toMetaValue $ show y) + (SetMeta yearMetaField $ S.singleton $ toMetaValue $ encodeBS' $ show y) `ComposeModMeta` - (SetMeta monthMetaField $ S.singleton $ toMetaValue $ show m) + (SetMeta monthMetaField $ S.singleton $ toMetaValue $ encodeBS' $ show m) `ComposeModMeta` - (SetMeta dayMetaField $ S.singleton $ toMetaValue $ show d) + (SetMeta dayMetaField $ S.singleton $ toMetaValue $ encodeBS' $ show d) where (y, m, d) = toGregorian $ utctDay mtime {- Parses field=value, field+=value, field-=value, field?=value -} parseModMeta :: String -> Either String ModMeta parseModMeta p = case lastMaybe f of - Just '+' -> AddMeta <$> mkMetaField f' <*> v - Just '-' -> DelMeta <$> mkMetaField f' <*> (Just <$> v) - Just '?' -> MaybeSetMeta <$> mkMetaField f' <*> v - _ -> SetMeta <$> mkMetaField f <*> (S.singleton <$> v) + Just '+' -> AddMeta <$> mkMetaField (T.pack f') <*> v + Just '-' -> DelMeta <$> mkMetaField (T.pack f') <*> (Just <$> v) + Just '?' -> MaybeSetMeta <$> mkMetaField (T.pack f') <*> v + _ -> SetMeta <$> mkMetaField (T.pack f) <*> (S.singleton <$> v) where (f, sv) = separate (== '=') p f' = beginning f - v = pure (toMetaValue sv) + v = pure (toMetaValue (encodeBS sv)) {- Parses field=value, fieldvalue, field>=value -} parseMetaDataMatcher :: String -> Either String (MetaField, MetaValue -> Bool) parseMetaDataMatcher p = (,) - <$> mkMetaField f + <$> mkMetaField (T.pack f) <*> pure matcher where (f, op_v) = break (`elem` "=<>") p @@ -107,8 +108,8 @@ _ -> checkglob "" checkglob v = let cglob = compileGlob v CaseInsensative - in matchGlob cglob . fromMetaValue - checkcmp cmp v v' = case (doubleval v, doubleval (fromMetaValue v')) of + in matchGlob cglob . decodeBS . fromMetaValue + checkcmp cmp v v' = case (doubleval v, doubleval (decodeBS (fromMetaValue v'))) of (Just d, Just d') -> d' `cmp` d _ -> False doubleval v = readish v :: Maybe Double diff --git a/Annex/MetaData/StandardFields.hs b/Annex/MetaData/StandardFields.hs --- a/Annex/MetaData/StandardFields.hs +++ b/Annex/MetaData/StandardFields.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.MetaData.StandardFields ( tagMetaField, yearMetaField, @@ -18,7 +20,9 @@ import Types.MetaData -import Data.List +import qualified Data.Text as T +import Data.Monoid +import Prelude tagMetaField :: MetaField tagMetaField = mkMetaFieldUnchecked "tag" @@ -43,17 +47,17 @@ lastChangedField = mkMetaFieldUnchecked lastchanged mkLastChangedField :: MetaField -> MetaField -mkLastChangedField f = mkMetaFieldUnchecked (fromMetaField f ++ lastchangedSuffix) +mkLastChangedField f = mkMetaFieldUnchecked (fromMetaField f <> lastchangedSuffix) isLastChangedField :: MetaField -> Bool isLastChangedField f | f == lastChangedField = True - | otherwise = lastchanged `isSuffixOf` s && s /= lastchangedSuffix + | otherwise = lastchanged `T.isSuffixOf` s && s /= lastchangedSuffix where s = fromMetaField f -lastchanged :: String +lastchanged :: T.Text lastchanged = "lastchanged" -lastchangedSuffix :: String +lastchangedSuffix :: T.Text lastchangedSuffix = "-lastchanged" diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs --- a/Annex/ReplaceFile.hs +++ b/Annex/ReplaceFile.hs @@ -10,7 +10,7 @@ module Annex.ReplaceFile where import Annex.Common -import Annex.Perms +import Annex.Tmp import Utility.Tmp.Dir import Utility.Path.Max @@ -27,21 +27,19 @@ - Throws an IO exception when it was unable to replace the file. -} replaceFile :: FilePath -> (FilePath -> Annex a) -> Annex a -replaceFile file action = do - misctmpdir <- fromRepo gitAnnexTmpMiscDir - void $ createAnnexDirectory misctmpdir +replaceFile file action = withOtherTmp $ \othertmpdir -> do #ifndef mingw32_HOST_OS -- Use part of the filename as the template for the temp -- directory. This does not need to be unique, but it -- makes it more clear what this temp directory is for. - filemax <- liftIO $ fileNameLengthLimit misctmpdir + filemax <- liftIO $ fileNameLengthLimit othertmpdir let basetmp = take (filemax `div` 2) (takeFileName file) #else -- Windows has limits on the whole path length, so keep -- it short. let basetmp = "t" #endif - withTmpDirIn misctmpdir basetmp $ \tmpdir -> do + withTmpDirIn othertmpdir basetmp $ \tmpdir -> do let tmpfile = tmpdir basetmp r <- action tmpfile liftIO $ replaceFileFrom tmpfile file diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -32,7 +32,6 @@ import Config import Annex.Path import Utility.Env -import Utility.FileSystemEncoding import Utility.Hash import Types.CleanupActions import Types.Concurrency @@ -300,7 +299,7 @@ fromSshHost host ++ "!" ++ show port hostport2socket' :: String -> FilePath hostport2socket' s - | length s > lengthofmd5s = show $ md5 $ encodeBS s + | length s > lengthofmd5s = show $ md5 $ encodeBL s | otherwise = s where lengthofmd5s = 32 diff --git a/Annex/Tmp.hs b/Annex/Tmp.hs new file mode 100644 --- /dev/null +++ b/Annex/Tmp.hs @@ -0,0 +1,56 @@ +{- git-annex tmp files + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Tmp where + +import Common +import Annex +import Annex.Locations +import Annex.LockFile +import Annex.Perms +import Types.CleanupActions + +import Data.Time.Clock.POSIX + +-- | For creation of tmp files, other than for key's contents. +-- +-- The action should normally clean up whatever files it writes to the temp +-- directory that is passed to it. However, once the action is done, +-- any files left in that directory may be cleaned up by another process at +-- any time. +withOtherTmp :: (FilePath -> Annex a) -> Annex a +withOtherTmp a = do + addCleanup OtherTmpCleanup cleanupOtherTmp + tmpdir <- fromRepo gitAnnexTmpOtherDir + tmplck <- fromRepo gitAnnexTmpOtherLock + void $ createAnnexDirectory tmpdir + withSharedLock (const tmplck) (a tmpdir) + +-- | Cleans up any tmp files that were left by a previous +-- git-annex process that got interrupted or failed to clean up after +-- itself for some other reason. +-- +-- Does not do anything if withOtherTmp is running. +cleanupOtherTmp :: Annex () +cleanupOtherTmp = do + tmplck <- fromRepo gitAnnexTmpOtherLock + void $ tryIO $ tryExclusiveLock (const tmplck) $ do + tmpdir <- fromRepo gitAnnexTmpOtherDir + void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir + -- This is only to clean up cruft left by old versions of + -- git-annex; it can be removed eventually. + oldtmp <- fromRepo gitAnnexTmpOtherDirOld + liftIO $ mapM_ cleanold =<< dirContentsRecursive oldtmp + liftIO $ void $ tryIO $ removeDirectory oldtmp -- when empty + where + cleanold f = do + now <- liftIO getPOSIXTime + let oldenough = now - (60 * 60 * 24 * 7) + catchMaybeIO (modificationTime <$> getSymbolicLinkStatus f) >>= \case + Just mtime | realToFrac mtime <= oldenough -> + void $ tryIO $ nukeFile f + _ -> return () diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -178,7 +178,7 @@ | cryptographicallySecure variety = a | otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig) ( do - warning $ "annex.securehashesonly blocked transfer of " ++ formatKeyVariety variety ++ " key" + warning $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key" return observeFailure , a ) diff --git a/Annex/UUID.hs b/Annex/UUID.hs --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -37,20 +37,20 @@ import qualified Data.UUID as U import qualified Data.UUID.V4 as U4 import qualified Data.UUID.V5 as U5 -import Utility.FileSystemEncoding +import Data.String configkey :: ConfigKey configkey = annexConfig "uuid" {- Generates a random UUID, that does not include the MAC address. -} genUUID :: IO UUID -genUUID = UUID . show <$> U4.nextRandom +genUUID = toUUID <$> U4.nextRandom {- Generates a UUID from a given string, using a namespace. - Given the same namespace, the same string will always result - in the same UUID. -} genUUIDInNameSpace :: U.UUID -> String -> UUID -genUUIDInNameSpace namespace = UUID . show . U5.generateNamed namespace . s2w8 +genUUIDInNameSpace namespace = toUUID . U5.generateNamed namespace . s2w8 {- Namespace used for UUIDs derived from git-remote-gcrypt ids. -} gCryptNameSpace :: U.UUID @@ -117,8 +117,8 @@ -- Dummy uuid for the whole web. Do not alter. webUUID :: UUID -webUUID = UUID "00000000-0000-0000-0000-000000000001" +webUUID = UUID (fromString "00000000-0000-0000-0000-000000000001") -- Dummy uuid for bittorrent. Do not alter. bitTorrentUUID :: UUID -bitTorrentUUID = UUID "00000000-0000-0000-0000-000000000002" +bitTorrentUUID = UUID (fromString "00000000-0000-0000-0000-000000000002") diff --git a/Annex/VariantFile.hs b/Annex/VariantFile.hs --- a/Annex/VariantFile.hs +++ b/Annex/VariantFile.hs @@ -8,9 +8,10 @@ module Annex.VariantFile where import Annex.Common -import Utility.FileSystemEncoding import Utility.Hash +import qualified Data.ByteString.Lazy as L + variantMarker :: String variantMarker = ".variant-" @@ -35,10 +36,10 @@ -} variantFile :: FilePath -> Key -> FilePath variantFile file key - | doubleconflict = mkVariant file (key2file key) - | otherwise = mkVariant file (shortHash $ key2file key) + | doubleconflict = mkVariant file (keyFile key) + | otherwise = mkVariant file (shortHash $ serializeKey' key) where doubleconflict = variantMarker `isInfixOf` file -shortHash :: String -> String -shortHash = take 4 . show . md5 . encodeBS +shortHash :: L.ByteString -> String +shortHash = take 4 . show . md5 diff --git a/Annex/VectorClock.hs b/Annex/VectorClock.hs --- a/Annex/VectorClock.hs +++ b/Annex/VectorClock.hs @@ -3,7 +3,7 @@ - We don't have a way yet to keep true distributed vector clocks. - The next best thing is a timestamp. - - - Copyright 2017 Joey Hess + - Copyright 2017-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -11,17 +11,19 @@ module Annex.VectorClock where import Data.Time.Clock.POSIX +import Data.ByteString.Builder import Control.Applicative import Prelude import Utility.Env import Utility.TimeStamp import Utility.QuickCheck +import qualified Data.Attoparsec.ByteString.Lazy as A -- | Some very old logs did not have any time stamp at all; -- Unknown is used for those. data VectorClock = Unknown | VectorClock POSIXTime - deriving (Eq, Ord) + deriving (Eq, Ord, Show) -- Unknown is oldest. prop_VectorClock_sane :: Bool @@ -39,8 +41,14 @@ Nothing -> VectorClock <$> getPOSIXTime formatVectorClock :: VectorClock -> String -formatVectorClock Unknown = "0" +formatVectorClock Unknown = "0" formatVectorClock (VectorClock t) = show t +buildVectorClock :: VectorClock -> Builder +buildVectorClock = string7 . formatVectorClock + parseVectorClock :: String -> Maybe VectorClock parseVectorClock t = VectorClock <$> parsePOSIXTime t + +vectorClockParser :: A.Parser VectorClock +vectorClockParser = VectorClock <$> parserPOSIXTime diff --git a/Annex/View.hs b/Annex/View.hs --- a/Annex/View.hs +++ b/Annex/View.hs @@ -31,6 +31,8 @@ import Types.Command import CmdLine.Action +import qualified Data.Text as T +import qualified Data.ByteString as B import qualified Data.Set as S import qualified Data.Map as M import "mtl" Control.Monad.Writer @@ -68,18 +70,18 @@ ) (field, wanted) | end field == "!" -> - ( mkMetaFieldUnchecked (beginning field) + ( mkMetaFieldUnchecked (T.pack (beginning field)) , mkExcludeValues wanted ) | otherwise -> - ( mkMetaFieldUnchecked field + ( mkMetaFieldUnchecked (T.pack field) , mkFilterValues wanted ) where mkFilterValues v | any (`elem` v) "*?" = FilterGlob v - | otherwise = FilterValues $ S.singleton $ toMetaValue v - mkExcludeValues = ExcludeValues . S.singleton . toMetaValue + | otherwise = FilterValues $ S.singleton $ toMetaValue $ encodeBS v + mkExcludeValues = ExcludeValues . S.singleton . toMetaValue . encodeBS data ViewChange = Unchanged | Narrowing | Widening deriving (Ord, Eq, Show) @@ -156,7 +158,7 @@ combineViewFilter (FilterValues _) newglob@(FilterGlob _) = (newglob, Widening) combineViewFilter (FilterGlob oldglob) new@(FilterValues s) - | all (matchGlob (compileGlob oldglob CaseInsensative) . fromMetaValue) (S.toList s) = (new, Narrowing) + | all (matchGlob (compileGlob oldglob CaseInsensative) . decodeBS . fromMetaValue) (S.toList s) = (new, Narrowing) | otherwise = (new, Widening) combineViewFilter (FilterGlob old) newglob@(FilterGlob new) | old == new = (newglob, Unchanged) @@ -211,7 +213,7 @@ FilterGlob glob -> let cglob = compileGlob glob CaseInsensative in \values -> setmatches $ - S.filter (matchGlob cglob . fromMetaValue) values + S.filter (matchGlob cglob . decodeBS . fromMetaValue) values ExcludeValues excludes -> \values -> if S.null (S.intersection values excludes) then Just [] @@ -231,7 +233,7 @@ pseudoBackslash = "\56546\56469\56498" toViewPath :: MetaValue -> FilePath -toViewPath = escapeslash [] . fromMetaValue +toViewPath = escapeslash [] . decodeBS . fromMetaValue where escapeslash s ('/':cs) = escapeslash (pseudoSlash:s) cs escapeslash s ('\\':cs) = escapeslash (pseudoBackslash:s) cs @@ -243,7 +245,7 @@ escapeslash s cs = concat (reverse (cs:s)) fromViewPath :: FilePath -> MetaValue -fromViewPath = toMetaValue . deescapeslash [] +fromViewPath = toMetaValue . encodeBS . deescapeslash [] where deescapeslash s ('%':escapedc:cs) = deescapeslash ([escapedc]:s) cs deescapeslash s (c1:c2:c3:cs) @@ -285,7 +287,7 @@ all hasfields (viewedFiles view viewedFileFromReference f metadata) where view = View (Git.Ref "master") $ - map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . null . fromMetaValue) mv) visible) + map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . B.null . fromMetaValue) mv) visible) (fromMetaData metadata) visiblefields = sort (map viewField $ filter viewVisible (viewComponents view)) hasfields fv = sort (map fst (fromMetaData (fromView view fv))) == visiblefields @@ -300,9 +302,9 @@ getDirMetaData d = MetaData $ M.fromList $ zip fields values where dirs = splitDirectories d - fields = map (mkMetaFieldUnchecked . addTrailingPathSeparator . joinPath) + fields = map (mkMetaFieldUnchecked . T.pack . addTrailingPathSeparator . joinPath) (inits dirs) - values = map (S.singleton . toMetaValue . fromMaybe "" . headMaybe) + values = map (S.singleton . toMetaValue . encodeBS . fromMaybe "" . headMaybe) (tails dirs) getWorkTreeMetaData :: FilePath -> MetaData diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -27,7 +27,7 @@ import Network.URI import Control.Concurrent.Async --- youtube-dl is can follow redirects to anywhere, including potentially +-- youtube-dl can follow redirects to anywhere, including potentially -- localhost or a private address. So, it's only allowed to download -- content if the user has allowed access to all addresses. youtubeDlAllowed :: Annex Bool diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -106,8 +106,8 @@ (c', u) <- R.setup remotetype ss mu mcreds weakc dummycfg configSet u c' when setdesc $ - whenM (isNothing . M.lookup u <$> uuidMap) $ - describeUUID u name + whenM (isNothing . M.lookup u <$> uuidDescMap) $ + describeUUID u (toUUIDDesc name) return name {- Returns the name of the git remote it created. If there's already a diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -27,6 +27,7 @@ import "mtl" Control.Monad.Reader import System.Log.Logger +import qualified Control.Monad.Fail as Fail import Annex.Common import Assistant.Types.ThreadedMonad @@ -49,6 +50,7 @@ Monad, MonadIO, MonadReader AssistantData, + Fail.MonadFail, Functor, Applicative ) diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -29,6 +29,7 @@ import Annex.Content import Annex.Ingest import Annex.Link +import Annex.Tmp import Annex.CatFile import Annex.InodeSentinal import Annex.Version @@ -487,9 +488,7 @@ ( liftIO $ do let segments = segmentXargsUnordered $ map keyFilename keysources concat <$> forM segments (\fs -> Lsof.query $ "--" : fs) - , do - tmpdir <- fromRepo gitAnnexTmpMiscDir - liftIO $ Lsof.queryDir tmpdir + , withOtherTmp $ liftIO . Lsof.queryDir ) {- After a Change is committed, queue any necessary transfers or drops diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -57,7 +57,7 @@ {- All git-annex's config files, and actions to run when they change. -} configFilesActions :: [(FilePath, Assistant ())] configFilesActions = - [ (uuidLog, void $ liftAnnex uuidMapLoad) + [ (uuidLog, void $ liftAnnex uuidDescMapLoad) , (remoteLog, void $ liftAnnex remoteListRefresh) , (trustLog, void $ liftAnnex trustMapLoad) , (groupLog, void $ liftAnnex groupMapLoad) diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Assistant.Threads.SanityChecker ( sanityCheckerStartupThread, @@ -39,8 +40,8 @@ import Assistant.Unused import Logs.Unused import Types.Transfer -import Types.Key import Annex.Path +import Annex.Tmp import qualified Annex #ifdef WITH_WEBAPP import Assistant.WebApp.Types @@ -86,9 +87,7 @@ liftIO $ fixUpSshRemotes {- Clean up old temp files. -} - void $ liftAnnex $ tryNonAsync $ do - cleanOldTmpMisc - cleanReallyOldTmp + void $ liftAnnex $ tryNonAsync $ cleanupOtherTmp {- If there's a startup delay, it's done here. -} liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay @@ -267,58 +266,6 @@ #else debug [show $ renderTense Past msg] #endif - -{- Files may be left in misctmp by eg, an interrupted add of files - - by the assistant, which hard links files to there as part of lockdown - - checks. Delete these files if they're more than a day old. - - - - Note that this is not safe to run after the Watcher starts up, since it - - will create such files, and due to hard linking they may have old - - mtimes. So, this should only be called from the - - sanityCheckerStartupThread, which runs before the Watcher starts up. - - - - Also, if a git-annex add is being run at the same time the assistant - - starts up, its tmp files could be deleted. However, the watcher will - - come along and add everything once it starts up anyway, so at worst - - this would make the git-annex add fail unexpectedly. - -} -cleanOldTmpMisc :: Annex () -cleanOldTmpMisc = do - now <- liftIO getPOSIXTime - let oldenough = now - (60 * 60 * 24) - tmp <- fromRepo gitAnnexTmpMiscDir - liftIO $ mapM_ (cleanOld (<= oldenough)) =<< dirContentsRecursive tmp - -{- While .git/annex/tmp is now only used for storing partially transferred - - objects, older versions of git-annex used it for misctemp. Clean up any - - files that might be left from that, by looking for files whose names - - cannot be the key of an annexed object. Only delete files older than - - 1 week old. - - - - Also, some remotes such as rsync may use this temp directory for storing - - eg, encrypted objects that are being transferred. So, delete old - - objects that use a GPGHMAC backend. - -} -cleanReallyOldTmp :: Annex () -cleanReallyOldTmp = do - now <- liftIO getPOSIXTime - let oldenough = now - (60 * 60 * 24 * 7) - tmp <- fromRepo gitAnnexTmpObjectDir - liftIO $ mapM_ (cleanjunk (<= oldenough)) =<< dirContentsRecursive tmp - where - cleanjunk check f = case fileKey (takeFileName f) of - Nothing -> cleanOld check f - Just k - | "GPGHMAC" `isPrefixOf` formatKeyVariety (keyVariety k) -> - cleanOld check f - | otherwise -> noop - -cleanOld :: (POSIXTime -> Bool) -> FilePath -> IO () -cleanOld check f = go =<< catchMaybeIO getmtime - where - getmtime = realToFrac . modificationTime <$> getSymbolicLinkStatus f - go (Just mtime) | check mtime = nukeFile f - go _ = noop checkRepoExists :: Assistant () checkRepoExists = do diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -44,7 +44,6 @@ import Config import Config.GitConfig import Utility.ThreadScheduler -import Utility.FileSystemEncoding import Logs.Location import qualified Database.Keys #ifndef mingw32_HOST_OS @@ -303,11 +302,11 @@ case linktarget of Nothing -> a Just lt -> do - case fileKey $ takeFileName lt of + case parseLinkTarget lt of Nothing -> noop Just key -> liftAnnex $ addassociatedfile key file - onAddSymlink' linktarget mk isdirect file fs + onAddSymlink' (Just $ fromRawFilePath lt) mk isdirect file fs {- A symlink might be an arbitrary symlink, which is just added. - Or, if it is a git-annex symlink, ensure it points to the content diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -191,16 +191,17 @@ sz <- readTVar (queuesize q) if sz < 1 then retry -- blocks until queuesize changes - else do - (r@(t,info):rest) <- readTList (queuelist q) - void $ modifyTVar' (queuesize q) pred - setTList (queuelist q) rest - if acceptable info - then do - adjustTransfersSTM dstatus $ - M.insert t info - return $ Just r - else return Nothing + else readTList (queuelist q) >>= \case + [] -> retry -- blocks until something is queued + (r@(t,info):rest) -> do + void $ modifyTVar' (queuesize q) pred + setTList (queuelist q) rest + if acceptable info + then do + adjustTransfersSTM dstatus $ + M.insert t info + return $ Just r + else return Nothing {- Moves transfers matching a condition from the queue, to the - currentTransfers map. -} diff --git a/Assistant/Unused.hs b/Assistant/Unused.hs --- a/Assistant/Unused.hs +++ b/Assistant/Unused.hs @@ -74,7 +74,7 @@ now <- liftIO getPOSIXTime let oldkeys = M.keys $ M.filter (tooold now) m forM_ oldkeys $ \k -> do - debug ["removing old unused key", key2file k] + debug ["removing old unused key", serializeKey k] liftAnnex $ tryNonAsync $ do lockContentForRemoval k removeAnnex logStatus k InfoMissing 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 @@ -45,6 +45,7 @@ import Config import Config.GitConfig import Config.DynamicConfig +import Types.Group import qualified Data.Text as T import qualified Data.Map as M @@ -66,15 +67,15 @@ getRepoConfig uuid mremote = do -- Ensure we're editing current data by discarding caches. void groupMapLoad - void uuidMapLoad + void uuidDescMapLoad groups <- lookupGroups uuid remoteconfig <- M.lookup uuid <$> readRemoteLog let (repogroup, associateddirectory) = case getStandardGroup groups of - Nothing -> (RepoGroupCustom $ unwords $ S.toList groups, Nothing) + Nothing -> (RepoGroupCustom $ unwords $ map fromGroup $ S.toList groups, Nothing) Just g -> (RepoGroupStandard g, associatedDirectory remoteconfig g) - description <- fmap T.pack . M.lookup uuid <$> uuidMap + description <- fmap (T.pack . fromUUIDDesc) . M.lookup uuid <$> uuidDescMap syncable <- case mremote of Just r -> liftIO $ getDynamicConfig $ remoteAnnexSync $ Remote.gitconfig r @@ -90,8 +91,8 @@ setRepoConfig :: UUID -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler () setRepoConfig uuid mremote oldc newc = do when descriptionChanged $ liftAnnex $ do - maybe noop (describeUUID uuid . T.unpack) (repoDescription newc) - void uuidMapLoad + maybe noop (describeUUID uuid . toUUIDDesc . T.unpack) (repoDescription newc) + void uuidDescMapLoad when nameChanged $ do liftAnnex $ do name <- uniqueRemoteName (legalName newc) 0 <$> Annex.getGitRemotes @@ -127,7 +128,7 @@ when groupChanged $ do liftAnnex $ case repoGroup newc of RepoGroupStandard g -> setStandardGroup uuid g - RepoGroupCustom s -> groupSet uuid $ S.fromList $ words s + RepoGroupCustom s -> groupSet uuid $ S.fromList $ map toGroup $ words s {- Enabling syncing will cause a scan, - so avoid queueing a duplicate scan. -} when (repoSyncable newc && not syncableChanged) $ liftAssistant $ 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 @@ -289,7 +289,7 @@ askcombine = page "Combine repositories?" (Just Configuration) $ $(widgetFile "configurators/adddrive/combine") isknownuuid driveuuid = - ifM (M.member driveuuid <$> liftAnnex uuidMap) + ifM (M.member driveuuid <$> liftAnnex uuidDescMap) ( knownrepo , askcombine ) 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 @@ -213,23 +213,21 @@ enableSshRemote getsshdata rsyncnetsetup genericsetup u = do m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog case (unmangle <$> getsshdata m, M.lookup "name" m) of - (Just sshdata, Just reponame) - | isGitLab sshdata -> enableGitLab sshdata - | otherwise -> sshConfigurator $ do - ((result, form), enctype) <- liftH $ - runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ - sshInputAForm textField $ mkSshInput sshdata - case result of - FormSuccess sshinput - | isRsyncNet (inputHostname sshinput) -> - void $ liftH $ rsyncnetsetup sshinput reponame - | otherwise -> do - s <- liftAssistant $ testServer sshinput - case s of - Left status -> showform form enctype status - Right (sshdata', _u) -> void $ liftH $ genericsetup - ( sshdata' { sshRepoName = reponame } ) u - _ -> showform form enctype UntestedServer + (Just sshdata, Just reponame) -> sshConfigurator $ do + ((result, form), enctype) <- liftH $ + runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ + sshInputAForm textField $ mkSshInput sshdata + case result of + FormSuccess sshinput + | isRsyncNet (inputHostname sshinput) -> + void $ liftH $ rsyncnetsetup sshinput reponame + | otherwise -> do + s <- liftAssistant $ testServer sshinput + case s of + Left status -> showform form enctype status + Right (sshdata', _u) -> void $ liftH $ genericsetup + ( sshdata' { sshRepoName = reponame } ) u + _ -> showform form enctype UntestedServer _ -> redirect AddSshR where unmangle sshdata = sshdata @@ -418,7 +416,7 @@ getConfirmSshR :: SshData -> UUID -> Handler Html getConfirmSshR sshdata u | u == NoUUID = handlenew - | otherwise = handleexisting =<< (M.lookup u <$> liftAnnex uuidMap) + | otherwise = handleexisting =<< (M.lookup u <$> liftAnnex uuidDescMap) where handlenew = sshConfigurator $ do cmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig @@ -675,110 +673,3 @@ isRsyncNet :: Maybe Text -> Bool isRsyncNet Nothing = False isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host - -data GitLabUrl = GitLabUrl { unGitLabUrl :: Text } - -badGitLabUrl :: Text -badGitLabUrl = "Bad SSH clone url. Expected something like: git@gitlab.com:yourlogin/annex.git" - -parseGitLabUrl :: GitLabUrl -> Maybe SshData -parseGitLabUrl (GitLabUrl t) = - let (u, r) = separate (== '@') (T.unpack t) - (h, p) = separate (== ':') r - in if null u || null h || null p - then Nothing - else Just $ SshData - { sshHostName = T.pack h - , sshUserName = Just (T.pack u) - , sshDirectory = T.pack p - , sshRepoName = genSshRepoName h p - , sshPort = 22 - , needsPubKey = False - , sshCapabilities = - [ GitAnnexShellCapable - , GitCapable - , PushCapable - ] - , sshRepoUrl = Just (T.unpack t) - } - -isGitLab :: SshData -> Bool -isGitLab d = T.pack "gitlab.com" `T.isSuffixOf` (T.toLower (sshHostName d)) - -toGitLabUrl :: SshData -> GitLabUrl -toGitLabUrl d = GitLabUrl $ T.concat - [ fromMaybe (T.pack "git") (sshUserName d) - , T.pack "@" - , sshHostName d - , T.pack ":" - , sshDirectory d - ] - -{- Try to ssh into the gitlab server, verify we can access the repository, - - and get the uuid of the repository, if it already has one. - - - - A repository on gitlab won't be initialized as a git-annex repo - - unless a git-annex branch was already pushed to it. So, if - - git-annex-shell fails to work that's probably why; verify if - - the server is letting us ssh in by running git send-pack - - (in dry run mode). -} -testGitLabUrl :: GitLabUrl -> Annex (ServerStatus, Maybe SshData, UUID) -testGitLabUrl glu = case parseGitLabUrl glu of - Nothing -> return (UnusableServer badGitLabUrl, Nothing, NoUUID) - Just sshdata -> - checkor sshdata $ do - (sshdata', keypair) <- liftIO $ setupSshKeyPair sshdata - checkor sshdata' $ - return (ServerNeedsPubKey (sshPubKey keypair), Just sshdata', NoUUID) - where - checkor sshdata ora = do - u <- probeuuid sshdata - if u /= NoUUID - then return (UsableServer (sshCapabilities sshdata), Just sshdata, u) - else ifM (verifysshworks sshdata) - ( return (UsableServer (sshCapabilities sshdata), Just sshdata, NoUUID) - , ora - ) - probeuuid sshdata = do - r <- inRepo $ Git.Construct.fromRemoteLocation (fromJust $ sshRepoUrl sshdata) - getUncachedUUID . either (const r) fst <$> - Remote.Helper.Ssh.onRemote NoConsumeStdin r - (Git.Config.fromPipe r, return (Left $ error "configlist failed")) - "configlist" [] [] - verifysshworks sshdata = inRepo $ Git.Command.runBool - [ Param "send-pack" - , Param (fromJust $ sshRepoUrl sshdata) - , Param "--dry-run" - , Param "--force" - , Param (fromRef Annex.Branch.name) - ] - -gitLabUrlAForm :: Maybe GitLabUrl -> AForm Handler GitLabUrl -gitLabUrlAForm defval = GitLabUrl <$> areq check_input (bfs "SSH clone url") (unGitLabUrl <$> defval) - where - check_input = checkBool (isJust . parseGitLabUrl . GitLabUrl) - badGitLabUrl textField - -getAddGitLabR :: Handler Html -getAddGitLabR = postAddGitLabR -postAddGitLabR :: Handler Html -postAddGitLabR = promptGitLab Nothing - -promptGitLab :: Maybe GitLabUrl -> Handler Html -promptGitLab defval = sshConfigurator $ do - ((result, form), enctype) <- liftH $ - runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ - gitLabUrlAForm defval - case result of - FormSuccess gitlaburl -> do - (status, msshdata, u) <- liftAnnex $ testGitLabUrl gitlaburl - case (status, msshdata) of - (UsableServer _, Just sshdata) -> - liftH $ redirect $ ConfirmSshR sshdata u - _ -> showform form enctype status - _ -> showform form enctype UntestedServer - where - showform form enctype status = $(widgetFile "configurators/gitlab.com/add") - -enableGitLab :: SshData -> Handler Html -enableGitLab = promptGitLab . Just . toGitLabUrl diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -30,9 +30,6 @@ webDAVConfigurator :: Widget -> Handler Html webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration) -boxConfigurator :: Widget -> Handler Html -boxConfigurator = page "Add a Box.com repository" (Just Configuration) - data WebDAVInput = WebDAVInput { user :: Text , password :: Text @@ -44,14 +41,6 @@ toCredPair :: WebDAVInput -> CredPair toCredPair input = (T.unpack $ user input, T.unpack $ password input) -boxComAForm :: Maybe CredPair -> MkAForm WebDAVInput -boxComAForm defcreds = WebDAVInput - <$> areq textField (bfs "Username or Email") (T.pack . fst <$> defcreds) - <*> areq passwordField (bfs "Box.com Password") (T.pack . snd <$> defcreds) - <*> areq checkBoxField "Share this account with other devices and friends?" (Just True) - <*> areq textField (bfs "Directory") (Just "annex") - <*> enableEncryptionField - webDAVCredsAForm :: Maybe CredPair -> MkAForm WebDAVInput webDAVCredsAForm defcreds = WebDAVInput <$> areq textField (bfs "Username or Email") (T.pack . fst <$> defcreds) @@ -60,32 +49,6 @@ <*> pure T.empty <*> pure NoEncryption -- not used! -getAddBoxComR :: Handler Html -getAddBoxComR = postAddBoxComR -postAddBoxComR :: Handler Html -#ifdef WITH_WEBDAV -postAddBoxComR = boxConfigurator $ do - defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com" - ((result, form), enctype) <- liftH $ - runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout - $ boxComAForm defcreds - case result of - FormSuccess input -> liftH $ - makeWebDavRemote initSpecialRemote "box.com" (toCredPair input) $ M.fromList - [ configureEncryption $ enableEncryption input - , ("embedcreds", if embedCreds input then "yes" else "no") - , ("type", "webdav") - , ("url", "https://dav.box.com/dav/" ++ T.unpack (directory input)) - -- Box.com has a max file size of 100 mb, but - -- using smaller chunks has better memory - -- performance. - , ("chunk", "10mb") - ] - _ -> $(widgetFile "configurators/addbox.com") -#else -postAddBoxComR = giveup "WebDAV not supported by this build" -#endif - getEnableWebDAVR :: UUID -> Handler Html getEnableWebDAVR = postEnableWebDAVR postEnableWebDAVR :: UUID -> Handler Html @@ -101,11 +64,7 @@ case mcreds of Just creds -> webDAVConfigurator $ liftH $ makeWebDavRemote enableSpecialRemote name creds M.empty - Nothing - | "box.com/" `isInfixOf` url -> - boxConfigurator $ showform name url - | otherwise -> - webDAVConfigurator $ showform name url + Nothing -> webDAVConfigurator $ showform name url where showform name url = do defcreds <- liftAnnex $ diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -44,7 +44,7 @@ isrunning info = not $ transferPaused info || isNothing (startedTime info) desc transfer info = case associatedFile info of - AssociatedFile Nothing -> key2file $ transferKey transfer + AssociatedFile Nothing -> serializeKey $ transferKey transfer AssociatedFile (Just af) -> af {- Simplifies a list of transfers, avoiding display of redundant diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -55,8 +55,6 @@ /config/repository/add/cloud/S3 AddS3R GET POST /config/repository/add/cloud/IA AddIAR GET POST /config/repository/add/cloud/glacier AddGlacierR GET POST -/config/repository/add/cloud/box.com AddBoxComR GET POST -/config/repository/add/cloud/gitlab.com AddGitLabR GET POST /config/repository/pair/local/start StartLocalPairR GET POST /config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET diff --git a/Backend.hs b/Backend.hs --- a/Backend.hs +++ b/Backend.hs @@ -29,6 +29,7 @@ import qualified Backend.URL import qualified Data.Map as M +import qualified Data.ByteString.Char8 as S8 list :: [Backend] list = Backend.Hash.backends ++ Backend.WORM.backends ++ Backend.URL.backends @@ -46,7 +47,7 @@ Annex.changeState $ \s -> s { Annex.backend = Just b } return b valid name = not (null name) - lookupname = lookupBackendVariety . parseKeyVariety + lookupname = lookupBackendVariety . parseKeyVariety . encodeBS {- Generates a key for a file. -} genKey :: KeySource -> Maybe Backend -> Annex (Maybe (Key, Backend)) @@ -57,7 +58,7 @@ Just k -> Just (makesane k, b) where -- keyNames should not contain newline characters. - makesane k = k { keyName = map fixbadchar (keyName k) } + makesane k = k { keyName = S8.map fixbadchar (keyName k) } fixbadchar c | c == '\n' = '_' | otherwise = c @@ -66,7 +67,7 @@ getBackend file k = case maybeLookupBackendVariety (keyVariety k) of Just backend -> return $ Just backend Nothing -> do - warning $ "skipping " ++ file ++ " (unknown backend " ++ formatKeyVariety (keyVariety k) ++ ")" + warning $ "skipping " ++ file ++ " (unknown backend " ++ decodeBS (formatKeyVariety (keyVariety k)) ++ ")" return Nothing {- Looks up the backend that should be used for a file. @@ -75,7 +76,7 @@ chooseBackend :: FilePath -> Annex (Maybe Backend) chooseBackend f = Annex.getState Annex.forcebackend >>= go where - go Nothing = maybeLookupBackendVariety . parseKeyVariety + go Nothing = maybeLookupBackendVariety . parseKeyVariety . encodeBS <$> checkAttr "annex.backend" f go (Just _) = Just <$> defaultBackend @@ -83,7 +84,7 @@ lookupBackendVariety :: KeyVariety -> Backend lookupBackendVariety v = fromMaybe unknown $ maybeLookupBackendVariety v where - unknown = giveup $ "unknown backend " ++ formatKeyVariety v + unknown = giveup $ "unknown backend " ++ decodeBS (formatKeyVariety v) maybeLookupBackendVariety :: KeyVariety -> Maybe Backend maybeLookupBackendVariety v = M.lookup v varietyMap diff --git a/Backend/Hash.hs b/Backend/Hash.hs --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -1,11 +1,12 @@ {- git-annex hashing backends - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Backend.Hash ( backends, @@ -19,6 +20,8 @@ import Types.KeySource import Utility.Hash +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Char @@ -71,15 +74,15 @@ } hashKeyVariety :: Hash -> HasExt -> KeyVariety -hashKeyVariety MD5Hash = MD5Key -hashKeyVariety SHA1Hash = SHA1Key -hashKeyVariety (SHA2Hash size) = SHA2Key size -hashKeyVariety (SHA3Hash size) = SHA3Key size -hashKeyVariety (SkeinHash size) = SKEINKey size +hashKeyVariety MD5Hash he = MD5Key he +hashKeyVariety SHA1Hash he = SHA1Key he +hashKeyVariety (SHA2Hash size) he = SHA2Key size he +hashKeyVariety (SHA3Hash size) he = SHA3Key size he +hashKeyVariety (SkeinHash size) he = SKEINKey size he #if MIN_VERSION_cryptonite(0,23,0) -hashKeyVariety (Blake2bHash size) = Blake2bKey size -hashKeyVariety (Blake2sHash size) = Blake2sKey size -hashKeyVariety (Blake2spHash size) = Blake2spKey size +hashKeyVariety (Blake2bHash size) he = Blake2bKey size he +hashKeyVariety (Blake2sHash size) he = Blake2sKey size he +hashKeyVariety (Blake2spHash size) he = Blake2spKey size he #endif {- A key is a hash of its contents. -} @@ -89,7 +92,7 @@ filesize <- liftIO $ getFileSize file s <- hashFile hash file return $ Just $ stubKey - { keyName = s + { keyName = encodeBS s , keyVariety = hashKeyVariety hash (HasExt False) , keySize = Just filesize } @@ -102,7 +105,7 @@ maxlen <- annexMaxExtensionLength <$> Annex.getGitConfig let ext = selectExtension maxlen (keyFilename source) return $ Just $ k - { keyName = keyName k ++ ext + { keyName = keyName k <> encodeBS ext , keyVariety = hashKeyVariety hash (HasExt True) } @@ -132,7 +135,7 @@ check <$> hashFile hash file _ -> return True where - expected = keyHash key + expected = decodeBS (keyHash key) check s | s == expected = True {- A bug caused checksums to be prefixed with \ in some @@ -145,8 +148,8 @@ warning $ "hardware fault: " ++ show e return False -keyHash :: Key -> String -keyHash key = dropExtensions (keyName key) +keyHash :: Key -> S.ByteString +keyHash = fst . splitKeyNameExtension validInExtension :: Char -> Bool validInExtension c @@ -163,8 +166,8 @@ -} needsUpgrade :: Key -> Bool needsUpgrade key = or - [ "\\" `isPrefixOf` keyHash key - , any (not . validInExtension) (takeExtensions $ keyName key) + [ "\\" `S8.isPrefixOf` keyHash key + , any (not . validInExtension) (decodeBS $ snd $ splitKeyNameExtension key) , not (hasExt (keyVariety key)) && keyHash key /= keyName key ] @@ -184,7 +187,7 @@ AssociatedFile Nothing -> Nothing AssociatedFile (Just file) -> Just $ oldkey { keyName = keyHash oldkey - ++ selectExtension maxextlen file + <> encodeBS (selectExtension maxextlen file) , keyVariety = newvariety } {- Upgrade to fix bad previous migration that created a @@ -285,5 +288,5 @@ let b = genBackendE (SHA2Hash (HashSize 256)) in b { getKey = (fmap addE) <$$> getKey b } where - addE k = k { keyName = keyName k ++ longext } + addE k = k { keyName = keyName k <> longext } longext = ".this-is-a-test-key" diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -1,6 +1,6 @@ {- git-annex backend utilities - - - Copyright 2012 Joey Hess + - Copyright 2012-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -8,20 +8,21 @@ module Backend.Utilities where import Annex.Common -import Utility.FileSystemEncoding import Utility.Hash +import qualified Data.ByteString as S + {- 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. - Otherwise, it's truncated, and its md5 is prepended to ensure a unique - key. -} -genKeyName :: String -> String +genKeyName :: String -> S.ByteString genKeyName s -- Avoid making keys longer than the length of a SHA256 checksum. - | bytelen > sha256len = + | bytelen > sha256len = encodeBS' $ truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++ - show (md5 (encodeBS s)) - | otherwise = s' + show (md5 (encodeBL s)) + | otherwise = encodeBS' s' where s' = preSanitizeKeyName s bytelen = length (decodeW8 s') diff --git a/Backend/WORM.hs b/Backend/WORM.hs --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -14,6 +14,8 @@ import Backend.Utilities import Git.FilePath +import qualified Data.ByteString.Char8 as S8 + backends :: [Backend] backends = [backend] @@ -45,12 +47,12 @@ {- Old WORM keys could contain spaces, and can be upgraded to remove them. -} needsUpgrade :: Key -> Bool -needsUpgrade key = ' ' `elem` keyName key +needsUpgrade key = ' ' `S8.elem` keyName key removeSpaces :: Key -> Backend -> AssociatedFile -> Annex (Maybe Key) removeSpaces oldkey newbackend _ | migratable = return $ Just $ oldkey - { keyName = reSanitizeKeyName (keyName oldkey) } + { keyName = encodeBS $ reSanitizeKeyName $ decodeBS $ keyName oldkey } | otherwise = return Nothing where migratable = oldvariety == newvariety diff --git a/Benchmark.hs b/Benchmark.hs new file mode 100644 --- /dev/null +++ b/Benchmark.hs @@ -0,0 +1,53 @@ +{- git-annex benchmark infrastructure + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Benchmark where + +import Common +import Types.Benchmark +import Types.Command +import CmdLine.Action +import CmdLine +import CmdLine.GitAnnex.Options +import qualified Annex +import qualified Annex.Branch +import Annex.Action + +import qualified Options.Applicative as O + +{- Given a list of all git-annex Commands, and the user's input, + - generates an IO action to benchmark that runs the specified + - commands. -} +mkGenerator :: MkBenchmarkGenerator +mkGenerator cmds userinput = do + -- Get the git-annex branch updated, to avoid the overhead of doing + -- so skewing the runtime of the first action that will be + -- benchmarked. + Annex.Branch.commit "benchmarking" + Annex.Branch.update + l <- mapM parsesubcommand $ split [";"] userinput + return $ do + forM_ l $ \(cmd, seek, st) -> + -- The cmd is run for benchmarking without startup or + -- shutdown actions. + Annex.eval st $ performCommandAction cmd seek noop + -- Since the cmd will be run many times, some zombie + -- processes that normally only occur once per command + -- will build up; reap them. + reapZombies + where + -- Simplified versio of CmdLine.dispatch, without support for fuzzy + -- matching or out-of-repo commands. + parsesubcommand ps = do + (cmd, seek, globalconfig) <- liftIO $ O.handleParseResult $ + parseCmd "git-annex" "benchmarking" gitAnnexGlobalOptions ps cmds cmdparser + -- Make an entirely separate Annex state for each subcommand, + -- and prepare it to run the cmd. + st <- liftIO . Annex.new =<< Annex.getState Annex.repo + ((), st') <- liftIO $ Annex.run st $ + prepRunCommand cmd globalconfig + return (cmd, seek, st') diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,52 @@ +git-annex (7.20190122) upstream; urgency=medium + + * sync --content: Fix dropping unwanted content from the local repository. + * sync --content: Support dropping local content that has reached an + exporttree remote that is not untrusted (currently only S3 remotes + with versioning). + * init: When --version=5 is passed on a crippled filesystem, + use a v5 direct mode repo as requested, rather than upgrading to v7 + adjusted unlocked. (Fixes test suite on crippled filesystems.) + * Some optimisations, including a 10x faster timestamp parser, + a 7x faster key parser, and improved parsing and serialization of + git-annex branch data. Many commands will run 5-15% faster. + * Stricter parser for keys doesn't allow doubled fields or out of order fields. + * The benchmark command, which only had some old benchmarking of the sqlite + databases before, now allows benchmarking any other git-annex commands. + * Support being built with ghc 8.6.3 (MonadFail). + * Removed old code that cleaned up after a bug in git-annex versions + 3.20111105-3.20111110. In the unlikely event that a repo was + last touched by that ancient git-annex version, the descriptions + of remotes would appear missing when used with this version of + git-annex. + * Improve uuid.log parser to preserve whitespace in repo descriptions. + * Improve activity.log parser to not remove unknown values, + allowing for future expansion. + * addunused, merge, assistant: Avoid creating work tree files in + subdirectories in an edge case where the key contains "/". + * testremote: Support testing readonly remotes with the --test-readonly option. + * Switch to using .git/annex/othertmp for tmp files other than partial + downloads, and make stale files left in that directory when git-annex + is interrupted be cleaned up promptly by subsequent git-annex processes. + * The .git/annex/misctmp directory is no longer used and git-annex will + delete anything lingering in there after it's 1 week old. + * Estimated time to completion display shortened from eg "1h1m1s" to "1h1m". + * Fix doubled progress display when downloading an url when -J is used. + * unused: Update suggested git log message to see where data was previously + used so it will also work with v7 unlocked pointer files. + * importfeed: Better error message when downloading the feed fails. + * Make test suite work better when the temp directory is on NFS. + * webapp: Remove configurator for box.com repository, since their + webdav support is going away at the end of this January. + * webapp: Remove configurator for gitlab, which stopped supporting git-annex + some time ago. + * Android: For armv71 architecture, use the armel build. + * Windows: If 64 bit git is installed, use it when installing git-annex. + (However, rsync still won't work and this is still not the documented way + to install it.) + + -- Joey Hess Tue, 22 Jan 2019 12:25:26 -0400 + git-annex (7.20181211) upstream; urgency=medium * S3: Improve diagnostics when a remote is configured with exporttree and diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -2,7 +2,7 @@ Source: native package Files: * -Copyright: © 2010-2018 Joey Hess +Copyright: © 2010-2019 Joey Hess License: GPL-3+ Files: Assistant/WebApp.hs Assistant/WebApp/* templates/* static/* @@ -30,7 +30,7 @@ License: Expat Files: Utility/* -Copyright: 2012-2018 Joey Hess +Copyright: 2012-2019 Joey Hess License: BSD-2-clause Files: doc/logo* */favicon.ico standalone/osx/git-annex.app/Contents/Resources/git-annex.icns @@ -80,38 +80,6 @@ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -Files: Logs/Line.hs -Copyright: 2001, The University Court of the University of Glasgow. -License: ghc-license - All rights reserved. - . - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - . - - Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - . - - 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. - . - - Neither name of the University nor the names of its contributors may be - used to endorse or promote products derived from this software without - specific prior written permission. - . - THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF - GLASGOW AND 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 - UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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: GPL-3+ The full text of version 3 of the GPL is distributed as doc/license/GPL in diff --git a/CmdLine.hs b/CmdLine.hs --- a/CmdLine.hs +++ b/CmdLine.hs @@ -8,6 +8,8 @@ module CmdLine ( dispatch, usage, + parseCmd, + prepRunCommand, ) where import qualified Options.Applicative as O @@ -39,13 +41,7 @@ (cmd, seek, globalconfig) <- parsewith False cmdparser (\a -> inRepo $ a . Just) (liftIO . O.handleParseResult) - when (cmdnomessages cmd) $ do - Annex.setOutput QuietOutput - Annex.changeState $ \s -> s - { Annex.output = (Annex.output s) { implicitMessages = False } } - getParsed globalconfig - whenM (annexDebug <$> Annex.getGitConfig) $ - liftIO enableDebugOutput + prepRunCommand cmd globalconfig startup performCommandAction cmd seek $ shutdown $ cmdnocommit cmd @@ -123,3 +119,13 @@ inexactcmds = case name of Nothing -> [] Just n -> Git.AutoCorrect.fuzzymatches n cmdname cmds + +prepRunCommand :: Command -> GlobalSetter -> Annex () +prepRunCommand cmd globalconfig = do + when (cmdnomessages cmd) $ do + Annex.setOutput QuietOutput + Annex.changeState $ \s -> s + { Annex.output = (Annex.output s) { implicitMessages = False } } + getParsed globalconfig + whenM (annexDebug <$> Annex.getGitConfig) $ + liftIO enableDebugOutput diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -1,6 +1,6 @@ {- git-annex main program - - - Copyright 2010-2015 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -16,6 +16,7 @@ import Annex.Ssh import Annex.Multicast import Types.Test +import Types.Benchmark import qualified Command.Help import qualified Command.Add @@ -119,12 +120,10 @@ import qualified Command.Test import qualified Command.FuzzTest import qualified Command.TestRemote -#ifdef WITH_BENCHMARK import qualified Command.Benchmark -#endif -cmds :: Parser TestOptions -> TestRunner -> [Command] -cmds testoptparser testrunner = +cmds :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [Command] +cmds testoptparser testrunner mkbenchmarkgenerator = [ Command.Help.cmd , Command.Add.cmd , Command.Get.cmd @@ -228,16 +227,15 @@ , Command.Test.cmd testoptparser testrunner , Command.FuzzTest.cmd , Command.TestRemote.cmd -#ifdef WITH_BENCHMARK - , Command.Benchmark.cmd -#endif + , Command.Benchmark.cmd $ + mkbenchmarkgenerator $ cmds testoptparser testrunner (\_ _ -> return noop) ] -run :: Parser TestOptions -> TestRunner -> [String] -> IO () -run testoptparser testrunner args = go envmodes +run :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [String] -> IO () +run testoptparser testrunner mkbenchmarkgenerator args = go envmodes where go [] = dispatch True args - (cmds testoptparser testrunner) + (cmds testoptparser testrunner mkbenchmarkgenerator) gitAnnexGlobalOptions [] Git.CurrentRepo.get "git-annex" "manage files with git, without checking their contents in" diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -210,7 +210,7 @@ ) parseKey :: Monad m => String -> m Key -parseKey = maybe (fail "invalid key") return . file2key +parseKey = maybe (fail "invalid key") return . deserializeKey -- Options to match properties of annexed files. annexedMatchingOptions :: [GlobalOption] @@ -410,4 +410,4 @@ completeBackends :: HasCompleter f => Mod f a completeBackends = completeWith $ - map (formatKeyVariety . Backend.backendVariety) Backend.list + map (decodeBS . formatKeyVariety . Backend.backendVariety) Backend.list diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -158,7 +158,7 @@ withKeys :: (Key -> CommandSeek) -> CmdParams -> CommandSeek withKeys a l = seekActions $ return $ map (a . parse) l where - parse p = fromMaybe (giveup "bad key") $ file2key p + parse p = fromMaybe (giveup "bad key") $ deserializeKey p withNothing :: CommandSeek -> CmdParams -> CommandSeek withNothing a [] = a diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -150,7 +150,7 @@ cleanup :: Key -> Bool -> CommandCleanup cleanup key hascontent = do - maybeShowJSON $ JSONChunk [("key", key2file key)] + maybeShowJSON $ JSONChunk [("key", serializeKey key)] when hascontent $ logStatus key InfoPresent return True diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -32,7 +32,7 @@ addLink file key Nothing return True where - file = "unused." ++ key2file key + file = "unused." ++ 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 @@ -28,7 +28,6 @@ import Annex.FileMatcher import Logs.Location import Utility.Metered -import Utility.FileSystemEncoding import Utility.HtmlDetect import Utility.Path.Max import qualified Annex.Transfer as Transfer @@ -401,7 +400,7 @@ else void $ Command.Add.addSmall file where go = do - maybeShowJSON $ JSONChunk [("key", key2file key)] + maybeShowJSON $ JSONChunk [("key", serializeKey key)] setUrlPresent key url logChange key u InfoPresent ifM (addAnnexedFile file key mtmp) diff --git a/Command/Benchmark.hs b/Command/Benchmark.hs --- a/Command/Benchmark.hs +++ b/Command/Benchmark.hs @@ -1,123 +1,49 @@ {- git-annex benchmark - - - Copyright 2016 Joey Hess + - Copyright 2016-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} module Command.Benchmark where import Command -import Database.Types -import qualified Database.Keys.SQL as SQL -import qualified Database.Queue as H -import Utility.Tmp -import Git.FilePath +import Types.Benchmark +#ifdef WITH_BENCHMARK import Criterion.Main -import Criterion.Internal (runAndAnalyse) -import Criterion.Monad -import Control.Monad.IO.Class (liftIO) -import Control.Monad -import Control.DeepSeq -import System.FilePath -import System.Random - -cmd :: Command -cmd = noRepo (withParams benchmark) $ - dontCheck repoExists $ - command "benchmark" SectionTesting - "run benchmarks" - paramNothing - (withParams (liftIO . benchmark)) - -benchmark :: CmdParams -> IO () -benchmark _ = withTmpDirIn "." "benchmark" $ \tmpdir -> do - -- benchmark different sizes of databases - dbs <- mapM (benchDb tmpdir) - [ 1000 - , 10000 - -- , 100000 - ] - runCriterion $ - bgroup "keys database" $ flip concatMap dbs $ \db -> - [ getAssociatedFilesHitBench db - , getAssociatedFilesMissBench db - , getAssociatedKeyHitBench db - , getAssociatedKeyMissBench db - , addAssociatedFileOldBench db - , addAssociatedFileNewBench db - ] - -getAssociatedFilesHitBench :: BenchDb -> Benchmark -getAssociatedFilesHitBench ( BenchDb h num) = bench ("getAssociatedFiles from " ++ show num ++ " (hit)") $ nfIO $ do - n <- getStdRandom (randomR (1,num)) - SQL.getAssociatedFiles (keyN n) (SQL.ReadHandle h) - -getAssociatedFilesMissBench :: BenchDb -> Benchmark -getAssociatedFilesMissBench ( BenchDb h num) = bench ("getAssociatedFiles from " ++ show num ++ " (miss)") $ nfIO $ - SQL.getAssociatedFiles keyMiss (SQL.ReadHandle h) - -getAssociatedKeyHitBench :: BenchDb -> Benchmark -getAssociatedKeyHitBench (BenchDb h num) = bench ("getAssociatedKey from " ++ show num ++ " (hit)") $ nfIO $ do - n <- getStdRandom (randomR (1,num)) - SQL.getAssociatedKey (fileN n) (SQL.ReadHandle h) - -getAssociatedKeyMissBench :: BenchDb -> Benchmark -getAssociatedKeyMissBench (BenchDb h num) = bench ("getAssociatedKey from " ++ show num ++ " (miss)") $ nfIO $ - SQL.getAssociatedKey fileMiss (SQL.ReadHandle h) - -addAssociatedFileOldBench :: BenchDb -> Benchmark -addAssociatedFileOldBench ( BenchDb h num) = bench ("addAssociatedFile to " ++ show num ++ " (old)") $ nfIO $ do - n <- getStdRandom (randomR (1,num)) - SQL.addAssociatedFile (keyN n) (fileN n) (SQL.WriteHandle h) - H.flushDbQueue h - -addAssociatedFileNewBench :: BenchDb -> Benchmark -addAssociatedFileNewBench ( BenchDb h num) = bench ("addAssociatedFile to " ++ show num ++ " (new)") $ nfIO $ do - n <- getStdRandom (randomR (1,num)) - SQL.addAssociatedFile (keyN n) (fileN (n+1)) (SQL.WriteHandle h) - H.flushDbQueue h - -populateAssociatedFiles :: H.DbQueue -> Int -> IO () -populateAssociatedFiles h num = do - forM_ [1..num] $ \n -> - SQL.addAssociatedFile (keyN n) (fileN n) (SQL.WriteHandle h) - H.flushDbQueue h - -keyN :: Int -> IKey -keyN n = IKey ("key" ++ show n) - -fileN :: Int -> TopFilePath -fileN n = asTopFilePath ("file" ++ show n) - -keyMiss :: IKey -keyMiss = keyN 0 -- 0 is never stored +import Criterion.Main.Options (parseWith, Mode) +#endif -fileMiss :: TopFilePath -fileMiss = fileN 0 -- 0 is never stored +cmd :: BenchmarkGenerator -> Command +cmd generator = command "benchmark" SectionTesting + "benchmark git-annex commands" + paramNothing + (seek generator <$$> optParser) -data BenchDb = BenchDb H.DbQueue Int +#ifndef WITH_BENCHMARK +type Mode = () +#endif -benchDb :: FilePath -> Int -> IO BenchDb -benchDb tmpdir num = do - putStrLn $ "setting up database with " ++ show num - H.initDb f SQL.createTables - h <- H.openDbQueue f SQL.containedTable - populateAssociatedFiles h num - return (BenchDb h num) - where - f = tmpdir "db" ++ show num +data BenchmarkOptions = BenchmarkOptions CmdParams Mode -instance NFData TopFilePath where - rnf = rnf . getTopFilePath +optParser :: CmdParamsDesc -> Parser BenchmarkOptions +optParser desc = BenchmarkOptions + <$> cmdParams desc +#ifdef WITH_BENCHMARK + -- parse criterion's options + <*> parseWith defaultConfig +#else + <*> pure () +#endif -instance NFData IKey where - rnf (IKey s) = rnf s - --- can't use Criterion's defaultMain here because it looks at --- command-line parameters -runCriterion :: Benchmark -> IO () -runCriterion = withConfig defaultConfig . runAndAnalyse (const True) +seek :: BenchmarkGenerator -> BenchmarkOptions -> CommandSeek +#ifdef WITH_BENCHMARK +seek generator (BenchmarkOptions ps mode) = do + runner <- generator ps + liftIO $ runMode mode [ bench (unwords ps) $ nfIO runner ] +#else +seek _ _ = giveup "git-annex is not built with benchmarking support" +#endif diff --git a/Command/CalcKey.hs b/Command/CalcKey.hs --- a/Command/CalcKey.hs +++ b/Command/CalcKey.hs @@ -14,13 +14,13 @@ cmd :: Command cmd = noCommit $ noMessages $ dontCheck repoExists $ command "calckey" SectionPlumbing - "calculates the key that would be used to refer to a file" + "calulate key for a file" (paramRepeating paramFile) (batchable run (pure ())) run :: () -> String -> Annex Bool run _ file = genKey (KeySource file file Nothing) Nothing >>= \case Just (k, _) -> do - liftIO $ putStrLn $ key2file k + liftIO $ putStrLn $ serializeKey k return True Nothing -> return False diff --git a/Command/CheckPresentKey.hs b/Command/CheckPresentKey.hs --- a/Command/CheckPresentKey.hs +++ b/Command/CheckPresentKey.hs @@ -69,7 +69,7 @@ batchResult _ = liftIO $ putStrLn "0" toKey :: String -> Key -toKey = fromMaybe (giveup "Bad key") . file2key +toKey = fromMaybe (giveup "Bad key") . deserializeKey toRemote :: String -> Annex Remote toRemote rn = maybe (giveup "Unknown remote") return diff --git a/Command/ContentLocation.hs b/Command/ContentLocation.hs --- a/Command/ContentLocation.hs +++ b/Command/ContentLocation.hs @@ -19,7 +19,7 @@ run :: () -> String -> Annex Bool run _ p = do - let k = fromMaybe (giveup "bad key") $ file2key p + let k = fromMaybe (giveup "bad key") $ deserializeKey p maybe (return False) (\f -> liftIO (putStrLn f) >> return True) =<< inAnnex' (pure True) Nothing check k where diff --git a/Command/Dead.hs b/Command/Dead.hs --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -33,7 +33,7 @@ startKey :: Key -> CommandStart startKey key = do - showStart' "dead" (Just $ key2file key) + showStart' "dead" (Just $ serializeKey key) keyLocations key >>= \case [] -> next $ performKey key _ -> giveup "This key is still known to be present in some locations; not marking as dead." diff --git a/Command/Describe.hs b/Command/Describe.hs --- a/Command/Describe.hs +++ b/Command/Describe.hs @@ -29,5 +29,5 @@ perform :: UUID -> String -> CommandPerform perform u description = do - describeUUID u description + describeUUID u (toUUIDDesc description) next $ return True diff --git a/Command/DiffDriver.hs b/Command/DiffDriver.hs --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -88,7 +88,7 @@ check getfile getmode setfile r = case readTreeItemType (getmode r) of Just TreeSymlink -> do v <- getAnnexLinkTarget' (getfile r) False - case fileKey . takeFileName =<< v of + case parseLinkTargetOrPointer =<< v of Nothing -> return r Just k -> setfile r <$> withObjectLoc k diff --git a/Command/DropKey.hs b/Command/DropKey.hs --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -38,7 +38,7 @@ Batch fmt -> batchInput fmt parsekey $ batchCommandAction . start NoBatch -> noop where - parsekey = maybe (Left "bad key") Right . file2key + parsekey = maybe (Left "bad key") Right . deserializeKey start :: Key -> CommandStart start key = do diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -100,7 +100,9 @@ unknownNameError :: String -> Annex a unknownNameError prefix = do m <- Annex.SpecialRemote.specialRemoteMap - descm <- M.unionWith Remote.addName <$> uuidMap <*> pure m + descm <- M.unionWith Remote.addName + <$> uuidDescMap + <*> pure (M.map toUUIDDesc m) specialmsg <- if M.null m then pure "(No special remotes are currently known; perhaps use initremote instead?)" else Remote.prettyPrintUUIDsDescs diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -21,6 +21,6 @@ run :: Maybe Utility.Format.Format -> String -> Annex Bool run format p = do - let k = fromMaybe (giveup "bad key") $ file2key p - showFormatted format (key2file k) (keyVars k) + let k = fromMaybe (giveup "bad key") $ deserializeKey p + showFormatted format (serializeKey k) (keyVars k) return True diff --git a/Command/Expire.hs b/Command/Expire.hs --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -51,11 +51,11 @@ expire <- parseExpire (expireParams o) actlog <- lastActivities (activityOption o) u <- getUUID - us <- filter (/= u) . M.keys <$> uuidMap - descs <- uuidMap + us <- filter (/= u) . M.keys <$> uuidDescMap + descs <- uuidDescMap commandActions $ map (start expire (noActOption o) actlog descs) us -start :: Expire -> Bool -> Log Activity -> M.Map UUID String -> UUID -> CommandStart +start :: Expire -> Bool -> Log Activity -> UUIDDescMap -> UUID -> CommandStart start (Expire expire) noact actlog descs u = case lastact of Just ent | notexpired ent -> checktrust (== DeadTrusted) $ do @@ -75,7 +75,7 @@ d <- liftIO $ durationSince $ posixSecondsToUTCTime c return $ "last active: " ++ fromDuration d ++ " ago" _ -> return "no activity" - desc = fromUUID u ++ " " ++ fromMaybe "" (M.lookup u descs) + desc = fromUUID u ++ " " ++ fromUUIDDesc (fromMaybe mempty (M.lookup u descs)) notexpired ent = case ent of Unknown -> False VectorClock c -> case lookupexpire of diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -66,7 +66,7 @@ -- to a stable temporary name based on the key. exportTempName :: ExportKey -> ExportLocation exportTempName ek = mkExportLocation $ - ".git-annex-tmp-content-" ++ key2file (asKey (ek)) + ".git-annex-tmp-content-" ++ serializeKey (asKey (ek)) seek :: ExportOptions -> CommandSeek seek o = do diff --git a/Command/Find.hs b/Command/Find.hs --- a/Command/Find.hs +++ b/Command/Find.hs @@ -88,11 +88,11 @@ keyVars :: Key -> [(String, String)] keyVars key = - [ ("key", key2file key) - , ("backend", formatKeyVariety $ keyVariety key) + [ ("key", serializeKey key) + , ("backend", decodeBS $ formatKeyVariety $ keyVariety key) , ("bytesize", size show) , ("humansize", size $ roughSize storageUnits True) - , ("keyname", keyName key) + , ("keyname", decodeBS $ keyName key) , ("hashdirlower", hashDirLower def key) , ("hashdirmixed", hashDirMixed def key) , ("mtime", whenavail show $ keyMtime key) diff --git a/Command/FromKey.hs b/Command/FromKey.hs --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -79,7 +79,7 @@ mkKey s = case parseURI s of Just u | not (isKeyPrefix (uriScheme u)) -> Backend.URL.fromUrl s Nothing - _ -> case file2key s of + _ -> case deserializeKey s of Just k -> k Nothing -> giveup $ "bad key/url " ++ s diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -205,8 +205,7 @@ check :: [Annex Bool] -> Annex Bool check cs = and <$> sequence cs -{- Checks that symlinks points correctly to the annexed content. - -} +{- Checks that symlinks points correctly to the annexed content. -} fixLink :: Key -> FilePath -> Annex Bool fixLink key file = do want <- calcRepo $ gitAnnexLink file key @@ -215,7 +214,7 @@ return True where go want have - | want /= fromInternalGitPath have = do + | want /= fromInternalGitPath (fromRawFilePath have) = do showNote "fixing link" liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ removeFile file @@ -250,7 +249,7 @@ - config was set. -} when (present && not (cryptographicallySecure (keyVariety key))) $ whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $ - warning $ "** Despite annex.securehashesonly being set, " ++ obj ++ " has content present in the annex using an insecure " ++ formatKeyVariety (keyVariety key) ++ " key" + warning $ "** Despite annex.securehashesonly being set, " ++ obj ++ " has content present in the annex using an insecure " ++ decodeBS (formatKeyVariety (keyVariety key)) ++ " key" {- In direct mode, modified files will show up as not present, - but that is expected and not something to do anything about. -} @@ -424,7 +423,7 @@ [ actionItemDesc ai key , ": Can be upgraded to an improved key format. " , "You can do so by running: git annex migrate --backend=" - , formatKeyVariety (keyVariety key) ++ " " + , decodeBS (formatKeyVariety (keyVariety key)) ++ " " , file ] return True @@ -498,7 +497,7 @@ checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool checkKeyNumCopies key afile numcopies = do let (desc, hasafile) = case afile of - AssociatedFile Nothing -> (key2file key, False) + AssociatedFile Nothing -> (serializeKey key, False) AssociatedFile (Just af) -> (af, True) locs <- loggedLocations key (untrustedlocations, otherlocations) <- trustPartition UnTrusted locs @@ -562,7 +561,7 @@ badContentRemote :: Remote -> FilePath -> Key -> Annex String badContentRemote remote localcopy key = do bad <- fromRepo gitAnnexBadDir - let destbad = bad key2file key + let destbad = bad keyFile key movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad)) ( return False , do diff --git a/Command/Group.hs b/Command/Group.hs --- a/Command/Group.hs +++ b/Command/Group.hs @@ -26,11 +26,13 @@ allowMessages showStart' "group" (Just name) u <- Remote.nameToUUID name - next $ setGroup u g + next $ setGroup u (toGroup g) start (name:[]) = do u <- Remote.nameToUUID name - liftIO . putStrLn . unwords . S.toList =<< lookupGroups u + liftIO . putStrLn . unwords . map fmt . S.toList =<< lookupGroups u stop + where + fmt (Group g) = decodeBS g start _ = giveup "Specify a repository and a group." setGroup :: UUID -> Group -> CommandPerform diff --git a/Command/GroupWanted.hs b/Command/GroupWanted.hs --- a/Command/GroupWanted.hs +++ b/Command/GroupWanted.hs @@ -10,6 +10,7 @@ import Command import Logs.PreferredContent import Command.Wanted (performGet, performSet) +import Types.Group cmd :: Command cmd = noMessages $ command "groupwanted" SectionSetup @@ -21,9 +22,9 @@ seek = withWords (commandAction . start) start :: [String] -> CommandStart -start (g:[]) = next $ performGet groupPreferredContentMapRaw g +start (g:[]) = next $ performGet groupPreferredContentMapRaw (toGroup g) start (g:expr:[]) = do allowMessages showStart' "groupwanted" (Just g) - next $ performSet groupPreferredContentSet expr g + next $ performSet groupPreferredContentSet expr (toGroup g) start _ = giveup "Specify a group." diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -86,7 +86,7 @@ ) where deletedup k = do - showNote $ "duplicate of " ++ key2file k + showNote $ "duplicate of " ++ serializeKey k verifyExisting k destfile ( do liftIO $ removeFile srcfile diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Command.ImportFeed where @@ -19,9 +20,7 @@ #if ! MIN_VERSION_time(1,5,0) import System.Locale #endif -#if MIN_VERSION_feed(1,0,0) import qualified Data.Text as T -#endif import Command import qualified Annex @@ -75,9 +74,10 @@ next $ perform opts cache url perform :: ImportFeedOptions -> Cache -> URLString -> CommandPerform -perform opts cache url = do - v <- findDownloads url - case v of +perform opts cache url = go =<< downloadFeed url + where + go Nothing = next $ feedProblem url "downloading the feed failed" + go (Just f) = case findDownloads url f of [] -> next $ feedProblem url "bad feed content; no enclosures to download" l -> do @@ -123,25 +123,23 @@ knownItems :: (Key, URLString) -> Annex ([ItemId], URLString) knownItems (k, u) = do - itemids <- S.toList . S.filter (/= noneValue) . S.map fromMetaValue + itemids <- S.toList . S.filter (/= noneValue) + . S.map (decodeBS . fromMetaValue) . currentMetaDataValues itemIdField <$> getCurrentMetaData k return (itemids, u) -findDownloads :: URLString -> Annex [ToDownload] -findDownloads u = go =<< downloadFeed u +findDownloads :: URLString -> Feed -> [ToDownload] +findDownloads u f = catMaybes $ map mk (feedItems f) where - go Nothing = pure [] - go (Just f) = catMaybes <$> mapM (mk f) (feedItems f) - - mk f i = case getItemEnclosure i of - Just (enclosureurl, _, _) -> return $ + mk i = case getItemEnclosure i of + Just (enclosureurl, _, _) -> Just $ ToDownload f u i $ Enclosure $ fromFeed enclosureurl Nothing -> case getItemLink i of - Just link -> return $ Just $ ToDownload f u i $ + Just link -> Just $ ToDownload f u i $ MediaLink $ fromFeed link - Nothing -> return Nothing + Nothing -> Nothing {- Feeds change, so a feed download cannot be resumed. -} downloadFeed :: URLString -> Annex (Maybe Feed) @@ -324,14 +322,14 @@ Just (Just d) -> unionMetaData meta (dateMetaData d meta) _ -> meta where - tometa (k, v) = (mkMetaFieldUnchecked k, S.singleton (toMetaValue v)) + tometa (k, v) = (mkMetaFieldUnchecked (T.pack k), S.singleton (toMetaValue (encodeBS v))) meta = MetaData $ M.fromList $ map tometa $ extractFields i minimalMetaData :: ToDownload -> MetaData minimalMetaData i = case getItemId (item i) of (Nothing) -> emptyMetaData (Just (_, itemid)) -> MetaData $ M.singleton itemIdField - (S.singleton $ toMetaValue $ fromFeed itemid) + (S.singleton $ toMetaValue $ encodeBS $ fromFeed itemid) {- Extract fields from the feed and item, that are both used as metadata, - and to generate the filename. -} diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -102,7 +102,7 @@ cmd :: Command cmd = noCommit $ withGlobalOptions [jsonOptions, annexedMatchingOptions] $ command "info" SectionQuery - "shows information about the specified item or the repository as a whole" + "information about an item or the repository" (paramRepeating paramItem) (seek <$$> optParser) data InfoOptions = InfoOptions @@ -326,7 +326,7 @@ repo_list :: TrustLevel -> Stat repo_list level = stat n $ nojson $ lift $ do us <- filter (/= NoUUID) . M.keys - <$> (M.union <$> uuidMap <*> remoteMap Remote.name) + <$> (M.union <$> (M.map fromUUIDDesc <$> uuidDescMap) <*> remoteMap Remote.name) rs <- fst <$> trustPartition level us countRepoList (length rs) -- This also handles json display. @@ -410,7 +410,7 @@ key_size k = simpleStat "size" $ showSizeKeys $ foldKeys [k] key_name :: Key -> Stat -key_name k = simpleStat "key" $ pure $ key2file k +key_name k = simpleStat "key" $ pure $ serializeKey k content_present :: Key -> Stat content_present k = stat "present" $ json boolConfig $ lift $ inAnnex k @@ -456,7 +456,7 @@ [ ("transfer", toJSON' (formatDirection (transferDirection t))) , ("key", toJSON' (transferKey t)) , ("file", toJSON' afile) - , ("remote", toJSON' (fromUUID (transferUUID t))) + , ("remote", toJSON' (fromUUID (transferUUID t) :: String)) ] where AssociatedFile afile = associatedFile i @@ -481,7 +481,7 @@ backend_usage :: Stat backend_usage = stat "backend usage" $ json fmt $ - ObjectMap . (M.mapKeys formatKeyVariety) . backendsKeys + ObjectMap . (M.mapKeys (decodeBS . formatKeyVariety)) . backendsKeys <$> cachedReferencedData where fmt = multiLine . map (\(b, n) -> b ++ ": " ++ show n) . sort . M.toList . fromObjectMap diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -59,6 +59,6 @@ cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup cleanup u name c = do - describeUUID u name + describeUUID u (toUUIDDesc name) Logs.Remote.configSet u c return True diff --git a/Command/List.hs b/Command/List.hs --- a/Command/List.hs +++ b/Command/List.hs @@ -61,10 +61,10 @@ let l = (hereu, "here", heretrust) : zip3 (map uuid rs) (map name rs) ts return $ filter (\(_, _, t) -> t /= DeadTrusted) l getAllUUIDs = do - rs <- M.toList <$> uuidMap - rs3 <- forM rs $ \(u, n) -> (,,) + rs <- M.toList <$> uuidDescMap + rs3 <- forM rs $ \(u, d) -> (,,) <$> pure u - <*> pure n + <*> pure (fromUUIDDesc d) <*> lookupTrust u return $ sortBy (comparing snd3) $ filter (\t -> thd3 t /= DeadTrusted) rs3 diff --git a/Command/LockContent.hs b/Command/LockContent.hs --- a/Command/LockContent.hs +++ b/Command/LockContent.hs @@ -32,7 +32,7 @@ then exitSuccess else exitFailure where - k = fromMaybe (giveup "bad key") (file2key ks) + k = fromMaybe (giveup "bad key") (deserializeKey ks) locksuccess = liftIO $ do putStrLn contentLockedMarker hFlush stdout diff --git a/Command/Log.hs b/Command/Log.hs --- a/Command/Log.hs +++ b/Command/Log.hs @@ -144,19 +144,19 @@ - as showLogIncremental. -} showLog :: (String -> Outputter) -> [RefChange] -> Annex () showLog outputter cs = forM_ cs $ \c -> do - let keyname = key2file (changekey c) + let keyname = serializeKey (changekey c) new <- S.fromList <$> loggedLocationsRef (newref c) old <- S.fromList <$> loggedLocationsRef (oldref c) sequence_ $ compareChanges (outputter keyname) [(changetime c, new, old)] -mkOutputter :: M.Map UUID String -> TimeZone -> LogOptions -> FilePath -> Outputter +mkOutputter :: UUIDDescMap -> TimeZone -> LogOptions -> FilePath -> Outputter mkOutputter m zone o file | rawDateOption o = normalOutput lookupdescription file show | gourceOption o = gourceOutput lookupdescription file | otherwise = normalOutput lookupdescription file (showTimeStamp zone) where - lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m + lookupdescription u = maybe (fromUUID u) (fromUUIDDesc) (M.lookup u m) normalOutput :: (UUID -> String) -> FilePath -> (POSIXTime -> String) -> Outputter normalOutput lookupdescription file formattime logchange ts us = diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -23,7 +23,7 @@ Nothing -> return False Just file' -> catKeyFile file' >>= \case Just k -> do - liftIO $ putStrLn $ key2file k + liftIO $ putStrLn $ serializeKey k return True Nothing -> return False diff --git a/Command/Map.hs b/Command/Map.hs --- a/Command/Map.hs +++ b/Command/Map.hs @@ -43,7 +43,7 @@ start = do rs <- combineSame <$> (spider =<< gitRepo) - umap <- uuidMap + umap <- uuidDescMap trustmap <- trustMapLoad file <- () <$> fromRepo gitAnnexDir <*> pure "map.dot" @@ -79,7 +79,7 @@ - the repositories first, followed by uuids that were not matched - to a repository. -} -drawMap :: [RepoRemotes] -> TrustMap -> M.Map UUID String -> String +drawMap :: [RepoRemotes] -> TrustMap -> UUIDDescMap -> String drawMap rs trustmap umap = Dot.graph $ repos ++ others where repos = map (node umap (map fst rs) trustmap) rs @@ -88,7 +88,9 @@ filter (\u -> M.lookup u trustmap /= Just DeadTrusted) $ filter (`notElem` ruuids) (M.keys umap) uuidnode u = trustDecorate trustmap u $ - Dot.graphNode (fromUUID u) $ M.findWithDefault "" u umap + Dot.graphNode + (fromUUID u) + (fromUUIDDesc $ M.findWithDefault mempty u umap) hostname :: Git.Repo -> String hostname r @@ -100,10 +102,10 @@ {- A name to display for a repo. Uses the name from uuid.log if available, - or the remote name if not. -} -repoName :: M.Map UUID String -> Git.Repo -> String +repoName :: UUIDDescMap -> Git.Repo -> String repoName umap r | repouuid == NoUUID = fallback - | otherwise = M.findWithDefault fallback repouuid umap + | otherwise = maybe fallback fromUUIDDesc $ M.lookup repouuid umap where repouuid = getUncachedUUID r fallback = fromMaybe "unknown" $ Git.remoteName r @@ -113,10 +115,10 @@ nodeId r = case getUncachedUUID r of NoUUID -> Git.repoLocation r - UUID u -> u + u@(UUID _) -> fromUUID u {- A node representing a repo. -} -node :: M.Map UUID String -> [Git.Repo] -> TrustMap -> RepoRemotes -> String +node :: UUIDDescMap -> [Git.Repo] -> TrustMap -> RepoRemotes -> String node umap fullinfo trustmap (r, rs) = unlines $ n:edges where n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $ @@ -125,7 +127,7 @@ edges = map (edge umap fullinfo r) rs {- An edge between two repos. The second repo is a remote of the first. -} -edge :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> Git.Repo -> String +edge :: UUIDDescMap -> [Git.Repo] -> Git.Repo -> Git.Repo -> String edge umap fullinfo from to = Dot.graphEdge (nodeId from) (nodeId fullto) edgename where diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -20,6 +20,7 @@ import qualified Data.Set as S import qualified Data.Map as M import qualified Data.Text as T +import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.UTF8 as BU import Control.Concurrent @@ -45,7 +46,7 @@ <*> optional parseKeyOptions <*> parseBatchOption where - getopt = option (eitherReader mkMetaField) + getopt = option (eitherReader (mkMetaField . T.pack)) ( long "get" <> short 'g' <> metavar paramField <> help "get single metadata field" ) @@ -53,15 +54,15 @@ ( long "set" <> short 's' <> metavar "FIELD[+-]=VALUE" <> help "set or unset metadata value" ) - <|> (AddMeta tagMetaField . toMetaValue <$> strOption + <|> (AddMeta tagMetaField . toMetaValue . encodeBS <$> strOption ( long "tag" <> short 't' <> metavar "TAG" <> help "set a tag" )) - <|> (DelMeta tagMetaField . Just . toMetaValue <$> strOption + <|> (DelMeta tagMetaField . Just . toMetaValue . encodeBS <$> strOption ( long "untag" <> short 'u' <> metavar "TAG" <> help "remove a tag" )) - <|> option (eitherReader (\f -> DelMeta <$> mkMetaField f <*> pure Nothing)) + <|> option (eitherReader (\f -> DelMeta <$> mkMetaField (T.pack f) <*> pure Nothing)) ( long "remove" <> short 'r' <> metavar "FIELD" <> help "remove all values of a field" ) @@ -101,7 +102,7 @@ Get f -> do l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k liftIO $ forM_ l $ - putStrLn . fromMetaValue + B8.putStrLn . fromMetaValue stop _ -> do showStartKey "metadata" k ai @@ -126,7 +127,7 @@ return True where unwrapmeta (f, v) = (fromMetaField f, map fromMetaValue (S.toList v)) - showmeta (f, vs) = map ((f ++ "=") ++) vs + showmeta (f, vs) = map ((T.unpack f ++ "=") ++) (map decodeBS vs) -- Metadata serialized to JSON in the field named "fields" of -- a larger object. diff --git a/Command/Multicast.hs b/Command/Multicast.hs --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -208,7 +208,7 @@ storeReceived :: FilePath -> Annex () storeReceived f = do - case file2key (takeFileName f) of + case deserializeKey (takeFileName f) of Nothing -> do warning $ "Received a file " ++ f ++ " that is not a git-annex key. Deleting this file." liftIO $ nukeFile f diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -29,6 +29,7 @@ import qualified Git.LsFiles as Git import qualified Data.Set as S +import qualified Data.Text as T cmd :: Command cmd = command "pre-commit" SectionPlumbing @@ -111,7 +112,7 @@ showMetaDataChange = showLongNote . unlines . concatMap showmeta . fromMetaData where showmeta (f, vs) = map (showmetavalue f) $ S.toList vs - showmetavalue f v = fromMetaField f ++ showset v ++ "=" ++ fromMetaValue v + showmetavalue f v = T.unpack (fromMetaField f) <> showset v <> "=" <> decodeBS (fromMetaValue v) showset v | isSet v = "+" | otherwise = "-" diff --git a/Command/Proxy.hs b/Command/Proxy.hs --- a/Command/Proxy.hs +++ b/Command/Proxy.hs @@ -12,6 +12,7 @@ import Utility.Tmp.Dir import Utility.Env import Annex.Direct +import Annex.Tmp import qualified Git import qualified Git.Sha import qualified Git.Ref @@ -32,9 +33,7 @@ start :: [String] -> CommandStart start [] = giveup "Did not specify command to run." start (c:ps) = liftIO . exitWith =<< ifM isDirect - ( do - tmp <- gitAnnexTmpMiscDir <$> gitRepo - withTmpDirIn tmp "proxy" go + ( withOtherTmp $ \tmp -> withTmpDirIn tmp "proxy" go , liftIO $ safeSystem c (map Param ps) ) where diff --git a/Command/ReKey.hs b/Command/ReKey.hs --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -43,7 +43,7 @@ batchParser s = case separate (== ' ') (reverse s) of (rk, rf) | null rk || null rf -> Left "Expected: \"file key\"" - | otherwise -> case file2key (reverse rk) of + | otherwise -> case deserializeKey (reverse rk) of Nothing -> Left "bad key" Just k -> Right (reverse rf, k) @@ -53,7 +53,7 @@ NoBatch -> withPairs (commandAction . start . parsekey) (reKeyThese o) where parsekey (file, skey) = - (file, fromMaybe (giveup "bad key") (file2key skey)) + (file, fromMaybe (giveup "bad key") (deserializeKey skey)) start :: (FilePath, Key) -> CommandStart start (file, newkey) = ifAnnexed file go stop diff --git a/Command/ReadPresentKey.hs b/Command/ReadPresentKey.hs --- a/Command/ReadPresentKey.hs +++ b/Command/ReadPresentKey.hs @@ -27,5 +27,5 @@ then liftIO exitSuccess else liftIO exitFailure where - k = fromMaybe (giveup "bad key") (file2key ks) + k = fromMaybe (giveup "bad key") (deserializeKey ks) start _ = giveup "Wrong number of parameters" diff --git a/Command/SetKey.hs b/Command/SetKey.hs --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -26,7 +26,7 @@ start _ = giveup "specify a key and a content file" mkKey :: String -> Key -mkKey = fromMaybe (giveup "bad key") . file2key +mkKey = fromMaybe (giveup "bad key") . deserializeKey perform :: FilePath -> Key -> CommandPerform perform file key = do diff --git a/Command/SetPresentKey.hs b/Command/SetPresentKey.hs --- a/Command/SetPresentKey.hs +++ b/Command/SetPresentKey.hs @@ -40,7 +40,7 @@ parseKeyStatus :: [String] -> Either String KeyStatus parseKeyStatus (ks:us:vs:[]) = do - k <- maybe (Left "bad key") Right (file2key ks) + k <- maybe (Left "bad key") Right (deserializeKey ks) let u = toUUID us s <- maybe (Left "bad value") Right (parseStatus vs) return $ KeyStatus k u s diff --git a/Command/Smudge.hs b/Command/Smudge.hs --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -22,7 +22,8 @@ import qualified Git.Ref import Backend -import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L cmd :: Command cmd = noCommit $ noMessages $ @@ -62,14 +63,14 @@ -- smudge filter in memory, which is a problem with large files. smudge :: FilePath -> CommandStart smudge file = do - b <- liftIO $ B.hGetContents stdin - case parseLinkOrPointer b of + b <- liftIO $ L.hGetContents stdin + case parseLinkTargetOrPointerLazy b of Nothing -> noop Just k -> do topfile <- inRepo (toTopFilePath file) Database.Keys.addAssociatedFile k topfile void $ smudgeLog k topfile - liftIO $ B.putStr b + liftIO $ L.putStr b stop -- Clean filter is fed file content on stdin, decides if a file @@ -77,13 +78,13 @@ -- injested content if so. Otherwise, the original content. clean :: FilePath -> CommandStart clean file = do - b <- liftIO $ B.hGetContents stdin + b <- liftIO $ L.hGetContents stdin ifM fileoutsiderepo - ( liftIO $ B.hPut stdout b - , case parseLinkOrPointer b of + ( liftIO $ L.hPut stdout b + , case parseLinkTargetOrPointerLazy b of Just k -> do getMoveRaceRecovery k file - liftIO $ B.hPut stdout b + liftIO $ L.hPut stdout b Nothing -> go b =<< catKeyFile file ) stop @@ -97,7 +98,7 @@ -- to free memory when sending the file, so the -- less we let it send, the less memory it will waste.) if Git.BuildVersion.older "2.5" - then B.length b `seq` return () + then L.length b `seq` return () else liftIO $ hClose stdin -- Optimization for the case when the file is already @@ -108,7 +109,7 @@ ( liftIO $ emitPointer ko , doingest oldkey ) - , liftIO $ B.hPut stdout b + , liftIO $ L.hPut stdout b ) doingest oldkey = do @@ -158,7 +159,7 @@ Nothing -> isNothing <$> catObjectMetaData (Git.Ref.fileRef file) emitPointer :: Key -> IO () -emitPointer = putStr . formatPointer +emitPointer = S.putStr . formatPointer -- Recover from a previous race between eg git mv and git-annex get. -- That could result in the file remaining a pointer file, while diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -166,9 +166,9 @@ remotes <- syncRemotes (syncWith o) let gitremotes = filter Remote.gitSyncableRemote remotes - (exportremotes, dataremotes) <- partition (exportTree . Remote.config) - . filter (\r -> Remote.uuid r /= NoUUID) + dataremotes <- filter (\r -> Remote.uuid r /= NoUUID) <$> filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) remotes + let exportremotes = filter (exportTree . Remote.config) dataremotes if cleanupOption o then do @@ -187,8 +187,11 @@ ] whenM shouldsynccontent $ do - syncedcontent <- withbranch $ seekSyncContent o dataremotes + -- Send content to any exports first, in + -- case that lets content be dropped from + -- other repositories. exportedcontent <- withbranch $ seekExportContent exportremotes + syncedcontent <- withbranch $ seekSyncContent o dataremotes -- Transferring content can take a while, -- and other changes can be pushed to the -- git-annex branch on the remotes in the @@ -293,8 +296,8 @@ commitMsg :: Annex String commitMsg = do u <- getUUID - m <- uuidMap - return $ "git-annex in " ++ fromMaybe "unknown" (M.lookup u m) + m <- uuidDescMap + return $ "git-annex in " ++ maybe "unknown" fromUUIDDesc (M.lookup u m) commitStaged :: Git.Branch.CommitMode -> String -> Annex Bool commitStaged commitmode commitmessage = do @@ -618,14 +621,15 @@ -} syncFile :: Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> AssociatedFile -> Key -> Annex Bool syncFile ebloom rs af k = onlyActionOn' k $ do + inhere <- inAnnex k locs <- map Remote.uuid <$> Remote.keyPossibilities k let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs - got <- anyM id =<< handleget have + got <- anyM id =<< handleget have inhere putrs <- handleput lack u <- getUUID - let locs' = concat [[u | got], putrs, locs] + let locs' = concat [if inhere || got then [u] else [], putrs, locs] -- A bloom filter is populated with all the keys in the first pass. -- On the second pass, avoid dropping keys that were seen in the @@ -649,12 +653,12 @@ return (got || not (null putrs)) where - wantget have = allM id + wantget have inhere = allM id [ pure (not $ null have) - , not <$> inAnnex k + , pure (not inhere) , wantGet True (Just k) af ] - handleget have = ifM (wantget have) + handleget have inhere = ifM (wantget have inhere) ( return [ get have ] , return [] ) diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2014 Joey Hess + - Copyright 2014-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -14,7 +14,9 @@ import qualified Types.Backend as Backend import Types.KeySource import Annex.Content +import Annex.WorkTree import Backend +import Logs.Location import qualified Backend.Hash import Utility.Tmp import Utility.Metered @@ -42,6 +44,7 @@ data TestRemoteOptions = TestRemoteOptions { testRemote :: RemoteName , sizeOption :: ByteSize + , testReadonlyFile :: [FilePath] } optParser :: CmdParamsDesc -> Parser TestRemoteOptions @@ -52,22 +55,43 @@ <> value (1024 * 1024) <> help "base key size (default 1MiB)" ) + <*> many testreadonly + where + testreadonly = option str + ( long "test-readonly" <> metavar paramFile + <> help "readonly test object" + ) seek :: TestRemoteOptions -> CommandSeek -seek o = commandAction $ start (fromInteger $ sizeOption o) (testRemote o) +seek = commandAction . start -start :: Int -> RemoteName -> CommandStart -start basesz name = do - showStart' "testremote" (Just name) +start :: TestRemoteOptions -> CommandStart +start o = do + showStart' "testremote" (Just (testRemote o)) fast <- Annex.getState Annex.fast - r <- either giveup disableExportTree =<< Remote.byName' name - rs <- catMaybes <$> mapM (adjustChunkSize r) (chunkSizes basesz fast) - rs' <- concat <$> mapM encryptionVariants rs - unavailrs <- catMaybes <$> mapM Remote.mkUnavailable [r] - exportr <- exportTreeVariant r - showAction "generating test keys" - ks <- mapM randKey (keySizes basesz fast) - next $ perform rs' unavailrs exportr ks + r <- either giveup disableExportTree =<< Remote.byName' (testRemote o) + ks <- case testReadonlyFile o of + [] -> if Remote.readonly r + then giveup "This remote is readonly, so you need to use the --test-readonly option." + else do + showAction "generating test keys" + mapM randKey (keySizes basesz fast) + fs -> mapM (getReadonlyKey r) fs + let r' = if null (testReadonlyFile o) + then r + else r { Remote.readonly = True } + rs <- if Remote.readonly r' + then return [r'] + else do + rs <- catMaybes <$> mapM (adjustChunkSize r') (chunkSizes basesz fast) + concat <$> mapM encryptionVariants rs + unavailrs <- catMaybes <$> mapM Remote.mkUnavailable [r'] + exportr <- if Remote.readonly r' + then return Nothing + else exportTreeVariant r' + next $ perform rs unavailrs exportr ks + where + basesz = fromInteger $ sizeOption o perform :: [Remote] -> [Remote] -> Maybe Remote -> [Key] -> CommandPerform perform rs unavailrs exportr ks = do @@ -132,18 +156,18 @@ (Remote.gitconfig r) test :: Annex.AnnexState -> Remote -> Key -> [TestTree] -test st r k = - [ check "removeKey when not present" remove - , present False - , check "storeKey" store - , present True - , check "storeKey when already present" store - , present True - , check "retrieveKeyFile" $ do +test st r k = catMaybes + [ whenwritable $ check "removeKey when not present" remove + , whenwritable $ present False + , whenwritable $ check "storeKey" store + , whenwritable $ present True + , whenwritable $ check "storeKey when already present" store + , Just $ present True + , Just $ check "retrieveKeyFile" $ do lockContentForRemoval k removeAnnex get - , check "fsck downloaded object" fsck - , check "retrieveKeyFile resume from 33%" $ do + , Just $ check "fsck downloaded object" fsck + , Just $ check "retrieveKeyFile resume from 33%" $ do loc <- Annex.calcRepo (gitAnnexLocation k) tmp <- prepTmp k partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do @@ -152,24 +176,25 @@ liftIO $ L.writeFile tmp partial lockContentForRemoval k removeAnnex get - , check "fsck downloaded object" fsck - , check "retrieveKeyFile resume from 0" $ do + , Just $ check "fsck downloaded object" fsck + , Just $ check "retrieveKeyFile resume from 0" $ do tmp <- prepTmp k liftIO $ writeFile tmp "" lockContentForRemoval k removeAnnex get - , check "fsck downloaded object" fsck - , check "retrieveKeyFile resume from end" $ do + , Just $ check "fsck downloaded object" fsck + , Just $ check "retrieveKeyFile resume from end" $ do loc <- Annex.calcRepo (gitAnnexLocation k) tmp <- prepTmp k void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp lockContentForRemoval k removeAnnex get - , check "fsck downloaded object" fsck - , check "removeKey when present" remove - , present False + , Just $ check "fsck downloaded object" fsck + , whenwritable $ check "removeKey when present" remove + , whenwritable $ present False ] where + whenwritable a = if Remote.readonly r then Nothing else Just a check desc a = testCase desc $ Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed" present b = check ("present " ++ show b) $ @@ -178,7 +203,7 @@ Nothing -> return True Just b -> case Backend.verifyKeyContent b of Nothing -> return True - Just verifier -> verifier k (key2file k) + Just verifier -> verifier k (serializeKey k) get = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate @@ -252,10 +277,12 @@ checkval v @? ("(got: " ++ show v ++ ")") cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup -cleanup rs ks ok = do - forM_ rs $ \r -> forM_ ks (Remote.removeKey r) - forM_ ks $ \k -> lockContentForRemoval k removeAnnex - return ok +cleanup rs ks ok + | all Remote.readonly rs = return ok + | otherwise = do + forM_ rs $ \r -> forM_ ks (Remote.removeKey r) + forM_ ks $ \k -> lockContentForRemoval k removeAnnex + return ok chunkSizes :: Int -> Bool -> [Int] chunkSizes base False = @@ -297,3 +324,13 @@ <$> Backend.getKey Backend.Hash.testKeyBackend ks _ <- moveAnnex k f return k + +getReadonlyKey :: Remote -> FilePath -> Annex Key +getReadonlyKey r f = lookupFile f >>= \case + Nothing -> giveup $ f ++ " is not an annexed file" + Just k -> do + unlessM (inAnnex k) $ + giveup $ f ++ " does not have its content locally present, cannot test it" + unlessM ((Remote.uuid r `elem`) <$> loggedLocations k) $ + giveup $ f ++ " is not stored in the remote being tested, cannot test it" + return k diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -38,7 +38,7 @@ -} start :: [String] -> CommandStart start (k:[]) = do - case file2key k of + case deserializeKey k of Nothing -> error "bad key" (Just key) -> whenM (inAnnex key) $ do afile <- AssociatedFile <$> Fields.getField Fields.associatedFile diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -82,7 +82,7 @@ sendRequest t tinfo h = do hPutStr h $ intercalate fieldSep [ serialize (transferDirection t) - , maybe (serialize (fromUUID (transferUUID t))) + , maybe (serialize ((fromUUID (transferUUID t)) :: String)) (serialize . Remote.name) (transferRemote tinfo) , serialize (transferKey t) @@ -126,5 +126,5 @@ deserialize n = Just n instance TCSerialized Key where - serialize = key2file - deserialize = file2key + serialize = serializeKey + deserialize = deserializeKey diff --git a/Command/Unannex.hs b/Command/Unannex.hs --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -70,7 +70,8 @@ showStart "unannex" file next $ ifM isDirect ( performDirect file key - , performIndirect file key) + , performIndirect file key + ) performIndirect :: FilePath -> Key -> CommandPerform performIndirect file key = do diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs --- a/Command/Ungroup.hs +++ b/Command/Ungroup.hs @@ -25,7 +25,7 @@ start (name:g:[]) = do showStart' "ungroup" (Just name) u <- Remote.nameToUUID name - next $ perform u g + next $ perform u (toGroup g) start _ = giveup "Specify a repository and a group." perform :: UUID -> Group -> CommandPerform diff --git a/Command/Unused.hs b/Command/Unused.hs --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -118,7 +118,7 @@ table :: [(Int, Key)] -> [String] table l = " NUMBER KEY" : map cols l where - cols (n,k) = " " ++ pad 6 (show n) ++ " " ++ key2file k + cols (n,k) = " " ++ pad 6 (show n) ++ " " ++ serializeKey k pad n s = s ++ replicate (n - length s) ' ' staleTmpMsg :: [(Int, Key)] -> String @@ -139,7 +139,7 @@ unusedMsg' u mheader mtrailer = unlines $ mheader ++ table u ++ - ["(To see where data was previously used, try: git log --stat -S'KEY')"] ++ + ["(To see where data was previously used, try: git log --stat --no-textconv -S'KEY')"] ++ mtrailer remoteUnusedMsg :: Maybe Remote -> RemoteName -> [(Int, Key)] -> String diff --git a/Command/Version.hs b/Command/Version.hs --- a/Command/Version.hs +++ b/Command/Version.hs @@ -59,7 +59,7 @@ vinfo "build flags" $ unwords buildFlags vinfo "dependency versions" $ unwords dependencyVersions vinfo "key/value backends" $ unwords $ - map (formatKeyVariety . B.backendVariety) Backend.list + map (decodeBS . formatKeyVariety . B.backendVariety) Backend.list vinfo "remote types" $ unwords $ map R.typename Remote.remoteTypes vinfo "operating system" $ unwords [os, arch] vinfo "supported repository versions" $ diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -129,7 +129,7 @@ diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x) (f newcfg) (f curcfg) -genCfg :: Cfg -> M.Map UUID String -> String +genCfg :: Cfg -> UUIDDescMap -> String genCfg cfg descs = unlines $ intercalate [""] [ intro , trust @@ -167,10 +167,10 @@ , com $ "(Standard groups: " ++ grouplist ++ ")" , com "(Separate group names with spaces)" ] - (\(s, u) -> line "group" u $ unwords $ S.toList s) + (\(s, u) -> line "group" u $ unwords $ map fromGroup $ S.toList s) (\u -> lcom $ line "group" u "") where - grouplist = unwords $ map fromStandardGroup [minBound..] + grouplist = unwords $ map (fromGroup . fromStandardGroup) [minBound..] preferredcontent = settings cfg descs cfgPreferredContentMap [ com "Repository preferred contents" @@ -191,7 +191,7 @@ (\(s, g) -> gline g s) (\g -> gline g "") where - gline g val = [ unwords ["groupwanted", g, "=", val] ] + gline g val = [ unwords ["groupwanted", fromGroup g, "=", val] ] allgroups = S.unions $ stdgroups : M.elems (cfgGroupMap cfg) stdgroups = S.fromList $ map fromStandardGroup [minBound..maxBound] @@ -204,7 +204,7 @@ where gline g = com $ unwords [ "standard" - , fromStandardGroup g, "=", standardPreferredContent g + , fromGroup (fromStandardGroup g), "=", standardPreferredContent g ] schedule = settings cfg descs cfgScheduleMap @@ -223,7 +223,7 @@ gline g val = [ unwords ["config", g, "=", val] ] line setting u val = - [ com $ "(for " ++ fromMaybe "" (M.lookup u descs) ++ ")" + [ com $ "(for " ++ fromUUIDDesc (fromMaybe mempty (M.lookup u descs)) ++ ")" , unwords [setting, fromUUID u, "=", val] ] @@ -235,7 +235,7 @@ , line' "numcopies" (show . fromNumCopies <$> cfgNumCopies cfg) ] -settings :: Ord v => Cfg -> M.Map UUID String -> (Cfg -> M.Map UUID v) -> [String] -> ((v, UUID) -> [String]) -> (UUID -> [String]) -> [String] +settings :: Ord v => Cfg -> UUIDDescMap -> (Cfg -> M.Map UUID v) -> [String] -> ((v, UUID) -> [String]) -> (UUID -> [String]) -> [String] settings cfg descs = settings' cfg (M.keysSet descs) settings' :: (Ord v, Ord f) => Cfg -> S.Set f -> (Cfg -> M.Map f v) -> [String] -> ((v, f) -> [String]) -> (f -> [String]) -> [String] @@ -282,7 +282,7 @@ let m = M.insert u (Down t) (cfgTrustMap cfg) in Right $ cfg { cfgTrustMap = m } | setting == "group" = - let m = M.insert u (S.fromList $ words val) (cfgGroupMap cfg) + let m = M.insert u (S.fromList $ map toGroup $ words val) (cfgGroupMap cfg) in Right $ cfg { cfgGroupMap = m } | setting == "wanted" = case checkPreferredContentExpression val of @@ -300,7 +300,7 @@ case checkPreferredContentExpression val of Just e -> Left e Nothing -> - let m = M.insert f val (cfgGroupPreferredContentMap cfg) + let m = M.insert (toGroup f) val (cfgGroupPreferredContentMap cfg) in Right $ cfg { cfgGroupPreferredContentMap = m } | setting == "schedule" = case parseScheduledActivities val of Left e -> Left e diff --git a/Common.hs b/Common.hs --- a/Common.hs +++ b/Common.hs @@ -30,5 +30,6 @@ import Utility.FileSize as X import Utility.Network as X import Utility.Split as X +import Utility.FileSystemEncoding as X import Utility.PartialPrelude as X diff --git a/Crypto.hs b/Crypto.hs --- a/Crypto.hs +++ b/Crypto.hs @@ -9,6 +9,7 @@ -} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} module Crypto ( @@ -33,6 +34,7 @@ prop_HmacSha1WithCipher_sane ) where +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.UTF8 (fromString) import qualified Data.Map as M @@ -159,16 +161,17 @@ - on content. It does need to be repeatable. -} encryptKey :: Mac -> Cipher -> EncKey encryptKey mac c k = stubKey - { keyName = macWithCipher mac c (key2file k) - , keyVariety = OtherKey (encryptedBackendNamePrefix ++ showMac mac) + { keyName = encodeBS (macWithCipher mac c (serializeKey k)) + , keyVariety = OtherKey $ + encryptedBackendNamePrefix <> encodeBS (showMac mac) } -encryptedBackendNamePrefix :: String +encryptedBackendNamePrefix :: S.ByteString encryptedBackendNamePrefix = "GPG" isEncKey :: Key -> Bool isEncKey k = case keyVariety k of - OtherKey s -> encryptedBackendNamePrefix `isPrefixOf` s + OtherKey s -> encryptedBackendNamePrefix `S.isPrefixOf` s _ -> False type Feeder = Handle -> IO () diff --git a/Database/Types.hs b/Database/Types.hs --- a/Database/Types.hs +++ b/Database/Types.hs @@ -23,10 +23,10 @@ deriving (Show, Read) toSKey :: Key -> SKey -toSKey = SKey . key2file +toSKey = SKey . serializeKey fromSKey :: SKey -> Key -fromSKey (SKey s) = fromMaybe (error $ "bad serialized Key " ++ s) (file2key s) +fromSKey (SKey s) = fromMaybe (error $ "bad serialized Key " ++ s) (deserializeKey s) derivePersistField "SKey" @@ -41,10 +41,10 @@ show (IKey s) = s toIKey :: Key -> IKey -toIKey = IKey . key2file +toIKey = IKey . serializeKey fromIKey :: IKey -> Key -fromIKey (IKey s) = fromMaybe (error $ "bad serialized Key " ++ s) (file2key s) +fromIKey (IKey s) = fromMaybe (error $ "bad serialized Key " ++ s) (deserializeKey s) derivePersistField "IKey" diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -38,7 +38,6 @@ import Git.FilePath import Git.HashObject import qualified Utility.CoProcess as CoProcess -import Utility.FileSystemEncoding import Utility.Tuple data CatFileHandle = CatFileHandle @@ -207,7 +206,7 @@ dropsha = L.drop 21 parsemodefile b = - let (modestr, file) = separate (== ' ') (decodeBS b) + let (modestr, file) = separate (== ' ') (decodeBL b) in (file, readmode modestr) readmode = fromMaybe 0 . fmap fst . headMaybe . readOct diff --git a/Git/HashObject.hs b/Git/HashObject.hs --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -1,6 +1,6 @@ {- git hash-object interface - - - Copyright 2011-2014 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -17,6 +17,10 @@ import qualified Utility.CoProcess as CoProcess import Utility.Tmp +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Builder + type HashObjectHandle = CoProcess.CoProcessHandle hashObjectStart :: Repo -> IO HashObjectHandle @@ -37,14 +41,23 @@ send to = hPutStrLn to =<< absPath file receive from = getSha "hash-object" $ hGetLine from +class HashableBlob t where + hashableBlobToHandle :: Handle -> t -> IO () + +instance HashableBlob L.ByteString where + hashableBlobToHandle = L.hPut + +instance HashableBlob S.ByteString where + hashableBlobToHandle = S.hPut + +instance HashableBlob Builder where + hashableBlobToHandle = hPutBuilder + {- Injects a blob into git. Unfortunately, the current git-hash-object - interface does not allow batch hashing without using temp files. -} -hashBlob :: HashObjectHandle -> String -> IO Sha -hashBlob h s = withTmpFile "hash" $ \tmp tmph -> do -#ifdef mingw32_HOST_OS - hSetNewlineMode tmph noNewlineTranslation -#endif - hPutStr tmph s +hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha +hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do + hashableBlobToHandle tmph b hClose tmph hashFile h tmp diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -10,7 +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 import Common @@ -22,7 +22,6 @@ import Git.HashObject import Git.Types import Git.FilePath -import Utility.FileSystemEncoding {- Performs a union merge between two branches, staging it in the index. - Any previously staged changes in the index will be lost. @@ -86,26 +85,25 @@ [] -> return Nothing (sha:[]) -> use sha shas -> use - =<< either return (\s -> hashBlob hashhandle (unlines s)) + =<< either return (hashBlob hashhandle . L8.unlines) =<< calcMerge . zip shas <$> mapM getcontents shas where [_colonmode, _bmode, asha, bsha, _status] = words info use sha = return $ Just $ updateIndexLine sha TreeFile $ asTopFilePath file - -- We don't know how the file is encoded, but need to - -- split it into lines to union merge. Using the - -- FileSystemEncoding for this is a hack, but ensures there - -- are no decoding errors. - getcontents s = lines . encodeW8NUL . L.unpack <$> catObject h s + -- Get file and split into lines to union merge. + -- The encoding of the file is assumed to be either ASCII or utf-8; + -- in either case it's safe to split on \n + getcontents s = L8.lines <$> catObject h s {- Calculates a union merge between a list of refs, with contents. - - When possible, reuses the content of an existing ref, rather than - generating new content. -} -calcMerge :: [(Ref, [String])] -> Either Ref [String] +calcMerge :: [(Ref, [L8.ByteString])] -> Either Ref [L8.ByteString] calcMerge shacontents - | null reuseable = Right $ new + | null reuseable = Right new | otherwise = Left $ fst $ Prelude.head reuseable where reuseable = filter (\c -> sorteduniq (snd c) == new) shacontents diff --git a/Key.hs b/Key.hs --- a/Key.hs +++ b/Key.hs @@ -1,6 +1,6 @@ {- git-annex Keys - - - Copyright 2011-2017 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -11,19 +11,30 @@ Key(..), AssociatedFile(..), stubKey, - key2file, - file2key, + buildKey, + keyParser, + serializeKey, + serializeKey', + deserializeKey, + deserializeKey', nonChunkKey, chunkKeyOffset, isChunkKey, isKeyPrefix, + splitKeyNameExtension, - prop_isomorphic_key_encode, - prop_isomorphic_key_decode + prop_isomorphic_key_encode ) where -import Data.Char import qualified Data.Text as T +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Builder +import Data.ByteString.Builder.Extra +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import Foreign.C.Types import Common import Types.Key @@ -34,8 +45,8 @@ stubKey :: Key stubKey = Key - { keyName = "" - , keyVariety = OtherKey "" + { keyName = mempty + , keyVariety = OtherKey mempty , keySize = Nothing , keyMtime = Nothing , keyChunkSize = Nothing @@ -65,117 +76,123 @@ fieldSep :: Char fieldSep = '-' -{- Converts a key to a string that is suitable for use as a filename. +{- Builds a ByteString from a Key. + - - The name field is always shown last, separated by doubled fieldSeps, - - and is the only field allowed to contain the fieldSep. -} -key2file :: Key -> FilePath -key2file Key { keyVariety = kv, keySize = s, keyMtime = m, keyChunkSize = cs, keyChunkNum = cn, keyName = n } = - formatKeyVariety kv +++ ('s' ?: s) +++ ('m' ?: m) +++ ('S' ?: cs) +++ ('C' ?: cn) +++ (fieldSep : n) + - and is the only field allowed to contain the fieldSep. + -} +buildKey :: Key -> Builder +buildKey k = byteString (formatKeyVariety (keyVariety k)) + <> 's' ?: (integerDec <$> keySize k) + <> 'm' ?: (integerDec . (\(CTime t) -> fromIntegral t) <$> keyMtime k) + <> 'S' ?: (integerDec <$> keyChunkSize k) + <> 'C' ?: (integerDec <$> keyChunkNum k) + <> sepbefore (sepbefore (byteString (keyName k))) where - "" +++ y = y - x +++ "" = x - x +++ y = x ++ fieldSep:y - f ?: (Just v) = f : show v - _ ?: _ = "" + sepbefore s = char7 fieldSep <> s + c ?: (Just b) = sepbefore (char7 c <> b) + _ ?: Nothing = mempty -file2key :: FilePath -> Maybe Key -file2key s - | key == Just stubKey || (keyName <$> key) == Just "" || (keyVariety <$> key) == Just (OtherKey "") = Nothing - | otherwise = key - where - key = startbackend stubKey s +serializeKey :: Key -> String +serializeKey = decodeBL' . serializeKey' - startbackend k v = sepfield k v addvariety - - sepfield k v a = case span (/= fieldSep) v of - (v', _:r) -> findfields r $ a k v' - _ -> Nothing +serializeKey' :: Key -> L.ByteString +serializeKey' = toLazyByteStringWith (safeStrategy 128 smallChunkSize) L.empty . buildKey - findfields (c:v) (Just k) - | c == fieldSep = addkeyname k v - | otherwise = sepfield k v $ addfield c - findfields _ v = v +{- This is a strict parser for security reasons; a key + - can contain only 4 fields, which all consist only of numbers. + - Any key containing other fields, or non-numeric data will fail + - to parse. + - + - If a key contained non-numeric fields, they could be used to + - embed data used in a SHA1 collision attack, which would be a + - problem since the keys are committed to git. + -} +keyParser :: A.Parser Key +keyParser = do + -- key variety cannot be empty + v <- (parseKeyVariety <$> A8.takeWhile1 (/= fieldSep)) + s <- parsesize + m <- parsemtime + cs <- parsechunksize + cn <- parsechunknum + _ <- A8.char fieldSep + _ <- A8.char fieldSep + n <- A.takeByteString + if validKeyName v n + then return $ Key + { keyName = n + , keyVariety = v + , keySize = s + , keyMtime = m + , keyChunkSize = cs + , keyChunkNum = cn + } + else fail "invalid keyName" + where + parseopt p = (Just <$> (A8.char fieldSep *> p)) <|> pure Nothing + parsesize = parseopt $ A8.char 's' *> A8.decimal + parsemtime = parseopt $ CTime <$> (A8.char 'm' *> A8.decimal) + parsechunksize = parseopt $ A8.char 'S' *> A8.decimal + parsechunknum = parseopt $ A8.char 'C' *> A8.decimal - addvariety k v = Just k { keyVariety = parseKeyVariety v } +deserializeKey :: String -> Maybe Key +deserializeKey = deserializeKey' . encodeBS' - -- This is a strict parser for security reasons; a key - -- can contain only 4 fields, which all consist only of numbers. - -- Any key containing other fields, or non-numeric data is - -- rejected with Nothing. - -- - -- If a key contained non-numeric fields, they could be used to - -- embed data used in a SHA1 collision attack, which would be a - -- problem since the keys are committed to git. - addfield _ _ v | not (all isDigit v) = Nothing - addfield 's' k v = do - sz <- readish v - return $ k { keySize = Just sz } - addfield 'm' k v = do - mtime <- readish v - return $ k { keyMtime = Just mtime } - addfield 'S' k v = do - chunksize <- readish v - return $ k { keyChunkSize = Just chunksize } - addfield 'C' k v = case readish v of - Just chunknum | chunknum > 0 -> - return $ k { keyChunkNum = Just chunknum } - _ -> Nothing - addfield _ _ _ = Nothing +deserializeKey' :: S.ByteString -> Maybe Key +deserializeKey' b = eitherToMaybe $ A.parseOnly keyParser b - addkeyname k v - | validKeyName k v = Just $ k { keyName = v } - | otherwise = Nothing +{- This splits any extension out of the keyName, returning the + - keyName minus extension, and the extension (including leading dot). + -} +splitKeyNameExtension :: Key -> (S.ByteString, S.ByteString) +splitKeyNameExtension = splitKeyNameExtension' . keyName -{- When a key HasExt, the length of the extension is limited in order to - - mitigate against SHA1 collision attacks. +splitKeyNameExtension' :: S.ByteString -> (S.ByteString, S.ByteString) +splitKeyNameExtension' keyname = S8.span (/= '.') keyname + +{- Limits the length of the extension in the keyName to mitigate against + - SHA1 collision attacks. - - In such an attack, the extension of the key could be made to contain - the collision generation data, with the result that a signed git commit - including such keys would not be secure. - - The maximum extension length ever generated for such a key was 8 - - characters; 20 is used here to give a little future wiggle-room. + - characters, but they may be unicode which could use up to 4 bytes each, + - so 32 bytes. 64 bytes is used here to give a little future wiggle-room. - The SHA1 common-prefix attack needs 128 bytes of data. -} -validKeyName :: Key -> String -> Bool -validKeyName k name - | hasExt (keyVariety k) = length (takeExtensions name) <= 20 +validKeyName :: KeyVariety -> S.ByteString -> Bool +validKeyName kv name + | hasExt kv = + let ext = snd $ splitKeyNameExtension' name + in S.length ext <= 64 | otherwise = True instance Arbitrary Key where arbitrary = Key - <$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t") - <*> (parseKeyVariety <$> (listOf1 $ elements ['A'..'Z'])) -- BACKEND + <$> (encodeBS <$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t")) + <*> (parseKeyVariety . encodeBS <$> (listOf1 $ elements ['A'..'Z'])) -- BACKEND <*> ((abs <$>) <$> arbitrary) -- size cannot be negative <*> ((abs . fromInteger <$>) <$> arbitrary) -- mtime cannot be negative <*> ((abs <$>) <$> arbitrary) -- chunksize cannot be negative <*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative instance Hashable Key where - hashIO32 = hashIO32 . key2file - hashIO64 = hashIO64 . key2file + hashIO32 = hashIO32 . serializeKey' + hashIO64 = hashIO64 . serializeKey' instance ToJSON' Key where - toJSON' = toJSON' . key2file + toJSON' = toJSON' . serializeKey instance FromJSON Key where - parseJSON (String t) = maybe mempty pure $ file2key $ T.unpack t + parseJSON (String t) = maybe mempty pure $ deserializeKey $ T.unpack t parseJSON _ = mempty instance Proto.Serializable Key where - serialize = key2file - deserialize = file2key + serialize = serializeKey + deserialize = deserializeKey prop_isomorphic_key_encode :: Key -> Bool -prop_isomorphic_key_encode k = Just k == (file2key . key2file) k - -prop_isomorphic_key_decode :: FilePath -> Bool -prop_isomorphic_key_decode f - | normalfieldorder = maybe True (\k -> key2file k == f) (file2key f) - | otherwise = True - where - -- file2key will accept the fields in any order, so don't - -- try the test unless the fields are in the normal order - normalfieldorder = fields `isPrefixOf` "smSC" - fields = map (f !!) $ filter (< length f) $ map succ $ - elemIndices fieldSep f +prop_isomorphic_key_encode k = Just k == (deserializeKey . serializeKey) k diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -169,7 +169,7 @@ -- level, it's parsed as a trust level, not as a group. [v, n] -> case parsetrustspec v of Just checker -> go n $ checktrust checker - Nothing -> go n $ checkgroup v + Nothing -> go n $ checkgroup (toGroup v) [n] -> go n $ const $ return True _ -> Left "bad value for copies" where @@ -237,7 +237,7 @@ limitInAllGroup :: Annex GroupMap -> MkLimit Annex limitInAllGroup getgroupmap groupname = Right $ \notpresent mi -> do m <- getgroupmap - let want = fromMaybe S.empty $ M.lookup groupname $ uuidsByGroup m + let want = fromMaybe S.empty $ M.lookup (toGroup groupname) $ uuidsByGroup m if S.null want then return True -- optimisation: Check if a wanted uuid is notpresent. @@ -257,7 +257,7 @@ limitInBackend name = Right $ const $ checkKey check where check key = pure $ keyVariety key == variety - variety = parseKeyVariety name + variety = parseKeyVariety (encodeBS name) {- Adds a limit to skip files not using a secure hash. -} addSecureHash :: Annex () diff --git a/Logs.hs b/Logs.hs --- a/Logs.hs +++ b/Logs.hs @@ -124,7 +124,7 @@ {- Old versions stored the urls elsewhere. -} oldurlLogs :: GitConfig -> Key -> [FilePath] oldurlLogs config key = - [ "remote/web" hdir key2file key ++ ".log" + [ "remote/web" hdir serializeKey key ++ ".log" , "remote/web" hdir keyFile key ++ ".log" ] where diff --git a/Logs/Activity.hs b/Logs/Activity.hs --- a/Logs/Activity.hs +++ b/Logs/Activity.hs @@ -1,6 +1,6 @@ {- git-annex activity log - - - Copyright 2015 Joey Hess + - Copyright 2015-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -17,19 +17,36 @@ import Logs import Logs.UUIDBased -data Activity = Fsck +import qualified Data.ByteString as S +import qualified Data.Attoparsec.ByteString as A +import Data.ByteString.Builder + +data Activity + = Fsck deriving (Eq, Read, Show, Enum, Bounded) recordActivity :: Activity -> UUID -> Annex () recordActivity act uuid = do c <- liftIO currentVectorClock Annex.Branch.change activityLog $ - showLog show . changeLog c uuid act . parseLog readish + buildLog buildActivity + . changeLog c uuid (Right act) + . parseLog parseActivity lastActivities :: Maybe Activity -> Annex (Log Activity) -lastActivities wantact = parseLog onlywanted <$> Annex.Branch.get activityLog +lastActivities wantact = parseLog (onlywanted =<< parseActivity) + <$> Annex.Branch.get activityLog where - onlywanted s = case readish s of - Just a | wanted a -> Just a - _ -> Nothing + onlywanted (Right a) | wanted a = pure a + onlywanted _ = fail "unwanted activity" wanted a = maybe True (a ==) wantact + +buildActivity :: Either S.ByteString Activity -> Builder +buildActivity (Right a) = byteString $ encodeBS $ show a +buildActivity (Left b) = byteString b + +-- Allow for unknown activities to be added later by preserving them. +parseActivity :: A.Parser (Either S.ByteString Activity) +parseActivity = go <$> A.takeByteString + where + go b = maybe (Left b) Right $ readish $ decodeBS b diff --git a/Logs/Chunk.hs b/Logs/Chunk.hs --- a/Logs/Chunk.hs +++ b/Logs/Chunk.hs @@ -38,7 +38,7 @@ c <- liftIO currentVectorClock config <- Annex.getGitConfig Annex.Branch.change (chunkLogFile config k) $ - showLog . changeMapLog c (u, chunkmethod) chunkcount . parseLog + buildLog . changeMapLog c (u, chunkmethod) chunkcount . parseLog chunksRemoved :: UUID -> Key -> ChunkMethod -> Annex () chunksRemoved u k chunkmethod = chunksStored u k chunkmethod 0 diff --git a/Logs/Chunk/Pure.hs b/Logs/Chunk/Pure.hs --- a/Logs/Chunk/Pure.hs +++ b/Logs/Chunk/Pure.hs @@ -1,6 +1,6 @@ {- Chunk logs, pure operations. - - - Copyright 2014 Joey Hess + - Copyright 2014, 2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -11,16 +11,22 @@ , ChunkCount , ChunkLog , parseLog - , showLog + , buildLog ) where import Annex.Common import Logs.MapLog import Data.Int +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 +import Data.ByteString.Builder + -- Currently chunks are all fixed size, but other chunking methods -- may be added. -data ChunkMethod = FixedSizeChunks ChunkSize | UnknownChunks String +data ChunkMethod = FixedSizeChunks ChunkSize | UnknownChunks S.ByteString deriving (Ord, Eq, Show) type ChunkSize = Int64 @@ -30,26 +36,27 @@ type ChunkLog = MapLog (UUID, ChunkMethod) ChunkCount -parseChunkMethod :: String -> ChunkMethod -parseChunkMethod s = maybe (UnknownChunks s) FixedSizeChunks (readish s) +buildChunkMethod :: ChunkMethod -> Builder +buildChunkMethod (FixedSizeChunks sz) = int64Dec sz +buildChunkMethod (UnknownChunks s) = byteString s -showChunkMethod :: ChunkMethod -> String -showChunkMethod (FixedSizeChunks sz) = show sz -showChunkMethod (UnknownChunks s) = s +chunkMethodParser :: A.Parser ChunkMethod +chunkMethodParser = + (FixedSizeChunks <$> A8.decimal) <|> (UnknownChunks <$> A.takeByteString) -parseLog :: String -> ChunkLog -parseLog = parseMapLog fieldparser valueparser +buildLog :: ChunkLog -> Builder +buildLog = buildMapLog fieldbuilder valuebuilder where - fieldparser s = - let (u,m) = separate (== sep) s - in Just (toUUID u, parseChunkMethod m) - valueparser = readish + fieldbuilder (u, m) = buildUUID u <> sep <> buildChunkMethod m + valuebuilder = integerDec + sep = charUtf8 ':' -showLog :: ChunkLog -> String -showLog = showMapLog fieldshower valueshower +parseLog :: L.ByteString -> ChunkLog +parseLog = parseMapLog fieldparser valueparser where - fieldshower (u, m) = fromUUID u ++ sep : showChunkMethod m - valueshower = show - -sep :: Char -sep = ':' + fieldparser = (,) + <$> (toUUID <$> A8.takeTill (== ':')) + <* A8.char ':' + <*> chunkMethodParser + <* A.endOfInput + valueparser = A8.decimal diff --git a/Logs/Config.hs b/Logs/Config.hs --- a/Logs/Config.hs +++ b/Logs/Config.hs @@ -1,6 +1,6 @@ {- git-annex repository-global config log - - - Copyright 2017 Joey Hess + - Copyright 2017-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -20,6 +20,9 @@ import qualified Annex.Branch import qualified Data.Map as M +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 @@ -34,7 +37,7 @@ setGlobalConfig' name new = do c <- liftIO currentVectorClock Annex.Branch.change configLog $ - showMapLog id id . changeMapLog c name new . parseGlobalConfig + buildGlobalConfig . changeMapLog c name new . parseGlobalConfig unsetGlobalConfig :: ConfigName -> Annex () unsetGlobalConfig name = do @@ -46,8 +49,16 @@ getGlobalConfig :: ConfigName -> Annex (Maybe ConfigValue) getGlobalConfig name = M.lookup name <$> loadGlobalConfig -parseGlobalConfig :: String -> MapLog ConfigName ConfigValue -parseGlobalConfig = parseMapLog Just Just +buildGlobalConfig :: MapLog ConfigName ConfigValue -> Builder +buildGlobalConfig = buildMapLog fieldbuilder valuebuilder + where + fieldbuilder = byteString . encodeBS + valuebuilder = byteString . encodeBS + +parseGlobalConfig :: L.ByteString -> MapLog ConfigName ConfigValue +parseGlobalConfig = parseMapLog string string + where + string = decodeBS <$> A.takeByteString loadGlobalConfig :: Annex (M.Map ConfigName ConfigValue) loadGlobalConfig = M.filter (not . null) . simpleMap . parseGlobalConfig diff --git a/Logs/Difference.hs b/Logs/Difference.hs --- a/Logs/Difference.hs +++ b/Logs/Difference.hs @@ -13,6 +13,8 @@ ) where import qualified Data.Map as M +import qualified Data.Attoparsec.ByteString as A +import Data.ByteString.Builder import Annex.Common import Types.Difference @@ -25,7 +27,9 @@ recordDifferences ds@(Differences {}) uuid = do c <- liftIO currentVectorClock Annex.Branch.change differenceLog $ - showLog id . changeLog c uuid (showDifferences ds) . parseLog Just + buildLog byteString + . changeLog c uuid (encodeBS $ showDifferences ds) + . parseLog A.takeByteString recordDifferences UnknownDifferences _ = return () -- Map of UUIDs that have Differences recorded. @@ -35,5 +39,4 @@ recordedDifferences = parseDifferencesLog <$> Annex.Branch.get differenceLog recordedDifferencesFor :: UUID -> Annex Differences -recordedDifferencesFor u = fromMaybe mempty . M.lookup u - <$> recordedDifferences +recordedDifferencesFor u = fromMaybe mempty . M.lookup u <$> recordedDifferences diff --git a/Logs/Difference/Pure.hs b/Logs/Difference/Pure.hs --- a/Logs/Difference/Pure.hs +++ b/Logs/Difference/Pure.hs @@ -11,13 +11,16 @@ ) where import qualified Data.Map as M +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString as A import Annex.Common import Types.Difference import Logs.UUIDBased -parseDifferencesLog :: String -> (M.Map UUID Differences) -parseDifferencesLog = simpleMap . parseLog (Just . readDifferences) +parseDifferencesLog :: L.ByteString -> (M.Map UUID Differences) +parseDifferencesLog = simpleMap + . parseLog (readDifferences . decodeBS <$> A.takeByteString) -- The sum of all recorded differences, across all UUIDs. allDifferences :: M.Map UUID Differences -> Differences diff --git a/Logs/Export.hs b/Logs/Export.hs --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -18,6 +18,11 @@ import Logs.MapLog import Annex.UUID +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString.Lazy as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import Data.ByteString.Builder + data Exported = Exported { exportedTreeish :: Git.Ref , incompleteExportedTreeish :: [Git.Ref] @@ -28,7 +33,7 @@ { exportFrom :: UUID , exportTo :: UUID } - deriving (Eq, Ord) + deriving (Eq, Ord, Show) data ExportChange = ExportChange { oldTreeish :: [Git.Ref] @@ -68,7 +73,7 @@ let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid } let exported = Exported (newTreeish ec) [] Annex.Branch.change exportLog $ - showExportLog + buildExportLog . changeMapLog c ep exported . M.mapWithKey (updateothers c u) . parseExportLog @@ -92,34 +97,38 @@ <$> Annex.Branch.get exportLog let new = old { incompleteExportedTreeish = nub (newtree:incompleteExportedTreeish old) } Annex.Branch.change exportLog $ - showExportLog + buildExportLog . changeMapLog c ep new . parseExportLog Annex.Branch.graftTreeish newtree (asTopFilePath "export.tree") -parseExportLog :: String -> MapLog ExportParticipants Exported -parseExportLog = parseMapLog parseExportParticipants parseExported +parseExportLog :: L.ByteString -> MapLog ExportParticipants Exported +parseExportLog = parseMapLog exportParticipantsParser exportedParser -showExportLog :: MapLog ExportParticipants Exported -> String -showExportLog = showMapLog formatExportParticipants formatExported +buildExportLog :: MapLog ExportParticipants Exported -> Builder +buildExportLog = buildMapLog buildExportParticipants buildExported -formatExportParticipants :: ExportParticipants -> String -formatExportParticipants ep = - fromUUID (exportFrom ep) ++ ':' : fromUUID (exportTo ep) +buildExportParticipants :: ExportParticipants -> Builder +buildExportParticipants ep = + buildUUID (exportFrom ep) <> sep <> buildUUID (exportTo ep) + where + sep = charUtf8 ':' -parseExportParticipants :: String -> Maybe ExportParticipants -parseExportParticipants s = case separate (== ':') s of - ("",_) -> Nothing - (_,"") -> Nothing - (f,t) -> Just $ ExportParticipants - { exportFrom = toUUID f - , exportTo = toUUID t - } -formatExported :: Exported -> String -formatExported exported = unwords $ map Git.fromRef $ - exportedTreeish exported : incompleteExportedTreeish exported +exportParticipantsParser :: A.Parser ExportParticipants +exportParticipantsParser = ExportParticipants + <$> (toUUID <$> A8.takeWhile1 (/= ':')) + <* A8.char ':' + <*> (toUUID <$> A8.takeWhile1 (const True)) -parseExported :: String -> Maybe Exported -parseExported s = case words s of - (et:it) -> Just $ Exported (Git.Ref et) (map Git.Ref it) - _ -> Nothing +buildExported :: Exported -> Builder +buildExported exported = go (exportedTreeish exported : incompleteExportedTreeish exported) + where + go [] = mempty + go (r:rs) = rref r <> mconcat [ charUtf8 ' ' <> rref r' | r' <- rs ] + rref r = byteString (encodeBS' (Git.fromRef r)) + +exportedParser :: A.Parser Exported +exportedParser = Exported <$> refparser <*> many refparser + where + refparser = (Git.Ref . decodeBS <$> A8.takeWhile1 (/= ' ') ) + <* ((const () <$> A8.char ' ') <|> A.endOfInput) diff --git a/Logs/Group.hs b/Logs/Group.hs --- a/Logs/Group.hs +++ b/Logs/Group.hs @@ -1,6 +1,6 @@ {- git-annex group log - - - Copyright 2012 Joey Hess + - Copyright 2012, 2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -18,6 +18,9 @@ import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import Data.ByteString.Builder import Annex.Common import Logs @@ -37,9 +40,7 @@ curr <- lookupGroups uuid c <- liftIO currentVectorClock Annex.Branch.change groupLog $ - showLog (unwords . S.toList) . - changeLog c uuid (modifier curr) . - parseLog (Just . S.fromList . words) + buildLog buildGroup . changeLog c uuid (modifier curr) . parseLog parseGroup -- The changed group invalidates the preferred content cache. Annex.changeState $ \s -> s @@ -48,6 +49,23 @@ } groupChange NoUUID _ = error "unknown UUID; cannot modify" +buildGroup :: S.Set Group -> Builder +buildGroup = go . S.toList + where + go [] = mempty + go (g:gs) = bld g <> mconcat [ charUtf8 ' ' <> bld g' | g' <- gs ] + bld (Group g) = byteString g + +parseGroup :: A.Parser (S.Set Group) +parseGroup = S.fromList <$> go [] + where + go l = (A.endOfInput *> pure l) + <|> ((getgroup <* A8.char ' ') >>= go . (:l)) + <|> ((:l) <$> getgroup) + -- allow extra writespace before or after a group name + <|> (A8.char ' ' >>= const (go l)) + getgroup = Group <$> A8.takeWhile1 (/= ' ') + groupSet :: UUID -> S.Set Group -> Annex () groupSet u g = groupChange u (const g) @@ -58,9 +76,7 @@ {- Loads the map, updating the cache. -} groupMapLoad :: Annex GroupMap groupMapLoad = do - m <- makeGroupMap . simpleMap . - parseLog (Just . S.fromList . words) <$> - Annex.Branch.get groupLog + m <- makeGroupMap . simpleMap . parseLog parseGroup <$> Annex.Branch.get groupLog Annex.changeState $ \s -> s { Annex.groupmap = Just m } return m diff --git a/Logs/Line.hs b/Logs/Line.hs --- a/Logs/Line.hs +++ b/Logs/Line.hs @@ -1,51 +1,38 @@ -{- - -The Glasgow Haskell Compiler License - -Copyright 2001, The University Court of the University of Glasgow. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- 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. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. +{- line based log files + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND 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 -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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. +module Logs.Line where --} +import Common -module Logs.Line where +import qualified Data.Attoparsec.ByteString.Lazy as A +import Data.Attoparsec.ByteString.Char8 (isEndOfLine) +import qualified Data.DList as D --- This is the same as Data.List.lines, with \r added. --- This works around some versions of git-annex which wrote \r --- into git-annex branch files on Windows. Those \r's sometimes --- accumulated over time, so a single line could end with multiple \r's --- before the \n. -splitLines :: String -> [String] -splitLines "" = [] -splitLines s = cons (case break (\c -> c == '\n' || c == '\r') s of - (l, s') -> (l, case s' of - [] -> [] - _:s'' -> splitLines s'')) +{- Applies a parser to each line of a log file. + - + - If the parser fails to parse a line, that line is skipped, instead of + - the overall parse failing. This is generally a good idea in case a newer + - version of git-annex somehow changed the format of the log file. + - + - Any combination of \r and \n are taken to be the end of the line. + - (Some versions of git-annex on Windows wrote \r into git-annex branch + - files, and multiple \r's sometimes accumulated.) + - + - The parser does not itself need to avoid parsing beyond the end of line; + - this is implemented only pass the content of a line to the parser. + -} +parseLogLines :: A.Parser a -> A.Parser [a] +parseLogLines parser = go D.empty where - cons ~(h, t) = h : t + go dl = do + line <- A.takeTill isEndOfLine + A.skipWhile isEndOfLine + let dl' = case A.parseOnly parser line of + Left _ -> dl + Right v -> D.snoc dl v + (A.endOfInput *> return (D.toList dl')) <|> go dl' diff --git a/Logs/Location.hs b/Logs/Location.hs --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -41,7 +41,6 @@ import qualified Annex import Data.Time.Clock -import qualified Data.ByteString.Lazy.Char8 as L {- Log a change in the presence of a key's value in current repository. -} logStatus :: Key -> LogStatus -> Annex () @@ -53,10 +52,10 @@ logChange :: Key -> UUID -> LogStatus -> Annex () logChange = logChange' logNow -logChange' :: (LogStatus -> String -> Annex LogLine) -> Key -> UUID -> LogStatus -> Annex () -logChange' mklog key (UUID u) s = do +logChange' :: (LogStatus -> LogInfo -> Annex LogLine) -> Key -> UUID -> LogStatus -> Annex () +logChange' mklog key u@(UUID _) s = do config <- Annex.getGitConfig - maybeAddLog (locationLogFile config key) =<< mklog s u + maybeAddLog (locationLogFile config key) =<< mklog s (LogInfo (fromUUID u)) logChange' _ _ NoUUID _ = noop {- Returns a list of repository UUIDs that, according to the log, have @@ -70,12 +69,12 @@ {- Gets the locations contained in a git ref. -} loggedLocationsRef :: Ref -> Annex [UUID] -loggedLocationsRef ref = map toUUID . getLog . L.unpack <$> catObject ref +loggedLocationsRef ref = map (toUUID . fromLogInfo) . getLog <$> catObject ref -getLoggedLocations :: (FilePath -> Annex [String]) -> Key -> Annex [UUID] +getLoggedLocations :: (FilePath -> Annex [LogInfo]) -> Key -> Annex [UUID] getLoggedLocations getter key = do config <- Annex.getGitConfig - map toUUID <$> getter (locationLogFile config key) + map (toUUID . fromLogInfo) <$> getter (locationLogFile config key) {- Is there a location log for the key? True even for keys with no - remaining locations. -} diff --git a/Logs/MapLog.hs b/Logs/MapLog.hs --- a/Logs/MapLog.hs +++ b/Logs/MapLog.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE CPP #-} - {- git-annex Map log - - This is used to store a Map, in a way that can be union merged. - - A line of the log will look like: "timestamp field value" - - - Copyright 2014 Joey Hess + - The field names cannot contain whitespace. - + - Copyright 2014, 2019 Joey Hess + - - Licensed under the GNU GPL version 3 or higher. -} @@ -21,34 +21,46 @@ import Annex.VectorClock import Logs.Line +import qualified Data.ByteString.Lazy as L import qualified Data.Map.Strict as M +import qualified Data.Attoparsec.ByteString.Lazy as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import Data.ByteString.Builder data LogEntry v = LogEntry { changed :: VectorClock , value :: v - } deriving (Eq) + } deriving (Eq, Show) type MapLog f v = M.Map f (LogEntry v) -showMapLog :: (f -> String) -> (v -> String) -> MapLog f v -> String -showMapLog fieldshower valueshower = unlines . map showpair . M.toList +buildMapLog :: (f -> Builder) -> (v -> Builder) -> MapLog f v -> Builder +buildMapLog fieldbuilder valuebuilder = mconcat . map genline . M.toList where - showpair (f, LogEntry (VectorClock c) v) = - unwords [show c, fieldshower f, valueshower v] - showpair (f, LogEntry Unknown v) = - unwords ["0", fieldshower f, valueshower v] + genline (f, LogEntry c v) = + buildVectorClock c <> sp + <> fieldbuilder f <> sp + <> valuebuilder v <> nl + sp = charUtf8 ' ' + nl = charUtf8 '\n' -parseMapLog :: Ord f => (String -> Maybe f) -> (String -> Maybe v) -> String -> MapLog f v -parseMapLog fieldparser valueparser = M.fromListWith best . mapMaybe parse . splitLines +parseMapLog :: Ord f => A.Parser f -> A.Parser v -> L.ByteString -> MapLog f v +parseMapLog fieldparser valueparser = fromMaybe M.empty . A.maybeResult + . A.parse (mapLogParser fieldparser valueparser) + +mapLogParser :: Ord f => A.Parser f -> A.Parser v -> A.Parser (MapLog f v) +mapLogParser fieldparser valueparser = M.fromListWith best <$> parseLogLines go where - parse line = do - let (sc, rest) = splitword line - (sf, sv) = splitword rest - c <- parseVectorClock sc - f <- fieldparser sf - v <- valueparser sv - Just (f, LogEntry c v) - splitword = separate (== ' ') + go = do + c <- vectorClockParser + _ <- A8.char ' ' + w <- A8.takeTill (== ' ') + f <- either fail return $ + A.parseOnly (fieldparser <* A.endOfInput) w + _ <- A8.char ' ' + v <- valueparser + A.endOfInput + return (f, LogEntry c v) changeMapLog :: Ord f => VectorClock -> f -> v -> MapLog f v -> MapLog f v changeMapLog c f v = M.insert f $ LogEntry c v diff --git a/Logs/MetaData.hs b/Logs/MetaData.hs --- a/Logs/MetaData.hs +++ b/Logs/MetaData.hs @@ -78,7 +78,7 @@ let MetaData m = value l ts = lastchangedval l in M.map (const ts) m - lastchangedval l = S.singleton $ toMetaValue $ showts $ + lastchangedval l = S.singleton $ toMetaValue $ encodeBS $ showts $ case changed l of VectorClock t -> t Unknown -> 0 @@ -110,7 +110,7 @@ | otherwise = do config <- Annex.getGitConfig Annex.Branch.change (getlogfile config k) $ - showLog . simplifyLog + buildLog . simplifyLog . S.insert (LogEntry c metadata) . parseLog where @@ -145,7 +145,7 @@ else do config <- Annex.getGitConfig Annex.Branch.change (metaDataLogFile config newkey) $ - const $ showLog l + const $ buildLog l return True readLog :: FilePath -> Annex (Log MetaData) diff --git a/Logs/MetaData/Pure.hs b/Logs/MetaData/Pure.hs --- a/Logs/MetaData/Pure.hs +++ b/Logs/MetaData/Pure.hs @@ -11,7 +11,7 @@ Log, LogEntry(..), parseLog, - showLog, + buildLog, logToCurrentMetaData, simplifyLog, filterRemoteMetaData, diff --git a/Logs/Multicast.hs b/Logs/Multicast.hs --- a/Logs/Multicast.hs +++ b/Logs/Multicast.hs @@ -1,6 +1,6 @@ {- git-annex multicast fingerprint log - - - Copyright 2017 Joey Hess + - Copyright 2017, 2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -17,6 +17,8 @@ import Logs.UUIDBased import qualified Data.Map as M +import qualified Data.Attoparsec.ByteString.Lazy as A +import Data.ByteString.Builder newtype Fingerprint = Fingerprint String deriving (Eq, Read, Show) @@ -25,7 +27,17 @@ recordFingerprint fp uuid = do c <- liftIO currentVectorClock Annex.Branch.change multicastLog $ - showLog show . changeLog c uuid fp . parseLog readish + buildLog buildFindgerPrint + . changeLog c uuid fp + . parseLog fingerprintParser knownFingerPrints :: Annex (M.Map UUID Fingerprint) -knownFingerPrints = simpleMap . parseLog readish <$> Annex.Branch.get activityLog +knownFingerPrints = simpleMap . parseLog fingerprintParser + <$> Annex.Branch.get activityLog + +fingerprintParser :: A.Parser Fingerprint +fingerprintParser = maybe (fail "fingerprint parse failed") pure + . readish . decodeBS =<< A.takeByteString + +buildFindgerPrint :: Fingerprint -> Builder +buildFindgerPrint = byteString . encodeBS . show diff --git a/Logs/NumCopies.hs b/Logs/NumCopies.hs --- a/Logs/NumCopies.hs +++ b/Logs/NumCopies.hs @@ -20,8 +20,8 @@ import Logs.SingleValue instance SingleValueSerializable NumCopies where - serialize (NumCopies n) = show n - deserialize = NumCopies <$$> readish + serialize (NumCopies n) = encodeBS (show n) + deserialize = NumCopies <$$> readish . decodeBS setGlobalNumCopies :: NumCopies -> Annex () setGlobalNumCopies new = do diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -1,6 +1,6 @@ {- git-annex preferred content matcher configuration - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -26,6 +26,7 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Either +import qualified Data.Attoparsec.ByteString.Lazy as A import Annex.Common import Logs.PreferredContent.Raw @@ -73,7 +74,7 @@ groupmap <- groupMap configmap <- readRemoteLog let genmap l gm = simpleMap - . parseLogWithUUID ((Just .) . makeMatcher groupmap configmap gm) + . parseLogWithUUID (\u -> makeMatcher groupmap configmap gm u . decodeBS <$> A.takeByteString) <$> Annex.Branch.get l pc <- genmap preferredContentLog =<< groupPreferredContentMapRaw rc <- genmap requiredContentLog M.empty diff --git a/Logs/PreferredContent/Raw.hs b/Logs/PreferredContent/Raw.hs --- a/Logs/PreferredContent/Raw.hs +++ b/Logs/PreferredContent/Raw.hs @@ -1,6 +1,6 @@ {- unparsed preferred content expressions - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -17,6 +17,9 @@ import Types.Group import qualified Data.Map as M +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString.Lazy as A +import Data.ByteString.Builder {- Changes the preferred content configuration of a remote. -} preferredContentSet :: UUID -> PreferredContentExpression -> Annex () @@ -29,9 +32,9 @@ setLog logfile uuid@(UUID _) val = do c <- liftIO currentVectorClock Annex.Branch.change logfile $ - showLog id + buildLog buildPreferredContentExpression . changeLog c uuid val - . parseLog Just + . parseLog parsePreferredContentExpression Annex.changeState $ \s -> s { Annex.preferredcontentmap = Nothing , Annex.requiredcontentmap = Nothing @@ -43,19 +46,37 @@ groupPreferredContentSet g val = do c <- liftIO currentVectorClock Annex.Branch.change groupPreferredContentLog $ - showMapLog id id + buildGroupPreferredContent . changeMapLog c g val - . parseMapLog Just Just + . parseGroupPreferredContent Annex.changeState $ \s -> s { Annex.preferredcontentmap = Nothing } +parseGroupPreferredContent :: L.ByteString -> MapLog Group String +parseGroupPreferredContent = parseMapLog parsegroup parsestring + where + parsegroup = Group <$> A.takeByteString + parsestring = decodeBS <$> A.takeByteString + +buildGroupPreferredContent :: MapLog Group PreferredContentExpression -> Builder +buildGroupPreferredContent = buildMapLog buildgroup buildexpr + where + buildgroup (Group g) = byteString g + buildexpr = byteString . encodeBS + +parsePreferredContentExpression :: A.Parser PreferredContentExpression +parsePreferredContentExpression = decodeBS <$> A.takeByteString + +buildPreferredContentExpression :: PreferredContentExpression -> Builder +buildPreferredContentExpression = byteString . encodeBS + preferredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression) -preferredContentMapRaw = simpleMap . parseLog Just +preferredContentMapRaw = simpleMap . parseLog parsePreferredContentExpression <$> Annex.Branch.get preferredContentLog requiredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression) -requiredContentMapRaw = simpleMap . parseLog Just +requiredContentMapRaw = simpleMap . parseLog parsePreferredContentExpression <$> Annex.Branch.get requiredContentLog groupPreferredContentMapRaw :: Annex (M.Map Group PreferredContentExpression) -groupPreferredContentMapRaw = simpleMap . parseMapLog Just Just +groupPreferredContentMapRaw = simpleMap . parseGroupPreferredContent <$> Annex.Branch.get groupPreferredContentLog diff --git a/Logs/Presence.hs b/Logs/Presence.hs --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -31,8 +31,8 @@ {- Adds a LogLine to the log, removing any LogLines that are obsoleted by - adding it. -} addLog :: FilePath -> LogLine -> Annex () -addLog file line = Annex.Branch.change file $ \s -> - showLog $ compactLog (line : parseLog s) +addLog file line = Annex.Branch.change file $ \b -> + buildLog $ compactLog (line : parseLog b) {- When a LogLine already exists with the same status and info, but an - older timestamp, that LogLine is preserved, rather than updating the log @@ -41,7 +41,7 @@ maybeAddLog :: FilePath -> LogLine -> Annex () maybeAddLog file line = Annex.Branch.maybeChange file $ \s -> do m <- insertNewStatus line $ logMap $ parseLog s - return $ showLog $ mapLog m + return $ buildLog $ mapLog m {- Reads a log file. - Note that the LogLines returned may be in any order. -} @@ -49,13 +49,13 @@ readLog = parseLog <$$> Annex.Branch.get {- Generates a new LogLine with the current time. -} -logNow :: LogStatus -> String -> Annex LogLine +logNow :: LogStatus -> LogInfo -> Annex LogLine logNow s i = do c <- liftIO currentVectorClock return $ LogLine c s i {- Reads a log and returns only the info that is still in effect. -} -currentLogInfo :: FilePath -> Annex [String] +currentLogInfo :: FilePath -> Annex [LogInfo] currentLogInfo file = map info <$> currentLog file currentLog :: FilePath -> Annex [LogLine] @@ -66,6 +66,6 @@ - - The date is formatted as shown in gitrevisions man page. -} -historicalLogInfo :: RefDate -> FilePath -> Annex [String] +historicalLogInfo :: RefDate -> FilePath -> Annex [LogInfo] historicalLogInfo refdate file = map info . filterPresent . parseLog <$> Annex.Branch.getHistorical refdate file diff --git a/Logs/Presence/Pure.hs b/Logs/Presence/Pure.hs --- a/Logs/Presence/Pure.hs +++ b/Logs/Presence/Pure.hs @@ -1,6 +1,6 @@ {- git-annex presence log, pure operations - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -13,48 +13,64 @@ import Utility.QuickCheck import qualified Data.Map as M +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as C8 +import qualified Data.Attoparsec.ByteString.Lazy as A +import Data.Attoparsec.ByteString.Char8 (char, anyChar) +import Data.ByteString.Builder +newtype LogInfo = LogInfo { fromLogInfo :: S.ByteString } + deriving (Show, Eq, Ord) + data LogLine = LogLine { date :: VectorClock , status :: LogStatus - , info :: String - } deriving (Eq) - -instance Show LogLine where - show l = "LogLine " ++ formatVectorClock (date l) ++ show (status l) ++ " " ++ show (info l) + , info :: LogInfo + } deriving (Eq, Show) data LogStatus = InfoPresent | InfoMissing | InfoDead deriving (Eq, Show, Bounded, Enum) -{- Parses a log file. Unparseable lines are ignored. -} -parseLog :: String -> [LogLine] -parseLog = mapMaybe parseline . splitLines - where - parseline l = LogLine - <$> parseVectorClock c - <*> parseStatus s - <*> pure rest - where - (c, pastc) = separate (== ' ') l - (s, rest) = separate (== ' ') pastc +parseLog :: L.ByteString -> [LogLine] +parseLog = fromMaybe [] . A.maybeResult . A.parse logParser +logParser :: A.Parser [LogLine] +logParser = parseLogLines $ LogLine + <$> vectorClockParser + <* char ' ' + <*> statusParser + <* char ' ' + <*> (LogInfo <$> A.takeByteString) + +statusParser :: A.Parser LogStatus +statusParser = do + c <- anyChar + case c of + '1' -> return InfoPresent + '0' -> return InfoMissing + 'X' -> return InfoDead + _ -> fail "unknown status character" + parseStatus :: String -> Maybe LogStatus parseStatus "1" = Just InfoPresent parseStatus "0" = Just InfoMissing parseStatus "X" = Just InfoDead parseStatus _ = Nothing -{- Generates a log file. -} -showLog :: [LogLine] -> String -showLog = unlines . map genline +buildLog :: [LogLine] -> Builder +buildLog = mconcat . map genline where - genline (LogLine c s i) = unwords [formatVectorClock c, genstatus s, i] - genstatus InfoPresent = "1" - genstatus InfoMissing = "0" - genstatus InfoDead = "X" + genline (LogLine c s (LogInfo i)) = + buildVectorClock c <> sp <> genstatus s <> sp <> byteString i <> nl + sp = charUtf8 ' ' + nl = charUtf8 '\n' + genstatus InfoPresent = charUtf8 '1' + genstatus InfoMissing = charUtf8 '0' + genstatus InfoDead = charUtf8 'X' {- Given a log, returns only the info that is are still in effect. -} -getLog :: String -> [String] +getLog :: L.ByteString -> [LogInfo] getLog = map info . filterPresent . parseLog {- Returns the info from LogLines that are in effect. -} @@ -66,7 +82,7 @@ compactLog :: [LogLine] -> [LogLine] compactLog = mapLog . logMap -type LogMap = M.Map String LogLine +type LogMap = M.Map LogInfo LogLine mapLog :: LogMap -> [LogLine] mapLog = M.elems @@ -101,9 +117,11 @@ arbitrary = LogLine <$> arbitrary <*> elements [minBound..maxBound] - <*> arbitrary `suchThat` - (\c -> '\n' `notElem` c && '\r' `notElem` c) + <*> (LogInfo <$> arbinfo) + where + arbinfo = (encodeBS <$> arbitrary) `suchThat` + (\b -> C8.notElem '\n' b && C8.notElem '\r' b) -prop_parse_show_log :: [LogLine] -> Bool -prop_parse_show_log l = parseLog (showLog l) == l +prop_parse_build_log :: [LogLine] -> Bool +prop_parse_build_log l = parseLog (toLazyByteString (buildLog l)) == l diff --git a/Logs/Remote.hs b/Logs/Remote.hs --- a/Logs/Remote.hs +++ b/Logs/Remote.hs @@ -12,7 +12,6 @@ keyValToConfig, configToKeyVal, showConfig, - parseConfig, prop_isomorphic_configEscape, prop_parse_show_Config, @@ -26,20 +25,25 @@ import qualified Data.Map as M import Data.Char +import qualified Data.Attoparsec.ByteString.Lazy as A +import Data.ByteString.Builder {- Adds or updates a remote's config in the log. -} configSet :: UUID -> RemoteConfig -> Annex () configSet u cfg = do c <- liftIO currentVectorClock Annex.Branch.change remoteLog $ - showLog showConfig . changeLog c u cfg . parseLog parseConfig + buildLog (byteString . encodeBS . showConfig) + . changeLog c u cfg + . parseLog remoteConfigParser {- Map of remotes by uuid containing key/value config maps. -} readRemoteLog :: Annex (M.Map UUID RemoteConfig) -readRemoteLog = simpleMap . parseLog parseConfig <$> Annex.Branch.get remoteLog +readRemoteLog = simpleMap . parseLog remoteConfigParser + <$> Annex.Branch.get remoteLog -parseConfig :: String -> Maybe RemoteConfig -parseConfig = Just . keyValToConfig . words +remoteConfigParser :: A.Parser RemoteConfig +remoteConfigParser = keyValToConfig . words . decodeBS <$> A.takeByteString showConfig :: RemoteConfig -> String showConfig = unwords . configToKeyVal @@ -88,9 +92,16 @@ prop_parse_show_Config :: RemoteConfig -> Bool prop_parse_show_Config c - -- whitespace and '=' are not supported in keys + -- whitespace and '=' are not supported in config keys | any (\k -> any isSpace k || elem '=' k) (M.keys c) = True - | otherwise = parseConfig (showConfig c) ~~ Just c + | any (any excluded) (M.keys c) = True + | any (any excluded) (M.elems c) = True + | otherwise = A.parseOnly remoteConfigParser (encodeBS $ showConfig c) ~~ Right c where normalize v = sort . M.toList <$> v a ~~ b = normalize a == normalize b + -- limit to ascii alphanumerics for simplicity; characters not + -- allowed by the current character set in the config may not + -- round-trip in an identical representation due to the use of the + -- filesystem encoding. + excluded ch = not (isAlphaNum ch) || not (isAscii ch) diff --git a/Logs/RemoteState.hs b/Logs/RemoteState.hs --- a/Logs/RemoteState.hs +++ b/Logs/RemoteState.hs @@ -1,6 +1,6 @@ {- Remote state logs. - - - Copyright 2014 Joey Hess + - Copyright 2014, 2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -17,6 +17,9 @@ import qualified Annex import qualified Data.Map as M +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString.Lazy as A +import Data.ByteString.Builder type RemoteState = String @@ -25,12 +28,18 @@ c <- liftIO currentVectorClock config <- Annex.getGitConfig Annex.Branch.change (remoteStateLogFile config k) $ - showLogNew id . changeLog c u s . parseLogNew Just + buildRemoteState . changeLog c u s . parseRemoteState +buildRemoteState :: Log RemoteState -> Builder +buildRemoteState = buildLogNew (byteString . encodeBS) + getRemoteState :: UUID -> Key -> Annex (Maybe RemoteState) getRemoteState u k = do config <- Annex.getGitConfig - extract . parseLogNew Just + extract . parseRemoteState <$> Annex.Branch.get (remoteStateLogFile config k) where extract m = value <$> M.lookup u m + +parseRemoteState :: L.ByteString -> Log RemoteState +parseRemoteState = parseLogNew (decodeBS <$> A.takeByteString) diff --git a/Logs/Schedule.hs b/Logs/Schedule.hs --- a/Logs/Schedule.hs +++ b/Logs/Schedule.hs @@ -20,6 +20,8 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Time.LocalTime +import qualified Data.Attoparsec.ByteString.Lazy as A +import Data.ByteString.Builder import Annex.Common import Types.ScheduledActivity @@ -32,17 +34,18 @@ scheduleSet uuid@(UUID _) activities = do c <- liftIO currentVectorClock Annex.Branch.change scheduleLog $ - showLog id . changeLog c uuid val . parseLog Just + buildLog byteString + . changeLog c uuid (encodeBS val) + . parseLog A.takeByteString where val = fromScheduledActivities activities scheduleSet NoUUID _ = error "unknown UUID; cannot modify" scheduleMap :: Annex (M.Map UUID [ScheduledActivity]) -scheduleMap = simpleMap - . parseLogWithUUID parser - <$> Annex.Branch.get scheduleLog +scheduleMap = simpleMap . parseLog parser <$> Annex.Branch.get scheduleLog where - parser _uuid = eitherToMaybe . parseScheduledActivities + parser = either fail pure . parseScheduledActivities . decodeBS + =<< A.takeByteString scheduleGet :: UUID -> Annex (S.Set ScheduledActivity) scheduleGet u = do diff --git a/Logs/SingleValue.hs b/Logs/SingleValue.hs --- a/Logs/SingleValue.hs +++ b/Logs/SingleValue.hs @@ -35,4 +35,4 @@ setLog f v = do c <- liftIO currentVectorClock let ent = LogEntry c v - Annex.Branch.change f $ \_old -> showLog (S.singleton ent) + Annex.Branch.change f $ \_old -> buildLog (S.singleton ent) diff --git a/Logs/SingleValue/Pure.hs b/Logs/SingleValue/Pure.hs --- a/Logs/SingleValue/Pure.hs +++ b/Logs/SingleValue/Pure.hs @@ -1,6 +1,6 @@ {- git-annex single-value log, pure operations - - - Copyright 2014 Joey Hess + - Copyright 2014-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -12,10 +12,15 @@ import Annex.VectorClock import qualified Data.Set as S +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString.Lazy as A +import Data.Attoparsec.ByteString.Char8 (char) +import Data.ByteString.Builder class SingleValueSerializable v where - serialize :: v -> String - deserialize :: String -> Maybe v + serialize :: v -> B.ByteString + deserialize :: B.ByteString -> Maybe v data LogEntry v = LogEntry { changed :: VectorClock @@ -24,20 +29,25 @@ type Log v = S.Set (LogEntry v) -showLog :: (SingleValueSerializable v) => Log v -> String -showLog = unlines . map showline . S.toList +buildLog :: (SingleValueSerializable v) => Log v -> Builder +buildLog = mconcat . map genline . S.toList where - showline (LogEntry c v) = unwords [formatVectorClock c, serialize v] + genline (LogEntry c v) = + buildVectorClock c <> sp <> byteString (serialize v) <> nl + sp = charUtf8 ' ' + nl = charUtf8 '\n' -parseLog :: (Ord v, SingleValueSerializable v) => String -> Log v -parseLog = S.fromList . mapMaybe parse . splitLines +parseLog :: (Ord v, SingleValueSerializable v) => L.ByteString -> Log v +parseLog = S.fromList . fromMaybe [] + . A.maybeResult . A.parse (logParser <* A.endOfInput) + +logParser :: SingleValueSerializable v => A.Parser [LogEntry v] +logParser = parseLogLines $ LogEntry + <$> vectorClockParser + <* char ' ' + <*> (parsevalue =<< A.takeByteString) where - parse line = do - let (sc, s) = splitword line - c <- parseVectorClock sc - v <- deserialize s - Just (LogEntry c v) - splitword = separate (== ' ') + parsevalue = maybe (fail "log line parse failure") return . deserialize newestValue :: Log v -> Maybe v newestValue s diff --git a/Logs/Smudge.hs b/Logs/Smudge.hs --- a/Logs/Smudge.hs +++ b/Logs/Smudge.hs @@ -16,7 +16,7 @@ smudgeLog k f = do logf <- fromRepo gitAnnexSmudgeLog appendLogFile logf gitAnnexSmudgeLock $ - key2file k ++ " " ++ getTopFilePath f + serializeKey k ++ " " ++ getTopFilePath f -- | Streams all smudged files, and then empties the log at the end. -- @@ -36,5 +36,5 @@ parse l = let (ks, f) = separate (== ' ') l in do - k <- file2key ks + k <- deserializeKey ks return (k, asTopFilePath f) diff --git a/Logs/Transitions.hs b/Logs/Transitions.hs --- a/Logs/Transitions.hs +++ b/Logs/Transitions.hs @@ -7,7 +7,7 @@ - done that is listed in the remote branch by checking that the local - branch contains the same transition, with the same or newer start time. - - - Copyright 2013 Joey Hess + - Copyright 2013-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -19,6 +19,12 @@ import Logs.Line import qualified Data.Set as S +import Data.Either +import Data.ByteString (ByteString) +import Data.ByteString.Builder +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString.Lazy as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 transitionsLog :: FilePath transitionsLog = "transitions.log" @@ -30,7 +36,8 @@ data TransitionLine = TransitionLine { transitionStarted :: VectorClock - , transition :: Transition + -- New transitions that we don't know about yet are preserved. + , transition :: Either ByteString Transition } deriving (Ord, Eq) type Transitions = S.Set TransitionLine @@ -43,44 +50,50 @@ noTransitions = S.empty addTransition :: VectorClock -> Transition -> Transitions -> Transitions -addTransition c t = S.insert $ TransitionLine c t - -showTransitions :: Transitions -> String -showTransitions = unlines . map showTransitionLine . S.elems +addTransition c t = S.insert $ TransitionLine c (Right t) -{- If the log contains new transitions we don't support, returns Nothing. -} -parseTransitions :: String -> Maybe Transitions -parseTransitions = check . map parseTransitionLine . splitLines +buildTransitions :: Transitions -> Builder +buildTransitions = mconcat . map genline . S.elems where - check l - | all isJust l = Just $ S.fromList $ catMaybes l - | otherwise = Nothing + genline tl = buildt (transition tl) <> charUtf8 ' ' + <> buildVectorClock (transitionStarted tl) <> charUtf8 '\n' + buildt (Left b) = byteString b + buildt (Right t) = byteString (encodeBS (show t)) -parseTransitionsStrictly :: String -> String -> Transitions -parseTransitionsStrictly source = fromMaybe badsource . parseTransitions - where - badsource = giveup $ "unknown transitions listed in " ++ source ++ "; upgrade git-annex!" +parseTransitions :: L.ByteString -> Transitions +parseTransitions = fromMaybe S.empty . A.maybeResult . A.parse + (S.fromList <$> parseLogLines transitionLineParser) +parseTransitionsStrictly :: String -> L.ByteString -> Transitions +parseTransitionsStrictly source b = + let ts = parseTransitions b + in if S.null $ S.filter (isLeft . transition) ts + then ts + else giveup $ "unknown transitions listed in " ++ source ++ "; upgrade git-annex!" + showTransitionLine :: TransitionLine -> String showTransitionLine (TransitionLine c t) = unwords [show t, formatVectorClock c] -parseTransitionLine :: String -> Maybe TransitionLine -parseTransitionLine s = TransitionLine - <$> parseVectorClock cs - <*> readish ts +transitionLineParser :: A.Parser TransitionLine +transitionLineParser = do + t <- (parsetransition <$> A.takeByteString) + _ <- A8.char ' ' + c <- vectorClockParser + return $ TransitionLine c t where - ws = words s - ts = Prelude.head ws - cs = unwords $ Prelude.tail ws + parsetransition b = case readish (decodeBS b) of + Just t -> Right t + Nothing -> Left b combineTransitions :: [Transitions] -> Transitions combineTransitions = S.unions -transitionList :: Transitions -> [Transition] -transitionList = nub . map transition . S.elems +{- Unknown types of transitions are omitted. -} +knownTransitionList :: Transitions -> [Transition] +knownTransitionList = nub . rights . map transition . S.elems {- Typically ran with Annex.Branch.change, but we can't import Annex.Branch - here since it depends on this module. -} -recordTransitions :: (FilePath -> (String -> String) -> Annex ()) -> Transitions -> Annex () +recordTransitions :: (FilePath -> (L.ByteString -> Builder) -> Annex ()) -> Transitions -> Annex () recordTransitions changer t = changer transitionsLog $ - showTransitions . S.union t . parseTransitionsStrictly "local" + buildTransitions . S.union t . parseTransitionsStrictly "local" diff --git a/Logs/Trust/Basic.hs b/Logs/Trust/Basic.hs --- a/Logs/Trust/Basic.hs +++ b/Logs/Trust/Basic.hs @@ -24,9 +24,9 @@ trustSet uuid@(UUID _) level = do c <- liftIO currentVectorClock Annex.Branch.change trustLog $ - showLog showTrustLog . + buildLog buildTrustLevel . changeLog c uuid level . - parseLog (Just . parseTrustLog) + parseLog trustLevelParser Annex.changeState $ \s -> s { Annex.trustmap = Nothing } trustSet NoUUID _ = error "unknown UUID; cannot modify" diff --git a/Logs/Trust/Pure.hs b/Logs/Trust/Pure.hs --- a/Logs/Trust/Pure.hs +++ b/Logs/Trust/Pure.hs @@ -1,36 +1,49 @@ {- git-annex trust log, pure operations - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2018 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Logs.Trust.Pure where import Annex.Common import Types.TrustLevel import Logs.UUIDBased -calcTrustMap :: String -> TrustMap -calcTrustMap = simpleMap . parseLog (Just . parseTrustLog) +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString.Lazy as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import Data.ByteString.Builder -{- The trust.log used to only list trusted repos, without a field for the - - trust status, which is why this defaults to Trusted. -} -parseTrustLog :: String -> TrustLevel -parseTrustLog s = maybe Trusted parse $ headMaybe $ words s +calcTrustMap :: L.ByteString -> TrustMap +calcTrustMap = simpleMap . parseLog trustLevelParser + +trustLevelParser :: A.Parser TrustLevel +trustLevelParser = (totrust <$> A8.anyChar <* A.endOfInput) + -- The trust log used to only list trusted repos, without a + -- value for the trust status + <|> (const Trusted <$> A.endOfInput) where - parse "1" = Trusted - parse "0" = UnTrusted - parse "X" = DeadTrusted - parse _ = SemiTrusted + totrust '1' = Trusted + totrust '0' = UnTrusted + totrust 'X' = DeadTrusted + -- Allow for future expansion by treating unknown trust levels as + -- semitrusted. + totrust _ = SemiTrusted -showTrustLog :: TrustLevel -> String -showTrustLog Trusted = "1" -showTrustLog UnTrusted = "0" -showTrustLog DeadTrusted = "X" -showTrustLog SemiTrusted = "?" +buildTrustLevel :: TrustLevel -> Builder +buildTrustLevel Trusted = byteString "1" +buildTrustLevel UnTrusted = byteString "0" +buildTrustLevel DeadTrusted = byteString "X" +buildTrustLevel SemiTrusted = byteString "?" -prop_parse_show_TrustLog :: Bool -prop_parse_show_TrustLog = all check [minBound .. maxBound] +prop_parse_build_TrustLevelLog :: Bool +prop_parse_build_TrustLevelLog = all check [minBound .. maxBound] where - check l = parseTrustLog (showTrustLog l) == l + check l = + let v = A.parseOnly trustLevelParser $ L.toStrict $ + toLazyByteString $ buildTrustLevel l + in v == Right l diff --git a/Logs/UUID.hs b/Logs/UUID.hs --- a/Logs/UUID.hs +++ b/Logs/UUID.hs @@ -1,14 +1,8 @@ -{- git-annex uuids - - - - Each git repository used by git-annex has an annex.uuid setting that - - uniquely identifies that repository. - - - - UUIDs of remotes are cached in git config, using keys named - - remote..annex-uuid +{- git-annex uuid log - - uuid.log stores a list of known uuids, and their descriptions. - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -16,8 +10,8 @@ module Logs.UUID ( uuidLog, describeUUID, - uuidMap, - uuidMapLoad + uuidDescMap, + uuidDescMapLoad ) where import Types.UUID @@ -30,57 +24,33 @@ import qualified Annex.UUID import qualified Data.Map.Strict as M +import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString.Lazy as A {- Records a description for a uuid in the log. -} -describeUUID :: UUID -> String -> Annex () +describeUUID :: UUID -> UUIDDesc -> Annex () describeUUID uuid desc = do c <- liftIO currentVectorClock Annex.Branch.change uuidLog $ - showLog id . changeLog c uuid desc . fixBadUUID . parseLog Just - -{- Temporarily here to fix badly formatted uuid logs generated by - - versions 3.20111105 and 3.20111025. - - - - Those logs contain entries with the UUID and description flipped. - - Due to parsing, if the description is multiword, only the first - - will be taken to be the UUID. So, if the UUID of an entry does - - not look like a UUID, and the last word of the description does, - - flip them back. - -} -fixBadUUID :: Log String -> Log String -fixBadUUID = M.fromList . map fixup . M.toList - where - fixup (k, v) - | isbad = (fixeduuid, LogEntry (newertime v) fixedvalue) - | otherwise = (k, v) - where - kuuid = fromUUID k - isbad = not (isuuid kuuid) && not (null ws) && isuuid lastword - ws = words $ value v - lastword = Prelude.last ws - fixeduuid = toUUID lastword - fixedvalue = unwords $ kuuid: Prelude.init ws - -- For the fixed line to take precidence, it should be - -- slightly newer, but only slightly. - newertime (LogEntry (VectorClock c) _) = VectorClock (c + minimumPOSIXTimeSlice) - newertime (LogEntry Unknown _) = VectorClock minimumPOSIXTimeSlice - minimumPOSIXTimeSlice = 0.000001 - isuuid s = length s == 36 && length (splitc '-' s) == 5 + buildLog buildUUIDDesc . changeLog c uuid desc . parseUUIDLog {- The map is cached for speed. -} -uuidMap :: Annex UUIDMap -uuidMap = maybe uuidMapLoad return =<< Annex.getState Annex.uuidmap +uuidDescMap :: Annex UUIDDescMap +uuidDescMap = maybe uuidDescMapLoad return =<< Annex.getState Annex.uuiddescmap {- Read the uuidLog into a simple Map. - - The UUID of the current repository is included explicitly, since - - it may not have been described and so otherwise would not appear. -} -uuidMapLoad :: Annex UUIDMap -uuidMapLoad = do - m <- (simpleMap . parseLog Just) <$> Annex.Branch.get uuidLog + - it may not have been described and otherwise would not appear. -} +uuidDescMapLoad :: Annex UUIDDescMap +uuidDescMapLoad = do + m <- simpleMap . parseUUIDLog <$> Annex.Branch.get uuidLog u <- Annex.UUID.getUUID - let m' = M.insertWith preferold u "" m - Annex.changeState $ \s -> s { Annex.uuidmap = Just m' } + let m' = M.insertWith preferold u mempty m + Annex.changeState $ \s -> s { Annex.uuiddescmap = Just m' } return m' where preferold = flip const + +parseUUIDLog :: L.ByteString -> Log UUIDDesc +parseUUIDLog = parseLog (UUIDDesc <$> A.takeByteString) diff --git a/Logs/UUIDBased.hs b/Logs/UUIDBased.hs --- a/Logs/UUIDBased.hs +++ b/Logs/UUIDBased.hs @@ -9,11 +9,13 @@ - - New uuid based logs instead use the form: "timestamp UUID INFO" - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings, TupleSections #-} + module Logs.UUIDBased ( Log, LogEntry(..), @@ -22,8 +24,8 @@ parseLog, parseLogNew, parseLogWithUUID, - showLog, - showLogNew, + buildLog, + buildLogNew, changeLog, addLog, simpleMap, @@ -37,54 +39,57 @@ import Logs.MapLog import Logs.Line +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 +import Data.ByteString.Builder +import qualified Data.DList as D + type Log v = MapLog UUID v -showLog :: (v -> String) -> Log v -> String -showLog shower = unlines . map showpair . M.toList +buildLog :: (v -> Builder) -> Log v -> Builder +buildLog builder = mconcat . map genline . M.toList where - showpair (k, LogEntry (VectorClock c) v) = - unwords [fromUUID k, shower v, tskey ++ show c] - showpair (k, LogEntry Unknown v) = - unwords [fromUUID k, shower v] + genline (u, LogEntry c@(VectorClock {}) v) = + buildUUID u <> sp <> builder v <> sp <> + byteString "timestamp=" <> buildVectorClock c <> nl + genline (u, LogEntry Unknown v) = + buildUUID u <> sp <> builder v <> nl + sp = charUtf8 ' ' + nl = charUtf8 '\n' -parseLog :: (String -> Maybe a) -> String -> Log a +parseLog :: A.Parser a -> L.ByteString -> Log a parseLog = parseLogWithUUID . const -parseLogWithUUID :: (UUID -> String -> Maybe a) -> String -> Log a -parseLogWithUUID parser = M.fromListWith best . mapMaybe parse . splitLines +parseLogWithUUID :: (UUID -> A.Parser a) -> L.ByteString -> Log a +parseLogWithUUID parser = fromMaybe M.empty . A.maybeResult + . A.parse (logParser parser) + +logParser :: (UUID -> A.Parser a) -> A.Parser (Log a) +logParser parser = M.fromListWith best <$> parseLogLines go where - parse line - -- This is a workaround for a bug that caused - -- NoUUID items to be stored in the log. - -- It can be removed at any time; is just here to clean - -- up logs where that happened temporarily. - | " " `isPrefixOf` line = Nothing - | null ws = Nothing - | otherwise = parser u (unwords info) >>= makepair - where - makepair v = Just (u, LogEntry ts v) - ws = words line - u = toUUID $ Prelude.head ws - t = Prelude.last ws - ts - | tskey `isPrefixOf` t = fromMaybe Unknown $ - parseVectorClock $ drop 1 $ dropWhile (/= '=') t - | otherwise = Unknown - info - | ts == Unknown = drop 1 ws - | otherwise = drop 1 $ beginning ws + go = do + u <- toUUID <$> A8.takeWhile1 (/= ' ') + (dl, ts) <- accumval D.empty + v <- either fail return $ A.parseOnly (parser u <* A.endOfInput) + (S.intercalate " " $ D.toList dl) + return (u, LogEntry ts v) + accumval dl = + ((dl,) <$> parsetimestamp) + <|> (A8.char ' ' *> (A8.takeWhile (/= ' ')) >>= accumval . D.snoc dl) + parsetimestamp = + (A8.string " timestamp=" *> vectorClockParser <* A.endOfInput) + <|> (const Unknown <$> A.endOfInput) -showLogNew :: (v -> String) -> Log v -> String -showLogNew = showMapLog fromUUID +buildLogNew :: (v -> Builder) -> Log v -> Builder +buildLogNew = buildMapLog buildUUID -parseLogNew :: (String -> Maybe v) -> String -> Log v -parseLogNew = parseMapLog (Just . toUUID) +parseLogNew :: A.Parser v -> L.ByteString -> Log v +parseLogNew = parseMapLog (toUUID <$> A.takeByteString) changeLog :: VectorClock -> UUID -> v -> Log v -> Log v changeLog = changeMapLog addLog :: UUID -> LogEntry v -> Log v -> Log v addLog = addMapLog - -tskey :: String -tskey = "timestamp=" diff --git a/Logs/Unused.hs b/Logs/Unused.hs --- a/Logs/Unused.hs +++ b/Logs/Unused.hs @@ -66,8 +66,8 @@ logfile <- fromRepo $ gitAnnexUnusedLog prefix writeLogFile logfile $ unlines $ map format $ M.toList l where - format (k, (i, Just t)) = show i ++ " " ++ key2file k ++ " " ++ show t - format (k, (i, Nothing)) = show i ++ " " ++ key2file k + format (k, (i, Just t)) = show i ++ " " ++ serializeKey k ++ " " ++ show t + format (k, (i, Nothing)) = show i ++ " " ++ serializeKey k readUnusedLog :: FilePath -> Annex UnusedLog readUnusedLog prefix = do @@ -78,7 +78,7 @@ , return M.empty ) where - parse line = case (readish sint, file2key skey, parsePOSIXTime ts) of + parse line = case (readish sint, deserializeKey skey, parsePOSIXTime ts) of (Just int, Just key, mtimestamp) -> Just (key, (int, mtimestamp)) _ -> Nothing where diff --git a/Logs/View.hs b/Logs/View.hs --- a/Logs/View.hs +++ b/Logs/View.hs @@ -28,6 +28,7 @@ import Git.Types import Logs.File +import qualified Data.Text as T import qualified Data.Set as S import Data.Char @@ -74,15 +75,15 @@ branchcomp c | viewVisible c = branchcomp' c | otherwise = "(" ++ branchcomp' c ++ ")" - branchcomp' (ViewComponent metafield viewfilter _) =concat - [ forcelegal (fromMetaField metafield) + branchcomp' (ViewComponent metafield viewfilter _) = concat + [ forcelegal (T.unpack (fromMetaField metafield)) , branchvals viewfilter ] branchvals (FilterValues set) = '=' : branchset set branchvals (FilterGlob glob) = '=' : forcelegal glob branchvals (ExcludeValues set) = "!=" ++ branchset set branchset = intercalate "," - . map (forcelegal . fromMetaValue) + . map (forcelegal . decodeBS . fromMetaValue) . S.toList forcelegal s | Git.Ref.legal True s = s diff --git a/Logs/Web.hs b/Logs/Web.hs --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -20,7 +20,6 @@ removeTempUrl, ) where -import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Map as M import Annex.Common @@ -49,7 +48,7 @@ us <- currentLogInfo l if null us then go ls - else return us + else return $ map (decodeBS . fromLogInfo) us getUrlsWithPrefix :: Key -> String -> Annex [URLString] getUrlsWithPrefix key prefix = filter (prefix `isPrefixOf`) @@ -61,7 +60,8 @@ us <- getUrls key unless (url `elem` us) $ do config <- Annex.getGitConfig - addLog (urlLogFile config key) =<< logNow InfoPresent url + addLog (urlLogFile config key) + =<< logNow InfoPresent (LogInfo (encodeBS url)) -- If the url does not have an OtherDownloader, it must be present -- in the web. case snd (getDownloader url) of @@ -71,7 +71,8 @@ setUrlMissing :: Key -> URLString -> Annex () setUrlMissing key url = do config <- Annex.getGitConfig - addLog (urlLogFile config key) =<< logNow InfoMissing url + addLog (urlLogFile config key) + =<< logNow InfoMissing (LogInfo (encodeBS url)) -- If the url was a web url (not OtherDownloader) and none of -- the remaining urls for the key are web urls, the key must not -- be present in the web. @@ -102,7 +103,9 @@ Just k -> zip (repeat k) <$> geturls s Nothing -> return [] geturls Nothing = return [] - geturls (Just logsha) = getLog . L.unpack <$> catObject logsha + geturls (Just logsha) = + map (decodeBS . fromLogInfo) . getLog + <$> catObject logsha setTempUrl :: Key -> URLString -> Annex () setTempUrl key url = Annex.changeState $ \s -> diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -1,10 +1,12 @@ {- git-annex remotes - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Remote ( Remote, uuid, @@ -57,6 +59,7 @@ ) where import Data.Ord +import Data.String import qualified Data.Map as M import qualified Data.Vector as V @@ -92,13 +95,16 @@ {- Map of UUIDs of repositories and their descriptions. - The names of Remotes are added to suppliment any description that has - been set for a repository. -} -uuidDescriptions :: Annex (M.Map UUID String) -uuidDescriptions = M.unionWith addName <$> uuidMap <*> remoteMap name +uuidDescriptions :: Annex UUIDDescMap +uuidDescriptions = M.unionWith addName + <$> uuidDescMap + <*> remoteMap (UUIDDesc . encodeBS . name) -addName :: String -> RemoteName -> String +{- Add a remote name to its description. -} +addName :: (IsString t, Monoid t, Eq t) => t -> t -> t addName desc n - | desc == n || null desc = "[" ++ n ++ "]" - | otherwise = desc ++ " [" ++ n ++ "]" + | desc == n || desc == mempty = "[" <> n <> "]" + | otherwise = desc <> " [" <> n <> "]" byUUID :: UUID -> Annex (Maybe Remote) byUUID u = headMaybe . filter matching <$> remoteList @@ -170,8 +176,9 @@ NoUUID -> Left $ noRemoteUUIDMsg r u -> Right u go (Left e) = do - m <- uuidMap - return $ case M.keys (M.filter (== n) m) of + m <- uuidDescMap + let descn = UUIDDesc (encodeBS n) + return $ case M.keys (M.filter (== descn) m) of [u] -> Right u [] -> let u = toUUID n in case M.keys (M.filterWithKey (\k _ -> k == u) m) of @@ -189,7 +196,7 @@ descm <- uuidDescriptions prettyPrintUUIDsDescs header descm uuids -prettyPrintUUIDsDescs :: String -> M.Map UUID RemoteName -> [UUID] -> Annex String +prettyPrintUUIDsDescs :: String -> UUIDDescMap -> [UUID] -> Annex String prettyPrintUUIDsDescs header descm uuids = prettyPrintUUIDsWith Nothing header descm (const Nothing) @@ -200,7 +207,7 @@ :: ToJSON' v => Maybe String -> String - -> M.Map UUID RemoteName + -> UUIDDescMap -> (v -> Maybe String) -> [(UUID, Maybe v)] -> Annex String @@ -209,7 +216,7 @@ maybeShowJSON $ JSONChunk [(header, V.fromList $ map (jsonify hereu) uuidvals)] return $ unwords $ map (\u -> "\t" ++ prettify hereu u ++ "\n") uuidvals where - finddescription u = M.findWithDefault "" u descm + finddescription u = fromUUIDDesc $ M.findWithDefault mempty u descm prettify hereu (u, optval) | not (null d) = addoptval $ fromUUID u ++ " -- " ++ d | otherwise = addoptval $ fromUUID u @@ -224,7 +231,7 @@ Nothing -> s Just val -> val ++ ": " ++ s jsonify hereu (u, optval) = object $ catMaybes - [ Just (packString "uuid", toJSON' $ fromUUID u) + [ Just (packString "uuid", toJSON' (fromUUID u :: String)) , Just (packString "description", toJSON' $ finddescription u) , Just (packString "here", toJSON' $ hereu == u) , case (optfield, optval) of @@ -237,9 +244,9 @@ prettyListUUIDs uuids = do hereu <- getUUID m <- uuidDescriptions - return $ map (prettify m hereu) uuids + return $ map (fromUUIDDesc . prettify m hereu) uuids where - finddescription m u = M.findWithDefault "" u m + finddescription m u = M.findWithDefault mempty u m prettify m hereu u | u == hereu = addName n "here" | otherwise = n diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -186,7 +186,7 @@ androidLocation :: AndroidPath -> Key -> AndroidPath androidLocation adir k = AndroidPath $ - fromAndroidPath (androidHashDir adir k) ++ key2file k + fromAndroidPath (androidHashDir adir k) ++ serializeKey k androidHashDir :: AndroidPath -> Key -> AndroidPath androidHashDir adir k = AndroidPath $ diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -22,9 +22,9 @@ import Messages.Progress import Utility.Metered import Utility.Tmp -import Utility.FileSystemEncoding import Backend.URL import Annex.Perms +import Annex.Tmp import Annex.UUID import qualified Annex.Url as Url import Remote.Helper.Export @@ -166,29 +166,20 @@ torrentUrlKey :: URLString -> Annex Key torrentUrlKey u = return $ fromUrl (fst $ torrentUrlNum u) Nothing -{- Temporary directory used to download a torrent. -} -tmpTorrentDir :: URLString -> Annex FilePath -tmpTorrentDir u = do - d <- fromRepo gitAnnexTmpMiscDir - f <- keyFile <$> torrentUrlKey u - return (d f) - {- Temporary filename to use to store the torrent file. -} tmpTorrentFile :: URLString -> Annex FilePath tmpTorrentFile u = fromRepo . gitAnnexTmpObjectLocation =<< torrentUrlKey u -{- A cleanup action is registered to delete the torrent file and its - - associated temp directory when git-annex exits. +{- A cleanup action is registered to delete the torrent file + - when git-annex exits. - - - This allows multiple actions that use the same torrent file and temp - - directory to run in a single git-annex run. + - This allows multiple actions that use the same torrent file + - directory to run in a single git-annex run, and only download the + - torrent file once. -} registerTorrentCleanup :: URLString -> Annex () -registerTorrentCleanup u = Annex.addCleanup (TorrentCleanup u) $ do +registerTorrentCleanup u = Annex.addCleanup (TorrentCleanup u) $ liftIO . nukeFile =<< tmpTorrentFile u - d <- tmpTorrentDir u - liftIO $ whenM (doesDirectoryExist d) $ - removeDirectoryRecursive d {- Downloads the torrent file. (Not its contents.) -} downloadTorrentFile :: URLString -> Annex Bool @@ -200,17 +191,16 @@ showAction "downloading torrent file" createAnnexDirectory (parentDir torrent) if isTorrentMagnetUrl u - then do - tmpdir <- tmpTorrentDir u - let metadir = tmpdir "meta" + then withOtherTmp $ \othertmp -> do + kf <- keyFile <$> torrentUrlKey u + let metadir = othertmp "torrentmeta" kf createAnnexDirectory metadir showOutput ok <- downloadMagnetLink u metadir torrent liftIO $ removeDirectoryRecursive metadir return ok - else do - misctmp <- fromRepo gitAnnexTmpMiscDir - withTmpFileIn misctmp "torrent" $ \f h -> do + else withOtherTmp $ \othertmp -> do + withTmpFileIn othertmp "torrent" $ \f h -> do liftIO $ hClose h ok <- Url.withUrlOptions $ liftIO . Url.download nullMeterUpdate u f @@ -245,16 +235,25 @@ downloadTorrentContent :: Key -> URLString -> FilePath -> Int -> MeterUpdate -> Annex Bool downloadTorrentContent k u dest filenum p = do torrent <- tmpTorrentFile u - tmpdir <- tmpTorrentDir u - createAnnexDirectory tmpdir - f <- wantedfile torrent - showOutput - ifM (download torrent tmpdir <&&> liftIO (doesFileExist (tmpdir f))) - ( do - liftIO $ renameFile (tmpdir f) dest - return True - , return False - ) + withOtherTmp $ \othertmp -> do + kf <- keyFile <$> torrentUrlKey u + let downloaddir = othertmp "torrent" kf + createAnnexDirectory downloaddir + f <- wantedfile torrent + showOutput + ifM (download torrent downloaddir <&&> liftIO (doesFileExist (downloaddir f))) + ( do + liftIO $ renameFile (downloaddir f) dest + -- The downloaddir is not removed here, + -- so if aria downloaded parts of other + -- files, and this is called again, it will + -- resume where it left off. + -- withOtherTmp registers a cleanup action + -- that will clean up leftover files when + -- git-annex terminates. + return True + , return False + ) where download torrent tmpdir = ariaProgress (keySize k) p [ Param $ "--select-file=" ++ show filenum @@ -350,7 +349,7 @@ torrentFileSizes :: FilePath -> IO [(FilePath, Integer)] torrentFileSizes torrent = do #ifdef WITH_TORRENTPARSER - let mkfile = joinPath . map (scrub . decodeBS) + let mkfile = joinPath . map (scrub . decodeBL) b <- B.readFile torrent return $ case readTorrent b of Left e -> giveup $ "failed to parse torrent: " ++ e diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -280,7 +280,7 @@ | Git.Ref.legal True shown = shown | otherwise = "git-annex-" ++ show (sha2_256 (fromString shown)) where - shown = key2file k + shown = serializeKey k bupLocal :: BupRepo -> Bool bupLocal = notElem ':' diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -110,7 +110,7 @@ let params = [ Param "c" , Param "-N" - , Param $ key2file k + , Param $ serializeKey k , Param $ ddarRepoLocation ddarrepo , File src ] @@ -138,7 +138,7 @@ {- Specialized ddarRemoteCall that includes extraction command and flags -} ddarExtractRemoteCall :: ConsumeStdin -> DdarRepo -> Key -> Annex (String, [CommandParam]) ddarExtractRemoteCall cs ddarrepo k = - ddarRemoteCall cs ddarrepo 'x' [Param "--force-stdout", Param $ key2file k] + ddarRemoteCall cs ddarrepo 'x' [Param "--force-stdout", Param $ serializeKey k] retrieve :: DdarRepo -> Retriever retrieve ddarrepo = byteRetriever $ \k sink -> do @@ -154,7 +154,7 @@ remove :: DdarRepo -> Remover remove ddarrepo key = do (cmd, params) <- ddarRemoteCall NoConsumeStdin ddarrepo 'd' - [Param $ key2file key] + [Param $ serializeKey key] liftIO $ boolSystem cmd params ddarDirectoryExists :: DdarRepo -> Annex (Either String Bool) @@ -188,7 +188,7 @@ contents <- hGetContents h return $ elem k' $ lines contents where - k' = key2file k + k' = serializeKey k checkKey :: DdarRepo -> CheckPresent checkKey ddarrepo key = do diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -16,7 +16,7 @@ import Utility.FileMode import Remote.Helper.Special import qualified Remote.Helper.Chunked.Legacy as Legacy -import Annex.Perms +import Annex.Tmp import Utility.Metered withCheckedFiles :: (FilePath -> IO Bool) -> FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool @@ -89,10 +89,8 @@ - :/ This is legacy code.. -} retrieve :: (FilePath -> Key -> [FilePath]) -> FilePath -> Preparer Retriever -retrieve locations d basek a = do +retrieve locations d basek a = withOtherTmp $ \tmpdir -> do showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow." - tmpdir <- fromRepo $ gitAnnexTmpMiscDir - createAnnexDirectory tmpdir let tmp = tmpdir keyFile basek ++ ".directorylegacy.tmp" a $ Just $ byteRetriever $ \k sink -> do liftIO $ void $ withStoredFiles d locations k $ \fs -> do diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -99,10 +99,10 @@ mkSafeKey :: Key -> Either String SafeKey mkSafeKey k - | any isSpace (keyName k) = Left $ concat + | any isSpace (decodeBS $ keyName k) = Left $ concat [ "Sorry, this file cannot be stored on an external special remote because its key's name contains a space. " , "To avoid this problem, you can run: git-annex migrate --backend=" - , formatKeyVariety (keyVariety k) + , decodeBS (formatKeyVariety (keyVariety k)) , " and pass it the name of the file" ] | otherwise = Right (SafeKey k) diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -427,7 +427,7 @@ fallback = do Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin repo "lockcontent" - [Param $ key2file key] [] + [Param $ serializeKey key] [] (Just hin, Just hout, Nothing, p) <- liftIO $ withFile devNull WriteMode $ \nullh -> createProcess $ @@ -530,7 +530,7 @@ : maybe [] (\f -> [(Fields.associatedFile, f)]) afile Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin repo "transferinfo" - [Param $ key2file key] fields + [Param $ serializeKey key] fields v <- liftIO (newEmptySV :: IO (MSampleVar Integer)) pidv <- liftIO $ newEmptyMVar tid <- liftIO $ forkIO $ void $ tryIO $ do diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -197,7 +197,7 @@ {- glacier checkpresent outputs the archive name to stdout if - it's present. -} s <- liftIO $ readProcessEnv "glacier" (toCommand params) (Just e) - let probablypresent = key2file k `elem` lines s + let probablypresent = serializeKey k `elem` lines s if probablypresent then ifM (Annex.getFlag "trustglacier") ( return True, giveup untrusted ) @@ -253,7 +253,7 @@ . M.lookup "vault" archive :: Remote -> Key -> Archive -archive r k = fileprefix ++ key2file k +archive r k = fileprefix ++ serializeKey k where fileprefix = M.findWithDefault "" "fileprefix" $ config r @@ -306,7 +306,7 @@ parse c [] = c parse c@(succeeded, failed) ((status:_date:vault:key:[]):rest) | vault == myvault = - case file2key key of + case deserializeKey key of Nothing -> parse c rest Just k | "a/d" `isPrefixOf` status -> diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -29,7 +29,6 @@ import Crypto import Types.Crypto import qualified Annex -import Utility.FileSystemEncoding -- Used to ensure that encryption has been set up before trying to -- eg, store creds in the remote config that would need to use the diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs --- a/Remote/Helper/Export.hs +++ b/Remote/Helper/Export.hs @@ -208,5 +208,5 @@ ea <- exportActions r retrieveExport ea k l dest p else do - warning $ "exported content cannot be verified due to using the " ++ formatKeyVariety (keyVariety k) ++ " backend" + warning $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (keyVariety k)) ++ " backend" return False diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -67,7 +67,7 @@ else params return (Param command : File dir : params') uuidcheck NoUUID = [] - uuidcheck (UUID u) = ["--uuid", u] + uuidcheck u@(UUID _) = ["--uuid", fromUUID u] fieldopts | null fields = [] | otherwise = fieldsep : map fieldopt fields ++ [fieldsep] @@ -98,7 +98,7 @@ inAnnex :: Git.Repo -> Key -> Annex Bool inAnnex r k = do showChecking r - onRemote NoConsumeStdin r (runcheck, cantCheck r) "inannex" [Param $ key2file k] [] + onRemote NoConsumeStdin r (runcheck, cantCheck r) "inannex" [Param $ serializeKey k] [] where runcheck c p = dispatch =<< safeSystem c p dispatch ExitSuccess = return True @@ -109,7 +109,7 @@ dropKey :: Git.Repo -> Key -> Annex Bool dropKey r key = onRemote NoConsumeStdin r (boolSystem, return False) "dropkey" [ Param "--quiet", Param "--force" - , Param $ key2file key + , Param $ serializeKey key ] [] @@ -141,7 +141,7 @@ repo <- getRepo r Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin repo (if direction == Download then "sendkey" else "recvkey") - [ Param $ key2file key ] + [ Param $ serializeKey key ] fields -- Convert the ssh command into rsync command line. let eparam = rsyncShell (Param shellcmd:shellparams) diff --git a/Remote/Hook.hs b/Remote/Hook.hs --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -92,7 +92,7 @@ mergeenv l = addEntries l <$> getEnvironment envvar s v = ("ANNEX_" ++ s, v) keyenv = catMaybes - [ Just $ envvar "KEY" (key2file k) + [ Just $ envvar "KEY" (serializeKey k) , Just $ envvar "ACTION" action , envvar "HASH_1" <$> headMaybe hashbits , envvar "HASH_2" <$> headMaybe (drop 1 hashbits) @@ -151,7 +151,7 @@ liftIO $ check v where action = "checkpresent" - findkey s = key2file k `elem` lines s + findkey s = serializeKey k `elem` lines s check Nothing = giveup $ action ++ " hook misconfigured" check (Just hook) = do environ <- hookEnv action k Nothing diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -19,6 +19,7 @@ import qualified Data.Text.Encoding as T import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 import qualified Data.Map as M import qualified Data.Set as S import qualified System.FilePath.Posix as Posix @@ -52,7 +53,6 @@ import Utility.Metered import qualified Annex.Url as Url import Utility.DataUnits -import Utility.FileSystemEncoding import Annex.Content import Annex.Url (withUrlOptions) import Utility.Url (checkBoth, UrlOptions(..)) @@ -278,7 +278,7 @@ let req = case loc of Left o -> S3.getObject (bucket info) o Right (S3VersionID o vid) -> (S3.getObject (bucket info) o) - { S3.goVersionId = Just (T.pack vid) } + { S3.goVersionId = Just vid } S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle' h req Url.sinkResponseFile p zeroBytesProcessed f WriteMode rsp @@ -328,7 +328,7 @@ req = case loc of Left o -> S3.headObject (bucket info) o Right (S3VersionID o vid) -> (S3.headObject (bucket info) o) - { S3.hoVersionId = Just (T.pack vid) } + { S3.hoVersionId = Just vid } #if ! MIN_VERSION_aws(0,10,0) {- Catch exception headObject returns when an object is not present @@ -433,13 +433,14 @@ Right _ -> noop Left _ -> do showAction $ "creating bucket in " ++ datacenter - void $ sendS3Handle h $ S3.PutBucket - (bucket info) - (acl info) - locconstraint + void $ sendS3Handle h $ + (S3.putBucket (bucket info)) + { S3.pbCannedAcl = acl info + , S3.pbLocationConstraint = locconstraint #if MIN_VERSION_aws(0,13,0) - storageclass + , S3.pbXStorageClass = storageclass #endif + } writeUUIDFile c u info h locconstraint = mkLocationConstraint $ T.pack datacenter @@ -652,7 +653,7 @@ getFilePrefix = M.findWithDefault "" "fileprefix" getBucketObject :: RemoteConfig -> Key -> BucketObject -getBucketObject c = munge . key2file +getBucketObject c = munge . serializeKey where munge s = case M.lookup "mungekeys" c of Just "ia" -> iaMunge $ getFilePrefix c ++ s @@ -775,36 +776,34 @@ _ -> Nothing -data S3VersionID = S3VersionID S3.Object String +data S3VersionID = S3VersionID S3.Object T.Text deriving (Show) -- smart constructor mkS3VersionID :: S3.Object -> Maybe T.Text -> Maybe S3VersionID -mkS3VersionID o = mkS3VersionID' o . fmap T.unpack - -mkS3VersionID' :: S3.Object -> Maybe String -> Maybe S3VersionID -mkS3VersionID' o (Just s) - | null s = Nothing +mkS3VersionID o (Just t) + | T.null t = Nothing -- AWS documentation says a version ID is at most 1024 bytes long. -- Since they are stored in the git-annex branch, prevent them from -- being very much larger than that. - | length s < 2048 = Just (S3VersionID o s) + | T.length t < 2048 = Just (S3VersionID o t) | otherwise = Nothing -mkS3VersionID' _ Nothing = Nothing +mkS3VersionID _ Nothing = Nothing -- Format for storage in per-remote metadata. -- -- A S3 version ID is "url ready" so does not contain '#' and so we'll use -- that to separate it from the object id. (Could use a space, but spaces -- in metadata values lead to an inefficient encoding.) -formatS3VersionID :: S3VersionID -> String -formatS3VersionID (S3VersionID o v) = v ++ '#' : T.unpack o +formatS3VersionID :: S3VersionID -> BS.ByteString +formatS3VersionID (S3VersionID o v) = T.encodeUtf8 v <> "#" <> T.encodeUtf8 o -- Parse from value stored in per-remote metadata. -parseS3VersionID :: String -> Maybe S3VersionID -parseS3VersionID s = - let (v, o) = separate (== '#') s - in mkS3VersionID' (T.pack o) (Just v) +parseS3VersionID :: BS.ByteString -> Maybe S3VersionID +parseS3VersionID b = do + let (v, rest) = B8.break (== '#') b + o <- eitherToMaybe $ T.decodeUtf8' $ BS.drop 1 rest + mkS3VersionID o (eitherToMaybe $ T.decodeUtf8' v) setS3VersionID :: S3Info -> UUID -> Key -> Maybe S3VersionID -> Annex () setS3VersionID info u k vid @@ -843,7 +842,7 @@ s3VersionIDPublicUrl mk info (S3VersionID obj vid) = mk info $ concat [ T.unpack obj , "?versionId=" - , vid -- version ID is "url ready" so no escaping needed + , T.unpack vid -- version ID is "url ready" so no escaping needed ] getS3VersionIDPublicUrls :: (S3Info -> BucketObject -> URLString) -> S3Info -> UUID -> Key -> Annex [URLString] diff --git a/Remote/Web.hs b/Remote/Web.hs --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -18,7 +18,6 @@ import Config import Logs.Web import Annex.UUID -import Messages.Progress import Utility.Metered import qualified Annex.Url as Url import Annex.YoutubeDl @@ -87,8 +86,7 @@ YoutubeDownloader -> do showOutput youtubeDlTo key u' dest - _ -> metered (Just p) key (pure Nothing) $ \_ p' -> - downloadUrl key p' [u'] dest + _ -> downloadUrl key p [u'] dest downloadKeyCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool downloadKeyCheap _ _ _ = return False diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -158,9 +158,7 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" [ testProperty "prop_encode_decode_roundtrip" Git.Filename.prop_encode_decode_roundtrip , testProperty "prop_encode_c_decode_c_roundtrip" Utility.Format.prop_encode_c_decode_c_roundtrip - , testProperty "prop_isomorphic_fileKey" Annex.Locations.prop_isomorphic_fileKey , testProperty "prop_isomorphic_key_encode" Key.prop_isomorphic_key_encode - , testProperty "prop_isomorphic_key_decode" Key.prop_isomorphic_key_decode , testProperty "prop_isomorphic_shellEscape" Utility.SafeCommand.prop_isomorphic_shellEscape , testProperty "prop_isomorphic_shellEscape_multiword" Utility.SafeCommand.prop_isomorphic_shellEscape_multiword , testProperty "prop_isomorphic_configEscape" Logs.Remote.prop_isomorphic_configEscape @@ -177,9 +175,9 @@ , testProperty "prop_segment_regressionTest" Utility.Misc.prop_segment_regressionTest , testProperty "prop_read_write_transferinfo" Logs.Transfer.prop_read_write_transferinfo , testProperty "prop_read_show_inodecache" Utility.InodeCache.prop_read_show_inodecache - , testProperty "prop_parse_show_log" Logs.Presence.prop_parse_show_log + , testProperty "prop_parse_build_log" Logs.Presence.prop_parse_build_log , testProperty "prop_read_show_TrustLevel" Types.TrustLevel.prop_read_show_TrustLevel - , testProperty "prop_parse_show_TrustLog" Logs.Trust.prop_parse_show_TrustLog + , testProperty "prop_parse_build_TrustLevelLog" Logs.Trust.prop_parse_build_TrustLevelLog , testProperty "prop_hashes_stable" Utility.Hash.prop_hashes_stable , testProperty "prop_mac_stable" Utility.Hash.prop_mac_stable , testProperty "prop_schedule_roundtrips" Utility.Scheduled.QuickCheck.prop_schedule_roundtrips @@ -275,9 +273,7 @@ test_init :: Assertion test_init = innewrepo $ do ver <- annexVersion <$> getTestMode - if ver == Annex.Version.defaultVersion - then git_annex "init" [reponame] @? "init failed" - else git_annex "init" [reponame, "--version", show (fromRepoVersion ver)] @? "init failed" + git_annex "init" [reponame, "--version", show (fromRepoVersion ver)] @? "init failed" setupTestMode where reponame = "test repo" @@ -399,7 +395,7 @@ git_annex "drop" ["--force", sha1annexedfile] @? "drop failed" annexed_notpresent sha1annexedfile writecontent tmp $ content sha1annexedfile - key <- Key.key2file <$> getKey backendSHA1 tmp + key <- Key.serializeKey <$> getKey backendSHA1 tmp git_annex "reinject" [tmp, sha1annexedfile] @? "reinject failed" annexed_present sha1annexedfile -- fromkey can't be used on a crippled filesystem, since it makes a @@ -869,9 +865,9 @@ checkunused [annexedfilekey, sha1annexedfilekey] "after rm sha1annexedfile" -- good opportunity to test dropkey also - git_annex "dropkey" ["--force", Key.key2file annexedfilekey] + git_annex "dropkey" ["--force", Key.serializeKey annexedfilekey] @? "dropkey failed" - checkunused [sha1annexedfilekey] ("after dropkey --force " ++ Key.key2file annexedfilekey) + checkunused [sha1annexedfilekey] ("after dropkey --force " ++ Key.serializeKey annexedfilekey) git_annex_shouldfail "dropunused" ["1"] @? "dropunused failed to fail without --force" git_annex "dropunused" ["--force", "1"] @? "dropunused failed" @@ -1455,18 +1451,21 @@ checkmerge "r2" r2 where conflictor = "conflictor" - setup r = indir r $ do + setup r = indir r $ whensupported $ do disconnectOrigin git_annex "upgrade" [] @? "upgrade failed" git_annex "adjust" ["--unlock", "--force"] @? "adjust failed" writecontent conflictor "conflictor" git_annex "add" [conflictor] @? "add conflicter failed" git_annex "sync" [] @? "sync failed" - checkmerge what d = indir d $ do + checkmerge what d = indir d $ whensupported $ do git_annex "sync" [] @? ("sync failed in " ++ what) l <- getDirectoryContents "." conflictor `elem` l @? ("conflictor not present after merge in " ++ what) + -- Currently this fails on FAT, for unknown reasons not to + -- do with what it's intended to test. + whensupported = unlessM (annexeval Config.crippledFileSystem) {- Regression test for a bug in adjusted branch syncing code, where adding - a subtree to an existing tree lost files. -} @@ -1619,10 +1618,14 @@ testscheme "pubkey" where gpgcmd = Utility.Gpg.mkGpgCmd Nothing - testscheme scheme = intmpclonerepo $ whenM (Utility.Path.inPath (Utility.Gpg.unGpgCmd gpgcmd)) $ do - Utility.Gpg.testTestHarness gpgcmd + testscheme scheme = do + gpgtmp <- ( "gpgtest") <$> absPath tmpdir + createDirectoryIfMissing False gpgtmp + testscheme' scheme gpgtmp + testscheme' scheme gpgtmp = intmpclonerepo $ whenM (Utility.Path.inPath (Utility.Gpg.unGpgCmd gpgcmd)) $ do + Utility.Gpg.testTestHarness gpgtmp gpgcmd @? "test harness self-test failed" - Utility.Gpg.testHarness gpgcmd $ do + Utility.Gpg.testHarness gpgtmp gpgcmd $ do createDirectory "dir" let a cmd = git_annex cmd $ [ "foo" @@ -1678,12 +1681,12 @@ let encparams = (mempty :: Types.Remote.RemoteConfig, dummycfg) cipher <- Crypto.decryptCipher gpgcmd encparams cip files <- filterM doesFileExist $ - map ("dir" ) $ concatMap (key2files cipher) keys + map ("dir" ) $ concatMap (serializeKeys cipher) keys return (not $ null files) <&&> allM (checkFile mvariant) files checkFile mvariant filename = Utility.Gpg.checkEncryptionFile gpgcmd filename $ if mvariant == Just Types.Crypto.PubKey then ks else Nothing - key2files cipher = Annex.Locations.keyPaths . + serializeKeys cipher = Annex.Locations.keyPaths . Crypto.encryptKey Types.Crypto.HmacSha1 cipher #else test_crypto = putStrLn "gpg testing not implemented on Windows" @@ -1699,7 +1702,7 @@ - calculated correctly for files in subdirs. -} unlessM (unlockedFiles <$> getTestMode) $ do git_annex "sync" [] @? "sync failed" - l <- annexeval $ Utility.FileSystemEncoding.decodeBS + l <- annexeval $ Utility.FileSystemEncoding.decodeBL <$> Annex.CatFile.catObject (Git.Types.Ref "HEAD:dir/foo") "../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l) diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -17,7 +17,6 @@ import qualified Annex import qualified Annex.UUID -import qualified Annex.Version import qualified Types.RepoVersion import qualified Backend import qualified Git.CurrentRepo @@ -65,8 +64,13 @@ -- catch all errors, including normally fatal errors try run ::IO (Either SomeException ()) where - run = GitAnnex.run dummyTestOptParser (\_ -> noop) (command:"-q":params) + run = GitAnnex.run dummyTestOptParser + dummyTestRunner + dummyBenchmarkGenerator + (command:"-q":params) dummyTestOptParser = pure mempty + dummyTestRunner _ = noop + dummyBenchmarkGenerator _ _ = return noop {- Runs git-annex and returns its output. -} git_annex_output :: String -> [String] -> IO String @@ -214,9 +218,7 @@ configrepo new indir new $ do ver <- annexVersion <$> getTestMode - if ver == Annex.Version.defaultVersion - then git_annex "init" ["-q", new] @? "git annex init failed" - else git_annex "init" ["-q", new, "--version", show (Types.RepoVersion.fromRepoVersion ver)] @? "git annex init failed" + git_annex "init" ["-q", new, "--version", show (Types.RepoVersion.fromRepoVersion ver)] @? "git annex init failed" unless (bareClone cfg) $ indir new $ setupTestMode @@ -339,7 +341,7 @@ case r of Just k -> do uuids <- annexeval $ Remote.keyLocations k - assertEqual ("bad content in location log for " ++ f ++ " key " ++ Key.key2file k ++ " uuid " ++ show thisuuid) + assertEqual ("bad content in location log for " ++ f ++ " key " ++ Key.serializeKey k ++ " uuid " ++ show thisuuid) expected (thisuuid `elem` uuids) _ -> assertFailure $ f ++ " failed to look up key" @@ -560,7 +562,7 @@ backendWORM = backend_ "WORM" backend_ :: String -> Types.Backend -backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety +backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety . encodeBS getKey :: Types.Backend -> FilePath -> IO Types.Key getKey b f = fromJust <$> annexeval go diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs --- a/Types/ActionItem.hs +++ b/Types/ActionItem.hs @@ -36,8 +36,8 @@ actionItemDesc :: ActionItem -> Key -> String actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f))) _ = f -actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing)) k = key2file k -actionItemDesc ActionItemKey k = key2file k +actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing)) k = serializeKey k +actionItemDesc ActionItemKey k = serializeKey k actionItemDesc (ActionItemBranchFilePath bfp) _ = descBranchFilePath bfp actionItemDesc (ActionItemFailedTransfer _ i) k = actionItemDesc (ActionItemAssociatedFile (associatedFile i)) k diff --git a/Types/Backend.hs b/Types/Backend.hs --- a/Types/Backend.hs +++ b/Types/Backend.hs @@ -12,6 +12,8 @@ import Types.Key import Types.KeySource +import Utility.FileSystemEncoding + data BackendA a = Backend { backendVariety :: KeyVariety , getKey :: KeySource -> a (Maybe Key) @@ -28,7 +30,7 @@ } instance Show (BackendA a) where - show backend = "Backend { name =\"" ++ formatKeyVariety (backendVariety backend) ++ "\" }" + show backend = "Backend { name =\"" ++ decodeBS (formatKeyVariety (backendVariety backend)) ++ "\" }" instance Eq (BackendA a) where a == b = backendVariety a == backendVariety b diff --git a/Types/Benchmark.hs b/Types/Benchmark.hs new file mode 100644 --- /dev/null +++ b/Types/Benchmark.hs @@ -0,0 +1,15 @@ +{- git-annex benchmark data types. + - + - Copyright 2019 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Types.Benchmark where + +import Annex +import Types.Command + +type BenchmarkGenerator = [String] -> Annex (IO ()) + +type MkBenchmarkGenerator = [Command] -> BenchmarkGenerator diff --git a/Types/CleanupActions.hs b/Types/CleanupActions.hs --- a/Types/CleanupActions.hs +++ b/Types/CleanupActions.hs @@ -17,4 +17,5 @@ | FsckCleanup | SshCachingCleanup | TorrentCleanup URLString + | OtherTmpCleanup deriving (Eq, Ord) diff --git a/Types/Distribution.hs b/Types/Distribution.hs --- a/Types/Distribution.hs +++ b/Types/Distribution.hs @@ -46,7 +46,7 @@ formatGitAnnexDistribution :: GitAnnexDistribution -> String formatGitAnnexDistribution d = unlines [ distributionUrl d - , key2file (distributionKey d) + , serializeKey (distributionKey d) , distributionVersion d , show (distributionReleasedate d) , maybe "" show (distributionUrgentUpgrade d) @@ -56,7 +56,7 @@ parseGitAnnexDistribution s = case lines s of (u:k:v:d:uu:_) -> GitAnnexDistribution <$> pure u - <*> file2key k + <*> deserializeKey k <*> pure v <*> readish d <*> pure (readish uu) diff --git a/Types/Group.hs b/Types/Group.hs --- a/Types/Group.hs +++ b/Types/Group.hs @@ -1,22 +1,33 @@ {- git-annex repo groups - - - Copyright 2012 Joey Hess + - Copyright 2012, 2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Types.Group ( - Group, + Group(..), + fromGroup, + toGroup, GroupMap(..), emptyGroupMap ) where import Types.UUID +import Utility.FileSystemEncoding import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.ByteString as S -type Group = String +newtype Group = Group S.ByteString + deriving (Eq, Ord, Show) + +fromGroup :: Group -> String +fromGroup (Group g) = decodeBS g + +toGroup :: String -> Group +toGroup = Group . encodeBS data GroupMap = GroupMap { groupsByUUID :: M.Map UUID (S.Set Group) diff --git a/Types/Key.hs b/Types/Key.hs --- a/Types/Key.hs +++ b/Types/Key.hs @@ -1,22 +1,25 @@ {- git-annex Key data type - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Types.Key where -import Utility.PartialPrelude - +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import System.Posix.Types +import Data.Monoid +import Prelude {- A Key has a unique name, which is derived from a particular backend, - and may contain other optional metadata. -} data Key = Key - { keyName :: String + { keyName :: S.ByteString , keyVariety :: KeyVariety , keySize :: Maybe Integer , keyMtime :: Maybe EpochTime @@ -42,7 +45,7 @@ | URLKey -- Some repositories may contain keys of other varieties, -- which can still be processed to some extent. - | OtherKey String + | OtherKey S.ByteString deriving (Eq, Ord, Read, Show) {- Some varieties of keys may contain an extension at the end of the @@ -64,7 +67,7 @@ hasExt (MD5Key (HasExt b)) = b hasExt WORMKey = False hasExt URLKey = False -hasExt (OtherKey s) = end s == "E" +hasExt (OtherKey s) = (snd <$> S8.unsnoc s) == Just 'E' sameExceptExt :: KeyVariety -> KeyVariety -> Bool sameExceptExt (SHA2Key sz1 _) (SHA2Key sz2 _) = sz1 == sz2 @@ -103,9 +106,9 @@ isVerifiable (MD5Key _) = True isVerifiable WORMKey = False isVerifiable URLKey = False -isVerifiable (OtherKey _) = False +isVerifiable (OtherKey _) = False -formatKeyVariety :: KeyVariety -> String +formatKeyVariety :: KeyVariety -> S.ByteString formatKeyVariety v = case v of SHA2Key sz e -> adde e (addsz sz "SHA") SHA3Key sz e -> adde e (addsz sz "SHA3_") @@ -120,10 +123,18 @@ OtherKey s -> s where adde (HasExt False) s = s - adde (HasExt True) s = s ++ "E" - addsz (HashSize n) s = s ++ show n + adde (HasExt True) s = s <> "E" + addsz (HashSize n) s = s <> case n of + 256 -> "256" + 512 -> "512" + 224 -> "224" + 384 -> "384" + 160 -> "160" + -- This is relatively slow, which is why the common hash + -- sizes are hardcoded above. + _ -> S8.pack (show n) -parseKeyVariety :: String -> KeyVariety +parseKeyVariety :: S.ByteString -> KeyVariety parseKeyVariety "SHA256" = SHA2Key (HashSize 256) (HasExt False) parseKeyVariety "SHA256E" = SHA2Key (HashSize 256) (HasExt True) parseKeyVariety "SHA512" = SHA2Key (HashSize 512) (HasExt False) @@ -172,4 +183,4 @@ parseKeyVariety "MD5E" = MD5Key (HasExt True) parseKeyVariety "WORM" = WORMKey parseKeyVariety "URL" = URLKey -parseKeyVariety s = OtherKey s +parseKeyVariety b = OtherKey b diff --git a/Types/MetaData.hs b/Types/MetaData.hs --- a/Types/MetaData.hs +++ b/Types/MetaData.hs @@ -1,11 +1,12 @@ {- git-annex general metadata - - - Copyright 2014-2018 Joey Hess + - Copyright 2014-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} module Types.MetaData ( MetaData(..), @@ -51,11 +52,14 @@ import Types.UUID import qualified Data.Text as T +import qualified Data.Text.Encoding as E import qualified Data.Set as S import qualified Data.Map.Strict as M import qualified Data.HashMap.Strict as HM import Data.Char import qualified Data.CaseInsensitive as CI +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 newtype MetaData = MetaData (M.Map MetaField (S.Set MetaValue)) deriving (Show, Eq, Ord) @@ -63,14 +67,14 @@ instance ToJSON' MetaData where toJSON' (MetaData m) = object $ map go (M.toList m) where - go (MetaField f, s) = (packString (CI.original f), toJSON' s) + go (MetaField f, s) = (CI.original f, toJSON' s) instance FromJSON MetaData where parseJSON (Object o) = do l <- HM.toList <$> parseJSON (Object o) MetaData . M.fromList <$> mapM go l where - go (t, l) = case mkMetaField (T.unpack t) of + go (t, l) = case mkMetaField t of Left e -> fail e Right f -> (,) <$> pure f <*> parseJSON l parseJSON _ = fail "expected an object" @@ -81,17 +85,18 @@ deriving (Read, Show, Eq, Ord, Arbitrary) {- Fields are case insensitive. -} -newtype MetaField = MetaField (CI.CI String) +newtype MetaField = MetaField (CI.CI T.Text) deriving (Read, Show, Eq, Ord) -data MetaValue = MetaValue CurrentlySet String +data MetaValue = MetaValue CurrentlySet B.ByteString deriving (Read, Show) instance ToJSON' MetaValue where toJSON' (MetaValue _ v) = toJSON' v instance FromJSON MetaValue where - parseJSON (String v) = return $ MetaValue (CurrentlySet True) (T.unpack v) + parseJSON (String v) = return $ + MetaValue (CurrentlySet True) (E.encodeUtf8 v) parseJSON _ = fail "expected a string" {- Metadata values compare and order the same whether currently set or not. -} @@ -105,14 +110,16 @@ - field1 +val1 +val2 -val3 field2 +val4 +val5 -} class MetaSerializable v where - serialize :: v -> String - deserialize :: String -> Maybe v + serialize :: v -> B.ByteString + deserialize :: B.ByteString -> Maybe v instance MetaSerializable MetaData where - serialize (MetaData m) = unwords $ concatMap go $ M.toList m + serialize (MetaData m) = B8.unwords $ concatMap go $ M.toList m where go (f, vs) = serialize f : map serialize (S.toList vs) - deserialize = Just . getfield emptyMetaData . words + -- Note that B8.words cannot be used here, because UTF-8 encoded + -- field names may contain bytes such as \160 that are whitespace. + deserialize = Just . getfield emptyMetaData . B8.split ' ' where getfield m [] = m getfield m (w:ws) = maybe m (getvalues m ws) (deserialize w) @@ -122,23 +129,25 @@ Nothing -> getfield m l instance MetaSerializable MetaField where - serialize (MetaField f) = CI.original f - deserialize = Just . mkMetaFieldUnchecked + serialize (MetaField f) = E.encodeUtf8 (CI.original f) + deserialize = MetaField . CI.mk <$$> eitherToMaybe . E.decodeUtf8' {- Base64 problematic values. -} instance MetaSerializable MetaValue where serialize (MetaValue isset v) = - serialize isset ++ - if any isSpace v || "!" `isPrefixOf` v - then '!' : toB64 v + serialize isset <> + if B8.any (== ' ') v || "!" `B8.isPrefixOf` v + then "!" <> toB64' v else v - deserialize (isset:'!':v) = MetaValue - <$> deserialize [isset] - <*> fromB64Maybe v - deserialize (isset:v) = MetaValue - <$> deserialize [isset] - <*> pure v - deserialize [] = Nothing + deserialize b = do + (isset, b') <- B8.uncons b + case B8.uncons b' of + Just ('!', b'') -> MetaValue + <$> deserialize (B8.singleton isset) + <*> fromB64Maybe' b'' + _ -> MetaValue + <$> deserialize (B8.singleton isset) + <*> pure b' instance MetaSerializable CurrentlySet where serialize (CurrentlySet True) = "+" @@ -147,17 +156,17 @@ deserialize "-" = Just (CurrentlySet False) deserialize _ = Nothing -mkMetaField :: String -> Either String MetaField +mkMetaField :: T.Text -> Either String MetaField mkMetaField f = maybe (Left $ badField f) Right (toMetaField f) -badField :: String -> String -badField f = "Illegal metadata field name, \"" ++ f ++ "\"" +badField :: T.Text -> String +badField f = "Illegal metadata field name, \"" ++ T.unpack f ++ "\"" {- Does not check that the field name is valid. Use with caution. -} -mkMetaFieldUnchecked :: String -> MetaField +mkMetaFieldUnchecked :: T.Text -> MetaField mkMetaFieldUnchecked = MetaField . CI.mk -toMetaField :: String -> Maybe MetaField +toMetaField :: T.Text -> Maybe MetaField toMetaField f | legalField f = Just $ MetaField $ CI.mk f | otherwise = Nothing @@ -168,23 +177,29 @@ - Additionally, fields should not contain any form of path separator, as - that would break views. - + - And, fields need to be valid JSON keys. + - - So, require they have an alphanumeric first letter, with the remainder - being either alphanumeric or a small set of whitelisted common punctuation. -} -legalField :: String -> Bool -legalField [] = False -legalField (c1:cs) - | not (isAlphaNum c1) = False - | otherwise = all legalchars cs +legalField :: T.Text -> Bool +legalField t = case T.uncons t of + Nothing -> False + Just (c1, t') + | not (isAlphaNum c1) -> False + | otherwise -> T.all legalchars t' where legalchars c | isAlphaNum c = True - | otherwise = c `elem` "_-." + | otherwise = c `elem` legalFieldWhiteList -toMetaValue :: String -> MetaValue +legalFieldWhiteList :: [Char] +legalFieldWhiteList = "_-." + +toMetaValue :: B.ByteString -> MetaValue toMetaValue = MetaValue (CurrentlySet True) -mkMetaValue :: CurrentlySet -> String -> MetaValue +mkMetaValue :: CurrentlySet -> B.ByteString -> MetaValue mkMetaValue = MetaValue unsetMetaValue :: MetaValue -> MetaValue @@ -194,10 +209,10 @@ unsetMetaData :: MetaData -> MetaData unsetMetaData (MetaData m) = MetaData $ M.map (S.map unsetMetaValue) m -fromMetaField :: MetaField -> String +fromMetaField :: MetaField -> T.Text fromMetaField (MetaField f) = CI.original f -fromMetaValue :: MetaValue -> String +fromMetaValue :: MetaValue -> B.ByteString fromMetaValue (MetaValue _ f) = f fromMetaData :: MetaData -> [(MetaField, S.Set MetaValue)] @@ -296,35 +311,34 @@ extractRemoteMetaData u (MetaData m) = RemoteMetaData u $ MetaData $ M.mapKeys removeprefix $ M.filterWithKey belongsremote m where - belongsremote (MetaField f) _v = prefix `isPrefixOf` CI.original f + belongsremote (MetaField f) _v = prefix `T.isPrefixOf` CI.original f removeprefix (MetaField f) = MetaField $ - CI.mk $ drop prefixlen $ CI.original f + CI.mk $ T.drop prefixlen $ CI.original f prefix = remoteMetaDataPrefix u - prefixlen = length prefix + prefixlen = T.length prefix splitRemoteMetaDataField :: MetaField -> Maybe (UUID, MetaField) splitRemoteMetaDataField (MetaField f) = do - let (su, sf) = separate (== ':') (CI.original f) - f' <- toMetaField sf - return $ (toUUID su, f') + let (su, sf) = T.break (== ':') (CI.original f) + f' <- toMetaField ((T.drop 1 sf)) + return $ (toUUID (T.unpack su), f') -remoteMetaDataPrefix :: UUID -> String -remoteMetaDataPrefix u = fromUUID u ++ ":" +remoteMetaDataPrefix :: UUID -> T.Text +remoteMetaDataPrefix u = T.pack (fromUUID u) <> ":" fromRemoteMetaData :: RemoteMetaData -> MetaData fromRemoteMetaData (RemoteMetaData u (MetaData m)) = MetaData $ M.mapKeys addprefix m where - addprefix (MetaField f) = MetaField $ CI.mk $ (prefix ++) $ CI.original f + addprefix (MetaField f) = MetaField $ CI.mk $ prefix <> CI.original f prefix = remoteMetaDataPrefix u {- Avoid putting too many fields in the map; extremely large maps make - the seriaization test slow due to the sheer amount of data. - It's unlikely that more than 100 fields of metadata will be used. -} instance Arbitrary MetaData where - arbitrary = do - size <- arbitrarySizedBoundedIntegral `suchThat` (< 500) - MetaData . M.filterWithKey legal . M.fromList <$> vector size + arbitrary = MetaData . M.filterWithKey legal . M.fromList + <$> resize 10 (listOf arbitrary) where legal k _v = legalField $ fromMetaField k @@ -334,11 +348,11 @@ -- Avoid non-ascii metavalues because fully arbitrary -- strings may not be encoded using the filesystem -- encoding, which is norally applied to all input. - <*> arbitrary `suchThat` all isAscii + <*> (encodeBS <$> arbitrary `suchThat` all isAscii) instance Arbitrary MetaField where - arbitrary = MetaField . CI.mk - <$> arbitrary `suchThat` legalField + arbitrary = MetaField . CI.mk + <$> (T.pack <$> arbitrary) `suchThat` legalField prop_metadata_sane :: MetaData -> MetaField -> MetaValue -> Bool prop_metadata_sane m f v = and diff --git a/Types/StandardGroups.hs b/Types/StandardGroups.hs --- a/Types/StandardGroups.hs +++ b/Types/StandardGroups.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Types.StandardGroups where import Types.Remote (RemoteConfig) @@ -29,28 +31,28 @@ deriving (Eq, Ord, Enum, Bounded, Show) fromStandardGroup :: StandardGroup -> Group -fromStandardGroup ClientGroup = "client" -fromStandardGroup TransferGroup = "transfer" -fromStandardGroup BackupGroup = "backup" -fromStandardGroup IncrementalBackupGroup = "incrementalbackup" -fromStandardGroup SmallArchiveGroup = "smallarchive" -fromStandardGroup FullArchiveGroup = "archive" -fromStandardGroup SourceGroup = "source" -fromStandardGroup ManualGroup = "manual" -fromStandardGroup PublicGroup = "public" -fromStandardGroup UnwantedGroup = "unwanted" +fromStandardGroup ClientGroup = Group "client" +fromStandardGroup TransferGroup = Group "transfer" +fromStandardGroup BackupGroup = Group "backup" +fromStandardGroup IncrementalBackupGroup = Group "incrementalbackup" +fromStandardGroup SmallArchiveGroup = Group "smallarchive" +fromStandardGroup FullArchiveGroup = Group "archive" +fromStandardGroup SourceGroup = Group "source" +fromStandardGroup ManualGroup = Group "manual" +fromStandardGroup PublicGroup = Group "public" +fromStandardGroup UnwantedGroup = Group "unwanted" toStandardGroup :: Group -> Maybe StandardGroup -toStandardGroup "client" = Just ClientGroup -toStandardGroup "transfer" = Just TransferGroup -toStandardGroup "backup" = Just BackupGroup -toStandardGroup "incrementalbackup" = Just IncrementalBackupGroup -toStandardGroup "smallarchive" = Just SmallArchiveGroup -toStandardGroup "archive" = Just FullArchiveGroup -toStandardGroup "source" = Just SourceGroup -toStandardGroup "manual" = Just ManualGroup -toStandardGroup "public" = Just PublicGroup -toStandardGroup "unwanted" = Just UnwantedGroup +toStandardGroup (Group "client") = Just ClientGroup +toStandardGroup (Group "transfer") = Just TransferGroup +toStandardGroup (Group "backup") = Just BackupGroup +toStandardGroup (Group "incrementalbackup") = Just IncrementalBackupGroup +toStandardGroup (Group "smallarchive") = Just SmallArchiveGroup +toStandardGroup (Group "archive") = Just FullArchiveGroup +toStandardGroup (Group "source") = Just SourceGroup +toStandardGroup (Group "manual") = Just ManualGroup +toStandardGroup (Group "public") = Just PublicGroup +toStandardGroup (Group "unwanted") = Just UnwantedGroup toStandardGroup _ = Nothing descStandardGroup :: StandardGroup -> String diff --git a/Types/UUID.hs b/Types/UUID.hs --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -1,42 +1,82 @@ {- git-annex UUID type - - - Copyright 2011 Joey Hess + - Copyright 2011-2019 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-} module Types.UUID where +import qualified Data.ByteString as B import qualified Data.Map as M import qualified Data.UUID as U import Data.Maybe +import Data.String +import Data.ByteString.Builder +import qualified Data.Semigroup as Sem +import Utility.FileSystemEncoding import qualified Utility.SimpleProtocol as Proto -- A UUID is either an arbitrary opaque string, or UUID info may be missing. -data UUID = NoUUID | UUID String +data UUID = NoUUID | UUID B.ByteString deriving (Eq, Ord, Show, Read) -fromUUID :: UUID -> String -fromUUID (UUID u) = u -fromUUID NoUUID = "" +class FromUUID a where + fromUUID :: UUID -> a class ToUUID a where toUUID :: a -> UUID +instance FromUUID UUID where + fromUUID = id + instance ToUUID UUID where toUUID = id +instance FromUUID B.ByteString where + fromUUID (UUID u) = u + fromUUID NoUUID = B.empty + +instance ToUUID B.ByteString where + toUUID b + | B.null b = NoUUID + | otherwise = UUID b + +instance FromUUID String where + fromUUID s = decodeBS' (fromUUID s) + instance ToUUID String where - toUUID [] = NoUUID - toUUID s = UUID s + toUUID s = toUUID (encodeBS' s) +-- 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. +instance ToUUID U.UUID where + toUUID = toUUID . U.toASCIIBytes + +buildUUID :: UUID -> Builder +buildUUID (UUID b) = byteString b +buildUUID NoUUID = mempty + isUUID :: String -> Bool isUUID = isJust . U.fromString -type UUIDMap = M.Map UUID String +-- A description of a UUID. +newtype UUIDDesc = UUIDDesc B.ByteString + deriving (Eq, Sem.Semigroup, Monoid, IsString) + +fromUUIDDesc :: UUIDDesc -> String +fromUUIDDesc (UUIDDesc d) = decodeBS d + +toUUIDDesc :: String -> UUIDDesc +toUUIDDesc = UUIDDesc . encodeBS + +buildUUIDDesc :: UUIDDesc -> Builder +buildUUIDDesc (UUIDDesc b) = byteString b + +type UUIDDescMap = M.Map UUID UUIDDesc instance Proto.Serializable UUID where serialize = fromUUID diff --git a/Types/View.hs b/Types/View.hs --- a/Types/View.hs +++ b/Types/View.hs @@ -23,7 +23,8 @@ deriving (Eq, Read, Show) instance Arbitrary View where - arbitrary = View <$> pure (Git.Ref "master") <*> arbitrary + arbitrary = View (Git.Ref "master") + <$> resize 10 (listOf arbitrary) data ViewComponent = ViewComponent { viewField :: MetaField @@ -43,8 +44,7 @@ instance Arbitrary ViewFilter where arbitrary = do - size <- arbitrarySizedBoundedIntegral `suchThat` (< 100) - s <- S.fromList <$> vector size + s <- S.fromList <$> resize 10 (listOf arbitrary) ifM arbitrary ( return (FilterValues s) , return (ExcludeValues s) diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -10,6 +10,9 @@ import System.Posix.Types import Data.Char import Data.Default +import Data.ByteString.Builder +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L import Annex.Common import Annex.Content @@ -131,7 +134,7 @@ where len = length l - 4 k = readKey1 (take len l) - sane = (not . null $ keyName k) && (not . null $ formatKeyVariety $ keyVariety k) + sane = (not . S.null $ keyName k) && (not . S.null $ formatKeyVariety $ keyVariety k) -- WORM backend keys: "WORM:mtime:size:filename" -- all the rest: "backend:key" @@ -141,10 +144,10 @@ -- as the v2 key that it is. readKey1 :: String -> Key readKey1 v - | mixup = fromJust $ file2key $ intercalate ":" $ Prelude.tail bits + | mixup = fromJust $ deserializeKey $ intercalate ":" $ Prelude.tail bits | otherwise = stubKey - { keyName = n - , keyVariety = parseKeyVariety b + { keyName = encodeBS n + , keyVariety = parseKeyVariety (encodeBS b) , keySize = s , keyMtime = t } @@ -163,11 +166,11 @@ showKey1 :: Key -> String showKey1 Key { keyName = n , keyVariety = v, keySize = s, keyMtime = t } = - intercalate ":" $ filter (not . null) [b, showifhere t, showifhere s, n] + intercalate ":" $ filter (not . null) [b, showifhere t, showifhere s, decodeBS n] where showifhere Nothing = "" showifhere (Just x) = show x - b = formatKeyVariety v + b = decodeBS $ formatKeyVariety v keyFile1 :: Key -> FilePath keyFile1 key = replace "/" "%" $ replace "%" "&s" $ replace "&" "&a" $ showKey1 key @@ -177,11 +180,11 @@ replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file writeLog1 :: FilePath -> [LogLine] -> IO () -writeLog1 file ls = viaTmp writeFile file (showLog ls) +writeLog1 file ls = viaTmp L.writeFile file (toLazyByteString $ buildLog ls) readLog1 :: FilePath -> IO [LogLine] readLog1 file = catchDefaultIO [] $ - parseLog <$> readFileStrict file + parseLog . encodeBL <$> readFileStrict file lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend)) lookupFile1 file = do @@ -194,14 +197,14 @@ makekey l = case maybeLookupBackendVariety (keyVariety k) of Nothing -> do unless (null kname || null bname || - not (isLinkToAnnex l)) $ + not (isLinkToAnnex (toRawFilePath l))) $ warning skip return Nothing Just backend -> return $ Just (k, backend) where k = fileKey1 l - bname = formatKeyVariety (keyVariety k) - kname = keyName k + bname = decodeBS (formatKeyVariety (keyVariety k)) + kname = decodeBS (keyName k) skip = "skipping " ++ file ++ " (unknown backend " ++ bname ++ ")" diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -83,7 +83,7 @@ old <- fromRepo olddir new <- liftIO (readFile $ old source) Annex.Branch.change dest $ \prev -> - unlines $ nub $ lines prev ++ lines new + encodeBL $ unlines $ nub $ lines (decodeBL prev) ++ lines new logFiles :: FilePath -> Annex [FilePath] logFiles dir = return . filter (".log" `isSuffixOf`) diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -29,6 +29,8 @@ import Utility.InodeCache import Annex.AdjustedBranch +import qualified Data.ByteString as S + upgrade :: Bool -> Annex Bool upgrade automatic = do unless automatic $ @@ -117,7 +119,7 @@ void $ linkToAnnex k f ic writepointer f k = liftIO $ do nukeFile f - writeFile f (formatPointer k) + S.writeFile f (formatPointer k) {- Remove all direct mode bookkeeping files. -} removeDirectCruft :: Annex () diff --git a/Utility/Aeson.hs b/Utility/Aeson.hs --- a/Utility/Aeson.hs +++ b/Utility/Aeson.hs @@ -2,7 +2,7 @@ - - Import instead of Data.Aeson - - - Copyright 2018 Joey Hess + - Copyright 2018-2019 Joey Hess - - License: BSD-2-clause -} @@ -14,6 +14,7 @@ ToJSON'(..), encode, packString, + packByteString, ) where import Data.Aeson as X hiding (ToJSON, toJSON, encode) @@ -43,9 +44,19 @@ class ToJSON' a where toJSON' :: a -> Value +instance ToJSON' T.Text where + toJSON' = toJSON + instance ToJSON' String where toJSON' = toJSON . packString +-- | Aeson does not have a ToJSON instance for ByteString; +-- this one assumes that the ByteString contains text, and will +-- have the same effect as toJSON' . decodeBS, but with a more efficient +-- implementation. +instance ToJSON' S.ByteString where + toJSON' = toJSON . packByteString + -- | Pack a String to Text, correctly handling the filesystem encoding. -- -- Use this instead of Data.Text.pack. @@ -53,9 +64,16 @@ -- Note that if the string contains invalid UTF8 characters not using -- the FileSystemEncoding, this is the same as Data.Text.pack. packString :: String -> T.Text -packString s = case T.decodeUtf8' (S.concat $ L.toChunks $ encodeBS s) of +packString s = case T.decodeUtf8' (encodeBS s) of Right t -> t Left _ -> T.pack s + +-- | The same as packString . decodeBS, but more efficient in the usual +-- case. +packByteString :: S.ByteString -> T.Text +packByteString b = case T.decodeUtf8' b of + Right t -> t + Left _ -> T.pack (decodeBS b) -- | An instance for lists cannot be included as it would overlap with -- the String instance. Instead, you can use a Vector. diff --git a/Utility/AuthToken.hs b/Utility/AuthToken.hs --- a/Utility/AuthToken.hs +++ b/Utility/AuthToken.hs @@ -28,7 +28,7 @@ import qualified Data.ByteString.Lazy as L import "crypto-api" Crypto.Random --- | An AuthToken is stored in secue memory, with constant time comparison. +-- | An AuthToken is stored in secure memory, with constant time comparison. -- -- It can have varying length, depending on the security needs of the -- application. diff --git a/Utility/Base64.hs b/Utility/Base64.hs --- a/Utility/Base64.hs +++ b/Utility/Base64.hs @@ -1,39 +1,49 @@ -{- Simple Base64 encoding of Strings - - - - Note that this uses the FileSystemEncoding, so it can be used on Strings - - that repesent filepaths containing arbitrarily encoded characters. +{- Simple Base64 encoding - - - Copyright 2011, 2015 Joey Hess + - Copyright 2011-2019 Joey Hess - - License: BSD-2-clause -} -module Utility.Base64 (toB64, fromB64Maybe, fromB64, prop_b64_roundtrips) where +module Utility.Base64 where import Utility.FileSystemEncoding import qualified "sandi" Codec.Binary.Base64 as B64 import Data.Maybe -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as B import Data.ByteString.UTF8 (fromString, toString) import Data.Char -toB64 :: String -> String -toB64 = toString . B64.encode . L.toStrict . encodeBS +-- | This uses the FileSystemEncoding, so it can be used on Strings +-- that repesent filepaths containing arbitrarily encoded characters. +toB64 :: String -> String +toB64 = toString . B64.encode . encodeBS +toB64' :: B.ByteString -> B.ByteString +toB64' = B64.encode + fromB64Maybe :: String -> Maybe String -fromB64Maybe s = either (const Nothing) (Just . decodeBS . L.fromStrict) +fromB64Maybe s = either (const Nothing) (Just . decodeBS) (B64.decode $ fromString s) +fromB64Maybe' :: B.ByteString -> Maybe (B.ByteString) +fromB64Maybe' = either (const Nothing) Just . B64.decode + fromB64 :: String -> String fromB64 = fromMaybe bad . fromB64Maybe where bad = error "bad base64 encoded data" +fromB64' :: B.ByteString -> B.ByteString +fromB64' = fromMaybe bad . fromB64Maybe' + where + bad = error "bad base64 encoded data" + -- Only ascii strings are tested, because an arbitrary string may contain -- characters not encoded using the FileSystemEncoding, which would thus --- not roundtrip, as fromB64 always generates an output encoded that way. +-- not roundtrip, as decodeBS always generates an output encoded that way. prop_b64_roundtrips :: String -> Bool prop_b64_roundtrips s - | all (isAscii) s = s == fromB64 (toB64 s) + | all (isAscii) s = s == decodeBS (fromB64' (toB64' (encodeBS s))) | otherwise = True diff --git a/Utility/DirWatcher/INotify.hs b/Utility/DirWatcher/INotify.hs --- a/Utility/DirWatcher/INotify.hs +++ b/Utility/DirWatcher/INotify.hs @@ -12,9 +12,6 @@ import Common hiding (isDirectory) import Utility.ThreadLock import Utility.DirWatcher.Types -#if MIN_VERSION_hinotify(0,3,10) -import Utility.FileSystemEncoding -#endif import System.INotify import qualified System.Posix.Files as Files diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -69,6 +69,7 @@ otherGroupModes = [ groupReadMode, otherReadMode , groupWriteMode, otherWriteMode + , groupExecuteMode, otherExecuteMode ] {- Removes the write bits from a file. -} diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -15,8 +15,14 @@ RawFilePath, fromRawFilePath, toRawFilePath, + decodeBL, + encodeBL, decodeBS, encodeBS, + decodeBL', + encodeBL', + decodeBS', + encodeBS', decodeW8, encodeW8, encodeW8NUL, @@ -38,6 +44,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS +import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.Lazy.UTF8 as L8 #endif @@ -107,23 +114,51 @@ `catchNonAsync` (\_ -> return fp) {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} -decodeBS :: L.ByteString -> FilePath +decodeBL :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS -decodeBS = encodeW8NUL . L.unpack +decodeBL = encodeW8NUL . L.unpack #else {- On Windows, we assume that the ByteString is utf-8, since Windows - only uses unicode for filenames. -} -decodeBS = L8.toString +decodeBL = L8.toString #endif {- Encodes a FilePath into a ByteString, applying the filesystem encoding. -} -encodeBS :: FilePath -> L.ByteString +encodeBL :: FilePath -> L.ByteString #ifndef mingw32_HOST_OS -encodeBS = L.pack . decodeW8NUL +encodeBL = L.pack . decodeW8NUL #else -encodeBS = L8.fromString +encodeBL = L8.fromString #endif +decodeBS :: S.ByteString -> FilePath +#ifndef mingw32_HOST_OS +decodeBS = encodeW8NUL . S.unpack +#else +decodeBS = S8.toString +#endif + +encodeBS :: FilePath -> S.ByteString +#ifndef mingw32_HOST_OS +encodeBS = S.pack . decodeW8NUL +#else +encodeBS = S8.fromString +#endif + +{- Faster version that assumes the string does not contain NUL; + - if it does it will be truncated before the NUL. -} +decodeBS' :: S.ByteString -> FilePath +decodeBS' = encodeW8 . S.unpack + +encodeBS' :: FilePath -> S.ByteString +encodeBS' = S.pack . decodeW8 + +decodeBL' :: L.ByteString -> FilePath +decodeBL' = encodeW8 . L.unpack + +encodeBL' :: FilePath -> L.ByteString +encodeBL' = L.pack . decodeW8 + {- Recent versions of the unix package have this alias; defined here - for backwards compatibility. -} type RawFilePath = S.ByteString @@ -132,22 +167,22 @@ - since filename's don't. This should only be used with actual - RawFilePaths not arbitrary ByteString that may contain NUL. -} fromRawFilePath :: RawFilePath -> FilePath -fromRawFilePath = encodeW8 . S.unpack +fromRawFilePath = decodeBS' {- Note that the FilePath is assumed to never contain NUL, - since filename's don't. This should only be used with actual FilePaths - not arbitrary String that may contain NUL. -} toRawFilePath :: FilePath -> RawFilePath -toRawFilePath = S.pack . decodeW8 +toRawFilePath = encodeBS' {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. - - - w82c produces a String, which may contain Chars that are invalid + - w82s produces a String, which may contain Chars that are invalid - unicode. From there, this is really a simple matter of applying the - file system encoding, only complicated by GHC's interface to doing so. - - Note that the encoding stops at any NUL in the input. FilePaths - - do not normally contain embedded NUL, but Haskell Strings may. + - cannot contain embedded NUL, but Haskell Strings may. -} {-# NOINLINE encodeW8 #-} encodeW8 :: [Word8] -> FilePath @@ -155,8 +190,6 @@ enc <- Encoding.getFileSystemEncoding GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc -{- Useful when you want the actual number of bytes that will be used to - - represent the FilePath on disk. -} decodeW8 :: FilePath -> [Word8] decodeW8 = s2w8 . _encodeFilePath diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -19,7 +19,7 @@ #else import Utility.Tmp #endif -import Utility.Tmp.Dir +import Utility.FileMode import Utility.Format (decode_c) import Control.Concurrent @@ -347,37 +347,39 @@ #ifndef mingw32_HOST_OS {- Runs an action using gpg in a test harness, in which gpg does - - not use ~/.gpg/, but a directory with the test key set up to be used. -} -testHarness :: GpgCmd -> IO a -> IO a -testHarness cmd a = withTmpDir "gpgtmpXXXXXX" $ \tmpdir -> - bracket (setup tmpdir) (cleanup tmpdir) (const a) + - not use ~/.gpg/, but sets up the test key in a subdirectory of + - the passed directory and uses it. -} +testHarness :: FilePath -> GpgCmd -> IO a -> IO a +testHarness tmpdir cmd a = bracket setup cleanup (const a) where var = "GNUPGHOME" - setup tmpdir = do + setup = do orig <- getEnv var - setEnv var tmpdir True + subdir <- makenewdir (1 :: Integer) + -- gpg is picky about permissions on its home dir + liftIO $ void $ tryIO $ modifyFileMode subdir $ + removeModes $ otherGroupModes + setEnv var subdir True -- For some reason, recent gpg needs a trustdb to be set up. _ <- pipeStrict cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] [] _ <- pipeStrict cmd [Param "--import", Param "-q"] $ unlines [testSecretKey, testKey] return orig - cleanup tmpdir orig = do - removeDirectoryRecursive tmpdir - -- gpg-agent may be shutting down at the same time - -- and may delete its socket at the same time as - -- we're trying to, causing an exception. Retrying - -- will deal with this race. - `catchIO` (\_ -> removeDirectoryRecursive tmpdir) - reset orig - reset (Just v) = setEnv var v True - reset _ = unsetEnv var + cleanup (Just v) = setEnv var v True + cleanup Nothing = unsetEnv var + makenewdir n = do + let subdir = tmpdir show n + catchIOErrorType AlreadyExists (const $ makenewdir $ n + 1) $ do + createDirectory subdir + return subdir + {- Tests the test harness. -} -testTestHarness :: GpgCmd -> IO Bool -testTestHarness cmd = do - keys <- testHarness cmd $ findPubKeys cmd testKeyId +testTestHarness :: FilePath -> GpgCmd -> IO Bool +testTestHarness tmpdir cmd = do + keys <- testHarness tmpdir cmd $ findPubKeys cmd testKeyId return $ KeyIds [testKeyId] == keys #endif diff --git a/Utility/Hash.hs b/Utility/Hash.hs --- a/Utility/Hash.hs +++ b/Utility/Hash.hs @@ -33,10 +33,10 @@ prop_mac_stable, ) where +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.ByteString as S import "cryptonite" Crypto.MAC.HMAC import "cryptonite" Crypto.Hash diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -60,15 +60,17 @@ fromDuration :: Duration -> String fromDuration Duration { durationSeconds = d } | d == 0 = "0s" - | otherwise = concatMap showunit $ go [] units d + | otherwise = concatMap showunit $ take 2 $ go [] units d where - showunit (u, n) - | n > 0 = show n ++ [u] - | otherwise = "" + showunit (u, n) = show n ++ [u] go c [] _ = reverse c go c ((u, n):us) v = let (q,r) = v `quotRem` n - in go ((u, q):c) us r + in if q > 0 + then go ((u, q):c) us r + else if null c + then go c us r + else reverse c units :: [(Char, Integer)] units = diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -156,7 +156,7 @@ (inode:size:mtime:mtimedecimal:_) -> do i <- readish inode sz <- readish size - t <- parsePOSIXTime' mtime mtimedecimal + t <- parsePOSIXTime $ mtime ++ '.' : mtimedecimal return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t) _ -> Nothing diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -102,7 +102,7 @@ let shortbase = reverse $ take 32 $ reverse base let md5sum = if base == shortbase then "" - else show (md5 (encodeBS base)) + else show (md5 (encodeBL base)) dir <- ifM (doesDirectoryExist "/dev/shm") ( return "/dev/shm" , return "/tmp" diff --git a/Utility/Metered.hs b/Utility/Metered.hs --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -10,7 +10,6 @@ module Utility.Metered where import Common -import Utility.FileSystemEncoding import Utility.Percentage import Utility.DataUnits import Utility.HumanTime diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -178,13 +178,10 @@ , std_out = Inherit , std_err = Inherit } - (select, p') - | h == StdinHandle = - (stdinHandle, base { std_in = CreatePipe }) - | h == StdoutHandle = - (stdoutHandle, base { std_out = CreatePipe }) - | h == StderrHandle = - (stderrHandle, base { std_err = CreatePipe }) + (select, p') = case h of + StdinHandle -> (stdinHandle, base { std_in = CreatePipe }) + StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe }) + StderrHandle -> (stderrHandle, base { std_err = CreatePipe }) -- | Like withHandle, but passes (stdin, stdout) handles to the action. withIOHandles diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs new file mode 100644 --- /dev/null +++ b/Utility/RawFilePath.hs @@ -0,0 +1,28 @@ +{- Portability shim around System.Posix.Files.ByteString + - + - Copyright 2019 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.RawFilePath ( + RawFilePath, + readSymbolicLink, +) where + +#ifndef mingw32_HOST_OS +import System.Posix.Files.ByteString +import System.Posix.ByteString.FilePath +#else +import qualified Data.ByteString as B +import System.IO.Error + +type RawFilePath = B.ByteString + +readSymbolicLink :: RawFilePath -> IO RawFilePath +readSymbolicLink _ = ioError $ mkIOError illegalOperationErrorType x Nothing Nothing + where + x = "Utility.RawFilePath.readSymbolicLink: not supported" +#endif diff --git a/Utility/TimeStamp.hs b/Utility/TimeStamp.hs --- a/Utility/TimeStamp.hs +++ b/Utility/TimeStamp.hs @@ -1,6 +1,6 @@ {- timestamp parsing and formatting - - - Copyright 2015-2016 Joey Hess + - Copyright 2015-2019 Joey Hess - - License: BSD-2-clause -} @@ -9,37 +9,51 @@ module Utility.TimeStamp where -import Utility.PartialPrelude -import Utility.Misc +import Utility.Data import Data.Time.Clock.POSIX import Data.Time import Data.Ratio +import Control.Applicative +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Attoparsec.ByteString as A +import Data.Attoparsec.ByteString.Char8 (char, decimal, signed, isDigit_w8) #if ! MIN_VERSION_time(1,5,0) import System.Locale #endif {- Parses how POSIXTime shows itself: "1431286201.113452s" - - Also handles the format with no fractional seconds. -} + - (The "s" is included for historical reasons and is optional.) + - Also handles the format with no decimal seconds. -} +parserPOSIXTime :: A.Parser POSIXTime +parserPOSIXTime = mkPOSIXTime + <$> signed decimal + <*> (declen <|> pure (0, 0)) + <* optional (char 's') + where + declen :: A.Parser (Integer, Int) + declen = do + _ <- char '.' + b <- A.takeWhile isDigit_w8 + let len = B.length b + d <- either fail pure $ + A.parseOnly (decimal <* A.endOfInput) b + return (d, len) + parsePOSIXTime :: String -> Maybe POSIXTime -parsePOSIXTime = uncurry parsePOSIXTime' . separate (== '.') +parsePOSIXTime s = eitherToMaybe $ + A.parseOnly (parserPOSIXTime <* A.endOfInput) (B8.pack s) -{- Parses the integral and decimal part of a POSIXTime -} -parsePOSIXTime' :: String -> String -> Maybe POSIXTime -parsePOSIXTime' sn sd = do - n <- fromIntegral <$> readi sn - let sd' = takeWhile (/= 's') sd - if null sd' - then return n - else do - d <- readi sd' - let r = d % (10 ^ (length sd')) - return $ if n < 0 - then n - fromRational r - else n + fromRational r +{- This implementation allows for higher precision in a POSIXTime than + - supported by the system's Double, and avoids the complications of + - floating point. -} +mkPOSIXTime :: Integer -> (Integer, Int) -> POSIXTime +mkPOSIXTime n (d, dlen) + | n < 0 = fromIntegral n - fromRational r + | otherwise = fromIntegral n + fromRational r where - readi :: String -> Maybe Integer - readi = readish + r = d % (10 ^ dlen) formatPOSIXTime :: String -> POSIXTime -> String formatPOSIXTime fmt t = formatTime defaultTimeLocale fmt (posixSecondsToUTCTime t) diff --git a/Utility/Tmp/Dir.hs b/Utility/Tmp/Dir.hs --- a/Utility/Tmp/Dir.hs +++ b/Utility/Tmp/Dir.hs @@ -19,8 +19,7 @@ #endif import Utility.Exception - -type Template = String +import Utility.Tmp (Template) {- Runs an action with a tmp directory located within the system's tmp - directory (or within "." if there is none), then removes the tmp diff --git a/doc/git-annex-adjust.mdwn b/doc/git-annex-adjust.mdwn --- a/doc/git-annex-adjust.mdwn +++ b/doc/git-annex-adjust.mdwn @@ -38,6 +38,14 @@ Unlock all annexed files in the adjusted branch. This allows annexed files to be modified. + Normally, unlocking a file requires a copy to be made of its content, + so that its original content is preserved, while the copy can be modified. + To use less space, annex.thin can be set to true before running this + command; this makes a hard link to the content be made instead of a copy. + (When supported by the file system.) While this can save considerable + disk space, any modification made to a file will cause the old version of the + file to be lost from the local repository. So, enable annex.thin with care. + * `--fix` Fix the symlinks to annexed files to point to the local git annex diff --git a/doc/git-annex-calckey.mdwn b/doc/git-annex-calckey.mdwn --- a/doc/git-annex-calckey.mdwn +++ b/doc/git-annex-calckey.mdwn @@ -1,6 +1,6 @@ # NAME -git-annex calckey - calculates the key that would be used to refer to a file +git-annex calckey - calulate key for a file # SYNOPSIS diff --git a/doc/git-annex-info.mdwn b/doc/git-annex-info.mdwn --- a/doc/git-annex-info.mdwn +++ b/doc/git-annex-info.mdwn @@ -1,6 +1,6 @@ # NAME -git-annex info - shows information about the specified item or the repository as a whole +git-annex info - information about an item or the repository # SYNOPSIS diff --git a/doc/git-annex-testremote.mdwn b/doc/git-annex-testremote.mdwn --- a/doc/git-annex-testremote.mdwn +++ b/doc/git-annex-testremote.mdwn @@ -8,8 +8,8 @@ # DESCRIPTION -This tests a remote by generating some random objects and sending them to -the remote, then redownloading them, removing them from the remote, etc. +This tests a remote by sending objects to it, downloading objects from it, +etc. It's safe to run in an existing repository (the repository contents are not altered), although it may perform expensive data transfers. @@ -20,7 +20,8 @@ Testing will use the remote's configuration, automatically varying the chunk sizes, and with simple shared encryption disabled and enabled, -and exporttree disabled and enabled. +and exporttree disabled and enabled. If the remote is readonly, testing +is limited to checking various properties of downloading from it. # OPTIONS @@ -28,9 +29,19 @@ Perform a smaller set of tests. +* `--test-readonly=file` + + Normally, random objects are generated for the test and are sent to the + remote. When a readonly remote is being tested, that cannot be done, + and so you need to specify some annexed files to use in the testing, + using this option. Their content needs to be present in the readonly remote + being tested, and in the local repository. + + This option can be repeated. + * `--size=NUnits` - Tune the base size of the generated objects. The default is 1MiB. + Tune the base size of generated objects. The default is 1MiB. # SEE ALSO diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -730,6 +730,8 @@ This runs git-annex's built-in benchmarks, if it was built with benchmarking support. + + See [[git-annex-benchmark]](1) for details. # COMMON OPTIONS diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,11 +1,11 @@ Name: git-annex -Version: 7.20181211 +Version: 7.20190122 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess Author: Joey Hess Stability: Stable -Copyright: 2010-2017 Joey Hess +Copyright: 2010-2019 Joey Hess License-File: COPYRIGHT Homepage: http://git-annex.branchable.com/ Build-type: Custom @@ -209,7 +209,6 @@ templates/configurators/edit/webrepository.hamlet templates/configurators/edit/repository.hamlet templates/configurators/unused.hamlet - templates/configurators/addbox.com.hamlet templates/configurators/ssh/testmodal.hamlet templates/configurators/ssh/expiredpassword.hamlet templates/configurators/ssh/error.hamlet @@ -228,7 +227,6 @@ templates/configurators/addrepository/wormholepairing.hamlet templates/configurators/rsync.net/add.hamlet templates/configurators/rsync.net/encrypt.hamlet - templates/configurators/gitlab.com/add.hamlet templates/configurators/needgcrypt.hamlet templates/configurators/needtor.hamlet templates/configurators/needmagicwormhole.hamlet @@ -588,7 +586,6 @@ if flag(Benchmark) Build-Depends: criterion, deepseq CPP-Options: -DWITH_BENCHMARK - Other-Modules: Command.Benchmark if flag(DebugLocks) CPP-Options: -DDEBUGLOCKS @@ -646,6 +643,7 @@ Annex.SpecialRemote Annex.Ssh Annex.TaggedPush + Annex.Tmp Annex.Transfer Annex.UpdateInstead Annex.UUID @@ -663,6 +661,7 @@ Backend.URL Backend.Utilities Backend.WORM + Benchmark Build.BundledPrograms Build.Configure Build.DesktopFile @@ -689,6 +688,7 @@ Command.AddUnused Command.AddUrl Command.Adjust + Command.Benchmark Command.CalcKey Command.CheckPresentKey Command.Commit @@ -949,6 +949,7 @@ Types.AdjustedBranch Types.Availability Types.Backend + Types.Benchmark Types.BranchState Types.CleanupActions Types.Command @@ -1055,6 +1056,7 @@ Utility.Process.Shim Utility.Process.Transcript Utility.QuickCheck + Utility.RawFilePath Utility.Rsync Utility.SafeCommand Utility.Scheduled diff --git a/git-annex.hs b/git-annex.hs --- a/git-annex.hs +++ b/git-annex.hs @@ -15,6 +15,7 @@ import qualified CmdLine.GitAnnexShell import qualified CmdLine.GitRemoteTorAnnex import qualified Test +import qualified Benchmark import Utility.FileSystemEncoding #ifdef mingw32_HOST_OS @@ -34,7 +35,7 @@ run ps n = case takeFileName n of "git-annex-shell" -> CmdLine.GitAnnexShell.run ps "git-remote-tor-annex" -> CmdLine.GitRemoteTorAnnex.run ps - _ -> CmdLine.GitAnnex.run Test.optParser Test.runner ps + _ -> CmdLine.GitAnnex.run Test.optParser Test.runner Benchmark.mkGenerator ps #ifdef mingw32_HOST_OS {- On Windows, if HOME is not set, probe it and set it. diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -10,6 +10,7 @@ magicmime: false dbus: false debuglocks: false + benchmark: false packages: - '.' extra-deps: diff --git a/templates/configurators/addbox.com.hamlet b/templates/configurators/addbox.com.hamlet deleted file mode 100644 --- a/templates/configurators/addbox.com.hamlet +++ /dev/null @@ -1,28 +0,0 @@ -
-
-

- Adding a Box.com repository -

- Box.com offers a small quantity of storage # - for free, and larger quantities for a fee. -

- Even a small amount of free storage is useful, as a transfer point # - between your repositories. -

-

-
- ^{form} - ^{webAppFormAuthToken} -
-
-