diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -32,10 +32,6 @@ withCurrentState, ) where -import "mtl" Control.Monad.Reader -import Control.Monad.Catch -import Control.Concurrent - import Common import qualified Git import qualified Git.Config @@ -62,12 +58,17 @@ import Types.MetaData import Types.DesktopNotify import Types.CleanupActions -import qualified Data.Map as M -import qualified Data.Set as S #ifdef WITH_QUVI import Utility.Quvi (QuviVersion) #endif +import Utility.InodeCache +import "mtl" Control.Monad.Reader +import Control.Monad.Catch +import Control.Concurrent +import qualified Data.Map as M +import qualified Data.Set as S + {- git-annex's monad is a ReaderT around an AnnexState stored in a MVar. - This allows modifying the state in an exception-safe fashion. - The MVar is not exposed outside this module. @@ -120,7 +121,7 @@ , fields :: M.Map String String , modmeta :: [ModMeta] , cleanup :: M.Map CleanupAction (Annex ()) - , inodeschanged :: Maybe Bool + , sentinalstatus :: Maybe SentinalStatus , useragent :: Maybe String , errcounter :: Integer , unusedkeys :: Maybe (S.Set Key) @@ -165,7 +166,7 @@ , fields = M.empty , modmeta = [] , cleanup = M.empty - , inodeschanged = Nothing + , sentinalstatus = Nothing , useragent = Nothing , errcounter = 0 , unusedkeys = Nothing diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -17,7 +17,6 @@ import qualified Git.UpdateIndex as UpdateIndex import qualified Git.Merge import qualified Git.Ref -import qualified Git.Sha import qualified Git import Git.Types (BlobType(..)) import Config @@ -38,14 +37,9 @@ Just b -> go =<< inRepo (Git.Ref.sha b) where go old = ifM isDirect - ( do - d <- fromRepo gitAnnexMergeDir - r <- inRepo (mergeDirect d branch) - <||> resolveMerge old branch - mergeDirectCleanup d (fromMaybe Git.Sha.emptyTree old) Git.Ref.headRef - return r + ( mergeDirect currbranch old branch (resolveMerge old branch) , inRepo (Git.Merge.mergeNonInteractive branch) - <||> resolveMerge old branch + <||> (resolveMerge old branch <&&> commitResolvedMerge) ) {- Resolves a conflicted merge. It's important that any conflicts be @@ -70,9 +64,11 @@ - - In indirect mode, the merge is resolved in the work tree and files - staged, to clean up from a conflicted merge that was run in the work - - tree. In direct mode, the work tree is not touched here; files are - - staged to the index, and written to the gitAnnexMergeDir, and later - - mergeDirectCleanup handles updating the work tree. + - tree. + - + - In direct mode, the work tree is not touched here; files are staged to + - the index, and written to the gitAnnexMergeDir, for later handling by + - the direct mode merge code. -} resolveMerge :: Maybe Git.Ref -> Git.Ref -> Annex Bool resolveMerge us them = do @@ -92,14 +88,6 @@ unlessM isDirect $ cleanConflictCruft mergedfs top Annex.Queue.flush - whenM isDirect $ - void preCommitDirect - void $ inRepo $ Git.Command.runBool - [ Param "commit" - , Param "--no-verify" - , Param "-m" - , Param "git-annex automatic merge conflict fix" - ] showLongNote "Merge conflict was automatically resolved; you may want to examine the result." return merged @@ -177,3 +165,11 @@ s = S.fromList resolvedfs matchesresolved f = S.member (base f) s base f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f + +commitResolvedMerge :: Annex Bool +commitResolvedMerge = inRepo $ Git.Command.runBool + [ Param "commit" + , Param "--no-verify" + , Param "-m" + , Param "git-annex automatic merge conflict fix" + ] diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs --- a/Annex/Content/Direct.hs +++ b/Annex/Content/Direct.hs @@ -1,10 +1,12 @@ {- git-annex file content managing for direct mode - - - Copyright 2012-2013 Joey Hess + - Copyright 2012-2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Annex.Content.Direct ( associatedFiles, associatedFilesRelative, @@ -27,6 +29,8 @@ inodesChanged, createInodeSentinalFile, addContentWhenNotPresent, + withTSDelta, + getTSDelta, ) where import Common.Annex @@ -136,7 +140,7 @@ -} updateInodeCache :: Key -> FilePath -> Annex () updateInodeCache key file = maybe noop (addInodeCache key) - =<< liftIO (genInodeCache file) + =<< withTSDelta (liftIO . genInodeCache file) {- Adds another inode to the cache for a key. -} addInodeCache :: Key -> InodeCache -> Annex () @@ -164,7 +168,7 @@ {- Checks if a InodeCache matches the current version of a file. -} sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool sameInodeCache _ [] = return False -sameInodeCache file old = go =<< liftIO (genInodeCache file) +sameInodeCache file old = go =<< withTSDelta (liftIO . genInodeCache file) where go Nothing = return False go (Just curr) = elemInodeCaches curr old @@ -173,7 +177,7 @@ sameFileStatus :: Key -> FileStatus -> Annex Bool sameFileStatus key status = do old <- recordedInodeCache key - let curr = toInodeCache status + curr <- withTSDelta $ \delta -> liftIO $ toInodeCache delta status case (old, curr) of (_, Just c) -> elemInodeCaches c old ([], Nothing) -> return True @@ -217,40 +221,43 @@ - inodes have changed. -} inodesChanged :: Annex Bool -inodesChanged = maybe calc return =<< Annex.getState Annex.inodeschanged - where - calc = do - scache <- liftIO . genInodeCache - =<< fromRepo gitAnnexInodeSentinal - scached <- readInodeSentinalFile - let changed = case (scache, scached) of - (Just c1, Just c2) -> not $ compareStrong c1 c2 - _ -> True - Annex.changeState $ \s -> s { Annex.inodeschanged = Just changed } - return changed +inodesChanged = sentinalInodesChanged <$> sentinalStatus -readInodeSentinalFile :: Annex (Maybe InodeCache) -readInodeSentinalFile = do - sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache - liftIO $ catchDefaultIO Nothing $ - readInodeCache <$> readFile sentinalcachefile +withTSDelta :: (TSDelta -> Annex a) -> Annex a +withTSDelta a = a =<< getTSDelta -writeInodeSentinalFile :: Annex () -writeInodeSentinalFile = do - sentinalfile <- fromRepo gitAnnexInodeSentinal - createAnnexDirectory (parentDir sentinalfile) - sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache - liftIO $ writeFile sentinalfile "" - liftIO $ maybe noop (writeFile sentinalcachefile . showInodeCache) - =<< genInodeCache sentinalfile +getTSDelta :: Annex TSDelta +#ifdef mingw32_HOST_OS +getTSDelta = sentinalTSDelta <$> sentinalStatus +#else +getTSDelta = pure noTSDelta -- optimisation +#endif +sentinalStatus :: Annex SentinalStatus +sentinalStatus = maybe check return =<< Annex.getState Annex.sentinalstatus + where + check = do + sc <- liftIO . checkSentinalFile =<< annexSentinalFile + Annex.changeState $ \s -> s { Annex.sentinalstatus = Just sc } + return sc + {- The sentinal file is only created when first initializing a repository. - If there are any annexed objects in the repository already, creating - the file would invalidate their inode caches. -} createInodeSentinalFile :: Annex () -createInodeSentinalFile = - unlessM (alreadyexists <||> hasobjects) - writeInodeSentinalFile +createInodeSentinalFile = unlessM (alreadyexists <||> hasobjects) $ do + s <- annexSentinalFile + createAnnexDirectory (parentDir (sentinalFile s)) + liftIO $ writeSentinalFile s where - alreadyexists = isJust <$> readInodeSentinalFile + alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile hasobjects = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir + +annexSentinalFile :: Annex SentinalFile +annexSentinalFile = do + sentinalfile <- fromRepo gitAnnexInodeSentinal + sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache + return $ SentinalFile + { sentinalFile = sentinalfile + , sentinalCacheFile = sentinalcachefile + } diff --git a/Annex/Direct.hs b/Annex/Direct.hs --- a/Annex/Direct.hs +++ b/Annex/Direct.hs @@ -1,6 +1,6 @@ {- git-annex direct mode - - - Copyright 2012, 2013 Joey Hess + - Copyright 2012-2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -34,6 +34,8 @@ import Annex.ReplaceFile import Annex.Exception import Annex.VariantFile +import Git.Index +import Annex.Index {- Uses git ls-files to find files that need to be committed, and stages - them into the index. Returns True if some changes were staged. -} @@ -51,11 +53,12 @@ {- Determine what kind of modified or deleted file this is, as - efficiently as we can, by getting any key that's associated - with it in git, as well as its stat info. -} - go (file, Just sha, Just mode) = do + go (file, Just sha, Just mode) = withTSDelta $ \delta -> do shakey <- catKey sha mode mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file + mcache <- liftIO $ maybe (pure Nothing) (toInodeCache delta) mstat filekey <- isAnnexLink file - case (shakey, filekey, mstat, toInodeCache =<< mstat) of + case (shakey, filekey, mstat, mcache) of (_, Just key, _, _) | shakey == filekey -> noop {- A changed symlink. -} @@ -141,21 +144,83 @@ ) {- In direct mode, git merge would usually refuse to do anything, since it - - sees present direct mode files as type changed files. To avoid this, - - merge is run with the work tree set to a temp directory. + - sees present direct mode files as type changed files. + - + - So, to handle a merge, it's run with the work tree set to a temp + - directory, and the merge is staged into a copy of the index. + - Then the work tree is updated to reflect the merge, and + - finally, the merge is committed and the real index updated. -} -mergeDirect :: FilePath -> Git.Ref -> Git.Repo -> IO Bool -mergeDirect d branch g = do - whenM (doesDirectoryExist d) $ - removeDirectoryRecursive d - createDirectoryIfMissing True d - let g' = g { location = Local { gitdir = Git.localGitDir g, worktree = Just d } } - Git.Merge.mergeNonInteractive branch g' +mergeDirect :: Maybe Git.Ref -> Maybe Git.Ref -> Git.Branch -> Annex Bool -> Annex Bool +mergeDirect startbranch oldref branch resolvemerge = do + -- Use the index lock file as the temp index file. + -- This is actually what git does when updating the index, + -- and so it will prevent other git processes from making + -- any changes to the index while our merge is in progress. + reali <- fromRepo indexFile + tmpi <- fromRepo indexFileLock + liftIO $ copyFile reali tmpi -{- Cleans up after a direct mode merge. The merge must have been committed, - - and the commit sha passed in, along with the old sha of the tree - - before the merge. Uses git diff-tree to find files that changed between - - the two shas, and applies those changes to the work tree. + d <- fromRepo gitAnnexMergeDir + liftIO $ do + whenM (doesDirectoryExist d) $ + removeDirectoryRecursive d + createDirectoryIfMissing True d + + withIndexFile tmpi $ do + merged <- stageMerge d branch + r <- if merged + then return True + else resolvemerge + mergeDirectCleanup d (fromMaybe Git.Sha.emptyTree oldref) + mergeDirectCommit merged startbranch branch + liftIO $ rename tmpi reali + return r + +{- Stage a merge into the index, avoiding changing HEAD or the current + - branch. -} +stageMerge :: FilePath -> Git.Branch -> Annex Bool +stageMerge d branch = do + -- XXX A bug in git makes stageMerge unsafe to use if the git repo + -- is configured with core.symlinks=false + -- Using mergeNonInteractive is not ideal though, since it will + -- update the current branch immediately, before the work tree + -- has been updated, which would leave things in an inconsistent + -- state if mergeDirectCleanup is interrupted. + -- + merger <- ifM (coreSymlinks <$> Annex.getGitConfig) + ( return Git.Merge.stageMerge + , return Git.Merge.mergeNonInteractive + ) + inRepo $ \g -> merger branch $ + g { location = Local { gitdir = Git.localGitDir g, worktree = Just d } } + +{- Commits after a direct mode merge is complete, and after the work + - tree has been updated by mergeDirectCleanup. + -} +mergeDirectCommit :: Bool -> Maybe Git.Ref -> Git.Branch -> Annex () +mergeDirectCommit allowff old branch = do + void preCommitDirect + d <- fromRepo Git.localGitDir + let merge_head = d "MERGE_HEAD" + let merge_msg = d "MERGE_MSG" + let merge_mode = d "MERGE_MODE" + ifM (pure allowff <&&> canff) + ( inRepo $ Git.Branch.update Git.Ref.headRef branch -- fast forward + , do + msg <- liftIO $ + catchDefaultIO ("merge " ++ fromRef branch) $ + readFile merge_msg + void $ inRepo $ Git.Branch.commit False msg + Git.Ref.headRef [Git.Ref.headRef, branch] + ) + liftIO $ mapM_ nukeFile [merge_head, merge_msg, merge_mode] + where + canff = maybe (return False) (\o -> inRepo $ Git.Branch.fastForwardable o branch) old + +{- Cleans up after a direct mode merge. The merge must have been staged + - in the index. Uses diff-index to compare the staged changes with + - the tree before the merge, and applies those changes to the work tree. - - There are really only two types of changes: An old item can be deleted, - or a new item added. Two passes are made, first deleting and then @@ -164,9 +229,9 @@ - order, but we cannot add the directory until the file with the - same name is removed.) -} -mergeDirectCleanup :: FilePath -> Git.Ref -> Git.Ref -> Annex () -mergeDirectCleanup d oldsha newsha = do - (items, cleanup) <- inRepo $ DiffTree.diffTreeRecursive oldsha newsha +mergeDirectCleanup :: FilePath -> Git.Ref -> Annex () +mergeDirectCleanup d oldref = do + (items, cleanup) <- inRepo $ DiffTree.diffIndex oldref makeabs <- flip fromTopFilePath <$> gitRepo let fsitems = zip (map (makeabs . DiffTree.file) items) items forM_ fsitems $ @@ -194,12 +259,12 @@ - key, it's left alone. - - If the file is already present, and does not exist in the - - oldsha branch, preserve this local file. + - oldref, preserve this local file. - - Otherwise, create the symlink and then if possible, replace it - with the content. -} movein item makeabs k f = unlessM (goodContent k f) $ do - preserveUnannexed item makeabs f oldsha + preserveUnannexed item makeabs f oldref l <- inRepo $ gitAnnexLink f k replaceFile f $ makeAnnexLink l toDirect k f @@ -207,13 +272,13 @@ {- Any new, modified, or renamed files were written to the temp - directory by the merge, and are moved to the real work tree. -} movein_raw item makeabs f = do - preserveUnannexed item makeabs f oldsha + preserveUnannexed item makeabs f oldref liftIO $ do createDirectoryIfMissing True $ parentDir f void $ tryIO $ rename (d getTopFilePath (DiffTree.file item)) f {- If the file that's being moved in is already present in the work - - tree, but did not exist in the oldsha branch, preserve this + - tree, but did not exist in the oldref, preserve this - local, unannexed file (or directory), as "variant-local". - - It's also possible that the file that's being moved in @@ -221,7 +286,7 @@ - file (not a directory), which should be preserved. -} preserveUnannexed :: DiffTree.DiffTreeItem -> (TopFilePath -> FilePath) -> FilePath -> Ref -> Annex () -preserveUnannexed item makeabs absf oldsha = do +preserveUnannexed item makeabs absf oldref = do whenM (liftIO (collidingitem absf) <&&> unannexed absf) $ liftIO $ findnewname absf 0 checkdirs (DiffTree.file item) @@ -241,7 +306,7 @@ <$> catchMaybeIO (getSymbolicLinkStatus f) unannexed f = (isNothing <$> isAnnexLink f) - <&&> (isNothing <$> catFileDetails oldsha f) + <&&> (isNothing <$> catFileDetails oldref f) findnewname :: FilePath -> Int -> IO () findnewname f n = do diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -22,7 +22,6 @@ import qualified Data.Map as M import Data.Hash.MD5 -import System.Process (cwd) import System.Exit import Common.Annex diff --git a/Assistant/Install.hs b/Assistant/Install.hs --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -122,15 +122,15 @@ cleanEnvironment :: IO (Maybe [(String, String)]) cleanEnvironment = clean <$> getEnvironment where - clean env + clean environ | null vars = Nothing - | otherwise = Just $ catMaybes $ map (restoreorig env) env + | otherwise = Just $ catMaybes $ map (restoreorig environ) environ | otherwise = Nothing where vars = words $ fromMaybe "" $ - lookup "GIT_ANNEX_STANDLONE_ENV" env - restoreorig oldenv p@(k, _v) - | k `elem` vars = case lookup ("ORIG_" ++ k) oldenv of + lookup "GIT_ANNEX_STANDLONE_ENV" environ + restoreorig oldenviron p@(k, _v) + | k `elem` vars = case lookup ("ORIG_" ++ k) oldenviron of (Just v') | not (null v') -> Just (k, v') _ -> Nothing diff --git a/Assistant/Restart.hs b/Assistant/Restart.hs --- a/Assistant/Restart.hs +++ b/Assistant/Restart.hs @@ -24,7 +24,6 @@ import qualified Git import Control.Concurrent -import System.Process (cwd) #ifndef mingw32_HOST_OS import System.Posix (signalProcess, sigTERM) #else diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -313,10 +313,11 @@ adddirect toadd = do ct <- liftAnnex compareInodeCachesWith m <- liftAnnex $ removedKeysMap ct cs + delta <- liftAnnex getTSDelta if M.null m then forM toadd add else forM toadd $ \c -> do - mcache <- liftIO $ genInodeCache $ changeFile c + mcache <- liftIO $ genInodeCache (changeFile c) delta case mcache of Nothing -> add c Just cache -> diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs --- a/Assistant/Threads/RemoteControl.hs +++ b/Assistant/Threads/RemoteControl.hs @@ -22,7 +22,6 @@ import Control.Concurrent import Control.Concurrent.Async -import System.Process (std_in, std_out) import Network.URI import qualified Data.Map as M import qualified Data.Set as S diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -47,6 +47,8 @@ import Network.Socket (SockAddr, HostName) import Data.Text (pack, unpack) import qualified Network.Wai.Handler.WarpTLS as TLS +import Network.Wai.Middleware.RequestLogger +import System.Log.Logger mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") @@ -83,7 +85,7 @@ setUrlRenderer urlrenderer $ yesodRender webapp (pack "") app <- toWaiAppPlain webapp app' <- ifM debugEnabled - ( return $ httpDebugLogger app + ( return $ logStdout app , return app ) runWebApp tlssettings listenhost' app' $ \addr -> if noannex @@ -135,3 +137,9 @@ #else return Nothing #endif + +{- Checks if debugging is actually enabled. -} +debugEnabled :: IO Bool +debugEnabled = do + l <- getRootLogger + return $ getLevel l <= Just DEBUG diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs --- a/Assistant/TransferrerPool.hs +++ b/Assistant/TransferrerPool.hs @@ -15,7 +15,6 @@ import qualified Command.TransferKeys as T import Control.Concurrent.STM hiding (check) -import System.Process (create_group, std_in, std_out) import Control.Exception (throw) import Control.Concurrent 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 @@ -116,11 +116,11 @@ defaultRepositoryPath firstrun = do #ifndef mingw32_HOST_OS home <- myHomeDir - cwd <- liftIO getCurrentDirectory - if home == cwd && firstrun + currdir <- liftIO getCurrentDirectory + if home == currdir && firstrun then inhome - else ifM (legit cwd <&&> canWrite cwd) - ( return cwd + else ifM (legit currdir <&&> canWrite currdir) + ( return currdir , inhome ) #else 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 @@ -381,7 +381,7 @@ login = getLogin sshinput geti f = maybe "" T.unpack (f sshinput) - go extraopts env = processTranscript' "ssh" (extraopts ++ opts) env $ + go extraopts environ = processTranscript' "ssh" (extraopts ++ opts) environ $ Just (fromMaybe "" input) setupAskPass = do @@ -392,8 +392,8 @@ Just pass -> withTmpFile "ssh" $ \passfile h -> do hClose h writeFileProtected passfile pass - env <- getEnvironment - let env' = addEntries + environ <- getEnvironment + let environ' = addEntries [ ("SSH_ASKPASS", program) , (sshAskPassEnv, passfile) -- ssh does not use SSH_ASKPASS @@ -401,8 +401,8 @@ -- there is no controlling -- terminal. , ("DISPLAY", ":0") - ] env - go [passwordprompts 1] (Just env') + ] environ + go [passwordprompts 1] (Just environ') passwordprompts :: Int -> String passwordprompts = sshOpt "NumberOfPasswordPrompts" . show diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -38,7 +38,6 @@ import Network.Protocol.XMPP import qualified Data.Text as T import System.Posix.Types -import System.Process (std_in, std_out, std_err) import Control.Concurrent import System.Timeout import qualified Data.ByteString as B @@ -112,15 +111,15 @@ tmpdir <- gettmpdir installwrapper tmpdir - env <- liftIO getEnvironment + environ <- liftIO getEnvironment path <- liftIO getSearchPath - let myenv = addEntries + let myenviron = addEntries [ ("PATH", intercalate [searchPathSeparator] $ tmpdir:path) , (relayIn, show inf) , (relayOut, show outf) , (relayControl, show controlf) ] - env + environ inh <- liftIO $ fdToHandle readpush outh <- liftIO $ fdToHandle writepush @@ -132,7 +131,7 @@ {- This can take a long time to run, so avoid running it in the - Annex monad. Also, override environment. -} g <- liftAnnex gitRepo - r <- liftIO $ gitpush $ g { gitEnv = Just myenv } + r <- liftIO $ gitpush $ g { gitEnv = Just myenviron } liftIO $ do mapM_ killThread [t1, t2] diff --git a/Build/EvilSplicer.hs b/Build/EvilSplicer.hs --- a/Build/EvilSplicer.hs +++ b/Build/EvilSplicer.hs @@ -310,6 +310,7 @@ . yesod_url_render_hack . text_builder_hack . nested_instances + . boxed_fileembed . collapse_multiline_strings . remove_package_version . emptylambda @@ -552,6 +553,42 @@ - that above, so have to fix up after it here. - The ; is added by case_layout. -} flip_colon = replace "; : _ " "; _ : " + +{- Embedded files use unsafe packing, which is problimatic + - for several reasons, including that GHC sometimes omits trailing + - newlines in the file content, which leads to the wrong byte + - count. Also, GHC sometimes outputs unicode characters, which + - are not legal in unboxed strings. + - + - Avoid problems by converting: + - GHC.IO.unsafePerformIO + - (Data.ByteString.Unsafe.unsafePackAddressLen + - lllll + - "blabblah"#)), + - to: + - Data.ByteString.Char8.pack "blabblah"), + - + - Note that the string is often multiline. This only works if + - collapse_multiline_strings has run first. + -} +boxed_fileembed :: String -> String +boxed_fileembed = parsecAndReplace $ do + i <- indent + void $ string "GHC.IO.unsafePerformIO" + void newline + void indent + void $ string "(Data.ByteString.Unsafe.unsafePackAddressLen" + void newline + void indent + void number + void newline + void indent + void $ char '"' + s <- restOfLine + let s' = take (length s - 5) s + if "\"#))," `isSuffixOf` s + then return (i ++ "Data.ByteString.Char8.pack \"" ++ s' ++ "\"),\n") + else fail "not an unboxed string" {- This works around a problem in the expanded template haskell for Yesod - type-safe url rendering. diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,22 @@ +git-annex (5.20140613) unstable; urgency=medium + + * Ignore setsid failures. + * Avoid leaving behind .tmp files when failing in some cases, including + importing files to a disk that is full. + * Avoid bad commits after interrupted direct mode sync (or merge). + * Fix build with wai 0.3.0. + * Deal with FAT's low resolution timestamps, which in combination with + Linux's caching of higher res timestamps while a FAT is mounted, caused + direct mode repositories on FAT to seem to have modified files after + they were unmounted and remounted. + * Windows: Fix opening webapp when repository is in a directory with + spaces in the path. + * Detect when Windows has lost its mind in a timezone change, and + automatically apply a delta to the timestamps it returns, to get back to + sane values. + + -- Joey Hess Fri, 13 Jun 2014 09:58:07 -0400 + git-annex (5.20140606) unstable; urgency=medium * webapp: When adding a new local repository, fix bug that caused its diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -102,7 +102,7 @@ lockDown' :: FilePath -> Annex (Either IOException KeySource) lockDown' file = ifM crippledFileSystem - ( liftIO $ tryIO nohardlink + ( withTSDelta $ liftIO . tryIO . nohardlink , tryAnnexIO $ do tmp <- fromRepo gitAnnexTmpMiscDir createAnnexDirectory tmp @@ -122,22 +122,22 @@ go tmp = do unlessM isDirect $ freezeContent file - liftIO $ do + withTSDelta $ \delta -> liftIO $ do (tmpfile, h) <- openTempFile tmp $ relatedTemplate $ takeFileName file hClose h nukeFile tmpfile - withhardlink tmpfile `catchIO` const nohardlink - nohardlink = do - cache <- genInodeCache file + withhardlink delta tmpfile `catchIO` const (nohardlink delta) + nohardlink delta = do + cache <- genInodeCache file delta return KeySource { keyFilename = file , contentLocation = file , inodeCache = cache } - withhardlink tmpfile = do + withhardlink delta tmpfile = do createLink file tmpfile - cache <- genInodeCache tmpfile + cache <- genInodeCache tmpfile delta return KeySource { keyFilename = file , contentLocation = tmpfile @@ -151,11 +151,11 @@ -} ingest :: Maybe KeySource -> Annex (Maybe Key, Maybe InodeCache) ingest Nothing = return (Nothing, Nothing) -ingest (Just source) = do +ingest (Just source) = withTSDelta $ \delta -> do backend <- chooseBackend $ keyFilename source k <- genKey source backend ms <- liftIO $ catchMaybeIO $ getFileStatus $ contentLocation source - let mcache = toInodeCache =<< ms + mcache <- maybe (pure Nothing) (liftIO . toInodeCache delta) ms case (mcache, inodeCache source) of (_, Nothing) -> go k mcache ms (Just newc, Just c) | compareStrong c newc -> go k mcache ms diff --git a/Command/Status.hs b/Command/Status.hs --- a/Command/Status.hs +++ b/Command/Status.hs @@ -28,9 +28,9 @@ start [] = do -- Like git status, when run without a directory, behave as if -- given the path to the top of the repository. - cwd <- liftIO getCurrentDirectory + currdir <- liftIO getCurrentDirectory top <- fromRepo Git.repoPath - start' [relPathDirToFile cwd top] + start' [relPathDirToFile currdir top] start locs = start' locs start' :: [FilePath] -> CommandStart diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -27,8 +27,8 @@ when (b == Annex.Branch.name) $ error $ "cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out" top <- fromRepo Git.repoPath - cwd <- liftIO getCurrentDirectory - whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $ + currdir <- liftIO getCurrentDirectory + whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $ error "can only run uninit from the top of the git repository" where current_branch = Git.Ref . Prelude.head . lines <$> revhead diff --git a/Command/WebApp.hs b/Command/WebApp.hs --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -34,7 +34,6 @@ import Control.Concurrent import Control.Concurrent.STM -import System.Process (env, std_out, std_err) import Network.Socket (HostName) import System.Environment (getArgs) @@ -215,7 +214,16 @@ where p = case mcmd of Just cmd -> proc cmd [htmlshim] - Nothing -> browserProc url + Nothing -> +#ifndef mingw32_HOST_OS + browserProc url +#else + {- Windows hack to avoid using the full path, + - which might contain spaces that cause problems + - for browserProc. -} + (browserProc (takeFileName htmlshim)) + { cwd = Just (takeDirectory htmlshim) } +#endif #ifdef __ANDROID__ {- Android does not support file:// urls, but neither is - the security of the url in the process table important diff --git a/Git/Branch.hs b/Git/Branch.hs --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -52,9 +52,24 @@ diffs = pipeReadStrict [ Param "log" , Param (fromRef origbranch ++ ".." ++ fromRef newbranch) - , Params "--oneline -n1" + , Param "-n1" + , Param "--pretty=%H" ] repo +{- Check if it's possible to fast-forward from the old + - ref to the new ref. + - + - This requires there to be a path from the old to the new. -} +fastForwardable :: Ref -> Ref -> Repo -> IO Bool +fastForwardable old new repo = not . null <$> + pipeReadStrict + [ Param "log" + , Param $ fromRef old ++ ".." ++ fromRef new + , Param "-n1" + , Param "--pretty=%H" + , Param "--ancestry-path" + ] repo + {- Given a set of refs that are all known to have commits not - on the branch, tries to update the branch by a fast-forward. - @@ -74,7 +89,7 @@ where no_ff = return False do_ff to = do - run [Param "update-ref", Param $ fromRef branch, Param $ fromRef to] repo + update branch to repo return True findbest c [] = return $ Just c findbest c (r:rs) diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs --- a/Git/CheckAttr.hs +++ b/Git/CheckAttr.hs @@ -23,9 +23,9 @@ - values and returns a handle. -} checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle checkAttrStart attrs repo = do - cwd <- getCurrentDirectory + currdir <- getCurrentDirectory h <- CoProcess.rawMode =<< gitCoProcessStart True params repo - return (h, attrs, cwd) + return (h, attrs, currdir) where params = [ Param "check-attr" @@ -38,7 +38,7 @@ {- Gets an attribute of a file. -} checkAttr :: CheckAttrHandle -> Attr -> FilePath -> IO String -checkAttr (h, attrs, cwd) want file = do +checkAttr (h, attrs, currdir) want file = do pairs <- CoProcess.query h send (receive "") let vals = map snd $ filter (\(attr, _) -> attr == want) pairs case vals of @@ -83,8 +83,8 @@ - so use relative filenames. -} oldgit = Git.BuildVersion.older "1.7.7" file' - | oldgit = absPathFrom cwd file - | otherwise = relPathDirToFile cwd $ absPathFrom cwd file + | oldgit = absPathFrom currdir file + | otherwise = relPathDirToFile currdir $ absPathFrom currdir file oldattrvalue attr l = end bits !! 0 where bits = split sep l diff --git a/Git/Command.hs b/Git/Command.hs --- a/Git/Command.hs +++ b/Git/Command.hs @@ -9,8 +9,6 @@ module Git.Command where -import System.Process (std_out, env) - import Common import Git import Git.Types diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -9,7 +9,6 @@ import qualified Data.Map as M import Data.Char -import System.Process (cwd, env) import Control.Exception.Extensible import Common diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -37,8 +37,8 @@ case wt of Nothing -> return r Just d -> do - cwd <- getCurrentDirectory - unless (d `dirContains` cwd) $ + curr <- getCurrentDirectory + unless (d `dirContains` curr) $ setCurrentDirectory d return $ addworktree wt r where @@ -57,8 +57,8 @@ configure Nothing (Just r) = Git.Config.read r configure (Just d) _ = do absd <- absPath d - cwd <- getCurrentDirectory - r <- newFrom $ Local { gitdir = absd, worktree = Just cwd } + curr <- getCurrentDirectory + r <- newFrom $ Local { gitdir = absd, worktree = Just curr } Git.Config.read r configure Nothing Nothing = error "Not in a git repository." diff --git a/Git/DiffTree.hs b/Git/DiffTree.hs --- a/Git/DiffTree.hs +++ b/Git/DiffTree.hs @@ -49,7 +49,7 @@ diffIndex ref = diffIndex' ref [Param "--cached"] {- Diffs between a tree and the working tree. Does nothing if there is not - - yet a commit in the repository, of if the repository is bare. -} + - yet a commit in the repository, or if the repository is bare. -} diffWorkTree :: Ref -> Repo -> IO ([DiffTreeItem], IO Bool) diffWorkTree ref repo = ifM (Git.Ref.headExists repo) diff --git a/Git/Fsck.hs b/Git/Fsck.hs --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -23,7 +23,6 @@ import qualified Git.Version import qualified Data.Set as S -import System.Process (std_out, std_err) import Control.Concurrent.Async type MissingObjects = S.Set Sha diff --git a/Git/Index.hs b/Git/Index.hs --- a/Git/Index.hs +++ b/Git/Index.hs @@ -30,3 +30,7 @@ indexFile :: Repo -> FilePath indexFile r = localGitDir r "index" + +{- Git locks the index by creating this file. -} +indexFileLock :: Repo -> FilePath +indexFileLock r = indexFile r ++ ".lock" diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -132,8 +132,8 @@ -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files. let top = repoPath repo - cwd <- getCurrentDirectory - return (map (\f -> relPathDirToFile cwd $ top f) fs, cleanup) + currdir <- getCurrentDirectory + return (map (\f -> relPathDirToFile currdir $ top f) fs, cleanup) where prefix = [Params "diff --name-only --diff-filter=T -z"] suffix = Param "--" : (if null l then [File "."] else map File l) diff --git a/Git/Merge.hs b/Git/Merge.hs --- a/Git/Merge.hs +++ b/Git/Merge.hs @@ -1,6 +1,6 @@ {- git merging - - - Copyright 2012 Joey Hess + - Copyright 2012, 2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -19,3 +19,15 @@ | otherwise = merge [Param "--no-edit", Param $ fromRef branch] where merge ps = runBool $ Param "merge" : ps + +{- Stage the merge into the index, but do not commit it.-} +stageMerge :: Ref -> Repo -> IO Bool +stageMerge branch = runBool + [ Param "merge" + , Param "--quiet" + , Param "--no-commit" + -- Without this, a fast-forward merge is done, since it involves no + -- commit. + , Param "--no-ff" + , Param $ fromRef branch + ] diff --git a/Git/Queue.hs b/Git/Queue.hs --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -24,9 +24,6 @@ import qualified Git.UpdateIndex import qualified Data.Map as M -#ifndef mingw32_HOST_OS -import System.Process -#endif {- Queable actions that can be performed in a git repository. -} @@ -159,9 +156,9 @@ -- Using xargs on Windows is problimatic, so just run the command -- once per file (not as efficient.) if null (getFiles action) - then void $ boolSystem "git" gitparams + then void $ boolSystemEnv "git" gitparams (gitEnv repo) else forM_ (getFiles action) $ \f -> - void $ boolSystem "git" (gitparams ++ [f]) + void $ boolSystemEnv "git" (gitparams ++ [f]) (gitEnv repo) #endif where gitparams = gitCommandLine diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -30,7 +30,6 @@ import Git.Sha import Control.Exception (bracket) -import System.Process (std_in) {- Streamers are passed a callback and should feed it lines in the form - read by update-index, and generated by ls-tree. -} diff --git a/Locations.hs b/Locations.hs --- a/Locations.hs +++ b/Locations.hs @@ -142,8 +142,8 @@ {- Calculates a symlink to link a file to an annexed object. -} gitAnnexLink :: FilePath -> Key -> Git.Repo -> IO FilePath gitAnnexLink file key r = do - cwd <- getCurrentDirectory - let absfile = fromMaybe whoops $ absNormPathUnix cwd file + currdir <- getCurrentDirectory + let absfile = fromMaybe whoops $ absNormPathUnix currdir file loc <- gitAnnexLocation' key r False return $ relPathDirToFile (parentDir absfile) loc where diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -28,7 +28,6 @@ import Creds import Control.Concurrent.STM -import System.Process (std_in, std_out, std_err) import System.Log.Logger (debugM) import qualified Data.Map as M import qualified Data.ByteString.Lazy as L diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -55,7 +55,6 @@ import Control.Concurrent import Control.Concurrent.MSampleVar -import System.Process (std_in, std_err) import qualified Data.Map as M import Control.Exception.Extensible @@ -467,12 +466,12 @@ | otherwise = return $ do program <- readProgramFile r' <- Git.Config.read r - env <- getEnvironment - let env' = addEntries + environ <- getEnvironment + let environ' = addEntries [ ("GIT_WORK_TREE", Git.repoPath r') , ("GIT_DIR", Git.localGitDir r') - ] env - batchCommandEnv program (Param "fsck" : params) $ Just env' + ] environ + batchCommandEnv program (Param "fsck" : params) $ Just environ' {- The passed repair action is run in the Annex monad of the remote. -} repairRemote :: Git.Repo -> Annex Bool -> Annex (IO Bool) diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -27,8 +27,6 @@ import Annex.UUID import Utility.Env -import System.Process - type Vault = String type Archive = FilePath diff --git a/Remote/Hook.hs b/Remote/Hook.hs --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -79,15 +79,15 @@ hookEnv action k f = Just <$> mergeenv (fileenv f ++ keyenv) where mergeenv l = addEntries l <$> getEnvironment - env s v = ("ANNEX_" ++ s, v) + envvar s v = ("ANNEX_" ++ s, v) keyenv = catMaybes - [ Just $ env "KEY" (key2file k) - , Just $ env "ACTION" action - , env "HASH_1" <$> headMaybe hashbits - , env "HASH_2" <$> headMaybe (drop 1 hashbits) + [ Just $ envvar "KEY" (key2file k) + , Just $ envvar "ACTION" action + , envvar "HASH_1" <$> headMaybe hashbits + , envvar "HASH_2" <$> headMaybe (drop 1 hashbits) ] fileenv Nothing = [] - fileenv (Just file) = [env "FILE" file] + fileenv (Just file) = [envvar "FILE" file] hashbits = map takeDirectory $ splitPath $ hashDirMixed k lookupHook :: HookName -> Action -> Annex (Maybe String) @@ -155,5 +155,5 @@ findkey s = key2file k `elem` lines s check Nothing = error $ action ++ " hook misconfigured" check (Just hook) = do - env <- hookEnv action k Nothing - findkey <$> readProcessEnv "sh" ["-c", hook] env + environ <- hookEnv action k Nothing + findkey <$> readProcessEnv "sh" ["-c", hook] environ diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -293,7 +293,7 @@ either s3Error return =<< liftIO (sendObject conn object) file = filePrefix c ++ "annex-uuid" - uuidb = L.fromStrict $ T.encodeUtf8 $ T.pack $ fromUUID u + uuidb = L.fromChunks [T.encodeUtf8 $ T.pack $ fromUUID u] bucket = fromJust $ getBucket c mkobject = S3Object bucket file "" (getXheaders c) diff --git a/RemoteDaemon/Transport/Ssh.hs b/RemoteDaemon/Transport/Ssh.hs --- a/RemoteDaemon/Transport/Ssh.hs +++ b/RemoteDaemon/Transport/Ssh.hs @@ -20,7 +20,6 @@ import Control.Concurrent.Chan import Control.Concurrent.Async -import System.Process (std_in, std_out, std_err) transport :: Transport transport r url h@(TransportHandle g s) ichan ochan = do diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -176,15 +176,15 @@ {- These tests set up the test environment, but also test some basic parts - of git-annex. They are always run before the unitTests. -} initTests :: TestEnv -> TestTree -initTests env = testGroup "Init Tests" +initTests testenv = testGroup "Init Tests" [ check "init" test_init , check "add" test_add ] where - check desc t = testCase desc (t env) + check desc t = testCase desc (t testenv) unitTests :: String -> IO TestEnv -> TestTree -unitTests note getenv = testGroup ("Unit Tests " ++ note) +unitTests note gettestenv = testGroup ("Unit Tests " ++ note) [ check "add sha1dup" test_add_sha1dup , check "add extras" test_add_extras , check "reinject" test_reinject @@ -236,25 +236,25 @@ , check "add subdirs" test_add_subdirs ] where - check desc t = testCase desc (getenv >>= t) + check desc t = testCase desc (gettestenv >>= t) -- this test case create the main repo test_init :: TestEnv -> Assertion -test_init env = innewrepo env $ do - git_annex env "init" [reponame] @? "init failed" - handleforcedirect env +test_init testenv = innewrepo testenv $ do + git_annex testenv "init" [reponame] @? "init failed" + handleforcedirect testenv where reponame = "test repo" -- this test case runs in the main repo, to set up a basic -- annexed file that later tests will use test_add :: TestEnv -> Assertion -test_add env = inmainrepo env $ do +test_add testenv = inmainrepo testenv $ do writeFile annexedfile $ content annexedfile - git_annex env "add" [annexedfile] @? "add failed" + git_annex testenv "add" [annexedfile] @? "add failed" annexed_present annexedfile writeFile sha1annexedfile $ content sha1annexedfile - git_annex env "add" [sha1annexedfile, "--backend=SHA1"] @? "add with SHA1 failed" + git_annex testenv "add" [sha1annexedfile, "--backend=SHA1"] @? "add with SHA1 failed" annexed_present sha1annexedfile checkbackend sha1annexedfile backendSHA1 ifM (annexeval Config.isDirect) @@ -262,223 +262,223 @@ writeFile ingitfile $ content ingitfile not <$> boolSystem "git" [Param "add", File ingitfile] @? "git add failed to fail in direct mode" nukeFile ingitfile - git_annex env "sync" [] @? "sync failed" + git_annex testenv "sync" [] @? "sync failed" , do writeFile ingitfile $ content ingitfile boolSystem "git" [Param "add", File ingitfile] @? "git add failed" boolSystem "git" [Params "commit -q -m commit"] @? "git commit failed" - git_annex env "add" [ingitfile] @? "add ingitfile should be no-op" + git_annex testenv "add" [ingitfile] @? "add ingitfile should be no-op" unannexed ingitfile ) test_add_sha1dup :: TestEnv -> Assertion -test_add_sha1dup env = intmpclonerepo env $ do +test_add_sha1dup testenv = intmpclonerepo testenv $ do writeFile sha1annexedfiledup $ content sha1annexedfiledup - git_annex env "add" [sha1annexedfiledup, "--backend=SHA1"] @? "add of second file with same SHA1 failed" + git_annex testenv "add" [sha1annexedfiledup, "--backend=SHA1"] @? "add of second file with same SHA1 failed" annexed_present sha1annexedfiledup annexed_present sha1annexedfile test_add_extras :: TestEnv -> Assertion -test_add_extras env = intmpclonerepo env $ do +test_add_extras testenv = intmpclonerepo testenv $ do writeFile wormannexedfile $ content wormannexedfile - git_annex env "add" [wormannexedfile, "--backend=WORM"] @? "add with WORM failed" + git_annex testenv "add" [wormannexedfile, "--backend=WORM"] @? "add with WORM failed" annexed_present wormannexedfile checkbackend wormannexedfile backendWORM test_reinject :: TestEnv -> Assertion -test_reinject env = intmpclonerepoInDirect env $ do - git_annex env "drop" ["--force", sha1annexedfile] @? "drop failed" +test_reinject testenv = intmpclonerepoInDirect testenv $ do + git_annex testenv "drop" ["--force", sha1annexedfile] @? "drop failed" writeFile tmp $ content sha1annexedfile r <- annexeval $ Types.Backend.getKey backendSHA1 Types.KeySource.KeySource { Types.KeySource.keyFilename = tmp, Types.KeySource.contentLocation = tmp, Types.KeySource.inodeCache = Nothing } let key = Types.Key.key2file $ fromJust r - git_annex env "reinject" [tmp, sha1annexedfile] @? "reinject failed" - git_annex env "fromkey" [key, sha1annexedfiledup] @? "fromkey failed for dup" + git_annex testenv "reinject" [tmp, sha1annexedfile] @? "reinject failed" + git_annex testenv "fromkey" [key, sha1annexedfiledup] @? "fromkey failed for dup" annexed_present sha1annexedfiledup where tmp = "tmpfile" test_unannex_nocopy :: TestEnv -> Assertion -test_unannex_nocopy env = intmpclonerepo env $ do +test_unannex_nocopy testenv = intmpclonerepo testenv $ do annexed_notpresent annexedfile - git_annex env "unannex" [annexedfile] @? "unannex failed with no copy" + git_annex testenv "unannex" [annexedfile] @? "unannex failed with no copy" annexed_notpresent annexedfile test_unannex_withcopy :: TestEnv -> Assertion -test_unannex_withcopy env = intmpclonerepo env $ do - git_annex env "get" [annexedfile] @? "get failed" +test_unannex_withcopy testenv = intmpclonerepo testenv $ do + git_annex testenv "get" [annexedfile] @? "get failed" annexed_present annexedfile - git_annex env "unannex" [annexedfile, sha1annexedfile] @? "unannex failed" + git_annex testenv "unannex" [annexedfile, sha1annexedfile] @? "unannex failed" unannexed annexedfile - git_annex env "unannex" [annexedfile] @? "unannex failed on non-annexed file" + git_annex testenv "unannex" [annexedfile] @? "unannex failed on non-annexed file" unannexed annexedfile unlessM (annexeval Config.isDirect) $ do - git_annex env "unannex" [ingitfile] @? "unannex ingitfile should be no-op" + git_annex testenv "unannex" [ingitfile] @? "unannex ingitfile should be no-op" unannexed ingitfile test_drop_noremote :: TestEnv -> Assertion -test_drop_noremote env = intmpclonerepo env $ do - git_annex env "get" [annexedfile] @? "get failed" +test_drop_noremote testenv = intmpclonerepo testenv $ do + git_annex testenv "get" [annexedfile] @? "get failed" boolSystem "git" [Params "remote rm origin"] @? "git remote rm origin failed" - not <$> git_annex env "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file" + not <$> git_annex testenv "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file" annexed_present annexedfile - git_annex env "drop" ["--force", annexedfile] @? "drop --force failed" + git_annex testenv "drop" ["--force", annexedfile] @? "drop --force failed" annexed_notpresent annexedfile - git_annex env "drop" [annexedfile] @? "drop of dropped file failed" + git_annex testenv "drop" [annexedfile] @? "drop of dropped file failed" unlessM (annexeval Config.isDirect) $ do - git_annex env "drop" [ingitfile] @? "drop ingitfile should be no-op" + git_annex testenv "drop" [ingitfile] @? "drop ingitfile should be no-op" unannexed ingitfile test_drop_withremote :: TestEnv -> Assertion -test_drop_withremote env = intmpclonerepo env $ do - git_annex env "get" [annexedfile] @? "get failed" +test_drop_withremote testenv = intmpclonerepo testenv $ do + git_annex testenv "get" [annexedfile] @? "get failed" annexed_present annexedfile - git_annex env "numcopies" ["2"] @? "numcopies config failed" - not <$> git_annex env "drop" [annexedfile] @? "drop succeeded although numcopies is not satisfied" - git_annex env "numcopies" ["1"] @? "numcopies config failed" - git_annex env "drop" [annexedfile] @? "drop failed though origin has copy" + git_annex testenv "numcopies" ["2"] @? "numcopies config failed" + not <$> git_annex testenv "drop" [annexedfile] @? "drop succeeded although numcopies is not satisfied" + git_annex testenv "numcopies" ["1"] @? "numcopies config failed" + git_annex testenv "drop" [annexedfile] @? "drop failed though origin has copy" annexed_notpresent annexedfile - inmainrepo env $ annexed_present annexedfile + inmainrepo testenv $ annexed_present annexedfile test_drop_untrustedremote :: TestEnv -> Assertion -test_drop_untrustedremote env = intmpclonerepo env $ do - git_annex env "untrust" ["origin"] @? "untrust of origin failed" - git_annex env "get" [annexedfile] @? "get failed" +test_drop_untrustedremote testenv = intmpclonerepo testenv $ do + git_annex testenv "untrust" ["origin"] @? "untrust of origin failed" + git_annex testenv "get" [annexedfile] @? "get failed" annexed_present annexedfile - not <$> git_annex env "drop" [annexedfile] @? "drop wrongly suceeded with only an untrusted copy of the file" + not <$> git_annex testenv "drop" [annexedfile] @? "drop wrongly suceeded with only an untrusted copy of the file" annexed_present annexedfile - inmainrepo env $ annexed_present annexedfile + inmainrepo testenv $ annexed_present annexedfile test_get :: TestEnv -> Assertion -test_get env = intmpclonerepo env $ do - inmainrepo env $ annexed_present annexedfile +test_get testenv = intmpclonerepo testenv $ do + inmainrepo testenv $ annexed_present annexedfile annexed_notpresent annexedfile - git_annex env "get" [annexedfile] @? "get of file failed" - inmainrepo env $ annexed_present annexedfile + git_annex testenv "get" [annexedfile] @? "get of file failed" + inmainrepo testenv $ annexed_present annexedfile annexed_present annexedfile - git_annex env "get" [annexedfile] @? "get of file already here failed" - inmainrepo env $ annexed_present annexedfile + git_annex testenv "get" [annexedfile] @? "get of file already here failed" + inmainrepo testenv $ annexed_present annexedfile annexed_present annexedfile unlessM (annexeval Config.isDirect) $ do - inmainrepo env $ unannexed ingitfile + inmainrepo testenv $ unannexed ingitfile unannexed ingitfile - git_annex env "get" [ingitfile] @? "get ingitfile should be no-op" - inmainrepo env $ unannexed ingitfile + git_annex testenv "get" [ingitfile] @? "get ingitfile should be no-op" + inmainrepo testenv $ unannexed ingitfile unannexed ingitfile test_move :: TestEnv -> Assertion -test_move env = intmpclonerepo env $ do +test_move testenv = intmpclonerepo testenv $ do annexed_notpresent annexedfile - inmainrepo env $ annexed_present annexedfile - git_annex env "move" ["--from", "origin", annexedfile] @? "move --from of file failed" + inmainrepo testenv $ annexed_present annexedfile + git_annex testenv "move" ["--from", "origin", annexedfile] @? "move --from of file failed" annexed_present annexedfile - inmainrepo env $ annexed_notpresent annexedfile - git_annex env "move" ["--from", "origin", annexedfile] @? "move --from of file already here failed" + inmainrepo testenv $ annexed_notpresent annexedfile + git_annex testenv "move" ["--from", "origin", annexedfile] @? "move --from of file already here failed" annexed_present annexedfile - inmainrepo env $ annexed_notpresent annexedfile - git_annex env "move" ["--to", "origin", annexedfile] @? "move --to of file failed" - inmainrepo env $ annexed_present annexedfile + inmainrepo testenv $ annexed_notpresent annexedfile + git_annex testenv "move" ["--to", "origin", annexedfile] @? "move --to of file failed" + inmainrepo testenv $ annexed_present annexedfile annexed_notpresent annexedfile - git_annex env "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed" - inmainrepo env $ annexed_present annexedfile + git_annex testenv "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed" + inmainrepo testenv $ annexed_present annexedfile annexed_notpresent annexedfile unlessM (annexeval Config.isDirect) $ do unannexed ingitfile - inmainrepo env $ unannexed ingitfile - git_annex env "move" ["--to", "origin", ingitfile] @? "move of ingitfile should be no-op" + inmainrepo testenv $ unannexed ingitfile + git_annex testenv "move" ["--to", "origin", ingitfile] @? "move of ingitfile should be no-op" unannexed ingitfile - inmainrepo env $ unannexed ingitfile - git_annex env "move" ["--from", "origin", ingitfile] @? "move of ingitfile should be no-op" + inmainrepo testenv $ unannexed ingitfile + git_annex testenv "move" ["--from", "origin", ingitfile] @? "move of ingitfile should be no-op" unannexed ingitfile - inmainrepo env $ unannexed ingitfile + inmainrepo testenv $ unannexed ingitfile test_copy :: TestEnv -> Assertion -test_copy env = intmpclonerepo env $ do +test_copy testenv = intmpclonerepo testenv $ do annexed_notpresent annexedfile - inmainrepo env $ annexed_present annexedfile - git_annex env "copy" ["--from", "origin", annexedfile] @? "copy --from of file failed" + inmainrepo testenv $ annexed_present annexedfile + git_annex testenv "copy" ["--from", "origin", annexedfile] @? "copy --from of file failed" annexed_present annexedfile - inmainrepo env $ annexed_present annexedfile - git_annex env "copy" ["--from", "origin", annexedfile] @? "copy --from of file already here failed" + inmainrepo testenv $ annexed_present annexedfile + git_annex testenv "copy" ["--from", "origin", annexedfile] @? "copy --from of file already here failed" annexed_present annexedfile - inmainrepo env $ annexed_present annexedfile - git_annex env "copy" ["--to", "origin", annexedfile] @? "copy --to of file already there failed" + inmainrepo testenv $ annexed_present annexedfile + git_annex testenv "copy" ["--to", "origin", annexedfile] @? "copy --to of file already there failed" annexed_present annexedfile - inmainrepo env $ annexed_present annexedfile - git_annex env "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed" + inmainrepo testenv $ annexed_present annexedfile + git_annex testenv "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed" annexed_notpresent annexedfile - inmainrepo env $ annexed_present annexedfile + inmainrepo testenv $ annexed_present annexedfile unlessM (annexeval Config.isDirect) $ do unannexed ingitfile - inmainrepo env $ unannexed ingitfile - git_annex env "copy" ["--to", "origin", ingitfile] @? "copy of ingitfile should be no-op" + inmainrepo testenv $ unannexed ingitfile + git_annex testenv "copy" ["--to", "origin", ingitfile] @? "copy of ingitfile should be no-op" unannexed ingitfile - inmainrepo env $ unannexed ingitfile - git_annex env "copy" ["--from", "origin", ingitfile] @? "copy of ingitfile should be no-op" + inmainrepo testenv $ unannexed ingitfile + git_annex testenv "copy" ["--from", "origin", ingitfile] @? "copy of ingitfile should be no-op" checkregularfile ingitfile checkcontent ingitfile test_preferred_content :: TestEnv -> Assertion -test_preferred_content env = intmpclonerepo env $ do +test_preferred_content testenv = intmpclonerepo testenv $ do annexed_notpresent annexedfile -- get --auto only looks at numcopies when preferred content is not -- set, and with 1 copy existing, does not get the file. - git_annex env "get" ["--auto", annexedfile] @? "get --auto of file failed with default preferred content" + git_annex testenv "get" ["--auto", annexedfile] @? "get --auto of file failed with default preferred content" annexed_notpresent annexedfile - git_annex env "wanted" [".", "standard"] @? "set expression to standard failed" - git_annex env "group" [".", "client"] @? "set group to standard failed" - git_annex env "get" ["--auto", annexedfile] @? "get --auto of file failed for client" + git_annex testenv "wanted" [".", "standard"] @? "set expression to standard failed" + git_annex testenv "group" [".", "client"] @? "set group to standard failed" + git_annex testenv "get" ["--auto", annexedfile] @? "get --auto of file failed for client" annexed_present annexedfile - git_annex env "ungroup" [".", "client"] @? "ungroup failed" + git_annex testenv "ungroup" [".", "client"] @? "ungroup failed" - git_annex env "wanted" [".", "standard"] @? "set expression to standard failed" - git_annex env "group" [".", "manual"] @? "set group to manual failed" + git_annex testenv "wanted" [".", "standard"] @? "set expression to standard failed" + git_annex testenv "group" [".", "manual"] @? "set group to manual failed" -- drop --auto with manual leaves the file where it is - git_annex env "drop" ["--auto", annexedfile] @? "drop --auto of file failed with manual preferred content" + git_annex testenv "drop" ["--auto", annexedfile] @? "drop --auto of file failed with manual preferred content" annexed_present annexedfile - git_annex env "drop" [annexedfile] @? "drop of file failed" + git_annex testenv "drop" [annexedfile] @? "drop of file failed" annexed_notpresent annexedfile -- get --auto with manual does not get the file - git_annex env "get" ["--auto", annexedfile] @? "get --auto of file failed with manual preferred content" + git_annex testenv "get" ["--auto", annexedfile] @? "get --auto of file failed with manual preferred content" annexed_notpresent annexedfile - git_annex env "ungroup" [".", "client"] @? "ungroup failed" + git_annex testenv "ungroup" [".", "client"] @? "ungroup failed" - git_annex env "wanted" [".", "exclude=*"] @? "set expression to exclude=* failed" - git_annex env "get" [annexedfile] @? "get of file failed" + git_annex testenv "wanted" [".", "exclude=*"] @? "set expression to exclude=* failed" + git_annex testenv "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex env "drop" ["--auto", annexedfile] @? "drop --auto of file failed with exclude=*" + git_annex testenv "drop" ["--auto", annexedfile] @? "drop --auto of file failed with exclude=*" annexed_notpresent annexedfile - git_annex env "get" ["--auto", annexedfile] @? "get --auto of file failed with exclude=*" + git_annex testenv "get" ["--auto", annexedfile] @? "get --auto of file failed with exclude=*" annexed_notpresent annexedfile test_lock :: TestEnv -> Assertion -test_lock env = intmpclonerepoInDirect env $ do +test_lock testenv = intmpclonerepoInDirect testenv $ do -- regression test: unlock of not present file should skip it annexed_notpresent annexedfile - not <$> git_annex env "unlock" [annexedfile] @? "unlock failed to fail with not present file" + not <$> git_annex testenv "unlock" [annexedfile] @? "unlock failed to fail with not present file" annexed_notpresent annexedfile - git_annex env "get" [annexedfile] @? "get of file failed" + git_annex testenv "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex env "unlock" [annexedfile] @? "unlock failed" + git_annex testenv "unlock" [annexedfile] @? "unlock failed" unannexed annexedfile -- write different content, to verify that lock -- throws it away changecontent annexedfile writeFile annexedfile $ content annexedfile ++ "foo" - not <$> git_annex env "lock" [annexedfile] @? "lock failed to fail without --force" - git_annex env "lock" ["--force", annexedfile] @? "lock --force failed" + not <$> git_annex testenv "lock" [annexedfile] @? "lock failed to fail without --force" + git_annex testenv "lock" ["--force", annexedfile] @? "lock --force failed" annexed_present annexedfile - git_annex env "unlock" [annexedfile] @? "unlock failed" + git_annex testenv "unlock" [annexedfile] @? "unlock failed" unannexed annexedfile changecontent annexedfile - git_annex env "add" [annexedfile] @? "add of modified file failed" + git_annex testenv "add" [annexedfile] @? "add of modified file failed" runchecks [checklink, checkunwritable] annexedfile c <- readFile annexedfile assertEqual "content of modified file" c (changedcontent annexedfile) - r' <- git_annex env "drop" [annexedfile] + r' <- git_annex testenv "drop" [annexedfile] not r' @? "drop wrongly succeeded with no known copy of modified file" test_edit :: TestEnv -> Assertion @@ -488,37 +488,37 @@ test_edit_precommit = test_edit' True test_edit' :: Bool -> TestEnv -> Assertion -test_edit' precommit env = intmpclonerepoInDirect env $ do - git_annex env "get" [annexedfile] @? "get of file failed" +test_edit' precommit testenv = intmpclonerepoInDirect testenv $ do + git_annex testenv "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex env "edit" [annexedfile] @? "edit failed" + git_annex testenv "edit" [annexedfile] @? "edit failed" unannexed annexedfile changecontent annexedfile boolSystem "git" [Param "add", File annexedfile] @? "git add of edited file failed" if precommit - then git_annex env "pre-commit" [] + then git_annex testenv "pre-commit" [] @? "pre-commit failed" else boolSystem "git" [Params "commit -q -m contentchanged"] @? "git commit of edited file failed" runchecks [checklink, checkunwritable] annexedfile c <- readFile annexedfile assertEqual "content of modified file" c (changedcontent annexedfile) - not <$> git_annex env "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of modified file" + not <$> git_annex testenv "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of modified file" test_fix :: TestEnv -> Assertion -test_fix env = intmpclonerepoInDirect env $ do +test_fix testenv = intmpclonerepoInDirect testenv $ do annexed_notpresent annexedfile - git_annex env "fix" [annexedfile] @? "fix of not present failed" + git_annex testenv "fix" [annexedfile] @? "fix of not present failed" annexed_notpresent annexedfile - git_annex env "get" [annexedfile] @? "get of file failed" + git_annex testenv "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex env "fix" [annexedfile] @? "fix of present file failed" + git_annex testenv "fix" [annexedfile] @? "fix of present file failed" annexed_present annexedfile createDirectory subdir boolSystem "git" [Param "mv", File annexedfile, File subdir] @? "git mv failed" - git_annex env "fix" [newfile] @? "fix of moved file failed" + git_annex testenv "fix" [newfile] @? "fix of moved file failed" runchecks [checklink, checkunwritable] newfile c <- readFile newfile assertEqual "content of moved file" c (content annexedfile) @@ -527,22 +527,22 @@ newfile = subdir ++ "/" ++ annexedfile test_trust :: TestEnv -> Assertion -test_trust env = intmpclonerepo env $ do - git_annex env "trust" [repo] @? "trust failed" +test_trust testenv = intmpclonerepo testenv $ do + git_annex testenv "trust" [repo] @? "trust failed" trustcheck Logs.Trust.Trusted "trusted 1" - git_annex env "trust" [repo] @? "trust of trusted failed" + git_annex testenv "trust" [repo] @? "trust of trusted failed" trustcheck Logs.Trust.Trusted "trusted 2" - git_annex env "untrust" [repo] @? "untrust failed" + git_annex testenv "untrust" [repo] @? "untrust failed" trustcheck Logs.Trust.UnTrusted "untrusted 1" - git_annex env "untrust" [repo] @? "untrust of untrusted failed" + git_annex testenv "untrust" [repo] @? "untrust of untrusted failed" trustcheck Logs.Trust.UnTrusted "untrusted 2" - git_annex env "dead" [repo] @? "dead failed" + git_annex testenv "dead" [repo] @? "dead failed" trustcheck Logs.Trust.DeadTrusted "deadtrusted 1" - git_annex env "dead" [repo] @? "dead of dead failed" + git_annex testenv "dead" [repo] @? "dead of dead failed" trustcheck Logs.Trust.DeadTrusted "deadtrusted 2" - git_annex env "semitrust" [repo] @? "semitrust failed" + git_annex testenv "semitrust" [repo] @? "semitrust failed" trustcheck Logs.Trust.SemiTrusted "semitrusted 1" - git_annex env "semitrust" [repo] @? "semitrust of semitrusted failed" + git_annex testenv "semitrust" [repo] @? "semitrust of semitrusted failed" trustcheck Logs.Trust.SemiTrusted "semitrusted 2" where repo = "origin" @@ -554,48 +554,48 @@ assertBool msg present test_fsck_basic :: TestEnv -> Assertion -test_fsck_basic env = intmpclonerepo env $ do - git_annex env "fsck" [] @? "fsck failed" - git_annex env "numcopies" ["2"] @? "numcopies config failed" - fsck_should_fail env "numcopies unsatisfied" - git_annex env "numcopies" ["1"] @? "numcopies config failed" +test_fsck_basic testenv = intmpclonerepo testenv $ do + git_annex testenv "fsck" [] @? "fsck failed" + git_annex testenv "numcopies" ["2"] @? "numcopies config failed" + fsck_should_fail testenv "numcopies unsatisfied" + git_annex testenv "numcopies" ["1"] @? "numcopies config failed" corrupt annexedfile corrupt sha1annexedfile where corrupt f = do - git_annex env "get" [f] @? "get of file failed" + git_annex testenv "get" [f] @? "get of file failed" Utility.FileMode.allowWrite f writeFile f (changedcontent f) ifM (annexeval Config.isDirect) - ( git_annex env "fsck" [] @? "fsck failed in direct mode with changed file content" - , not <$> git_annex env "fsck" [] @? "fsck failed to fail with corrupted file content" + ( git_annex testenv "fsck" [] @? "fsck failed in direct mode with changed file content" + , not <$> git_annex testenv "fsck" [] @? "fsck failed to fail with corrupted file content" ) - git_annex env "fsck" [] @? "fsck unexpectedly failed again; previous one did not fix problem with " ++ f + git_annex testenv "fsck" [] @? "fsck unexpectedly failed again; previous one did not fix problem with " ++ f test_fsck_bare :: TestEnv -> Assertion -test_fsck_bare env = intmpbareclonerepo env $ - git_annex env "fsck" [] @? "fsck failed" +test_fsck_bare testenv = intmpbareclonerepo testenv $ + git_annex testenv "fsck" [] @? "fsck failed" test_fsck_localuntrusted :: TestEnv -> Assertion -test_fsck_localuntrusted env = intmpclonerepo env $ do - git_annex env "get" [annexedfile] @? "get failed" - git_annex env "untrust" ["origin"] @? "untrust of origin repo failed" - git_annex env "untrust" ["."] @? "untrust of current repo failed" - fsck_should_fail env "content only available in untrusted (current) repository" - git_annex env "trust" ["."] @? "trust of current repo failed" - git_annex env "fsck" [annexedfile] @? "fsck failed on file present in trusted repo" +test_fsck_localuntrusted testenv = intmpclonerepo testenv $ do + git_annex testenv "get" [annexedfile] @? "get failed" + git_annex testenv "untrust" ["origin"] @? "untrust of origin repo failed" + git_annex testenv "untrust" ["."] @? "untrust of current repo failed" + fsck_should_fail testenv "content only available in untrusted (current) repository" + git_annex testenv "trust" ["."] @? "trust of current repo failed" + git_annex testenv "fsck" [annexedfile] @? "fsck failed on file present in trusted repo" test_fsck_remoteuntrusted :: TestEnv -> Assertion -test_fsck_remoteuntrusted env = intmpclonerepo env $ do - git_annex env "numcopies" ["2"] @? "numcopies config failed" - git_annex env "get" [annexedfile] @? "get failed" - git_annex env "get" [sha1annexedfile] @? "get failed" - git_annex env "fsck" [] @? "fsck failed with numcopies=2 and 2 copies" - git_annex env "untrust" ["origin"] @? "untrust of origin failed" - fsck_should_fail env "content not replicated to enough non-untrusted repositories" +test_fsck_remoteuntrusted testenv = intmpclonerepo testenv $ do + git_annex testenv "numcopies" ["2"] @? "numcopies config failed" + git_annex testenv "get" [annexedfile] @? "get failed" + git_annex testenv "get" [sha1annexedfile] @? "get failed" + git_annex testenv "fsck" [] @? "fsck failed with numcopies=2 and 2 copies" + git_annex testenv "untrust" ["origin"] @? "untrust of origin failed" + fsck_should_fail testenv "content not replicated to enough non-untrusted repositories" fsck_should_fail :: TestEnv -> String -> Assertion -fsck_should_fail env m = not <$> git_annex env "fsck" [] +fsck_should_fail testenv m = not <$> git_annex testenv "fsck" [] @? "fsck failed to fail with " ++ m test_migrate :: TestEnv -> Assertion @@ -605,26 +605,26 @@ test_migrate_via_gitattributes = test_migrate' True test_migrate' :: Bool -> TestEnv -> Assertion -test_migrate' usegitattributes env = intmpclonerepoInDirect env $ do +test_migrate' usegitattributes testenv = intmpclonerepoInDirect testenv $ do annexed_notpresent annexedfile annexed_notpresent sha1annexedfile - git_annex env "migrate" [annexedfile] @? "migrate of not present failed" - git_annex env "migrate" [sha1annexedfile] @? "migrate of not present failed" - git_annex env "get" [annexedfile] @? "get of file failed" - git_annex env "get" [sha1annexedfile] @? "get of file failed" + git_annex testenv "migrate" [annexedfile] @? "migrate of not present failed" + git_annex testenv "migrate" [sha1annexedfile] @? "migrate of not present failed" + git_annex testenv "get" [annexedfile] @? "get of file failed" + git_annex testenv "get" [sha1annexedfile] @? "get of file failed" annexed_present annexedfile annexed_present sha1annexedfile if usegitattributes then do writeFile ".gitattributes" "* annex.backend=SHA1" - git_annex env "migrate" [sha1annexedfile] + git_annex testenv "migrate" [sha1annexedfile] @? "migrate sha1annexedfile failed" - git_annex env "migrate" [annexedfile] + git_annex testenv "migrate" [annexedfile] @? "migrate annexedfile failed" else do - git_annex env "migrate" [sha1annexedfile, "--backend", "SHA1"] + git_annex testenv "migrate" [sha1annexedfile, "--backend", "SHA1"] @? "migrate sha1annexedfile failed" - git_annex env "migrate" [annexedfile, "--backend", "SHA1"] + git_annex testenv "migrate" [annexedfile, "--backend", "SHA1"] @? "migrate annexedfile failed" annexed_present annexedfile annexed_present sha1annexedfile @@ -633,9 +633,9 @@ -- check that reversing a migration works writeFile ".gitattributes" "* annex.backend=SHA256" - git_annex env "migrate" [sha1annexedfile] + git_annex testenv "migrate" [sha1annexedfile] @? "migrate sha1annexedfile failed" - git_annex env "migrate" [annexedfile] + git_annex testenv "migrate" [annexedfile] @? "migrate annexedfile failed" annexed_present annexedfile annexed_present sha1annexedfile @@ -644,12 +644,12 @@ test_unused :: TestEnv -> Assertion -- This test is broken in direct mode -test_unused env = intmpclonerepoInDirect env $ do +test_unused testenv = intmpclonerepoInDirect testenv $ do -- keys have to be looked up before files are removed annexedfilekey <- annexeval $ findkey annexedfile sha1annexedfilekey <- annexeval $ findkey sha1annexedfile - git_annex env "get" [annexedfile] @? "get of file failed" - git_annex env "get" [sha1annexedfile] @? "get of file failed" + git_annex testenv "get" [annexedfile] @? "get of file failed" + git_annex testenv "get" [sha1annexedfile] @? "get of file failed" checkunused [] "after get" boolSystem "git" [Params "rm -fq", File annexedfile] @? "git rm failed" checkunused [] "after rm" @@ -663,19 +663,19 @@ checkunused [annexedfilekey, sha1annexedfilekey] "after rm sha1annexedfile" -- good opportunity to test dropkey also - git_annex env "dropkey" ["--force", Types.Key.key2file annexedfilekey] + git_annex testenv "dropkey" ["--force", Types.Key.key2file annexedfilekey] @? "dropkey failed" checkunused [sha1annexedfilekey] ("after dropkey --force " ++ Types.Key.key2file annexedfilekey) - not <$> git_annex env "dropunused" ["1"] @? "dropunused failed to fail without --force" - git_annex env "dropunused" ["--force", "1"] @? "dropunused failed" + not <$> git_annex testenv "dropunused" ["1"] @? "dropunused failed to fail without --force" + git_annex testenv "dropunused" ["--force", "1"] @? "dropunused failed" checkunused [] "after dropunused" - not <$> git_annex env "dropunused" ["--force", "10", "501"] @? "dropunused failed to fail on bogus numbers" + not <$> git_annex testenv "dropunused" ["--force", "10", "501"] @? "dropunused failed to fail on bogus numbers" -- unused used to miss symlinks that were not staged and pointed -- at annexed content, and think that content was unused writeFile "unusedfile" "unusedcontent" - git_annex env "add" ["unusedfile"] @? "add of unusedfile failed" + git_annex testenv "add" ["unusedfile"] @? "add of unusedfile failed" unusedfilekey <- annexeval $ findkey "unusedfile" renameFile "unusedfile" "unusedunstagedfile" boolSystem "git" [Params "rm -qf", File "unusedfile"] @? "git rm failed" @@ -686,7 +686,7 @@ -- unused used to miss symlinks that were deleted or modified -- manually, but commited as such. writeFile "unusedfile" "unusedcontent" - git_annex env "add" ["unusedfile"] @? "add of unusedfile failed" + git_annex testenv "add" ["unusedfile"] @? "add of unusedfile failed" boolSystem "git" [Param "add", File "unusedfile"] @? "git add failed" unusedfilekey' <- annexeval $ findkey "unusedfile" checkunused [] "with staged deleted link" @@ -696,7 +696,7 @@ -- unused used to miss symlinks that were deleted or modified -- manually, but not staged as such. writeFile "unusedfile" "unusedcontent" - git_annex env "add" ["unusedfile"] @? "add of unusedfile failed" + git_annex testenv "add" ["unusedfile"] @? "add of unusedfile failed" boolSystem "git" [Param "add", File "unusedfile"] @? "git add failed" unusedfilekey'' <- annexeval $ findkey "unusedfile" checkunused [] "with unstaged deleted link" @@ -705,7 +705,7 @@ where checkunused expectedkeys desc = do - git_annex env "unused" [] @? "unused failed" + git_annex testenv "unused" [] @? "unused failed" unusedmap <- annexeval $ Logs.Unused.readUnusedMap "" let unusedkeys = M.elems unusedmap assertEqual ("unused keys differ " ++ desc) @@ -715,109 +715,109 @@ return $ fromJust r test_describe :: TestEnv -> Assertion -test_describe env = intmpclonerepo env $ do - git_annex env "describe" [".", "this repo"] @? "describe 1 failed" - git_annex env "describe" ["origin", "origin repo"] @? "describe 2 failed" +test_describe testenv = intmpclonerepo testenv $ do + git_annex testenv "describe" [".", "this repo"] @? "describe 1 failed" + git_annex testenv "describe" ["origin", "origin repo"] @? "describe 2 failed" test_find :: TestEnv -> Assertion -test_find env = intmpclonerepo env $ do +test_find testenv = intmpclonerepo testenv $ do annexed_notpresent annexedfile - git_annex_expectoutput env "find" [] [] - git_annex env "get" [annexedfile] @? "get failed" + git_annex_expectoutput testenv "find" [] [] + git_annex testenv "get" [annexedfile] @? "get failed" annexed_present annexedfile annexed_notpresent sha1annexedfile - git_annex_expectoutput env "find" [] [annexedfile] - git_annex_expectoutput env "find" ["--exclude", annexedfile, "--and", "--exclude", sha1annexedfile] [] - git_annex_expectoutput env "find" ["--include", annexedfile] [annexedfile] - git_annex_expectoutput env "find" ["--not", "--in", "origin"] [] - git_annex_expectoutput env "find" ["--copies", "1", "--and", "--not", "--copies", "2"] [sha1annexedfile] - git_annex_expectoutput env "find" ["--inbackend", "SHA1"] [sha1annexedfile] - git_annex_expectoutput env "find" ["--inbackend", "WORM"] [] + git_annex_expectoutput testenv "find" [] [annexedfile] + git_annex_expectoutput testenv "find" ["--exclude", annexedfile, "--and", "--exclude", sha1annexedfile] [] + git_annex_expectoutput testenv "find" ["--include", annexedfile] [annexedfile] + git_annex_expectoutput testenv "find" ["--not", "--in", "origin"] [] + git_annex_expectoutput testenv "find" ["--copies", "1", "--and", "--not", "--copies", "2"] [sha1annexedfile] + git_annex_expectoutput testenv "find" ["--inbackend", "SHA1"] [sha1annexedfile] + git_annex_expectoutput testenv "find" ["--inbackend", "WORM"] [] {- --include=* should match files in subdirectories too, - and --exclude=* should exclude them. -} createDirectory "dir" writeFile "dir/subfile" "subfile" - git_annex env "add" ["dir"] @? "add of subdir failed" - git_annex_expectoutput env "find" ["--include", "*", "--exclude", annexedfile, "--exclude", sha1annexedfile] ["dir/subfile"] - git_annex_expectoutput env "find" ["--exclude", "*"] [] + git_annex testenv "add" ["dir"] @? "add of subdir failed" + git_annex_expectoutput testenv "find" ["--include", "*", "--exclude", annexedfile, "--exclude", sha1annexedfile] ["dir/subfile"] + git_annex_expectoutput testenv "find" ["--exclude", "*"] [] test_merge :: TestEnv -> Assertion -test_merge env = intmpclonerepo env $ - git_annex env "merge" [] @? "merge failed" +test_merge testenv = intmpclonerepo testenv $ + git_annex testenv "merge" [] @? "merge failed" test_info :: TestEnv -> Assertion -test_info env = intmpclonerepo env $ do - json <- git_annex_output env "info" ["--json"] +test_info testenv = intmpclonerepo testenv $ do + json <- git_annex_output testenv "info" ["--json"] case Text.JSON.decodeStrict json :: Text.JSON.Result (Text.JSON.JSObject Text.JSON.JSValue) of Text.JSON.Ok _ -> return () Text.JSON.Error e -> assertFailure e test_version :: TestEnv -> Assertion -test_version env = intmpclonerepo env $ - git_annex env "version" [] @? "version failed" +test_version testenv = intmpclonerepo testenv $ + git_annex testenv "version" [] @? "version failed" test_sync :: TestEnv -> Assertion -test_sync env = intmpclonerepo env $ do - git_annex env "sync" [] @? "sync failed" +test_sync testenv = intmpclonerepo testenv $ do + git_annex testenv "sync" [] @? "sync failed" {- Regression test for bug fixed in - 7b0970b340d7faeb745c666146c7f701ec71808f, where in direct mode - sync committed the symlink standin file to the annex. -} - git_annex_expectoutput env "find" ["--in", "."] [] + git_annex_expectoutput testenv "find" ["--in", "."] [] {- Regression test for union merge bug fixed in - 0214e0fb175a608a49b812d81b4632c081f63027 -} test_union_merge_regression :: TestEnv -> Assertion -test_union_merge_regression env = +test_union_merge_regression testenv = {- We need 3 repos to see this bug. -} - withtmpclonerepo env False $ \r1 -> - withtmpclonerepo env False $ \r2 -> - withtmpclonerepo env False $ \r3 -> do - forM_ [r1, r2, r3] $ \r -> indir env r $ do + withtmpclonerepo testenv False $ \r1 -> + withtmpclonerepo testenv False $ \r2 -> + withtmpclonerepo testenv False $ \r3 -> do + forM_ [r1, r2, r3] $ \r -> indir testenv r $ do when (r /= r1) $ boolSystem "git" [Params "remote add r1", File ("../../" ++ r1)] @? "remote add" when (r /= r2) $ boolSystem "git" [Params "remote add r2", File ("../../" ++ r2)] @? "remote add" when (r /= r3) $ boolSystem "git" [Params "remote add r3", File ("../../" ++ r3)] @? "remote add" - git_annex env "get" [annexedfile] @? "get failed" + git_annex testenv "get" [annexedfile] @? "get failed" boolSystem "git" [Params "remote rm origin"] @? "remote rm" - forM_ [r3, r2, r1] $ \r -> indir env r $ - git_annex env "sync" [] @? "sync failed" - forM_ [r3, r2] $ \r -> indir env r $ - git_annex env "drop" ["--force", annexedfile] @? "drop failed" - indir env r1 $ do - git_annex env "sync" [] @? "sync failed in r1" - git_annex_expectoutput env "find" ["--in", "r3"] [] + forM_ [r3, r2, r1] $ \r -> indir testenv r $ + git_annex testenv "sync" [] @? "sync failed" + forM_ [r3, r2] $ \r -> indir testenv r $ + git_annex testenv "drop" ["--force", annexedfile] @? "drop failed" + indir testenv r1 $ do + git_annex testenv "sync" [] @? "sync failed in r1" + git_annex_expectoutput testenv "find" ["--in", "r3"] [] {- This was the bug. The sync - mangled location log data and it - thought the file was still in r2 -} - git_annex_expectoutput env "find" ["--in", "r2"] [] + git_annex_expectoutput testenv "find" ["--in", "r2"] [] {- Regression test for the automatic conflict resolution bug fixed - in f4ba19f2b8a76a1676da7bb5850baa40d9c388e2. -} test_conflict_resolution_movein_regression :: TestEnv -> Assertion -test_conflict_resolution_movein_regression env = withtmpclonerepo env False $ \r1 -> - withtmpclonerepo env False $ \r2 -> do +test_conflict_resolution_movein_regression testenv = withtmpclonerepo testenv False $ \r1 -> + withtmpclonerepo testenv False $ \r2 -> do let rname r = if r == r1 then "r1" else "r2" - forM_ [r1, r2] $ \r -> indir env r $ do + forM_ [r1, r2] $ \r -> indir testenv r $ do {- Get all files, see check below. -} - git_annex env "get" [] @? "get failed" + git_annex testenv "get" [] @? "get failed" disconnectOrigin - pair env r1 r2 - forM_ [r1, r2] $ \r -> indir env r $ do + pair testenv r1 r2 + forM_ [r1, r2] $ \r -> indir testenv r $ do {- Set up a conflict. -} let newcontent = content annexedfile ++ rname r ifM (annexeval Config.isDirect) ( writeFile annexedfile newcontent , do - git_annex env "unlock" [annexedfile] @? "unlock failed" + git_annex testenv "unlock" [annexedfile] @? "unlock failed" writeFile annexedfile newcontent ) {- Sync twice in r1 so it gets the conflict resolution - update from r2 -} - forM_ [r1, r2, r1] $ \r -> indir env r $ - git_annex env "sync" ["--force"] @? "sync failed in " ++ rname r + forM_ [r1, r2, r1] $ \r -> indir testenv r $ + git_annex testenv "sync" ["--force"] @? "sync failed in " ++ rname r {- After the sync, it should be possible to get all - files. This includes both sides of the conflict, - although the filenames are not easily predictable. @@ -825,28 +825,28 @@ - The bug caused, in direct mode, one repo to - be missing the content of the file that had - been put in it. -} - forM_ [r1, r2] $ \r -> indir env r $ do - git_annex env "get" [] @? "unable to get all files after merge conflict resolution in " ++ rname r + forM_ [r1, r2] $ \r -> indir testenv r $ do + git_annex testenv "get" [] @? "unable to get all files after merge conflict resolution in " ++ rname r {- Simple case of conflict resolution; 2 different versions of annexed - file. -} test_conflict_resolution :: TestEnv -> Assertion -test_conflict_resolution env = - withtmpclonerepo env False $ \r1 -> - withtmpclonerepo env False $ \r2 -> do - indir env r1 $ do +test_conflict_resolution testenv = + withtmpclonerepo testenv False $ \r1 -> + withtmpclonerepo testenv False $ \r2 -> do + indir testenv r1 $ do disconnectOrigin writeFile conflictor "conflictor1" - git_annex env "add" [conflictor] @? "add conflicter failed" - git_annex env "sync" [] @? "sync failed in r1" - indir env r2 $ do + git_annex testenv "add" [conflictor] @? "add conflicter failed" + git_annex testenv "sync" [] @? "sync failed in r1" + indir testenv r2 $ do disconnectOrigin writeFile conflictor "conflictor2" - git_annex env "add" [conflictor] @? "add conflicter failed" - git_annex env "sync" [] @? "sync failed in r2" - pair env r1 r2 - forM_ [r1,r2,r1] $ \r -> indir env r $ - git_annex env "sync" [] @? "sync failed" + git_annex testenv "add" [conflictor] @? "add conflicter failed" + git_annex testenv "sync" [] @? "sync failed in r2" + pair testenv r1 r2 + forM_ [r1,r2,r1] $ \r -> indir testenv r $ + git_annex testenv "sync" [] @? "sync failed" checkmerge "r1" r1 checkmerge "r2" r2 where @@ -857,35 +857,35 @@ let v = filter (variantprefix `isPrefixOf`) l length v == 2 @? (what ++ " not exactly 2 variant files in: " ++ show l) - indir env d $ do - git_annex env "get" v @? "get failed" - git_annex_expectoutput env "find" v v + indir testenv d $ do + git_annex testenv "get" v @? "get failed" + git_annex_expectoutput testenv "find" v v {- Check merge conflict resolution when one side is an annexed - file, and the other is a directory. -} test_mixed_conflict_resolution :: TestEnv -> Assertion -test_mixed_conflict_resolution env = do +test_mixed_conflict_resolution testenv = do check True check False where - check inr1 = withtmpclonerepo env False $ \r1 -> - withtmpclonerepo env False $ \r2 -> do - indir env r1 $ do + check inr1 = withtmpclonerepo testenv False $ \r1 -> + withtmpclonerepo testenv False $ \r2 -> do + indir testenv r1 $ do disconnectOrigin writeFile conflictor "conflictor" - git_annex env "add" [conflictor] @? "add conflicter failed" - git_annex env "sync" [] @? "sync failed in r1" - indir env r2 $ do + git_annex testenv "add" [conflictor] @? "add conflicter failed" + git_annex testenv "sync" [] @? "sync failed in r1" + indir testenv r2 $ do disconnectOrigin createDirectory conflictor writeFile subfile "subfile" - git_annex env "add" [conflictor] @? "add conflicter failed" - git_annex env "sync" [] @? "sync failed in r2" - pair env r1 r2 + git_annex testenv "add" [conflictor] @? "add conflicter failed" + git_annex testenv "sync" [] @? "sync failed in r2" + pair testenv r1 r2 let l = if inr1 then [r1, r2] else [r2, r1] - forM_ l $ \r -> indir env r $ - git_annex env "sync" [] @? "sync failed in mixed conflict" + forM_ l $ \r -> indir testenv r $ + git_annex testenv "sync" [] @? "sync failed in mixed conflict" checkmerge "r1" r1 checkmerge "r2" r2 conflictor = "conflictor" @@ -899,41 +899,41 @@ @? (what ++ " conflictor variant file missing in: " ++ show l ) length v == 1 @? (what ++ " too many variant files in: " ++ show v) - indir env d $ do - git_annex env "get" (conflictor:v) @? ("get failed in " ++ what) - git_annex_expectoutput env "find" [conflictor] [Git.FilePath.toInternalGitPath subfile] - git_annex_expectoutput env "find" v v + indir testenv d $ do + git_annex testenv "get" (conflictor:v) @? ("get failed in " ++ what) + git_annex_expectoutput testenv "find" [conflictor] [Git.FilePath.toInternalGitPath subfile] + git_annex_expectoutput testenv "find" v v {- Check merge conflict resolution when both repos start with an annexed - file; one modifies it, and the other deletes it. -} test_remove_conflict_resolution :: TestEnv -> Assertion -test_remove_conflict_resolution env = do +test_remove_conflict_resolution testenv = do check True check False where - check inr1 = withtmpclonerepo env False $ \r1 -> - withtmpclonerepo env False $ \r2 -> do - indir env r1 $ do + check inr1 = withtmpclonerepo testenv False $ \r1 -> + withtmpclonerepo testenv False $ \r2 -> do + indir testenv r1 $ do disconnectOrigin writeFile conflictor "conflictor" - git_annex env "add" [conflictor] @? "add conflicter failed" - git_annex env "sync" [] @? "sync failed in r1" - indir env r2 $ + git_annex testenv "add" [conflictor] @? "add conflicter failed" + git_annex testenv "sync" [] @? "sync failed in r1" + indir testenv r2 $ disconnectOrigin - pair env r1 r2 - indir env r2 $ do - git_annex env "sync" [] @? "sync failed in r2" - git_annex env "get" [conflictor] + pair testenv r1 r2 + indir testenv r2 $ do + git_annex testenv "sync" [] @? "sync failed in r2" + git_annex testenv "get" [conflictor] @? "get conflictor failed" unlessM (annexeval Config.isDirect) $ do - git_annex env "unlock" [conflictor] + git_annex testenv "unlock" [conflictor] @? "unlock conflictor failed" writeFile conflictor "newconflictor" - indir env r1 $ + indir testenv r1 $ nukeFile conflictor let l = if inr1 then [r1, r2, r1] else [r2, r1, r2] - forM_ l $ \r -> indir env r $ - git_annex env "sync" [] @? "sync failed" + forM_ l $ \r -> indir testenv r $ + git_annex testenv "sync" [] @? "sync failed" checkmerge "r1" r1 checkmerge "r2" r2 conflictor = "conflictor" @@ -953,31 +953,31 @@ - indirect mode. -} test_nonannexed_conflict_resolution :: TestEnv -> Assertion -test_nonannexed_conflict_resolution env = do +test_nonannexed_conflict_resolution testenv = do check True False check False False check True True check False True where - check inr1 switchdirect = withtmpclonerepo env False $ \r1 -> - withtmpclonerepo env False $ \r2 -> do + check inr1 switchdirect = withtmpclonerepo testenv False $ \r1 -> + withtmpclonerepo testenv False $ \r2 -> do whenM (isInDirect r1 <&&> isInDirect r2) $ do - indir env r1 $ do + indir testenv r1 $ do disconnectOrigin writeFile conflictor "conflictor" - git_annex env "add" [conflictor] @? "add conflicter failed" - git_annex env "sync" [] @? "sync failed in r1" - indir env r2 $ do + git_annex testenv "add" [conflictor] @? "add conflicter failed" + git_annex testenv "sync" [] @? "sync failed in r1" + indir testenv r2 $ do disconnectOrigin writeFile conflictor nonannexed_content boolSystem "git" [Params "add", File conflictor] @? "git add conflictor failed" - git_annex env "sync" [] @? "sync failed in r2" - pair env r1 r2 + git_annex testenv "sync" [] @? "sync failed in r2" + pair testenv r1 r2 let l = if inr1 then [r1, r2] else [r2, r1] - forM_ l $ \r -> indir env r $ do + forM_ l $ \r -> indir testenv r $ do when switchdirect $ - git_annex env "direct" [] @? "failed switching to direct mode" - git_annex env "sync" [] @? "sync failed" + git_annex testenv "direct" [] @? "failed switching to direct mode" + git_annex testenv "sync" [] @? "sync failed" checkmerge ("r1" ++ show switchdirect) r1 checkmerge ("r2" ++ show switchdirect) r2 conflictor = "conflictor" @@ -1005,37 +1005,37 @@ - Case 2: Remote adds conflictor/file; local has a file named conflictor. -} test_uncommitted_conflict_resolution :: TestEnv -> Assertion -test_uncommitted_conflict_resolution env = do +test_uncommitted_conflict_resolution testenv = do check conflictor check (conflictor "file") where - check remoteconflictor = withtmpclonerepo env False $ \r1 -> - withtmpclonerepo env False $ \r2 -> do - indir env r1 $ do + check remoteconflictor = withtmpclonerepo testenv False $ \r1 -> + withtmpclonerepo testenv False $ \r2 -> do + indir testenv r1 $ do disconnectOrigin createDirectoryIfMissing True (parentDir remoteconflictor) writeFile remoteconflictor annexedcontent - git_annex env "add" [conflictor] @? "add remoteconflicter failed" - git_annex env "sync" [] @? "sync failed in r1" - indir env r2 $ do + git_annex testenv "add" [conflictor] @? "add remoteconflicter failed" + git_annex testenv "sync" [] @? "sync failed in r1" + indir testenv r2 $ do disconnectOrigin writeFile conflictor localcontent - pair env r1 r2 - indir env r2 $ ifM (annexeval Config.isDirect) + pair testenv r1 r2 + indir testenv r2 $ ifM (annexeval Config.isDirect) ( do - git_annex env "sync" [] @? "sync failed" + git_annex testenv "sync" [] @? "sync failed" let local = conflictor ++ localprefix doesFileExist local @? (local ++ " missing after merge") s <- readFile local s == localcontent @? (local ++ " has wrong content: " ++ s) - git_annex env "get" [conflictor] @? "get failed" + git_annex testenv "get" [conflictor] @? "get failed" doesFileExist remoteconflictor @? (remoteconflictor ++ " missing after merge") s' <- readFile remoteconflictor s' == annexedcontent @? (remoteconflictor ++ " has wrong content: " ++ s) -- this case is intentionally not handled -- in indirect mode, since the user -- can recover on their own easily - , not <$> git_annex env "sync" [] @? "sync failed to fail" + , not <$> git_annex testenv "sync" [] @? "sync failed to fail" ) conflictor = "conflictor" localprefix = ".variant-local" @@ -1046,81 +1046,81 @@ - lost track of whether a file was a symlink. -} test_conflict_resolution_symlinks :: TestEnv -> Assertion -test_conflict_resolution_symlinks env = do - withtmpclonerepo env False $ \r1 -> - withtmpclonerepo env False $ \r2 -> do - withtmpclonerepo env False $ \r3 -> do - indir env r1 $ do +test_conflict_resolution_symlinks testenv = do + withtmpclonerepo testenv False $ \r1 -> + withtmpclonerepo testenv False $ \r2 -> do + withtmpclonerepo testenv False $ \r3 -> do + indir testenv r1 $ do writeFile conflictor "conflictor" - git_annex env "add" [conflictor] @? "add conflicter failed" - git_annex env "sync" [] @? "sync failed in r1" + git_annex testenv "add" [conflictor] @? "add conflicter failed" + git_annex testenv "sync" [] @? "sync failed in r1" check_is_link conflictor "r1" - indir env r2 $ do + indir testenv r2 $ do createDirectory conflictor writeFile (conflictor "subfile") "subfile" - git_annex env "add" [conflictor] @? "add conflicter failed" - git_annex env "sync" [] @? "sync failed in r2" + git_annex testenv "add" [conflictor] @? "add conflicter failed" + git_annex testenv "sync" [] @? "sync failed in r2" check_is_link (conflictor "subfile") "r2" - indir env r3 $ do + indir testenv r3 $ do writeFile conflictor "conflictor" - git_annex env "add" [conflictor] @? "add conflicter failed" - git_annex env "sync" [] @? "sync failed in r1" + git_annex testenv "add" [conflictor] @? "add conflicter failed" + git_annex testenv "sync" [] @? "sync failed in r1" check_is_link (conflictor "subfile") "r3" where conflictor = "conflictor" check_is_link f what = do - git_annex_expectoutput env "find" ["--include=*", f] [Git.FilePath.toInternalGitPath f] + git_annex_expectoutput testenv "find" ["--include=*", f] [Git.FilePath.toInternalGitPath f] l <- annexeval $ Annex.inRepo $ Git.LsTree.lsTreeFiles Git.Ref.headRef [f] all (\i -> Git.Types.toBlobType (Git.LsTree.mode i) == Just Git.Types.SymlinkBlob) l @? (what ++ " " ++ f ++ " lost symlink bit after merge: " ++ show l) {- Set up repos as remotes of each other. -} pair :: TestEnv -> FilePath -> FilePath -> Assertion -pair env r1 r2 = forM_ [r1, r2] $ \r -> indir env r $ do +pair testenv r1 r2 = forM_ [r1, r2] $ \r -> indir testenv r $ do when (r /= r1) $ boolSystem "git" [Params "remote add r1", File ("../../" ++ r1)] @? "remote add" when (r /= r2) $ boolSystem "git" [Params "remote add r2", File ("../../" ++ r2)] @? "remote add" test_map :: TestEnv -> Assertion -test_map env = intmpclonerepo env $ do +test_map testenv = intmpclonerepo testenv $ do -- set descriptions, that will be looked for in the map - git_annex env "describe" [".", "this repo"] @? "describe 1 failed" - git_annex env "describe" ["origin", "origin repo"] @? "describe 2 failed" + git_annex testenv "describe" [".", "this repo"] @? "describe 1 failed" + git_annex testenv "describe" ["origin", "origin repo"] @? "describe 2 failed" -- --fast avoids it running graphviz, not a build dependency - git_annex env "map" ["--fast"] @? "map failed" + git_annex testenv "map" ["--fast"] @? "map failed" test_uninit :: TestEnv -> Assertion -test_uninit env = intmpclonerepo env $ do - git_annex env "get" [] @? "get failed" +test_uninit testenv = intmpclonerepo testenv $ do + git_annex testenv "get" [] @? "get failed" annexed_present annexedfile - _ <- git_annex env "uninit" [] -- exit status not checked; does abnormal exit + _ <- git_annex testenv "uninit" [] -- exit status not checked; does abnormal exit checkregularfile annexedfile doesDirectoryExist ".git" @? ".git vanished in uninit" test_uninit_inbranch :: TestEnv -> Assertion -test_uninit_inbranch env = intmpclonerepoInDirect env $ do +test_uninit_inbranch testenv = intmpclonerepoInDirect testenv $ do boolSystem "git" [Params "checkout git-annex"] @? "git checkout git-annex" - not <$> git_annex env "uninit" [] @? "uninit failed to fail when git-annex branch was checked out" + not <$> git_annex testenv "uninit" [] @? "uninit failed to fail when git-annex branch was checked out" test_upgrade :: TestEnv -> Assertion -test_upgrade env = intmpclonerepo env $ do - git_annex env "upgrade" [] @? "upgrade from same version failed" +test_upgrade testenv = intmpclonerepo testenv $ do + git_annex testenv "upgrade" [] @? "upgrade from same version failed" test_whereis :: TestEnv -> Assertion -test_whereis env = intmpclonerepo env $ do +test_whereis testenv = intmpclonerepo testenv $ do annexed_notpresent annexedfile - git_annex env "whereis" [annexedfile] @? "whereis on non-present file failed" - git_annex env "untrust" ["origin"] @? "untrust failed" - not <$> git_annex env "whereis" [annexedfile] @? "whereis on non-present file only present in untrusted repo failed to fail" - git_annex env "get" [annexedfile] @? "get failed" + git_annex testenv "whereis" [annexedfile] @? "whereis on non-present file failed" + git_annex testenv "untrust" ["origin"] @? "untrust failed" + not <$> git_annex testenv "whereis" [annexedfile] @? "whereis on non-present file only present in untrusted repo failed to fail" + git_annex testenv "get" [annexedfile] @? "get failed" annexed_present annexedfile - git_annex env "whereis" [annexedfile] @? "whereis on present file failed" + git_annex testenv "whereis" [annexedfile] @? "whereis on present file failed" test_hook_remote :: TestEnv -> Assertion -test_hook_remote env = intmpclonerepo env $ do +test_hook_remote testenv = intmpclonerepo testenv $ do #ifndef mingw32_HOST_OS - git_annex env "initremote" (words "foo type=hook encryption=none hooktype=foo") @? "initremote failed" + git_annex testenv "initremote" (words "foo type=hook encryption=none hooktype=foo") @? "initremote failed" createDirectory dir git_config "annex.foo-store-hook" $ "cp $ANNEX_FILE " ++ loc @@ -1130,15 +1130,15 @@ "rm -f " ++ loc git_config "annex.foo-checkpresent-hook" $ "if [ -e " ++ loc ++ " ]; then echo $ANNEX_KEY; fi" - git_annex env "get" [annexedfile] @? "get of file failed" + git_annex testenv "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to hook remote failed" + git_annex testenv "copy" [annexedfile, "--to", "foo"] @? "copy --to hook remote failed" annexed_present annexedfile - git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex testenv "drop" [annexedfile, "--numcopies=2"] @? "drop failed" annexed_notpresent annexedfile - git_annex env "move" [annexedfile, "--from", "foo"] @? "move --from hook remote failed" + git_annex testenv "move" [annexedfile, "--from", "foo"] @? "move --from hook remote failed" annexed_present annexedfile - not <$> git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" + not <$> git_annex testenv "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" annexed_present annexedfile where dir = "dir" @@ -1151,34 +1151,34 @@ #endif test_directory_remote :: TestEnv -> Assertion -test_directory_remote env = intmpclonerepo env $ do +test_directory_remote testenv = intmpclonerepo testenv $ do createDirectory "dir" - git_annex env "initremote" (words "foo type=directory encryption=none directory=dir") @? "initremote failed" - git_annex env "get" [annexedfile] @? "get of file failed" + git_annex testenv "initremote" (words "foo type=directory encryption=none directory=dir") @? "initremote failed" + git_annex testenv "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to directory remote failed" + git_annex testenv "copy" [annexedfile, "--to", "foo"] @? "copy --to directory remote failed" annexed_present annexedfile - git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex testenv "drop" [annexedfile, "--numcopies=2"] @? "drop failed" annexed_notpresent annexedfile - git_annex env "move" [annexedfile, "--from", "foo"] @? "move --from directory remote failed" + git_annex testenv "move" [annexedfile, "--from", "foo"] @? "move --from directory remote failed" annexed_present annexedfile - not <$> git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" + not <$> git_annex testenv "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" annexed_present annexedfile test_rsync_remote :: TestEnv -> Assertion -test_rsync_remote env = intmpclonerepo env $ do +test_rsync_remote testenv = intmpclonerepo testenv $ do #ifndef mingw32_HOST_OS createDirectory "dir" - git_annex env "initremote" (words "foo type=rsync encryption=none rsyncurl=dir") @? "initremote failed" - git_annex env "get" [annexedfile] @? "get of file failed" + git_annex testenv "initremote" (words "foo type=rsync encryption=none rsyncurl=dir") @? "initremote failed" + git_annex testenv "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to rsync remote failed" + git_annex testenv "copy" [annexedfile, "--to", "foo"] @? "copy --to rsync remote failed" annexed_present annexedfile - git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex testenv "drop" [annexedfile, "--numcopies=2"] @? "drop failed" annexed_notpresent annexedfile - git_annex env "move" [annexedfile, "--from", "foo"] @? "move --from rsync remote failed" + git_annex testenv "move" [annexedfile, "--from", "foo"] @? "move --from rsync remote failed" annexed_present annexedfile - not <$> git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" + not <$> git_annex testenv "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" annexed_present annexedfile #else -- Rsync remotes with a rsyncurl of a directory do not currently @@ -1187,34 +1187,34 @@ #endif test_bup_remote :: TestEnv -> Assertion -test_bup_remote env = intmpclonerepo env $ when Build.SysConfig.bup $ do +test_bup_remote testenv = intmpclonerepo testenv $ when Build.SysConfig.bup $ do dir <- absPath "dir" -- bup special remote needs an absolute path createDirectory dir - git_annex env "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) @? "initremote failed" - git_annex env "get" [annexedfile] @? "get of file failed" + git_annex testenv "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) @? "initremote failed" + git_annex testenv "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to bup remote failed" + git_annex testenv "copy" [annexedfile, "--to", "foo"] @? "copy --to bup remote failed" annexed_present annexedfile - git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex testenv "drop" [annexedfile, "--numcopies=2"] @? "drop failed" annexed_notpresent annexedfile - git_annex env "copy" [annexedfile, "--from", "foo"] @? "copy --from bup remote failed" + git_annex testenv "copy" [annexedfile, "--from", "foo"] @? "copy --from bup remote failed" annexed_present annexedfile - not <$> git_annex env "move" [annexedfile, "--from", "foo"] @? "move --from bup remote failed to fail" + not <$> git_annex testenv "move" [annexedfile, "--from", "foo"] @? "move --from bup remote failed to fail" annexed_present annexedfile -- gpg is not a build dependency, so only test when it's available test_crypto :: TestEnv -> Assertion #ifndef mingw32_HOST_OS -test_crypto env = do +test_crypto testenv = do testscheme "shared" testscheme "hybrid" testscheme "pubkey" where - testscheme scheme = intmpclonerepo env $ whenM (Utility.Path.inPath Utility.Gpg.gpgcmd) $ do + testscheme scheme = intmpclonerepo testenv $ whenM (Utility.Path.inPath Utility.Gpg.gpgcmd) $ do Utility.Gpg.testTestHarness @? "test harness self-test failed" Utility.Gpg.testHarness $ do createDirectory "dir" - let a cmd = git_annex env cmd $ + let a cmd = git_annex testenv cmd $ [ "foo" , "type=directory" , "encryption=" ++ scheme @@ -1227,9 +1227,9 @@ not <$> a "initremote" @? "initremote failed to fail when run twice in a row" a "enableremote" @? "enableremote failed" a "enableremote" @? "enableremote failed when run twice in a row" - git_annex env "get" [annexedfile] @? "get of file failed" + git_annex testenv "get" [annexedfile] @? "get of file failed" annexed_present annexedfile - git_annex env "copy" [annexedfile, "--to", "foo"] @? "copy --to encrypted remote failed" + git_annex testenv "copy" [annexedfile, "--to", "foo"] @? "copy --to encrypted remote failed" (c,k) <- annexeval $ do uuid <- Remote.nameToUUID "foo" rs <- Logs.Remote.readRemoteLog @@ -1241,11 +1241,11 @@ testEncryptedRemote scheme key c [k] @? "invalid crypto setup" annexed_present annexedfile - git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex testenv "drop" [annexedfile, "--numcopies=2"] @? "drop failed" annexed_notpresent annexedfile - git_annex env "move" [annexedfile, "--from", "foo"] @? "move --from encrypted remote failed" + git_annex testenv "move" [annexedfile, "--from", "foo"] @? "move --from encrypted remote failed" annexed_present annexedfile - not <$> git_annex env "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" + not <$> git_annex testenv "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" annexed_present annexedfile {- Ensure the configuration complies with the encryption scheme, and - that all keys are encrypted properly for the given directory remote. -} @@ -1278,28 +1278,28 @@ #endif test_add_subdirs :: TestEnv -> Assertion -test_add_subdirs env = intmpclonerepo env $ do +test_add_subdirs testenv = intmpclonerepo testenv $ do createDirectory "dir" writeFile ("dir" "foo") $ "dir/" ++ content annexedfile - git_annex env "add" ["dir"] @? "add of subdir failed" + git_annex testenv "add" ["dir"] @? "add of subdir failed" {- Regression test for Windows bug where symlinks were not - calculated correctly for files in subdirs. -} - git_annex env "sync" [] @? "sync failed" + git_annex testenv "sync" [] @? "sync failed" l <- annexeval $ decodeBS <$> Annex.CatFile.catObject (Git.Types.Ref "HEAD:dir/foo") "../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l) createDirectory "dir2" writeFile ("dir2" "foo") $ content annexedfile setCurrentDirectory "dir" - git_annex env "add" [".." "dir2"] @? "add of ../subdir failed" + git_annex testenv "add" [".." "dir2"] @? "add of ../subdir failed" -- This is equivilant to running git-annex, but it's all run in-process -- (when the OS allows) so test coverage collection works. git_annex :: TestEnv -> String -> [String] -> IO Bool -git_annex env command params = do +git_annex testenv command params = do #ifndef mingw32_HOST_OS - forM_ (M.toList env) $ \(var, val) -> + forM_ (M.toList testenv) $ \(var, val) -> Utility.Env.setEnv var val True -- catch all errors, including normally fatal errors @@ -1312,23 +1312,23 @@ #else Utility.SafeCommand.boolSystemEnv "git-annex" (map Param $ command : params) - (Just $ M.toList env) + (Just $ M.toList testenv) #endif {- Runs git-annex and returns its output. -} git_annex_output :: TestEnv -> String -> [String] -> IO String -git_annex_output env command params = do +git_annex_output testenv command params = do got <- Utility.Process.readProcessEnv "git-annex" (command:params) - (Just $ M.toList env) + (Just $ M.toList testenv) -- XXX since the above is a separate process, code coverage stats are -- not gathered for things run in it. -- Run same command again, to get code coverage. - _ <- git_annex env command params + _ <- git_annex testenv command params return got git_annex_expectoutput :: TestEnv -> String -> [String] -> [String] -> IO () -git_annex_expectoutput env command params expected = do - got <- lines <$> git_annex_output env command params +git_annex_expectoutput testenv command params expected = do + got <- lines <$> git_annex_output testenv command params got == expected @? ("unexpected value running " ++ command ++ " " ++ show params ++ " -- got: " ++ show got ++ " expected: " ++ show expected) -- Runs an action in the current annex. Note that shutdown actions @@ -1341,16 +1341,16 @@ a innewrepo :: TestEnv -> Assertion -> Assertion -innewrepo env a = withgitrepo env $ \r -> indir env r a +innewrepo testenv a = withgitrepo testenv $ \r -> indir testenv r a inmainrepo :: TestEnv -> Assertion -> Assertion -inmainrepo env = indir env mainrepodir +inmainrepo testenv = indir testenv mainrepodir intmpclonerepo :: TestEnv -> Assertion -> Assertion -intmpclonerepo env a = withtmpclonerepo env False $ \r -> indir env r a +intmpclonerepo testenv a = withtmpclonerepo testenv False $ \r -> indir testenv r a intmpclonerepoInDirect :: TestEnv -> Assertion -> Assertion -intmpclonerepoInDirect env a = intmpclonerepo env $ +intmpclonerepoInDirect testenv a = intmpclonerepo testenv $ ifM isdirect ( putStrLn "not supported in direct mode; skipping" , a @@ -1366,62 +1366,62 @@ not <$> Annex.eval s Config.isDirect intmpbareclonerepo :: TestEnv -> Assertion -> Assertion -intmpbareclonerepo env a = withtmpclonerepo env True $ \r -> indir env r a +intmpbareclonerepo testenv a = withtmpclonerepo testenv True $ \r -> indir testenv r a withtmpclonerepo :: TestEnv -> Bool -> (FilePath -> Assertion) -> Assertion -withtmpclonerepo env bare a = do +withtmpclonerepo testenv bare a = do dir <- tmprepodir - bracket (clonerepo env mainrepodir dir bare) cleanup a + bracket (clonerepo testenv mainrepodir dir bare) cleanup a disconnectOrigin :: Assertion disconnectOrigin = boolSystem "git" [Params "remote rm origin"] @? "remote rm" withgitrepo :: TestEnv -> (FilePath -> Assertion) -> Assertion -withgitrepo env = bracket (setuprepo env mainrepodir) return +withgitrepo testenv = bracket (setuprepo testenv mainrepodir) return indir :: TestEnv -> FilePath -> Assertion -> Assertion -indir env dir a = do - cwd <- getCurrentDirectory +indir testenv dir a = do + currdir <- getCurrentDirectory -- Assertion failures throw non-IO errors; catch - -- any type of error and change back to cwd before + -- any type of error and change back to currdir before -- rethrowing. - r <- bracket_ (changeToTmpDir env dir) (setCurrentDirectory cwd) + r <- bracket_ (changeToTmpDir testenv dir) (setCurrentDirectory currdir) (try a::IO (Either SomeException ())) case r of Right () -> return () Left e -> throw e setuprepo :: TestEnv -> FilePath -> IO FilePath -setuprepo env dir = do +setuprepo testenv dir = do cleanup dir ensuretmpdir boolSystem "git" [Params "init -q", File dir] @? "git init failed" - configrepo env dir + configrepo testenv dir return dir -- clones are always done as local clones; we cannot test ssh clones clonerepo :: TestEnv -> FilePath -> FilePath -> Bool -> IO FilePath -clonerepo env old new bare = do +clonerepo testenv old new bare = do cleanup new ensuretmpdir let b = if bare then " --bare" else "" boolSystem "git" [Params ("clone -q" ++ b), File old, File new] @? "git clone failed" - indir env new $ - git_annex env "init" ["-q", new] @? "git annex init failed" - configrepo env new + indir testenv new $ + git_annex testenv "init" ["-q", new] @? "git annex init failed" + configrepo testenv new unless bare $ - indir env new $ - handleforcedirect env + indir testenv new $ + handleforcedirect testenv return new configrepo :: TestEnv -> FilePath -> IO () -configrepo env dir = indir env dir $ do +configrepo testenv dir = indir testenv dir $ do boolSystem "git" [Params "config user.name", Param "Test User"] @? "git config failed" boolSystem "git" [Params "config user.email test@example.com"] @? "git config failed" handleforcedirect :: TestEnv -> IO () -handleforcedirect env = when (M.lookup "FORCEDIRECT" env == Just "1") $ - git_annex env "direct" ["-q"] @? "git annex direct failed" +handleforcedirect testenv = when (M.lookup "FORCEDIRECT" testenv == Just "1") $ + git_annex testenv "direct" ["-q"] @? "git annex direct failed" ensuretmpdir :: IO () ensuretmpdir = do @@ -1539,12 +1539,12 @@ withTestEnv forcedirect = withResource prepare release where prepare = do - env <- prepareTestEnv forcedirect - case tryIngredients [consoleTestReporter] mempty (initTests env) of + testenv <- prepareTestEnv forcedirect + case tryIngredients [consoleTestReporter] mempty (initTests testenv) of Nothing -> error "No tests found!?" Just act -> unlessM act $ error "init tests failed! cannot continue" - return env + return testenv release = releaseTestEnv releaseTestEnv :: TestEnv -> IO () @@ -1555,14 +1555,14 @@ whenM (doesDirectoryExist tmpdir) $ error $ "The temporary directory " ++ tmpdir ++ " already exists; cannot run test suite." - cwd <- getCurrentDirectory + currdir <- getCurrentDirectory p <- Utility.Env.getEnvDefault "PATH" "" - env <- Utility.Env.getEnvironment + environ <- Utility.Env.getEnvironment let newenv = -- Ensure that the just-built git annex is used. - [ ("PATH", cwd ++ [searchPathSeparator] ++ p) - , ("TOPDIR", cwd) + [ ("PATH", currdir ++ [searchPathSeparator] ++ p) + , ("TOPDIR", currdir) -- Avoid git complaining if it cannot determine the user's -- email address, or exploding if it doesn't know the user's -- name. @@ -1575,11 +1575,11 @@ , ("FORCEDIRECT", if forcedirect then "1" else "") ] - return $ M.fromList newenv `M.union` M.fromList env + return $ M.fromList newenv `M.union` M.fromList environ changeToTmpDir :: TestEnv -> FilePath -> IO () -changeToTmpDir env t = do - let topdir = fromMaybe "" $ M.lookup "TOPDIR" env +changeToTmpDir testenv t = do + let topdir = fromMaybe "" $ M.lookup "TOPDIR" testenv setCurrentDirectory $ topdir ++ "/" ++ t tmpdir :: String diff --git a/Utility/Batch.hs b/Utility/Batch.hs --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -16,7 +16,6 @@ import System.Posix.Process #endif import qualified Control.Exception as E -import System.Process (env) {- Runs an operation, at batch priority. - diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -37,8 +37,8 @@ } start :: Int -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle -start numrestarts cmd params env = do - s <- start' $ CoProcessSpec numrestarts cmd params env +start numrestarts cmd params environ = do + s <- start' $ CoProcessSpec numrestarts cmd params environ newMVar s start' :: CoProcessSpec -> IO CoProcessState diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -39,7 +39,7 @@ checkalreadyrunning f = maybe noop (const alreadyRunning) =<< checkDaemon f child1 = do - _ <- createSession + _ <- tryIO createSession _ <- forkProcess child2 out child2 = do @@ -49,8 +49,8 @@ nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags redir nullfd stdInput redirLog logfd - {- forkProcess masks async exceptions; unmask them inside - - the action. -} + {- In old versions of ghc, forkProcess masks async exceptions; + - unmask them inside the action. -} wait =<< asyncWithUnmask (\unmask -> unmask a) out out = exitImmediately ExitSuccess @@ -59,7 +59,7 @@ foreground :: Fd -> Maybe FilePath -> IO () -> IO () foreground logfd pidfile a = do maybe noop lockPidFile pidfile - _ <- createSession + _ <- tryIO createSession redirLog logfd a exitImmediately ExitSuccess diff --git a/Utility/ExternalSHA.hs b/Utility/ExternalSHA.hs --- a/Utility/ExternalSHA.hs +++ b/Utility/ExternalSHA.hs @@ -15,7 +15,6 @@ import Utility.FileSystemEncoding import Utility.Misc -import System.Process import Data.List import Data.Char import Control.Applicative diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -1,12 +1,41 @@ -{- Caching a file's inode, size, and modification time to see when it's changed. +{- Caching a file's inode, size, and modification time + - to see when it's changed. - - - Copyright 2013 Joey Hess + - Copyright 2013, 2014 Joey Hess - - License: BSD-2-clause -} -module Utility.InodeCache where +{-# LANGUAGE CPP #-} +module Utility.InodeCache ( + InodeCache, + InodeComparisonType(..), + + compareStrong, + compareWeak, + compareBy, + + readInodeCache, + showInodeCache, + genInodeCache, + toInodeCache, + + InodeCacheKey, + inodeCacheToKey, + inodeCacheToMtime, + + SentinalFile(..), + SentinalStatus(..), + TSDelta, + noTSDelta, + writeSentinalFile, + checkSentinalFile, + sentinalFileExists, + + prop_read_show_inodecache +) where + import Common import System.PosixCompat.Types import Utility.QuickCheck @@ -28,10 +57,17 @@ {- Weak comparison of the inode caches, comparing the size and mtime, - but not the actual inode. Useful when inodes have changed, perhaps - - due to some filesystems being remounted. -} + - due to some filesystems being remounted. + - + - The weak mtime comparison treats any mtimes that are within 2 seconds + - of one-anther as the same. This is because FAT has only a 2 second + - resolution. When a FAT filesystem is used on Linux, higher resolution + - timestamps are cached and used by Linux, but this is lost on unmount, + - so after a remount, the timestamp can appear to have changed. + -} compareWeak :: InodeCache -> InodeCache -> Bool compareWeak (InodeCache (InodeCachePrim _ size1 mtime1)) (InodeCache (InodeCachePrim _ size2 mtime2)) = - size1 == size2 && mtime1 == mtime2 + size1 == size2 && (abs (mtime1 - mtime2) < 2) compareBy :: InodeComparisonType -> InodeCache -> InodeCache -> Bool compareBy Strongly = compareStrong @@ -69,16 +105,96 @@ in InodeCache <$> prim _ -> Nothing -genInodeCache :: FilePath -> IO (Maybe InodeCache) -genInodeCache f = catchDefaultIO Nothing $ toInodeCache <$> getFileStatus f +genInodeCache :: FilePath -> TSDelta -> IO (Maybe InodeCache) +genInodeCache f delta = catchDefaultIO Nothing $ + toInodeCache delta =<< getFileStatus f -toInodeCache :: FileStatus -> Maybe InodeCache -toInodeCache s - | isRegularFile s = Just $ InodeCache $ InodeCachePrim - (fileID s) - (fileSize s) - (modificationTime s) - | otherwise = Nothing +toInodeCache :: TSDelta -> FileStatus -> IO (Maybe InodeCache) +toInodeCache (TSDelta getdelta) s + | isRegularFile s = do + delta <- getdelta + return $ Just $ InodeCache $ InodeCachePrim + (fileID s) + (fileSize s) + (modificationTime s + delta) + | otherwise = pure Nothing + +{- Some filesystem get new random inodes each time they are mounted. + - To detect this and other problems, a sentinal file can be created. + - Its InodeCache at the time of its creation is written to the cache file, + - so changes can later be detected. -} +data SentinalFile = SentinalFile + { sentinalFile :: FilePath + , sentinalCacheFile :: FilePath + } + deriving (Show) + +{- On Windows, the mtime of a file appears to change when the time zone is + - changed. To deal with this, a TSDelta can be used; the delta is added to + - the mtime when generating an InodeCache. The current delta can be found + - by looking at the SentinalFile. Effectively, this makes all InodeCaches + - use the same time zone that was in use when the sential file was + - originally written. -} +newtype TSDelta = TSDelta (IO EpochTime) + +noTSDelta :: TSDelta +noTSDelta = TSDelta (pure 0) + +writeSentinalFile :: SentinalFile -> IO () +writeSentinalFile s = do + writeFile (sentinalFile s) "" + maybe noop (writeFile (sentinalCacheFile s) . showInodeCache) + =<< genInodeCache (sentinalFile s) noTSDelta + +data SentinalStatus = SentinalStatus + { sentinalInodesChanged :: Bool + , sentinalTSDelta :: TSDelta + } + +{- Checks if the InodeCache of the sentinal file is the same + - as it was when it was originally created. + - + - On Windows, time stamp differences are ignored, since they change + - with the timezone. + - + - When the sential file does not exist, InodeCaches canot reliably be + - compared, so the assumption is that there is has been a change. + -} +checkSentinalFile :: SentinalFile -> IO SentinalStatus +checkSentinalFile s = do + mold <- loadoldcache + case mold of + Nothing -> return dummy + (Just old) -> do + mnew <- gennewcache + case mnew of + Nothing -> return dummy + Just new -> return $ calc old new + where + loadoldcache = catchDefaultIO Nothing $ + readInodeCache <$> readFile (sentinalCacheFile s) + gennewcache = genInodeCache (sentinalFile s) noTSDelta + calc (InodeCache (InodeCachePrim oldinode oldsize oldmtime)) (InodeCache (InodeCachePrim newinode newsize newmtime)) = + SentinalStatus (not unchanged) tsdelta + where +#ifdef mingw32_HOST_OS + unchanged = oldinode == newinode && oldsize == newsize + tsdelta = TSDelta $ do + -- Run when generating an InodeCache, + -- to get the current delta. + mnew <- gennewcache + return $ case mnew of + Just (InodeCache (InodeCachePrim _ _ currmtime)) -> + oldmtime - currmtime + Nothing -> 0 +#else + unchanged = oldinode == newinode && oldsize == newsize && oldmtime == newmtime + tsdelta = noTSDelta +#endif + dummy = SentinalStatus True noTSDelta + +sentinalFileExists :: SentinalFile -> IO Bool +sentinalFileExists s = allM doesFileExist [sentinalCacheFile s, sentinalFile s] instance Arbitrary InodeCache where arbitrary = diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -10,7 +10,7 @@ module Utility.Process ( module X, - CreateProcess, + CreateProcess(..), StdHandle(..), readProcess, readProcessEnv, diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -9,7 +9,6 @@ import System.Exit import Utility.Process -import System.Process (env) import Data.String.Utils import Control.Applicative import System.FilePath diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -25,13 +25,20 @@ - then moving it into place. The temp file is stored in the same - directory as the final file to avoid cross-device renames. -} viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO () -viaTmp a file content = do - let (dir, base) = splitFileName file - createDirectoryIfMissing True dir - (tmpfile, handle) <- openTempFile dir (base ++ ".tmp") - hClose handle - a tmpfile content - rename tmpfile file +viaTmp a file content = bracket setup cleanup use + where + (dir, base) = splitFileName file + template = base ++ ".tmp" + setup = do + createDirectoryIfMissing True dir + openTempFile dir template + cleanup (tmpfile, handle) = do + _ <- tryIO $ hClose handle + tryIO $ removeFile tmpfile + use (tmpfile, handle) = do + hClose handle + a tmpfile content + rename tmpfile file {- Runs an action with a tmp file located in the system's tmp directory - (or in "." if there is none) then removes the file. -} diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -18,16 +18,12 @@ import qualified Network.Wai as Wai import Network.Wai.Handler.Warp import Network.Wai.Handler.WarpTLS -import Network.Wai.Logger -import Control.Monad.IO.Class import Network.HTTP.Types -import System.Log.Logger import qualified Data.CaseInsensitive as CI import Network.Socket import "crypto-api" Crypto.Random import qualified Web.ClientSession as CS import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.UTF8 as L8 import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -61,6 +57,10 @@ ["start", "-a", "android.intent.action.VIEW", "-d", url] #else #ifdef mingw32_HOST_OS +-- Warning: On Windows, no quoting or escaping of the url seems possible, +-- so spaces in it will cause problems. One approach is to make the url +-- be a relative filename, and adjust the returned CreateProcess to change +-- to the directory it's in. browserProc url = proc "cmd" ["/c start " ++ url] #else browserProc url = proc "xdg-open" [url] @@ -153,35 +153,6 @@ use sock = do listen sock maxListenQueue return sock - -{- Checks if debugging is actually enabled. -} -debugEnabled :: IO Bool -debugEnabled = do - l <- getRootLogger - return $ getLevel l <= Just DEBUG - -{- WAI middleware that logs using System.Log.Logger at debug level. - - - - Recommend only inserting this middleware when debugging is actually - - enabled, as it's not optimised at all. - -} -httpDebugLogger :: Wai.Middleware -httpDebugLogger waiApp req = do - logRequest req - waiApp req - -logRequest :: MonadIO m => Wai.Request -> m () -logRequest req = do - liftIO $ debugM "WebApp" $ unwords - [ showSockAddr $ Wai.remoteHost req - , frombs $ Wai.requestMethod req - , frombs $ Wai.rawPathInfo req - --, show $ Wai.httpVersion req - --, frombs $ lookupRequestField "referer" req - , frombs $ lookupRequestField "user-agent" req - ] - where - frombs v = L8.toString $ L.fromChunks [v] lookupRequestField :: CI.CI B.ByteString -> Wai.Request -> B.ByteString lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,22 @@ +git-annex (5.20140613) unstable; urgency=medium + + * Ignore setsid failures. + * Avoid leaving behind .tmp files when failing in some cases, including + importing files to a disk that is full. + * Avoid bad commits after interrupted direct mode sync (or merge). + * Fix build with wai 0.3.0. + * Deal with FAT's low resolution timestamps, which in combination with + Linux's caching of higher res timestamps while a FAT is mounted, caused + direct mode repositories on FAT to seem to have modified files after + they were unmounted and remounted. + * Windows: Fix opening webapp when repository is in a directory with + spaces in the path. + * Detect when Windows has lost its mind in a timezone change, and + automatically apply a delta to the timestamps it returns, to get back to + sane values. + + -- Joey Hess Fri, 13 Jun 2014 09:58:07 -0400 + git-annex (5.20140606) unstable; urgency=medium * webapp: When adding a new local repository, fix bug that caused its diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -40,7 +40,7 @@ libghc-warp-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc], libghc-warp-tls-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc], libghc-wai-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc], - libghc-wai-logger-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc], + libghc-wai-extra-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc], libghc-securemem-dev, libghc-byteable-dev, libghc-dns-dev, diff --git a/doc/bugs/On_Ubuntu_14.04_assistant_fails_to_create_new_setup.mdwn b/doc/bugs/On_Ubuntu_14.04_assistant_fails_to_create_new_setup.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/On_Ubuntu_14.04_assistant_fails_to_create_new_setup.mdwn @@ -0,0 +1,91 @@ +### Please describe the problem. + +Following steps from http://git-annex.branchable.com/assistant/quickstart/ does not get past the first screen. + +### What steps will reproduce the problem? + +* On a nearly fresh Lubuntu system, nearly fresh account, Lubuntu session, run `git-annex` from the start menu. +* Opens firefox, in `Create a git-annex repository` select my `~/Documents` folder, press `Make Repository`. + +* Expected: a new, different page opens. +* Observed: the same page opens, only difference the path displayed is `/home/mylogin/Documents`. Pressing `Make Repository` again shows the same page again. + +I couldn't find any logs at the time. Now I see that they are in .git/annex/daemon.log but content from that time is already gone. + +### What version of git-annex are you using? On what operating system? + +A fresh Ubuntu 14.04 (actually Lubuntu but this shouldn't change anything, right ?), create a user, login. + + + LC_ALL=C apt-cache policy git-annex + git-annex: + Installed: 5.20140412ubuntu1 + Candidate: 5.20140412ubuntu1 + Version table: + *** 5.20140412ubuntu1 0 + 500 http://fr.archive.ubuntu.com/ubuntu/ trusty/universe i386 Packages + 100 /var/lib/dpkg/status + + +### Please provide any additional information below. + +[[!format sh """ +# No command line in bug occurrence. This is the transcript of the workaround I found. +# Actually, the PC was rebooted then I went command line. +cd ~/Documents +git status +fatal: This operation must be run in a work tree +# oh I see it's a bare repo +git annex add . +add (my file names... one line for each) ok +(Recording state in git...) + +Now the webapp seems to run okay, I can see many pages, schedule checks, etc. + +# If the problem is with the git-annex assistant, paste in .git/annex/daemon.log +-> Ok but log shows only events after I manually dit git annex add. + +[2014-06-08 14:28:46 CEST] main: starting assistant version 5.20140412ubuntu1 +[2014-06-08 14:28:46 CEST] Cronner: You should enable consistency checking to protect your data. + + dbus failed; falling back to mtab polling (ClientError {clientErrorMessage = "runClient: unable to determine DBUS address", clientErrorFatal = True}) +(scanning...) [2014-06-08 14:28:46 CEST] Watcher: Performing startup scan +(started...) [2014-06-08 14:28:47 CEST] Committer: Adding (myfiles) + +add (my files...) ok +[2014-06-08 14:32:51 CEST] Committer: Committing changes to git +[2014-06-08 14:34:12 CEST] Committer: Committing changes to git +[2014-06-08 14:34:13 CEST] Committer: Adding (myfiles) +ok +(Recording state in git...) +(Recording state in git...) +(Recording state in git...) +(Recording state in git...) +(Recording state in git...) +add (myfile) ok +add (myfile) [2014-06-08 14:34:13 CEST] Committer: Committing changes to git +[2014-06-08 14:42:48 CEST] Cronner: Consistency check in progress +fsck (myfile) (checksum...) +ok + +# End of transcript or log. +"""]] + + + +# Question: + +cat /etc/xdg/autostart/git-annex.desktop +[Desktop Entry] +Type=Application +Version=1.0 +Name=Git Annex Assistant +Comment=Autostart +Terminal=false +Exec=/usr/bin/git-annex assistant --autostart +Categories= + +Should there be a git-annex process whenever I log in even if I don't launch the webapp ? +I can check that on next login. + +At the moment there is "git-annex webapp" and several child processes. diff --git a/doc/bugs/Windows_file_timestamp_timezone_madness.mdwn b/doc/bugs/Windows_file_timestamp_timezone_madness.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/Windows_file_timestamp_timezone_madness.mdwn @@ -0,0 +1,31 @@ +Windows has an unfortunate handling of time zones, which means that when +the time zone is changed (or DST changes), the timestamps of files also +appear to change. + +This means that after such a change, git-annex will see new mtimes, and +want to re-checksum every file in the repo. + +[[!tag confirmed]] + +> Update: Actually, I seem to have been getting confused by behavior of +> cygwin terminal setting TZ. That indeed led to timestamp changes when the +> time zone changed. I have made git-annex unset TZ to avoid this. +> +> Without TZ set, time stamps are actually stable across time zone changes. +> Ie, a simple program to read the time stamp of a file and print it +> always shows the same thing, before and after a timezone change. +> +> However, and here's where it gets truely ghastly: A program that stats a +> file in a loop will see its timestamp change when the timezone changes. +> I suspect this might be a bug in the Haskell RTS caching something it +> should not. Stopping and re-running the program gets back to the +> original timestamp. +> +> I have not tested DST changes, but it's hard to imagine it being any +> worse than the above behavior. +> +> So, that's insane then. We can't trust timestamps to be stable on windows +> when git-annex is running for a long period of time. --[[Joey]] +> +> > [[fixed|done]], using the inode sentinal file to detect when windows +> > has lost its mind, and calculating its delta from insanity. --[[Joey]] diff --git a/doc/bugs/android_4.3_install_failed_.mdwn b/doc/bugs/android_4.3_install_failed_.mdwn --- a/doc/bugs/android_4.3_install_failed_.mdwn +++ b/doc/bugs/android_4.3_install_failed_.mdwn @@ -16,4 +16,5 @@ lib/lib.runshell.so: line 133: can't create /sdcard/git-annex.home/git-annex-install.log: Permission denied Installation failed ! Please report a but and attach /sdcard/git-annex.home/git-annex-install.log - +[[!meta title="android 4.3 install failed on android device without sdcard"]] +[[!tag moreinfo]] diff --git a/doc/bugs/assistant_expensive_scan_unnecessarily_queues_files.mdwn b/doc/bugs/assistant_expensive_scan_unnecessarily_queues_files.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/assistant_expensive_scan_unnecessarily_queues_files.mdwn @@ -0,0 +1,65 @@ +### Please describe the problem. +Summary: The assistant pulls files from remote repos although they are stored on trusted repos (remote machine may be up or down). + +After starting the assistant via "git annex webapp --listen #ip# --verbose --debug" it starts to check for pending tasks and starts to queue lots of files (could be all of them). I checked the daemon.log and found the following line: + +[[!format sh """ +[2014-06-03 21:39:04 CEST] TransferScanner: queued Download UUID "541d2f88-16c3-11e2-aa7e-8f1a2c8e14c5" apps/Apache_OpenOffice_4.0.0_MacOS_x86_install_en-US.dmg Nothing : expensive scan found missing object +"""]] + +The file is available in a remote repo: + +[[!format sh """ +$ git annex whereis apps/Apache_OpenOffice_4.0.0_MacOS_x86_install_en-US.dmg +whereis apps/Apache_OpenOffice_4.0.0_MacOS_x86_install_en-US.dmg (1 copy) + 541d2f88-16c3-11e2-aa7e-8f1a2c8e14c5 -- dump +ok +"""]] + +The remote "dump" is trusted and is configured as "backup" repo. The repo running the assistant is configured as "manual". The configuration settings for wanted, required and scheduled remained untouched. + +Num copies is unset and defaults to 1: + +[[!format sh """ +$ git annex numcopies +global numcopies is not set +(default is 1) +"""]] + +When calling "git annex find --want-get" no files are listed as in my case, all are stored in the "dump" repo which is trusted. + +[[!format sh """ +$ git annex find --want-get +$ +"""]] + +### What steps will reproduce the problem? +Start the assistant and wait for it to finish startup checking. The assistant adds lots (all?) of the files due to “expensive scan found missing object”. + +### What version of git-annex are you using? On what operating system? +Snapshot build from the annex branchable webpage running on an OSX 10.9.3 machine: +[[!format sh """ +$ git annex version +git-annex version: 5.20140411-g2503f43 +build flags: Assistant Webapp Webapp-secure Pairing Testsuite S3 WebDAV FsEvents XMPP DNS Feeds Quvi TDFA CryptoHash +key/value backends: SHA256E SHA1E SHA512E SHA224E SHA384E SKEIN256E SKEIN512E SHA256 SHA1 SHA512 SHA224 SHA384 SKEIN256 SKEIN512 WORM URL +remote types: git gcrypt S3 bup directory rsync web webdav tahoe glacier hook external +local repository version: 5 +supported repository version: 5 +upgrade supported from repository versions: 0 1 2 4 +"""]] + +Note: Updated to 5.20140529-g68a56a6 but same behavior is observed. + +### Please provide any additional information below. + +The backup node was down while the assistant starts up. However also files from another trusted node that is online 24/7 is pulled. Repo was upgraded from version 4 to 5. Is there a way to further check why a file was added e.g. to dump all variables of the evaluated term (approxlackingcopies, copies, etc)? + +[[!format sh """ +[2014-06-03 21:39:04 CEST] TransferScanner: starting scan of [Remote { name ="origin" },Remote { name ="dump" }] +[2014-06-03 21:39:04 CEST] read: git ["--git-dir=/Volumes/DATA/annex/images/.git","--work-tree=/Volumes/DATA/annex/images","ls-files","--cached","-z","--"] +[2014-06-03 21:39:04 CEST] chat: git ["--git-dir=/Volumes/DATA/annex/images/.git","--work-tree=/Volumes/DATA/annex/images","check-attr","-z","--stdin","annex.backend","annex.numcopies","--"] +[2014-06-03 21:39:04 CEST] TransferScanner: queued Download UUID "541d2f88-16c3-11e2-aa7e-8f1a2c8e14c5" apps/Apache_OpenOffice_4.0.0_MacOS_x86_install_en-US.dmg Nothing : expensive scan found missing object +[2014-06-03 21:39:04 CEST] Transferrer: Transferring: Download UUID "541d2f88-16c3-11e2-aa7e-8f1a2c8e14c5" apps/Apache_OpenOffice_4.0.0_MacOS_x86_install_en-US.dmg Nothing +[2014-06-03 21:39:04 CEST] TransferScanner: queued Download UUID "541d2f88-16c3-11e2-aa7e-8f1a2c8e14c5" apps/Apache_OpenOffice_4.0.1_MacOS_x86_install_en-US.dmg Nothing : expensive scan found missing object +"""]] diff --git a/doc/bugs/direct_mode_merge_interrupt.mdwn b/doc/bugs/direct_mode_merge_interrupt.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/direct_mode_merge_interrupt.mdwn @@ -0,0 +1,54 @@ +Seems to me there is a bug in how merges are done in direct mode. This is +done in two steps: + +1. Merge the remote branch into the local branch, with work tree directed + to a temp dir. +2. Use the temp dir and the newly merged branch to update the work tree. + +If this is interrupted between 1 and 2, by eg the user ctrl-Cing or power +being lost, the result is a repository that thinks the current branch has +been merged, but does not have an updated work tree. The next sync in that +repository will see the files as deleted (or as being an old version), and +commit the current work tree state to the branch. + +Result is files appear to be lost, although `git revert` in an indirect +mode repo can get them back. + +To fix this, direct mode merge would need to avoid updating the current +branch when merging the remote branch into it (how?). It should first +update the whole work tree, and only after it's updated should it update +the index and the current branch to reflect the merge. + +This way, if the merge is interrupted, the work tree may have uncommitted +changed -- but it's fine if they get accidentially committed, since when +the merge is re-done, those changes will by the same ones made by the +merge. (I assume this is how `git merge` normally works.) --[[Joey]] + +> Implemented that. And then realized that even updating the index +> as part of a merge results in the work tree being out of sync with the +> index. Which will cause the next sync to again delete any files that +> are in the index but not the work tree. Urgh. +> +> Seems that a direct mode +> merge also needs to use a different index file to stage its changes? +> (Ugh) +> > done --[[Joey]] + +> > > I had to revert the fix on FAT/Windows due to +> > > a git bug: +> > > Once that bug's fixed, I can revisit this. --[[Joey]] + +[[!meta title="direct mode merge interrupt (fixed for all except FAT, Windows)"]] + +## other options + +> Or could perhaps use `git-merge-tree` +> and avoid staging the merge in the index until the work-tree is updated. +> +> Alternatively, could use another strategy.. Add a lock file which is held while +> the merge is in progress and contains the pre-merge sha. +> If the lock file is present but not held, state is inconsistent. +> `git-annex sync` and the SanityChecker should +> then run mergeDirectCleanup to recover, before any commits can be made +> from the inconsistent state. This approach seems to get complicated +> quickly.. --[[Joey]] diff --git a/doc/bugs/error_compiling_network-info_when_compiling_git-annex.mdwn b/doc/bugs/error_compiling_network-info_when_compiling_git-annex.mdwn --- a/doc/bugs/error_compiling_network-info_when_compiling_git-annex.mdwn +++ b/doc/bugs/error_compiling_network-info_when_compiling_git-annex.mdwn @@ -8,3 +8,5 @@ Is there some other dependency that needs network-info? Is there a way to find out? Thanks + +> fowarded 2 ways; [[done]] --[[Joey]] diff --git a/doc/bugs/import_leaves_stray___96__.tmp__96___files_if_interrupted.mdwn b/doc/bugs/import_leaves_stray___96__.tmp__96___files_if_interrupted.mdwn --- a/doc/bugs/import_leaves_stray___96__.tmp__96___files_if_interrupted.mdwn +++ b/doc/bugs/import_leaves_stray___96__.tmp__96___files_if_interrupted.mdwn @@ -7,3 +7,6 @@ ### What version of git-annex are you using? On what operating system? git-annex 5.20140517.4 in Ubuntu 12.04. + +> The ".tmp" means this dropping is left by viaTmp, and I see why. +> [[fixed|done]] --[[Joey]] diff --git a/doc/bugs/ssh_portnum_bugs.mdwn b/doc/bugs/ssh_portnum_bugs.mdwn --- a/doc/bugs/ssh_portnum_bugs.mdwn +++ b/doc/bugs/ssh_portnum_bugs.mdwn @@ -12,3 +12,4 @@ When I was experiencing this issue, I was running the default on Jessie/Wheezy. Now I'm running the latest (via auto-update and distributed binary) but don't know if this is still an issue with latest versions (I switched to 22 as a workaround). +[[!tag moreinfo]] diff --git a/doc/design/roadmap.mdwn b/doc/design/roadmap.mdwn --- a/doc/design/roadmap.mdwn +++ b/doc/design/roadmap.mdwn @@ -13,6 +13,6 @@ * Month 7 user-driven features and polishing * Month 8 [[!traillink git-remote-daemon]] * Month 9 Brazil!, [[!traillink assistant/sshpassword]] -* **Month 10 get [[assistant/Android]] out of beta** +* **Month 10 polish [[assistant/Windows]] port** * Month 11 [[!traillink assistant/chunks]], [[!traillink assistant/deltas]], [[!traillink assistant/gpgkeys]] (pick 2?) * Month 12 [[!traillink assistant/telehash]] diff --git a/doc/devblog/day_180__porting.mdwn b/doc/devblog/day_180__porting.mdwn --- a/doc/devblog/day_180__porting.mdwn +++ b/doc/devblog/day_180__porting.mdwn @@ -9,5 +9,5 @@ and does not use openssl itself, but a few programs bundled with it, like curl, do use openssl.) -A nice peice of news: OSX Homebrew now contains git-annex, so it can be +A nice piece of news: OSX Homebrew now contains git-annex, so it can be easily installed with `brew install git-annex` diff --git a/doc/devblog/day_181__tricky_merge.mdwn b/doc/devblog/day_181__tricky_merge.mdwn new file mode 100644 --- /dev/null +++ b/doc/devblog/day_181__tricky_merge.mdwn @@ -0,0 +1,8 @@ +Spent most of today improving behavior when a sync or merge is +interrupted in direct mode. It was possible for an interrupt at the wrong +time to leave the merge committed, but the work tree not yet updated. And +then the next sync would make a commit that reverted the merged changes! + +To fix this I had to avoid making any merge commit or indeed updating the +index until after the work tree is updated. It looked intractable for a +while; I'm still surprised I eventually succeeded. diff --git a/doc/devblog/day_182__service.mdwn b/doc/devblog/day_182__service.mdwn new file mode 100644 --- /dev/null +++ b/doc/devblog/day_182__service.mdwn @@ -0,0 +1,6 @@ +Have for the first time gotten git-annex to run as a proper Windows +service, using nssm. +([details](http://git-annex.branchable.com/todo/windows_support/#comment-a61be55862ea32e3dc30972f905bb987)) +Not quite ready yet though; doesn't run as the right user. + +And a few other windows porting bits. diff --git a/doc/devblog/day_183__rubbing_sticks_together.mdwn b/doc/devblog/day_183__rubbing_sticks_together.mdwn new file mode 100644 --- /dev/null +++ b/doc/devblog/day_183__rubbing_sticks_together.mdwn @@ -0,0 +1,23 @@ +Spent all day on some horrible timestamp issues on legacy systems. + +On FAT, timestamps have a 2s granularity, which is ok, but then Linux adds +a temporary higher resolution cache, which is lost on unmount. This +confused git-annex since the mtimes seemed to change and it had to +re-checksum half the files to get unconfused, which was not good. +I found a way to use the inode sentinal file to detect when on FAT +and put in a workaround, without degrading git-annex everywhere else. + +On Windows, time zones are a utter disaster; it changes the mtime it reports +for files after the time zone has changed. Also there's a bug in the +haskell time library which makes it return old time zone data after a time +zone change. (I just finished developing a fix for that bug..) + +Left with nothing but a few sticks, I rubbed them together, and +actually found a way to deal with this problem too. Scary details in +[[bugs/Windows_file_timestamp_timezone_madness]]. While I've implemented +it, it's stuck on a branch until I find a way to make git-annex notice when +the timezone changes while it's running. + +---- + +Today's work was sponsored by Svenne Krap. diff --git a/doc/devblog/day_184__windows_month.mdwn b/doc/devblog/day_184__windows_month.mdwn new file mode 100644 --- /dev/null +++ b/doc/devblog/day_184__windows_month.mdwn @@ -0,0 +1,22 @@ +It's officially a Windows porting month. Now that I'm half way through it +and with the last week of the month going to be a vacation, this makes +sense. + +Today, finished up dealing with the timezone/timestamp issues on Windows. +This got stranger and stranger the closer I looked at it. After a timestamp +change, a program that was already running will see one timestamp, while a +program that is started after the change will see another one! My approach +works pretty much no matter how Windows goes insane though, and always +recovers a true timestamp. Yay. + +Also fixed a regression test failure on Windows, which turned out to be +rooted in a bug in the command queue runner, which neglected to pass +along environment overrides on Windows. + +Then I spent 5 hours tracking down a tricky +test suite failure on Windows, which turned out to also +affect FAT and be a recent reversion that has as it's +root cause a [fun bug in git itself](http://marc.info/?l=git&m=140262402204212&w=2). +Put in a not very good workaround. Thank goodness for test suites! + +Also got the arm autobuilder unstuck. Release tomorrow. diff --git a/doc/install/NixOS/comment_1_4e487ddd2654a8a992c1538b9c3bf003._comment b/doc/install/NixOS/comment_1_4e487ddd2654a8a992c1538b9c3bf003._comment new file mode 100644 --- /dev/null +++ b/doc/install/NixOS/comment_1_4e487ddd2654a8a992c1538b9c3bf003._comment @@ -0,0 +1,21 @@ +[[!comment format=mdwn + username="https://www.google.com/accounts/o8/id?id=AItOawn3p4i4lk_zMilvjnJ9sS6g2nerpgz0Fjc" + nickname="Matthias" + subject="build failure" + date="2014-06-09T15:13:18Z" + content=""" +Building git-annex with Nix 1.7 fails for me. Error: + + trying https://git.samba.org/?p=rsync.git;a=commitdiff_plain;h=0dedfbce2c1b851684ba658861fe9d620636c56a + % Total % Received % Xferd Average Speed Time Time Time Current + Dload Upload Total Spent Left Speed + 100 2277 0 2277 0 0 2805 0 --:--:-- --:--:-- --:--:-- 5735 + output path `/nix/store/w6l1c3cdr52arymv3zgwly7razwnsdll-CVE-2014-2855.patch' should have sha256 hash `1jpwwdf07naqxc8fv1lspc95jgk50j5j3wvf037bjay2qzpwjmvf', instead has `0j1pqmwsqc5mh815x28izi4baki2y2r5q8k7ma1sgs4xsgjc4rk8' + building path(s) `/nix/store/85v7c8b3ygpfj8m8bk98kcygf29qcbq7-cacert-20131205.pem.bz2' + cannot build derivation `/nix/store/im9p1y2xbh08yrwp5yggj1ii884wv3ql-rsync-3.1.0.drv': 1 dependencies couldn't be built + killing process 2599 + cannot build derivation `/nix/store/sl48cnm06m7mcqxjfj2b0yv8am3blqr3-git-annex-5.20140517.drv': 1 dependencies couldn't be built + error: build of `/nix/store/sl48cnm06m7mcqxjfj2b0yv8am3blqr3-git-annex-5.20140517.drv' failed + +Someone has an idea what Nix expects me to do in this situation? +"""]] diff --git a/doc/news/version_5.20140412.mdwn b/doc/news/version_5.20140412.mdwn deleted file mode 100644 --- a/doc/news/version_5.20140412.mdwn +++ /dev/null @@ -1,3 +0,0 @@ -git-annex 5.20140412 released with [[!toggle text="these changes"]] -[[!toggleable text=""" - * Last release didn't quite fix the high cpu issue in all cases, this should."""]] diff --git a/doc/news/version_5.20140613.mdwn b/doc/news/version_5.20140613.mdwn new file mode 100644 --- /dev/null +++ b/doc/news/version_5.20140613.mdwn @@ -0,0 +1,16 @@ +git-annex 5.20140613 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Ignore setsid failures. + * Avoid leaving behind .tmp files when failing in some cases, including + importing files to a disk that is full. + * Avoid bad commits after interrupted direct mode sync (or merge). + * Fix build with wai 0.3.0. + * Deal with FAT's low resolution timestamps, which in combination with + Linux's caching of higher res timestamps while a FAT is mounted, caused + direct mode repositories on FAT to seem to have modified files after + they were unmounted and remounted. + * Windows: Fix opening webapp when repository is in a directory with + spaces in the path. + * Detect when Windows has lost its mind in a timezone change, and + automatically apply a delta to the timestamps it returns, to get back to + sane values."""]] diff --git a/doc/thanks.mdwn b/doc/thanks.mdwn --- a/doc/thanks.mdwn +++ b/doc/thanks.mdwn @@ -124,7 +124,8 @@ Mica Semrick, Paul Staab, Rémi Vanicat, Martin Holtschneider, Jan Ivar Beddari, Peter Simons, Thomas Koch, Justin Geibel, Guillaume DELVIT, Shanti Bouchez, Oliver Brandt, François Deppierraz, Chad Walstrom, Tim Mattison, -Jakub Antoni Tyszko, Casa do Boneco, and 30 anonymous bitcoin users +Jakub Antoni Tyszko, Casa do Boneco, Florian Tham, +and 30 anonymous bitcoin users With an especial thanks to the WikiMedia foundation, and Rede Mocambos. diff --git a/doc/users/anarcat.mdwn b/doc/users/anarcat.mdwn --- a/doc/users/anarcat.mdwn +++ b/doc/users/anarcat.mdwn @@ -46,3 +46,10 @@ Forums where I posted. [[!inline pages="forum/* and link(users/anarcat)" sort=mtime feeds=no actions=yes archive=yes show=0]] + +Git annex dev news +================== + +I find the recent changes a little too noisy, but i want more than just the [[news]], so i made up this little hybrid feed: + +[[!inline pages="(news/* and !news/*/* and !*/Discussion) or (devblog/* and !devblog/*/*)" feedonly="yes"]] diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 5.20140606 +Version: 5.20140613 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess @@ -189,7 +189,7 @@ if flag(Webapp) Build-Depends: yesod, yesod-default, yesod-static, yesod-form, yesod-core, - http-types, transformers, wai, wai-logger, warp, warp-tls, + http-types, transformers, wai, wai-extra, warp, warp-tls, blaze-builder, crypto-api, hamlet, clientsession, template-haskell, data-default, aeson, network-conduit, shakespeare diff --git a/git-annex.hs b/git-annex.hs --- a/git-annex.hs +++ b/git-annex.hs @@ -48,29 +48,38 @@ isshell n = takeFileName n == "git-annex-shell" #ifdef mingw32_HOST_OS -{- On Windows, if HOME is not set, probe it and set it, re-execing - - git-annex with the new environment. - - +{- On Windows, if HOME is not set, probe it and set it. - This is a workaround for some Cygwin commands needing HOME to be set, - and for there being no known way to set environment variables on - Windows, except by passing an environment in each call to a program. - While ugly, this workaround is easier than trying to ensure HOME is set - in all calls to the affected programs. + - + - If TZ is set, unset it. + - TZ being set can interfere with workarounds for Windows timezone + - horribleness, and prevents getCurrentTimeZone from seeing the system + - time zone. + - + - Due to Windows limitations, have to re-exec git-annex with the new + - environment. -} winEnv :: ([String] -> IO ()) -> [String] -> IO () -winEnv a ps = go =<< getEnv "HOME" +winEnv a ps = do + e <- getEnvironment + home <- myHomeDir + let e' = wantedenv e home + if (e' /= e) + then do + cmd <- readProgramFile + (_, _, _, pid) <- createProcess (proc cmd ps) + { env = Just e' } + exitWith =<< waitForProcess pid + else a ps where - go (Just _) = a ps - go Nothing = do - home <- myHomeDir - putStrLn $ "** Windows hack; overrideing HOME to " ++ home - e <- getEnvironment - let eoverride = + wantedenv e home = delEntry "TZ" $ case lookup "HOME" e of + Nothing -> e + Just _ -> addEntries [ ("HOME", home) , ("CYGWIN", "nodosfilewarning") - ] - cmd <- readProgramFile - (_, _, _, pid) <- createProcess (proc cmd ps) - { env = Just $ e ++ eoverride } - exitWith =<< waitForProcess pid + ] e #endif diff --git a/standalone/android/haskell-patches/skein_hardcode_little-endian.patch b/standalone/android/haskell-patches/skein_hardcode_little-endian.patch deleted file mode 100644 --- a/standalone/android/haskell-patches/skein_hardcode_little-endian.patch +++ /dev/null @@ -1,24 +0,0 @@ -From 3a04b41ffce4e4e87b0fedd3a1e3434a3f06cc76 Mon Sep 17 00:00:00 2001 -From: foo -Date: Sun, 22 Sep 2013 00:18:12 +0000 -Subject: [PATCH] hardcode little endian - ---- - c_impl/optimized/skein_port.h | 1 + - 1 file changed, 1 insertion(+) - -diff --git a/c_impl/optimized/skein_port.h b/c_impl/optimized/skein_port.h -index a2d0fc2..6929bb0 100644 ---- a/c_impl/optimized/skein_port.h -+++ b/c_impl/optimized/skein_port.h -@@ -45,6 +45,7 @@ typedef uint64_t u64b_t; /* 64-bit unsigned integer */ - * platform-specific code instead (e.g., for big-endian CPUs). - * - */ -+#define SKEIN_NEED_SWAP (0) - #ifndef SKEIN_NEED_SWAP /* compile-time "override" for endianness? */ - - #include "brg_endian.h" /* get endianness selection */ --- -1.7.10.4 - diff --git a/standalone/android/haskell-patches/vector_hack-to-build-with-new-ghc.patch b/standalone/android/haskell-patches/vector_hack-to-build-with-new-ghc.patch deleted file mode 100644 --- a/standalone/android/haskell-patches/vector_hack-to-build-with-new-ghc.patch +++ /dev/null @@ -1,24 +0,0 @@ -From b0a79f4f98188ba5d43b7e3912b36d34d099ab65 Mon Sep 17 00:00:00 2001 -From: dummy -Date: Fri, 18 Oct 2013 23:20:35 +0000 -Subject: [PATCH] cross build - ---- - Data/Vector/Fusion/Stream/Monadic.hs | 1 - - 1 file changed, 1 deletion(-) - -diff --git a/Data/Vector/Fusion/Stream/Monadic.hs b/Data/Vector/Fusion/Stream/Monadic.hs -index 51fec75..b089b3d 100644 ---- a/Data/Vector/Fusion/Stream/Monadic.hs -+++ b/Data/Vector/Fusion/Stream/Monadic.hs -@@ -101,7 +101,6 @@ import GHC.Exts ( SpecConstrAnnotation(..) ) - - data SPEC = SPEC | SPEC2 - #if __GLASGOW_HASKELL__ >= 700 --{-# ANN type SPEC ForceSpecConstr #-} - #endif - - emptyStream :: String --- -1.7.10.4 - diff --git a/standalone/linux/install-haskell-packages b/standalone/linux/install-haskell-packages --- a/standalone/linux/install-haskell-packages +++ b/standalone/linux/install-haskell-packages @@ -65,10 +65,12 @@ patched network patched wai-app-static + patched vector patched aeson patched shakespeare patched yesod-routes patched monad-logger + patched skein patched yesod-core patched persistent patched persistent-template diff --git a/standalone/no-th/evilsplicer-headers.hs b/standalone/no-th/evilsplicer-headers.hs --- a/standalone/no-th/evilsplicer-headers.hs +++ b/standalone/no-th/evilsplicer-headers.hs @@ -32,6 +32,7 @@ import qualified Yesod.Core.Types import qualified GHC.IO import qualified Data.ByteString.Unsafe +import qualified Data.ByteString.Char8 {- End EvilSplicer headers. -} diff --git a/standalone/no-th/haskell-patches/file-embed_remove-TH.patch b/standalone/no-th/haskell-patches/file-embed_remove-TH.patch --- a/standalone/no-th/haskell-patches/file-embed_remove-TH.patch +++ b/standalone/no-th/haskell-patches/file-embed_remove-TH.patch @@ -1,17 +1,17 @@ -From cd49a96991dc3dd8867038fa9d426a8ccdb25f8d Mon Sep 17 00:00:00 2001 -From: Joey Hess -Date: Tue, 17 Dec 2013 18:40:48 +0000 +From 2b41af230ea5675592e87a2362d9c17bcd8df1db Mon Sep 17 00:00:00 2001 +From: dummy +Date: Tue, 10 Jun 2014 19:00:44 +0000 Subject: [PATCH] remove TH --- - Data/FileEmbed.hs | 87 ++++--------------------------------------------------- - 1 file changed, 5 insertions(+), 82 deletions(-) + Data/FileEmbed.hs | 100 +++--------------------------------------------------- + 1 file changed, 5 insertions(+), 95 deletions(-) diff --git a/Data/FileEmbed.hs b/Data/FileEmbed.hs -index 5617493..ad92cdc 100644 +index aae9d5a..efdbb7b 100644 --- a/Data/FileEmbed.hs +++ b/Data/FileEmbed.hs -@@ -17,13 +17,13 @@ +@@ -17,19 +17,18 @@ -- > {-# LANGUAGE TemplateHaskell #-} module Data.FileEmbed ( -- * Embed at compile time @@ -30,7 +30,13 @@ #endif , inject , injectFile -@@ -56,72 +56,11 @@ import Data.ByteString.Unsafe (unsafePackAddressLen) + -- * Internal + , stringToBs +- , bsToExp + ) where + + import Language.Haskell.TH.Syntax +@@ -57,85 +56,12 @@ import Data.ByteString.Unsafe (unsafePackAddressLen) import System.IO.Unsafe (unsafePerformIO) import System.FilePath (()) @@ -81,7 +87,7 @@ - e <- ListE <$> ((runIO $ fileList fp) >>= mapM (pairToExp fp)) - return $ SigE e typ - ---- | Get a directory tree in the IO monad. + -- | Get a directory tree in the IO monad. -- -- This is the workhorse of 'embedDir' getDir :: FilePath -> IO [(FilePath, B.ByteString)] @@ -96,14 +102,27 @@ - return $! TupE [LitE $ StringL path, exp'] - -bsToExp :: B.ByteString -> Q Exp +-#if MIN_VERSION_template_haskell(2, 5, 0) +-bsToExp bs = +- return $ VarE 'unsafePerformIO +- `AppE` (VarE 'unsafePackAddressLen +- `AppE` LitE (IntegerL $ fromIntegral $ B8.length bs) +-#if MIN_VERSION_template_haskell(2, 8, 0) +- `AppE` LitE (StringPrimL $ B.unpack bs)) +-#else +- `AppE` LitE (StringPrimL $ B8.unpack bs)) +-#endif +-#else -bsToExp bs = do - helper <- [| stringToBs |] - let chars = B8.unpack bs - return $! AppE helper $! LitE $! StringL chars - +-#endif +- stringToBs :: String -> B.ByteString stringToBs = B8.pack -@@ -164,22 +103,6 @@ padSize i = + +@@ -177,22 +103,6 @@ padSize i = let s = show i in replicate (sizeLen - length s) '0' ++ s @@ -127,5 +146,5 @@ inject :: B.ByteString -- ^ bs to inject -> B.ByteString -- ^ original BS containing dummy -- -1.8.5.1 +2.0.0 diff --git a/standalone/no-th/haskell-patches/lens_no-TH.patch b/standalone/no-th/haskell-patches/lens_no-TH.patch --- a/standalone/no-th/haskell-patches/lens_no-TH.patch +++ b/standalone/no-th/haskell-patches/lens_no-TH.patch @@ -1,21 +1,20 @@ -From 2109923a879a02c8a79e8e08573bf9e500d8afc8 Mon Sep 17 00:00:00 2001 +From bc312c7431877b3b788de5e7ce5ee743be73c0ba Mon Sep 17 00:00:00 2001 From: dummy -Date: Wed, 21 May 2014 16:25:06 +0000 -Subject: [PATCH] remove TH +Date: Tue, 10 Jun 2014 22:13:58 +0000 +Subject: [PATCH] remove TH --- - lens.cabal | 20 +------------------- - src/Control/Lens.hs | 8 ++------ - src/Control/Lens/Cons.hs | 2 -- - src/Control/Lens/Internal/Fold.hs | 2 -- - src/Control/Lens/Internal/Reflection.hs | 2 -- - src/Control/Lens/Operators.hs | 2 +- - src/Control/Lens/Prism.hs | 2 -- - src/Control/Monad/Primitive/Lens.hs | 1 - - 8 files changed, 4 insertions(+), 35 deletions(-) + lens.cabal | 19 +------------------ + src/Control/Lens.hs | 8 ++------ + src/Control/Lens/Cons.hs | 2 -- + src/Control/Lens/Internal/Fold.hs | 2 -- + src/Control/Lens/Operators.hs | 2 +- + src/Control/Lens/Prism.hs | 2 -- + src/Control/Monad/Primitive/Lens.hs | 1 - + 7 files changed, 4 insertions(+), 32 deletions(-) diff --git a/lens.cabal b/lens.cabal -index 03f64f5..3f6f6d2 100644 +index d70c2f4..28af768 100644 --- a/lens.cabal +++ b/lens.cabal @@ -10,7 +10,7 @@ stability: provisional @@ -25,17 +24,9 @@ -build-type: Custom +build-type: Simple -- build-tools: cpphs - tested-with: GHC == 7.6.3 + tested-with: GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.1, GHC == 7.8.2 synopsis: Lenses, Folds and Traversals -@@ -182,7 +182,6 @@ flag j - - library - build-depends: -- aeson >= 0.7 && < 0.8, - array >= 0.3.0.2 && < 0.6, - base >= 4.3 && < 5, - bifunctors >= 4 && < 5, -@@ -221,7 +220,6 @@ library +@@ -220,7 +220,6 @@ library Control.Exception.Lens Control.Lens Control.Lens.Action @@ -43,7 +34,7 @@ Control.Lens.Combinators Control.Lens.Cons Control.Lens.Each -@@ -249,29 +247,24 @@ library +@@ -248,29 +247,24 @@ library Control.Lens.Internal.Reflection Control.Lens.Internal.Review Control.Lens.Internal.Setter @@ -73,7 +64,7 @@ Data.Array.Lens Data.Bits.Lens Data.ByteString.Lens -@@ -294,17 +287,10 @@ library +@@ -293,17 +287,10 @@ library Data.Typeable.Lens Data.Vector.Lens Data.Vector.Generic.Lens @@ -91,7 +82,7 @@ cpp-options: -traditional if flag(safe) -@@ -406,7 +392,6 @@ test-suite doctests +@@ -405,7 +392,6 @@ test-suite doctests deepseq, doctest >= 0.9.1, filepath, @@ -99,7 +90,7 @@ mtl, nats, parallel, -@@ -444,7 +429,6 @@ benchmark plated +@@ -443,7 +429,6 @@ benchmark plated comonad, criterion, deepseq, @@ -107,7 +98,7 @@ lens, transformers -@@ -479,7 +463,6 @@ benchmark unsafe +@@ -478,7 +463,6 @@ benchmark unsafe comonads-fd, criterion, deepseq, @@ -115,7 +106,7 @@ lens, transformers -@@ -496,6 +479,5 @@ benchmark zipper +@@ -495,6 +479,5 @@ benchmark zipper comonads-fd, criterion, deepseq, @@ -196,19 +187,6 @@ ------------------------------------------------------------------------------ -- Folding ------------------------------------------------------------------------------ -diff --git a/src/Control/Lens/Internal/Reflection.hs b/src/Control/Lens/Internal/Reflection.hs -index bf09f2c..c9e112f 100644 ---- a/src/Control/Lens/Internal/Reflection.hs -+++ b/src/Control/Lens/Internal/Reflection.hs -@@ -64,8 +64,6 @@ import Data.Word - import Data.Typeable - import Data.Reflection - --{-# ANN module "HLint: ignore Avoid lambda" #-} -- - class Typeable s => B s where - reflectByte :: proxy s -> IntPtr - diff --git a/src/Control/Lens/Operators.hs b/src/Control/Lens/Operators.hs index 9992e63..631e8e6 100644 --- a/src/Control/Lens/Operators.hs @@ -248,5 +226,5 @@ prim :: (PrimMonad m) => Iso' (m a) (State# (PrimState m) -> (# State# (PrimState m), a #)) prim = iso internal primitive -- -2.0.0.rc2 +2.0.0 diff --git a/standalone/no-th/haskell-patches/skein_hardcode_little-endian.patch b/standalone/no-th/haskell-patches/skein_hardcode_little-endian.patch new file mode 100644 --- /dev/null +++ b/standalone/no-th/haskell-patches/skein_hardcode_little-endian.patch @@ -0,0 +1,26 @@ +From 3a04b41ffce4e4e87b0fedd3a1e3434a3f06cc76 Mon Sep 17 00:00:00 2001 +From: foo +Date: Sun, 22 Sep 2013 00:18:12 +0000 +Subject: [PATCH] hardcode little endian + +This is the same as building with a cabal flag. + +--- + c_impl/optimized/skein_port.h | 1 + + 1 file changed, 1 insertion(+) + +diff --git a/c_impl/optimized/skein_port.h b/c_impl/optimized/skein_port.h +index a2d0fc2..6929bb0 100644 +--- a/c_impl/optimized/skein_port.h ++++ b/c_impl/optimized/skein_port.h +@@ -45,6 +45,7 @@ typedef uint64_t u64b_t; /* 64-bit unsigned integer */ + * platform-specific code instead (e.g., for big-endian CPUs). + * + */ ++#define SKEIN_NEED_SWAP (0) + #ifndef SKEIN_NEED_SWAP /* compile-time "override" for endianness? */ + + #include "brg_endian.h" /* get endianness selection */ +-- +1.7.10.4 + diff --git a/standalone/no-th/haskell-patches/vector_hack-to-build-with-new-ghc.patch b/standalone/no-th/haskell-patches/vector_hack-to-build-with-new-ghc.patch new file mode 100644 --- /dev/null +++ b/standalone/no-th/haskell-patches/vector_hack-to-build-with-new-ghc.patch @@ -0,0 +1,24 @@ +From b0a79f4f98188ba5d43b7e3912b36d34d099ab65 Mon Sep 17 00:00:00 2001 +From: dummy +Date: Fri, 18 Oct 2013 23:20:35 +0000 +Subject: [PATCH] cross build + +--- + Data/Vector/Fusion/Stream/Monadic.hs | 1 - + 1 file changed, 1 deletion(-) + +diff --git a/Data/Vector/Fusion/Stream/Monadic.hs b/Data/Vector/Fusion/Stream/Monadic.hs +index 51fec75..b089b3d 100644 +--- a/Data/Vector/Fusion/Stream/Monadic.hs ++++ b/Data/Vector/Fusion/Stream/Monadic.hs +@@ -101,7 +101,6 @@ import GHC.Exts ( SpecConstrAnnotation(..) ) + + data SPEC = SPEC | SPEC2 + #if __GLASGOW_HASKELL__ >= 700 +-{-# ANN type SPEC ForceSpecConstr #-} + #endif + + emptyStream :: String +-- +1.7.10.4 + diff --git a/standalone/no-th/haskell-patches/wai-app-static_deal-with-TH.patch b/standalone/no-th/haskell-patches/wai-app-static_deal-with-TH.patch --- a/standalone/no-th/haskell-patches/wai-app-static_deal-with-TH.patch +++ b/standalone/no-th/haskell-patches/wai-app-static_deal-with-TH.patch @@ -1,6 +1,6 @@ -From 685d4d9fbb929ed1356f8346f573e187746aee4b Mon Sep 17 00:00:00 2001 -From: Joey Hess -Date: Thu, 22 May 2014 16:29:20 -0400 +From 3aef808eee43c973ae1fbf6e8769d89b7f0d355b Mon Sep 17 00:00:00 2001 +From: dummy +Date: Tue, 10 Jun 2014 14:47:42 +0000 Subject: [PATCH] deal with TH Export modules referenced by it. @@ -14,7 +14,7 @@ 3 files changed, 5 insertions(+), 11 deletions(-) diff --git a/Network/Wai/Application/Static.hs b/Network/Wai/Application/Static.hs -index f2fa743..1a82b30 100644 +index db2b835..b2c1aec 100644 --- a/Network/Wai/Application/Static.hs +++ b/Network/Wai/Application/Static.hs @@ -33,8 +33,6 @@ import Control.Monad.IO.Class (liftIO) @@ -26,13 +26,13 @@ import Data.Text (Text) import qualified Data.Text as T -@@ -198,8 +196,6 @@ staticAppPieces _ _ req +@@ -198,8 +196,6 @@ staticAppPieces _ _ req sendResponse H.status405 [("Content-Type", "text/plain")] "Only GET is supported" --staticAppPieces _ [".hidden", "folder.png"] _ = return $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/folder.png")] --staticAppPieces _ [".hidden", "haskell.png"] _ = return $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/haskell.png")] - staticAppPieces ss rawPieces req = liftIO $ do +-staticAppPieces _ [".hidden", "folder.png"] _ sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/folder.png")] +-staticAppPieces _ [".hidden", "haskell.png"] _ sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/haskell.png")] + staticAppPieces ss rawPieces req sendResponse = liftIO $ do case toPieces rawPieces of Just pieces -> checkPieces ss pieces req >>= response diff --git a/WaiAppStatic/Storage/Embedded.hs b/WaiAppStatic/Storage/Embedded.hs @@ -55,7 +55,7 @@ -import WaiAppStatic.Storage.Embedded.TH +--import WaiAppStatic.Storage.Embedded.TH diff --git a/wai-app-static.cabal b/wai-app-static.cabal -index 925d350..e5d11a6 100644 +index ef6f898..9a59d71 100644 --- a/wai-app-static.cabal +++ b/wai-app-static.cabal @@ -33,7 +33,6 @@ library @@ -66,7 +66,7 @@ , text >= 0.7 , blaze-builder >= 0.2.1.4 , base64-bytestring >= 0.1 -@@ -60,9 +59,8 @@ library +@@ -61,9 +60,8 @@ library WaiAppStatic.Listing WaiAppStatic.Types WaiAppStatic.CmdLine @@ -78,5 +78,5 @@ extensions: CPP -- -2.0.0.rc2 +2.0.0 diff --git a/standalone/no-th/haskell-patches/yesod-auth_don-t-really-build.patch b/standalone/no-th/haskell-patches/yesod-auth_don-t-really-build.patch --- a/standalone/no-th/haskell-patches/yesod-auth_don-t-really-build.patch +++ b/standalone/no-th/haskell-patches/yesod-auth_don-t-really-build.patch @@ -1,19 +1,19 @@ -From 9a8637661270d3c6a15e6aeca5e8983fe126bd27 Mon Sep 17 00:00:00 2001 +From 583575461dc58b76c6c7e14d429f73182d49ef81 Mon Sep 17 00:00:00 2001 From: dummy -Date: Wed, 21 May 2014 05:27:36 +0000 +Date: Tue, 10 Jun 2014 20:29:51 +0000 Subject: [PATCH] don't really build --- - yesod-auth.cabal | 10 ---------- - 1 file changed, 10 deletions(-) + yesod-auth.cabal | 11 ----------- + 1 file changed, 11 deletions(-) diff --git a/yesod-auth.cabal b/yesod-auth.cabal -index 0872581..723cde0 100644 +index 906c08b..b4bc841 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal -@@ -60,16 +60,6 @@ library - , byteable - , binary +@@ -65,17 +65,6 @@ library + , conduit-extra + , attoparsec-conduit - exposed-modules: Yesod.Auth - Yesod.Auth.BrowserId @@ -23,11 +23,12 @@ - Yesod.Auth.Rpxnow - Yesod.Auth.Message - Yesod.Auth.GoogleEmail +- Yesod.Auth.GoogleEmail2 - other-modules: Yesod.Auth.Routes - Yesod.PasswordStore ghc-options: -Wall source-repository head -- -2.0.0.rc2 +2.0.0 diff --git a/standalone/no-th/haskell-patches/yesod-core_expand_TH.patch b/standalone/no-th/haskell-patches/yesod-core_expand_TH.patch --- a/standalone/no-th/haskell-patches/yesod-core_expand_TH.patch +++ b/standalone/no-th/haskell-patches/yesod-core_expand_TH.patch @@ -1,6 +1,6 @@ -From ccea70b3cb02c3a9e7fa43ebfbfcfdda76f9307f Mon Sep 17 00:00:00 2001 +From 9feb37d13dc8449dc4445db83485780caee4b7ff Mon Sep 17 00:00:00 2001 From: dummy -Date: Wed, 21 May 2014 03:51:16 +0000 +Date: Tue, 10 Jun 2014 17:44:52 +0000 Subject: [PATCH] expand and remove TH --- @@ -408,7 +408,7 @@ - char = show . snd . loc_start +fileLocationToString loc = "unknown" diff --git a/Yesod/Core/Dispatch.hs b/Yesod/Core/Dispatch.hs -index 59663a8..9408a95 100644 +index e0d1f0e..cc23fdd 100644 --- a/Yesod/Core/Dispatch.hs +++ b/Yesod/Core/Dispatch.hs @@ -1,4 +1,3 @@ @@ -445,7 +445,7 @@ , PathMultiPiece (..) , Texts -- * Convert to WAI -@@ -130,13 +129,6 @@ toWaiAppLogger logger site = do +@@ -135,13 +134,6 @@ toWaiAppLogger logger site = do , yreSite = site , yreSessionBackend = sb } @@ -459,7 +459,7 @@ middleware <- mkDefaultMiddlewares logger return $ middleware $ toWaiAppYre yre -@@ -165,14 +157,7 @@ warp port site = do +@@ -170,14 +162,7 @@ warp port site = do ] -} , Network.Wai.Handler.Warp.settingsOnException = const $ \e -> @@ -475,7 +475,7 @@ } where shouldLog' = -@@ -206,7 +191,6 @@ defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip def . methodOverr +@@ -211,7 +196,6 @@ defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip def . methodOverr -- | Deprecated synonym for 'warp'. warpDebug :: YesodDispatch site => Int -> site -> IO () warpDebug = warp @@ -484,10 +484,10 @@ -- | Runs your application using default middlewares (i.e., via 'toWaiApp'). It -- reads port information from the PORT environment variable, as used by tools diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs -index e5cbc44..db7c097 100644 +index 2e5d7cb..83f93bf 100644 --- a/Yesod/Core/Handler.hs +++ b/Yesod/Core/Handler.hs -@@ -169,7 +169,7 @@ import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +@@ -172,7 +172,7 @@ import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as TL import qualified Text.Blaze.Html.Renderer.Text as RenderText @@ -496,15 +496,15 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -@@ -198,6 +198,7 @@ import Control.Exception (throwIO) +@@ -201,6 +201,7 @@ import Control.Exception (throwIO) import Blaze.ByteString.Builder (Builder) import Safe (headMay) import Data.CaseInsensitive (CI) +import qualified Text.Blaze.Internal + import qualified Data.Conduit.List as CL + import Control.Monad (unless) import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO - #if MIN_VERSION_wai(2, 0, 0) - #else -@@ -806,19 +807,15 @@ redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url) +@@ -847,19 +848,15 @@ redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url) -> m a redirectToPost url = do urlText <- toTextUrl url @@ -534,7 +534,7 @@ -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html diff --git a/Yesod/Core/Internal/Run.hs b/Yesod/Core/Internal/Run.hs -index 3e2e4e0..b92eadb 100644 +index 09b4609..e1ef568 100644 --- a/Yesod/Core/Internal/Run.hs +++ b/Yesod/Core/Internal/Run.hs @@ -16,8 +16,8 @@ import Control.Exception.Lifted (catch) @@ -767,5 +767,5 @@ ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message) => HtmlUrlI18n message (Route (HandlerSite m)) -- -2.0.0.rc2 +2.0.0 diff --git a/standalone/no-th/haskell-patches/yesod-persistent_do-not-really-build.patch b/standalone/no-th/haskell-patches/yesod-persistent_do-not-really-build.patch --- a/standalone/no-th/haskell-patches/yesod-persistent_do-not-really-build.patch +++ b/standalone/no-th/haskell-patches/yesod-persistent_do-not-really-build.patch @@ -1,6 +1,6 @@ -From b232effd092b03c6ad4235e5aa0c5750461af02d Mon Sep 17 00:00:00 2001 +From 92a34bc2b09572a58a4e696e0d8a0a61475535f7 Mon Sep 17 00:00:00 2001 From: dummy -Date: Wed, 21 May 2014 04:47:44 +0000 +Date: Tue, 10 Jun 2014 19:09:56 +0000 Subject: [PATCH] do not really build --- @@ -8,7 +8,7 @@ 1 file changed, 10 deletions(-) diff --git a/yesod-persistent.cabal b/yesod-persistent.cabal -index 3560dd9..d01be4a 100644 +index b44499b..ef33863 100644 --- a/yesod-persistent.cabal +++ b/yesod-persistent.cabal @@ -14,16 +14,6 @@ description: Some helpers for using Persistent from Yesod. @@ -18,7 +18,7 @@ - , yesod-core >= 1.2.2 && < 1.3 - , persistent >= 1.2 && < 1.4 - , persistent-template >= 1.2 && < 1.4 -- , transformers >= 0.2.2 && < 0.4 +- , transformers >= 0.2.2 - , blaze-builder - , conduit - , resourcet >= 0.4.5 @@ -29,5 +29,5 @@ test-suite test -- -2.0.0.rc2 +2.0.0 diff --git a/standalone/no-th/haskell-patches/yesod_hack-TH.patch b/standalone/no-th/haskell-patches/yesod_hack-TH.patch --- a/standalone/no-th/haskell-patches/yesod_hack-TH.patch +++ b/standalone/no-th/haskell-patches/yesod_hack-TH.patch @@ -1,13 +1,13 @@ -From 86264ab2a76568585cacca9145e440d6c06edbe3 Mon Sep 17 00:00:00 2001 +From da032b804c0a35c2831664e28c9211f4fe712593 Mon Sep 17 00:00:00 2001 From: dummy -Date: Wed, 21 May 2014 06:30:03 +0000 +Date: Tue, 10 Jun 2014 20:39:42 +0000 Subject: [PATCH] avoid TH --- Yesod.hs | 19 ++++++++++++-- - Yesod/Default/Main.hs | 31 +---------------------- + Yesod/Default/Main.hs | 32 +----------------------- Yesod/Default/Util.hs | 69 ++------------------------------------------------- - 3 files changed, 20 insertions(+), 99 deletions(-) + 3 files changed, 20 insertions(+), 100 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index b367144..fbe309c 100644 @@ -41,7 +41,7 @@ +insert = undefined + diff --git a/Yesod/Default/Main.hs b/Yesod/Default/Main.hs -index e273de2..bf46642 100644 +index 565ed35..41c2df0 100644 --- a/Yesod/Default/Main.hs +++ b/Yesod/Default/Main.hs @@ -1,10 +1,8 @@ @@ -64,7 +64,7 @@ import System.Log.FastLogger (LogStr, toLogStr) import Language.Haskell.TH.Syntax (qLocation) -@@ -55,33 +53,6 @@ defaultMain load getApp = do +@@ -55,34 +53,6 @@ defaultMain load getApp = do type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () @@ -90,14 +90,15 @@ - } app - where - shouldLog' = --#if MIN_VERSION_wai(2,1,3) +-#if MIN_VERSION_warp(2,1,3) - Warp.defaultShouldDisplayException -#else - const True -#endif - +- -- | Run your application continously, listening for SIGINT and exiting -- when received + -- diff --git a/Yesod/Default/Util.hs b/Yesod/Default/Util.hs index a10358e..0547424 100644 --- a/Yesod/Default/Util.hs @@ -195,5 +196,5 @@ - else return $ Just ex - else return Nothing -- -2.0.0.rc2 +2.0.0 diff --git a/static/css/bootstrap-theme.css b/static/css/bootstrap-theme.css --- a/static/css/bootstrap-theme.css +++ b/static/css/bootstrap-theme.css diff --git a/static/css/bootstrap.css b/static/css/bootstrap.css --- a/static/css/bootstrap.css +++ b/static/css/bootstrap.css diff --git a/static/js/bootstrap.js b/static/js/bootstrap.js --- a/static/js/bootstrap.js +++ b/static/js/bootstrap.js diff --git a/static/js/jquery.full.js b/static/js/jquery.full.js --- a/static/js/jquery.full.js +++ b/static/js/jquery.full.js diff --git a/static/js/jquery.ui.core.js b/static/js/jquery.ui.core.js --- a/static/js/jquery.ui.core.js +++ b/static/js/jquery.ui.core.js diff --git a/static/js/jquery.ui.mouse.js b/static/js/jquery.ui.mouse.js --- a/static/js/jquery.ui.mouse.js +++ b/static/js/jquery.ui.mouse.js diff --git a/static/js/jquery.ui.sortable.js b/static/js/jquery.ui.sortable.js --- a/static/js/jquery.ui.sortable.js +++ b/static/js/jquery.ui.sortable.js diff --git a/static/js/jquery.ui.widget.js b/static/js/jquery.ui.widget.js --- a/static/js/jquery.ui.widget.js +++ b/static/js/jquery.ui.widget.js diff --git a/static/js/longpolling.js b/static/js/longpolling.js --- a/static/js/longpolling.js +++ b/static/js/longpolling.js @@ -44,5 +44,3 @@ } }); } - -//EOF