diff options
49 files changed, 370 insertions, 163 deletions
diff --git a/Annex/Branch.hs b/Annex/Branch.hs index af29b02b0..5482dc44b 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -29,8 +29,8 @@ module Annex.Branch ( import qualified Data.ByteString.Lazy as L import qualified Data.Set as S import qualified Data.Map as M -import Data.Bits.Utils import Data.Function +import Data.Char import Control.Concurrent (threadDelay) import Annex.Common @@ -304,7 +304,7 @@ commitIndex' jl branchref message basemessage retrynum parents = do -- look for "parent ref" lines and return the refs commitparents = map (Git.Ref . snd) . filter isparent . map (toassoc . decodeBS) . L.split newline - newline = c2w8 '\n' + newline = fromIntegral (ord '\n') toassoc = separate (== ' ') isparent (k,_) = k == "parent" diff --git a/Annex/DirHashes.hs b/Annex/DirHashes.hs index 82d751eee..f8438484d 100644 --- a/Annex/DirHashes.hs +++ b/Annex/DirHashes.hs @@ -1,6 +1,6 @@ {- git-annex file locations - - - Copyright 2010-2015 Joey Hess <id@joeyh.name> + - Copyright 2010-2017 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -19,14 +19,15 @@ module Annex.DirHashes ( import Data.Bits import Data.Word -import Data.Hash.MD5 import Data.Default +import qualified Data.ByteArray import Common import Key import Types.GitConfig import Types.Difference import Utility.FileSystemEncoding +import Utility.Hash type Hasher = Key -> FilePath @@ -62,15 +63,24 @@ hashDirs :: HashLevels -> Int -> String -> FilePath hashDirs (HashLevels 1) sz s = addTrailingPathSeparator $ take sz s hashDirs _ sz s = addTrailingPathSeparator $ take sz s </> drop sz s +hashDirLower :: HashLevels -> Hasher +hashDirLower n k = hashDirs n 3 $ take 6 $ show $ md5 $ + encodeBS $ key2file $ nonChunkKey k + +{- This was originally using Data.Hash.MD5 from MissingH. This new version +- is faster, but ugly as it has to replicate the 4 Word32's that produced. -} hashDirMixed :: HashLevels -> Hasher -hashDirMixed n k = hashDirs n 2 $ take 4 $ display_32bits_as_dir =<< [a,b,c,d] +hashDirMixed n k = hashDirs n 2 $ take 4 $ concatMap display_32bits_as_dir $ + encodeWord32 $ map fromIntegral $ Data.ByteArray.unpack $ + Utility.Hash.md5 $ encodeBS $ key2file $ nonChunkKey k where - ABCD (a,b,c,d) = md5 $ md5FilePath $ key2file $ nonChunkKey k - -hashDirLower :: HashLevels -> Hasher -hashDirLower n k = hashDirs n 3 $ take 6 $ md5s $ md5FilePath $ key2file $ nonChunkKey k + encodeWord32 (b1:b2:b3:b4:rest) = + (shiftL b4 24 .|. shiftL b3 16 .|. shiftL b2 8 .|. b1) + : encodeWord32 rest + encodeWord32 _ = [] {- modified version of display_32bits_as_hex from Data.Hash.MD5 + - in MissingH - Copyright (C) 2001 Ian Lynagh - License: Either BSD or GPL -} diff --git a/Annex/Locations.hs b/Annex/Locations.hs index 6bc24c4a8..494badcc6 100644 --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -172,7 +172,7 @@ gitAnnexLocation' key r config crippled symlinkssupported checker gitdir gitAnnexLink :: FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath gitAnnexLink file key r config = do currdir <- getCurrentDirectory - let absfile = fromMaybe whoops $ absNormPathUnix currdir file + let absfile = absNormPathUnix currdir file let gitdir = getgitdir currdir loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir toInternalGitPath <$> relPathDirToFile (parentDir absfile) loc @@ -182,10 +182,10 @@ gitAnnexLink file key r config = do - supporting symlinks; generate link target that will - work portably. -} | not (coreSymlinks config) && needsSubmoduleFixup r = - fromMaybe whoops $ absNormPathUnix currdir $ - Git.repoPath r </> ".git" + absNormPathUnix currdir $ Git.repoPath r </> ".git" | otherwise = Git.localGitDir r - whoops = error $ "unable to normalize " ++ file + absNormPathUnix d p = toInternalGitPath $ + absPathFrom (toInternalGitPath d) (toInternalGitPath p) {- Calculates a symlink target as would be used in a typical git - repository, with .git in the top of the work tree. -} diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index e0cc4a0fe..a9ff91751 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -33,8 +33,9 @@ import Config import Annex.Path import Utility.Env import Utility.FileSystemEncoding +import Utility.Hash import Types.CleanupActions -import Types.Messages +import Types.Concurrency import Git.Env import Git.Ssh #ifndef mingw32_HOST_OS @@ -42,7 +43,6 @@ import Annex.Perms import Annex.LockPool #endif -import Data.Hash.MD5 import Control.Concurrent.STM {- Some ssh commands are fed stdin on a pipe and so should be allowed to @@ -191,13 +191,16 @@ prepSocket socketfile gc sshparams = do liftIO $ createDirectoryIfMissing True $ parentDir socketfile let socketlock = socket2lock socketfile - prompt $ \s -> when (concurrentOutputEnabled s) $ do - -- If the LockCache already has the socketlock in it, - -- the connection has already been started. Otherwise, - -- get the connection started now. - whenM (isNothing <$> fromLockCache socketlock) $ - void $ liftIO $ boolSystem "ssh" $ - sshparams ++ startSshConnection gc + prompt $ \c -> case c of + Concurrent {} -> do + -- If the LockCache already has the socketlock in it, + -- the connection has already been started. Otherwise, + -- get the connection started now. + whenM (isNothing <$> fromLockCache socketlock) $ + void $ liftIO $ boolSystem "ssh" $ + sshparams ++ startSshConnection gc + NonConcurrent -> return () + lockFileCached socketlock -- Parameters to get ssh connected to the remote host, @@ -284,7 +287,7 @@ hostport2socket host Nothing = hostport2socket' host hostport2socket host (Just port) = hostport2socket' $ host ++ "!" ++ show port hostport2socket' :: String -> FilePath hostport2socket' s - | length s > lengthofmd5s = md5s (Str s) + | length s > lengthofmd5s = show $ md5 $ encodeBS s | otherwise = s where lengthofmd5s = 32 diff --git a/Annex/UUID.hs b/Annex/UUID.hs index 0e87cda59..8a2d88427 100644 --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -37,7 +37,7 @@ import Config import qualified Data.UUID as U import qualified Data.UUID.V4 as U4 import qualified Data.UUID.V5 as U5 -import Data.Bits.Utils +import Utility.FileSystemEncoding configkey :: ConfigKey configkey = annexConfig "uuid" diff --git a/Annex/VariantFile.hs b/Annex/VariantFile.hs index 17658a9c6..8365073d5 100644 --- a/Annex/VariantFile.hs +++ b/Annex/VariantFile.hs @@ -9,8 +9,7 @@ module Annex.VariantFile where import Annex.Common import Utility.FileSystemEncoding - -import Data.Hash.MD5 +import Utility.Hash variantMarker :: String variantMarker = ".variant-" @@ -42,4 +41,4 @@ variantFile file key doubleconflict = variantMarker `isInfixOf` file shortHash :: String -> String -shortHash = take 4 . md5s . md5FilePath +shortHash = take 4 . show . md5 . encodeBS diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index d0acb8c60..3680349be 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -38,9 +38,9 @@ import Annex.Content.Direct import qualified Database.Keys import qualified Command.Sync import qualified Git.Branch +import Utility.Tuple import Data.Time.Clock -import Data.Tuple.Utils import qualified Data.Set as S import qualified Data.Map as M import Data.Either diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 816969511..43812e5d4 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -257,9 +257,9 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit where go (Just Nothing) = noop go (Just (Just expireunused)) = expireUnused (Just expireunused) - go Nothing = maybe noop prompt =<< describeUnusedWhenBig + go Nothing = maybe noop promptconfig =<< describeUnusedWhenBig - prompt msg = + promptconfig msg = #ifdef WITH_WEBAPP do button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigUnusedR diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 90bb3dc78..742b8c88f 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -44,13 +44,13 @@ import Git.FilePath import Config import Config.GitConfig import Utility.ThreadScheduler +import Utility.FileSystemEncoding import Logs.Location import qualified Database.Keys #ifndef mingw32_HOST_OS import qualified Utility.Lsof as Lsof #endif -import Data.Bits.Utils import Data.Typeable import qualified Data.ByteString.Lazy as L import qualified Control.Exception as E diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 67a4d9fc2..cd1be4d4e 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -39,9 +39,9 @@ import qualified Utility.Lsof as Lsof import qualified Build.SysConfig import qualified Utility.Url as Url import qualified Annex.Url as Url +import Utility.Tuple import qualified Data.Map as M -import Data.Tuple.Utils {- Upgrade without interaction in the webapp. -} unattendedUpgrade :: Assistant () diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs index d1fb94f2a..1691fa2b2 100644 --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -7,10 +7,9 @@ module Backend.Utilities where -import Data.Hash.MD5 - import Annex.Common import Utility.FileSystemEncoding +import Utility.Hash {- Generates a keyName from an input string. Takes care of sanitizing it. - If it's not too long, the full string is used as the keyName. @@ -20,7 +19,8 @@ genKeyName :: String -> String genKeyName s -- Avoid making keys longer than the length of a SHA256 checksum. | bytelen > sha256len = - truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++ md5s (Str s) + truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++ + show (md5 (encodeBS s)) | otherwise = s' where s' = preSanitizeKeyName s diff --git a/Build/EvilLinker.hs b/Build/EvilLinker.hs index 47111d476..8d3afa9cd 100644 --- a/Build/EvilLinker.hs +++ b/Build/EvilLinker.hs @@ -10,7 +10,6 @@ module Main where -import Data.List.Utils import Text.Parsec import Text.Parsec.String import Control.Applicative ((<$>)) @@ -23,6 +22,7 @@ import Utility.Process hiding (env) import qualified Utility.Process import Utility.Env import Utility.Directory +import Utility.Split data CmdParams = CmdParams { cmd :: String diff --git a/Build/EvilSplicer.hs b/Build/EvilSplicer.hs index 4e7b1c9bf..e07034c5b 100644 --- a/Build/EvilSplicer.hs +++ b/Build/EvilSplicer.hs @@ -35,7 +35,6 @@ import Text.Parsec.String import Control.Applicative ((<$>)) import Data.Either import Data.List hiding (find) -import Data.String.Utils import Data.Char import System.Environment import System.FilePath @@ -49,6 +48,7 @@ import Utility.Exception hiding (try) import Utility.Path import Utility.FileSystemEncoding import Utility.Directory +import Utility.Split data Coord = Coord { coordLine :: Int @@ -4,6 +4,8 @@ git-annex (6.20170511) UNRELEASED; urgency=medium When ssh connection caching is enabled (and when GIT_ANNEX_USE_GIT_SSH is not set), only one ssh password prompt will be made per host, and only one ssh password prompt will be made at a time. + * Removed dependency on MissingH, instead depending on the split library. + * Progress is displayed for transfers of files of unknown size. -- Joey Hess <id@joeyh.name> Thu, 11 May 2017 15:16:23 -0400 diff --git a/Command/List.hs b/Command/List.hs index 2676b5d5d..05f12822a 100644 --- a/Command/List.hs +++ b/Command/List.hs @@ -11,7 +11,6 @@ module Command.List where import qualified Data.Set as S import qualified Data.Map as M import Data.Function -import Data.Tuple.Utils import Data.Ord import Command @@ -20,6 +19,7 @@ import Logs.Trust import Logs.UUID import Annex.UUID import Git.Types (RemoteName) +import Utility.Tuple cmd :: Command cmd = noCommit $ withGlobalOptions annexedMatchingOptions $ diff --git a/Command/Uninit.hs b/Command/Uninit.hs index d8c7d1295..af628d7a9 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -18,9 +18,6 @@ import Annex.Content import Annex.Init import Utility.FileMode -import System.IO.HVFS -import System.IO.HVFS.Utils - cmd :: Command cmd = addCheck check $ command "uninit" SectionUtility @@ -101,7 +98,8 @@ prepareRemoveAnnexDir annexdir = do prepareRemoveAnnexDir' :: FilePath -> IO () prepareRemoveAnnexDir' annexdir = - recurseDir SystemFS annexdir >>= mapM_ (void . tryIO . allowWrite) + dirTreeRecursiveSkipping (const False) annexdir + >>= mapM_ (void . tryIO . allowWrite) {- Keys that were moved out of the annex have a hard link still in the - annex, with > 1 link count, and those can be removed. @@ -9,7 +9,6 @@ import Control.Monad.IO.Class as X (liftIO) import Data.Maybe as X import Data.List as X hiding (head, tail, init, last) -import Data.String.Utils as X hiding (join) import Data.Monoid as X import Data.Default as X @@ -32,5 +31,6 @@ import Utility.Applicative as X import Utility.PosixFiles as X hiding (fileSize) import Utility.FileSize as X import Utility.Network as X +import Utility.Split as X import Utility.PartialPrelude as X diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 4935cdffa..ba68c4ea3 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -26,7 +26,6 @@ import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.Map as M import Data.String import Data.Char -import Data.Tuple.Utils import Numeric import System.Posix.Types @@ -38,6 +37,7 @@ import Git.Types import Git.FilePath import qualified Utility.CoProcess as CoProcess import Utility.FileSystemEncoding +import Utility.Tuple data CatFileHandle = CatFileHandle { catFileProcess :: CoProcess.CoProcessHandle diff --git a/Git/Construct.hs b/Git/Construct.hs index 489927880..4ad74fd73 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -94,7 +94,7 @@ fromUrl url fromUrlStrict :: String -> IO Repo fromUrlStrict url - | startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u + | "file://" `isPrefixOf` url = fromAbsPath $ unEscapeString $ uriPath u | otherwise = pure $ newFrom $ Url u where u = fromMaybe bad $ parseURI url @@ -128,7 +128,7 @@ fromRemotes repo = mapM construct remotepairs filterconfig f = filter f $ M.toList $ config repo filterkeys f = filterconfig (\(k,_) -> f k) remotepairs = filterkeys isremote - isremote k = startswith "remote." k && endswith ".url" k + isremote k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo {- Sets the name of a remote when constructing the Repo to represent it. -} diff --git a/Git/Remote.hs b/Git/Remote.hs index 717b54045..f6eaf9362 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -74,9 +74,9 @@ parseRemoteLocation s repo = ret $ calcloc s (bestkey, bestvalue) = maximumBy longestvalue insteadofs longestvalue (_, a) (_, b) = compare b a insteadofs = filterconfig $ \(k, v) -> - startswith prefix k && - endswith suffix k && - startswith v l + prefix `isPrefixOf` k && + suffix `isSuffixOf` k && + v `isPrefixOf` l filterconfig f = filter f $ concatMap splitconfigs $ M.toList $ fullconfig repo splitconfigs (k, vs) = map (\v -> (k, v)) vs diff --git a/Git/Repair.hs b/Git/Repair.hs index 1baf51a64..8e4324858 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -39,10 +39,10 @@ import qualified Git.Branch as Branch import Utility.Tmp import Utility.Rsync import Utility.FileMode +import Utility.Tuple import qualified Data.Set as S import qualified Data.ByteString.Lazy as L -import Data.Tuple.Utils {- Given a set of bad objects found by git fsck, which may not - be complete, finds and removes all corrupt objects. -} diff --git a/Messages.hs b/Messages.hs index f3c44aebf..83ea91dbc 100644 --- a/Messages.hs +++ b/Messages.hs @@ -54,6 +54,7 @@ import Common import Types import Types.Messages import Types.ActionItem +import Types.Concurrency import Messages.Internal import qualified Messages.JSON as JSON import qualified Annex @@ -226,10 +227,10 @@ implicitMessage = whenM (implicitMessages <$> Annex.getState Annex.output) - that the action is the only thing using the console, and can eg prompt - the user. -} -prompt :: (MessageState -> Annex a) -> Annex a -prompt a = withMessageState $ \s -> - if concurrentOutputEnabled s - then - let l = promptLock s - in bracketIO (takeMVar l) (putMVar l) (const (a s)) - else a s +prompt :: (Concurrency -> Annex a) -> Annex a +prompt a = go =<< Annex.getState Annex.concurrency + where + go NonConcurrent = a NonConcurrent + go c@(Concurrent {}) = withMessageState $ \s -> do + let l = promptLock s + bracketIO (takeMVar l) (putMVar l) (const (a c)) diff --git a/Messages/Progress.hs b/Messages/Progress.hs index c4f55de50..3c263c05c 100644 --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -23,34 +23,28 @@ import qualified System.Console.Regions as Regions import qualified System.Console.Concurrent as Console #endif -import Data.Progress.Meter -import Data.Progress.Tracker -import Data.Quantity - {- Shows a progress meter while performing a transfer of a key. - The action is passed a callback to use to update the meter. -} metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a metered othermeter key a = withMessageState $ go (keySize key) where go _ (MessageState { outputType = QuietOutput }) = nometer - go Nothing (MessageState { outputType = NormalOutput }) = nometer - go (Just size) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do + go (msize) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do showOutput - (progress, meter) <- mkmeter size - m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ \n -> do - setP progress $ fromBytesProcessed n - displayMeter stdout meter + meter <- liftIO $ mkMeter msize bandwidthMeter $ + displayMeterHandle stdout + m <- liftIO $ rateLimitMeterUpdate 0.1 msize $ + updateMeter meter r <- a (combinemeter m) - liftIO $ clearMeter stdout meter + liftIO $ clearMeterHandle meter stdout return r - go (Just size) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) = + go (msize) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) = #if WITH_CONCURRENTOUTPUT withProgressRegion $ \r -> do - (progress, meter) <- mkmeter size - m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ \n -> do - setP progress $ fromBytesProcessed n - s <- renderMeter meter - Regions.setConsoleRegion r ("\n" ++ s) + meter <- liftIO $ mkMeter msize bandwidthMeter $ \_ s -> + Regions.setConsoleRegion r ('\n' : s) + m <- liftIO $ rateLimitMeterUpdate 0.1 msize $ + updateMeter meter a (combinemeter m) #else nometer @@ -62,11 +56,6 @@ metered othermeter key a = withMessageState $ go (keySize key) JSON.progress buf msize a (combinemeter m) - mkmeter size = do - progress <- liftIO $ newProgress "" size - meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1) - return (progress, meter) - nometer = a $ combinemeter (const noop) combinemeter m = case othermeter of diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index b72a60efa..1fe6d75be 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -21,13 +21,13 @@ module Remote.Helper.Encryptable ( import qualified Data.Map as M import qualified "sandi" Codec.Binary.Base64 as B64 import qualified Data.ByteString as B -import Data.Bits.Utils import Annex.Common import Types.Remote import Crypto import Types.Crypto import qualified Annex +import Utility.FileSystemEncoding -- Used to ensure that encryption has been set up before trying to -- eg, store creds in the remote config that would need to use the diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 28970872e..ae654d517 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -62,7 +62,7 @@ findSpecialRemotes s = do where remotepairs = M.toList . M.filterWithKey match construct (k,_) = Git.Construct.remoteNamedFromKey k (pure Git.Construct.fromUnknown) - match k _ = startswith "remote." k && endswith (".annex-"++s) k + match k _ = "remote." `isPrefixOf` k && (".annex-"++s) `isSuffixOf` k {- Sets up configuration for a special remote in .git/config. -} gitConfigSpecialRemote :: UUID -> RemoteConfig -> String -> String -> Annex () diff --git a/Remote/Rsync/RsyncUrl.hs b/Remote/Rsync/RsyncUrl.hs index f7e9ebbb9..c0f30c1fb 100644 --- a/Remote/Rsync/RsyncUrl.hs +++ b/Remote/Rsync/RsyncUrl.hs @@ -17,7 +17,7 @@ import Utility.SafeCommand import Data.Default import System.FilePath.Posix #ifdef mingw32_HOST_OS -import Data.String.Utils +import Utility.Split #endif import Annex.DirHashes diff --git a/Remote/S3.hs b/Remote/S3.hs index ab8411726..a341da488 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -29,7 +29,6 @@ import Control.Monad.Trans.Resource import Control.Monad.Catch import Data.Conduit import Data.IORef -import Data.Bits.Utils import System.Log.Logger import Annex.Common @@ -46,6 +45,7 @@ import Annex.UUID import Logs.Web import Utility.Metered import Utility.DataUnits +import Utility.FileSystemEncoding import Annex.Content import Annex.Url (withUrlOptions) import Utility.Url (checkBoth, managerSettings, closeManager) diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs index e0e184686..daa669de1 100644 --- a/Remote/WebDAV/DavLocation.hs +++ b/Remote/WebDAV/DavLocation.hs @@ -13,14 +13,14 @@ module Remote.WebDAV.DavLocation where import Types import Annex.Locations import Utility.Url (URLString) +#ifdef mingw32_HOST_OS +import Utility.Split +#endif import System.FilePath.Posix -- for manipulating url paths import Network.Protocol.HTTP.DAV (inDAVLocation, DAVT) import Control.Monad.IO.Class (MonadIO) import Data.Default -#ifdef mingw32_HOST_OS -import Data.String.Utils -#endif -- Relative to the top of the DAV url. type DavLocation = String diff --git a/Types/Distribution.hs b/Types/Distribution.hs index 80471c067..d19074bf9 100644 --- a/Types/Distribution.hs +++ b/Types/Distribution.hs @@ -8,12 +8,12 @@ module Types.Distribution where import Utility.PartialPrelude +import Utility.Split import Types.Key import Key import Data.Time.Clock import Git.Config (isTrue, boolConfig) -import Data.String.Utils import Control.Applicative import Prelude diff --git a/Utility/DataUnits.hs b/Utility/DataUnits.hs index 6e40932ef..a6c9ffcf1 100644 --- a/Utility/DataUnits.hs +++ b/Utility/DataUnits.hs @@ -45,6 +45,7 @@ module Utility.DataUnits ( ByteSize, roughSize, + roughSize', compareSizes, readSize ) where @@ -109,7 +110,10 @@ oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits {- approximate display of a particular number of bytes -} roughSize :: [Unit] -> Bool -> ByteSize -> String -roughSize units short i +roughSize units short i = roughSize' units short 2 i + +roughSize' :: [Unit] -> Bool -> Int -> ByteSize -> String +roughSize' units short precision i | i < 0 = '-' : findUnit units' (negate i) | otherwise = findUnit units' i where @@ -123,7 +127,7 @@ roughSize units short i showUnit x (Unit size abbrev name) = s ++ " " ++ unit where v = (fromInteger x :: Double) / fromInteger size - s = showImprecise 2 v + s = showImprecise precision v unit | short = abbrev | s == "1" = name diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index ae3bd35d7..444dc4a90 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -12,7 +12,6 @@ module Utility.FileSystemEncoding ( useFileSystemEncoding, fileEncoding, withFilePath, - md5FilePath, decodeBS, encodeBS, decodeW8, @@ -20,6 +19,10 @@ module Utility.FileSystemEncoding ( encodeW8NUL, decodeW8NUL, truncateFilePath, + s2w8, + w82s, + c2w8, + w82c, ) where import qualified GHC.Foreign as GHC @@ -27,17 +30,15 @@ import qualified GHC.IO.Encoding as Encoding import Foreign.C import System.IO import System.IO.Unsafe -import qualified Data.Hash.MD5 as MD5 import Data.Word -import Data.Bits.Utils import Data.List -import Data.List.Utils import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.Lazy.UTF8 as L8 #endif import Utility.Exception +import Utility.Split {- Makes all subsequent Handles that are opened, as well as stdio Handles, - use the filesystem encoding, instead of the encoding of the current @@ -101,10 +102,6 @@ _encodeFilePath fp = unsafePerformIO $ do GHC.withCString enc fp (GHC.peekCString Encoding.char8) `catchNonAsync` (\_ -> return fp) -{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -} -md5FilePath :: FilePath -> MD5.Str -md5FilePath = MD5.Str . _encodeFilePath - {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} decodeBS :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS @@ -145,14 +142,26 @@ decodeW8 = s2w8 . _encodeFilePath {- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} encodeW8NUL :: [Word8] -> FilePath -encodeW8NUL = intercalate nul . map encodeW8 . split (s2w8 nul) +encodeW8NUL = intercalate [nul] . map encodeW8 . splitc (c2w8 nul) where - nul = ['\NUL'] + nul = '\NUL' decodeW8NUL :: FilePath -> [Word8] -decodeW8NUL = intercalate (s2w8 nul) . map decodeW8 . split nul +decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul where - nul = ['\NUL'] + nul = '\NUL' + +c2w8 :: Char -> Word8 +c2w8 = fromIntegral . fromEnum + +w82c :: Word8 -> Char +w82c = toEnum . fromIntegral + +s2w8 :: String -> [Word8] +s2w8 = map c2w8 + +w82s :: [Word8] -> String +w82s = map w82c {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. diff --git a/Utility/Glob.hs b/Utility/Glob.hs index 119ea4834..c7d535933 100644 --- a/Utility/Glob.hs +++ b/Utility/Glob.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PackageImports #-} + {- file globbing - - Copyright 2014 Joey Hess <id@joeyh.name> @@ -14,10 +16,9 @@ module Utility.Glob ( import Utility.Exception -import System.Path.WildMatch - import "regex-tdfa" Text.Regex.TDFA import "regex-tdfa" Text.Regex.TDFA.String +import Data.Char newtype Glob = Glob Regex @@ -30,11 +31,31 @@ compileGlob glob globcase = Glob $ Right r -> r Left _ -> giveup $ "failed to compile regex: " ++ regex where - regex = '^':wildToRegex glob + regex = '^' : wildToRegex glob ++ "$" casesentitive = case globcase of CaseSensative -> True CaseInsensative -> False +wildToRegex :: String -> String +wildToRegex = concat . go + where + go [] = [] + go ('*':xs) = ".*" : go xs + go ('?':xs) = "." : go xs + go ('[':'!':xs) = "[^" : inpat xs + go ('[':xs) = "[" : inpat xs + go (x:xs) + | isDigit x || isAlpha x = [x] : go xs + | otherwise = esc x : go xs + + inpat [] = [] + inpat (x:xs) = case x of + ']' -> "]" : go xs + '\\' -> esc x : inpat xs + _ -> [x] : inpat xs + + esc c = ['\\', c] + matchGlob :: Glob -> String -> Bool matchGlob (Glob regex) val = case execute regex val of diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index f6173cdb4..336711b3f 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -14,11 +14,9 @@ import qualified Build.SysConfig as SysConfig #ifndef mingw32_HOST_OS import System.Posix.Types import qualified System.Posix.IO -import System.Path import Utility.Env -#else -import Utility.Tmp #endif +import Utility.Tmp import Utility.Format (decode_c) import Control.Concurrent @@ -336,23 +334,21 @@ keyBlock public ls = unlines {- Runs an action using gpg in a test harness, in which gpg does - not use ~/.gpg/, but a directory with the test key set up to be used. -} testHarness :: GpgCmd -> IO a -> IO a -testHarness cmd a = do - orig <- getEnv var - bracket setup (cleanup orig) (const a) +testHarness cmd a = withTmpDir "gpgtmpXXXXXX" $ \tmpdir -> + bracket (setup tmpdir) (cleanup tmpdir) (const a) where var = "GNUPGHOME" - setup = do - base <- getTemporaryDirectory - dir <- mktmpdir $ base </> "gpgtmpXXXXXX" - setEnv var dir True + setup tmpdir = do + orig <- getEnv var + setEnv var tmpdir True -- For some reason, recent gpg needs a trustdb to be set up. _ <- pipeStrict cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] [] _ <- pipeStrict cmd [Param "--import", Param "-q"] $ unlines [testSecretKey, testKey] - return dir + return orig - cleanup orig tmpdir = do + cleanup tmpdir orig = do removeDirectoryRecursive tmpdir -- gpg-agent may be shutting down at the same time -- and may delete its socket at the same time as diff --git a/Utility/Hash.hs b/Utility/Hash.hs index b6bf996f8..70f826b7a 100644 --- a/Utility/Hash.hs +++ b/Utility/Hash.hs @@ -1,8 +1,4 @@ -{- Convenience wrapper around cryptohash/cryptonite. - - - - SHA3 hashes are currently only enabled when using cryptonite, - - because of https://github.com/vincenthz/hs-cryptohash/issues/36 - -} +{- Convenience wrapper around cryptonite's hashing. -} module Utility.Hash ( sha1, diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs index 122f39643..15f82fd18 100644 --- a/Utility/LinuxMkLibs.hs +++ b/Utility/LinuxMkLibs.hs @@ -12,10 +12,10 @@ import Utility.Directory import Utility.Process import Utility.Monad import Utility.Path +import Utility.Split import Data.Maybe import System.FilePath -import Data.List.Utils import System.Posix.Files import Data.Char import Control.Monad.IfElse diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs index 87c11c01c..23560fa57 100644 --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -25,6 +25,8 @@ import Utility.Path import Utility.FileMode import Utility.LockFile.LockStatus import Utility.ThreadScheduler +import Utility.Hash +import Utility.FileSystemEncoding import qualified Utility.LockFile.Posix as Posix import System.IO @@ -33,7 +35,6 @@ import Data.Maybe import Data.List import Network.BSD import System.FilePath -import Data.Hash.MD5 import Control.Applicative import Prelude @@ -99,7 +100,9 @@ sideLockFile lockfile = do f <- absPath lockfile let base = intercalate "_" (splitDirectories (makeRelative "/" f)) let shortbase = reverse $ take 32 $ reverse base - let md5sum = if base == shortbase then "" else md5s (Str base) + let md5sum = if base == shortbase + then "" + else show (md5 (encodeBS base)) dir <- ifM (doesDirectoryExist "/dev/shm") ( return "/dev/shm" , return "/tmp" diff --git a/Utility/Metered.hs b/Utility/Metered.hs index e21e18cf1..626aa2ca1 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -10,6 +10,10 @@ module Utility.Metered where import Common +import Utility.FileSystemEncoding +import Utility.Percentage +import Utility.DataUnits +import Utility.HumanTime import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -17,7 +21,6 @@ import System.IO.Unsafe import Foreign.Storable (Storable(sizeOf)) import System.Posix.Types import Data.Int -import Data.Bits.Utils import Control.Concurrent import Control.Concurrent.Async import Control.Monad.IO.Class (MonadIO) @@ -216,7 +219,7 @@ commandMeter progressparser oh meterupdate cmd params = unless (quietMode oh) $ do S.hPut stdout b hFlush stdout - let s = w82s (S.unpack b) + let s = encodeW8 (S.unpack b) let (mbytes, buf') = progressparser (buf++s) case mbytes of Nothing -> feedprogress prev buf' h @@ -297,3 +300,77 @@ rateLimitMeterUpdate delta totalsize meterupdate = do putMVar lastupdate now meterupdate n else putMVar lastupdate prev + +data Meter = Meter (Maybe Integer) (MVar MeterState) (MVar String) RenderMeter DisplayMeter + +type MeterState = (BytesProcessed, POSIXTime) + +type DisplayMeter = MVar String -> String -> IO () + +type RenderMeter = Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> String + +-- | Make a meter. Pass the total size, if it's known. +mkMeter :: Maybe Integer -> RenderMeter -> DisplayMeter -> IO Meter +mkMeter totalsize rendermeter displaymeter = Meter + <$> pure totalsize + <*> ((\t -> newMVar (zeroBytesProcessed, t)) =<< getPOSIXTime) + <*> newMVar "" + <*> pure rendermeter + <*> pure displaymeter + +-- | Updates the meter, displaying it if necessary. +updateMeter :: Meter -> BytesProcessed -> IO () +updateMeter (Meter totalsize sv bv rendermeter displaymeter) new = do + now <- getPOSIXTime + (old, before) <- swapMVar sv (new, now) + when (old /= new) $ + displaymeter bv $ + rendermeter totalsize (old, before) (new, now) + +-- | Display meter to a Handle. +displayMeterHandle :: Handle -> DisplayMeter +displayMeterHandle h v s = do + olds <- swapMVar v s + -- Avoid writing when the rendered meter has not changed. + when (olds /= s) $ do + let padding = replicate (length olds - length s) ' ' + hPutStr h ('\r':s ++ padding) + hFlush h + +-- | Clear meter displayed by displayMeterHandle. +clearMeterHandle :: Meter -> Handle -> IO () +clearMeterHandle (Meter _ _ v _ _) h = do + olds <- readMVar v + hPutStr h $ '\r' : replicate (length olds) ' ' ++ "\r" + hFlush h + +-- | Display meter in the form: +-- 10% 300 KiB/s 16m40s +-- or when total size is not known: +-- 1.3 MiB 300 KiB/s +bandwidthMeter :: RenderMeter +bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) = + unwords $ catMaybes + [ Just percentoramount + -- Pad enough for max width: "xxxx.xx KiB xxxx KiB/s" + , Just $ replicate (23 - length percentoramount - length rate) ' ' + , Just rate + , estimatedcompletion + ] + where + percentoramount = case mtotalsize of + Just totalsize -> showPercentage 0 $ + percentage totalsize (min new totalsize) + Nothing -> roughSize' memoryUnits True 2 new + rate = roughSize' memoryUnits True 0 bytespersecond ++ "/s" + bytespersecond + | duration == 0 = fromIntegral transferred + | otherwise = floor $ fromIntegral transferred / duration + transferred = max 0 (new - old) + duration = max 0 (now - before) + estimatedcompletion = case mtotalsize of + Just totalsize + | bytespersecond > 0 -> + Just $ fromDuration $ Duration $ + totalsize `div` bytespersecond + _ -> Nothing diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 564935ddb..4498c0a03 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -45,14 +45,6 @@ separate c l = unbreak $ break c l | null b = r | otherwise = (a, tail b) -{- Split on a single character. This is over twice as fast as using - - Data.List.Utils.split on a list of length 1, while producing - - identical results. -} -splitc :: Char -> String -> [String] -splitc c s = case break (== c) s of - (i, _c:rest) -> i : splitc c rest - (i, []) -> i : [] - {- Breaks out the first line. -} firstLine :: String -> String firstLine = takeWhile (/= '\n') diff --git a/Utility/Path.hs b/Utility/Path.hs index cd9dc3859..0779d1676 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -10,7 +10,6 @@ module Utility.Path where -import Data.String.Utils import System.FilePath import Data.List import Data.Maybe @@ -25,10 +24,10 @@ import System.Posix.Files import Utility.Exception #endif -import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo import Utility.Directory +import Utility.Split {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. @@ -68,18 +67,6 @@ simplifyPath path = dropTrailingPathSeparator $ absPathFrom :: FilePath -> FilePath -> FilePath absPathFrom dir path = simplifyPath (combine dir path) -{- On Windows, this converts the paths to unix-style, in order to run - - MissingH's absNormPath on them. -} -absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath -#ifndef mingw32_HOST_OS -absNormPathUnix dir path = MissingH.absNormPath dir path -#else -absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path) - where - fromdos = replace "\\" "/" - todos = replace "/" "\\" -#endif - {- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} parentDir :: FilePath -> FilePath parentDir = takeDirectory . dropTrailingPathSeparator @@ -89,12 +76,13 @@ parentDir = takeDirectory . dropTrailingPathSeparator upFrom :: FilePath -> Maybe FilePath upFrom dir | length dirs < 2 = Nothing - | otherwise = Just $ joinDrive drive (intercalate s $ init dirs) + | otherwise = Just $ joinDrive drive $ intercalate s $ init dirs where - -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" + -- on Unix, the drive will be "/" when the dir is absolute, + -- otherwise "" (drive, path) = splitDrive dir - dirs = filter (not . null) $ split s path s = [pathSeparator] + dirs = filter (not . null) $ split s path prop_upFrom_basics :: FilePath -> Bool prop_upFrom_basics dir @@ -149,11 +137,11 @@ relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to relPathDirToFileAbs :: FilePath -> FilePath -> FilePath relPathDirToFileAbs from to | takeDrive from /= takeDrive to = to - | otherwise = intercalate s $ dotdots ++ uncommon + | otherwise = joinPath $ dotdots ++ uncommon where - s = [pathSeparator] - pfrom = split s from - pto = split s to + pfrom = sp from + pto = sp to + sp = map dropTrailingPathSeparator . splitPath common = map fst $ takeWhile same $ zip pfrom pto same (c,d) = c == d uncommon = drop numcommon pto diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index d3823a528..f190b40de 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -11,10 +11,10 @@ module Utility.Rsync where import Common import Utility.Metered +import Utility.Tuple import Data.Char import System.Console.GetOpt -import Data.Tuple.Utils {- Generates parameters to make rsync use a specified command as its remote - shell. -} diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index bef0a619d..eb34d3de7 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -11,7 +11,7 @@ module Utility.SafeCommand where import System.Exit import Utility.Process -import Utility.Misc +import Utility.Split import System.FilePath import Data.Char import Data.List diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs index d23aaf039..b68ff901c 100644 --- a/Utility/Scheduled.hs +++ b/Utility/Scheduled.hs @@ -29,6 +29,7 @@ module Utility.Scheduled ( import Utility.Data import Utility.PartialPrelude import Utility.Misc +import Utility.Tuple import Data.List import Data.Time.Clock @@ -37,7 +38,6 @@ import Data.Time.Calendar import Data.Time.Calendar.WeekDate import Data.Time.Calendar.OrdinalDate import Data.Time.Format () -import Data.Tuple.Utils import Data.Char import Control.Applicative import Prelude diff --git a/Utility/Split.hs b/Utility/Split.hs new file mode 100644 index 000000000..decfe7d39 --- /dev/null +++ b/Utility/Split.hs @@ -0,0 +1,30 @@ +{- split utility functions + - + - Copyright 2017 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Split where + +import Data.List (intercalate) +import Data.List.Split (splitOn) + +-- | same as Data.List.Utils.split +-- +-- intercalate x . splitOn x === id +split :: Eq a => [a] -> [a] -> [[a]] +split = splitOn + +-- | Split on a single character. This is over twice as fast as using +-- split on a list of length 1, while producing identical results. -} +splitc :: Eq c => c -> [c] -> [[c]] +splitc c s = case break (== c) s of + (i, _c:rest) -> i : splitc c rest + (i, []) -> i : [] + +-- | same as Data.List.Utils.replace +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace old new = intercalate new . split old diff --git a/Utility/Tuple.hs b/Utility/Tuple.hs new file mode 100644 index 000000000..25c6e8f36 --- /dev/null +++ b/Utility/Tuple.hs @@ -0,0 +1,17 @@ +{- tuple utility functions + - + - Copyright 2017 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +module Utility.Tuple where + +fst3 :: (a,b,c) -> a +fst3 (a,_,_) = a + +snd3 :: (a,b,c) -> b +snd3 (_,b,_) = b + +thd3 :: (a,b,c) -> c +thd3 (_,_,c) = c diff --git a/debian/control b/debian/control index fa68c87fe..b34a79002 100644 --- a/debian/control +++ b/debian/control @@ -6,11 +6,12 @@ Build-Depends: ghc (>= 7.4), cabal-install, libghc-mtl-dev (>= 2.1.1), - libghc-missingh-dev, + libghc-split-dev, libghc-data-default-dev, libghc-hslogger-dev, libghc-pcre-light-dev, libghc-cryptonite-dev, + libghc-memory-dev, libghc-sandi-dev, libghc-utf8-string-dev, libghc-aws-dev (>= 0.9.2-2~), diff --git a/doc/devblog/day_458__adeiu_MissingH.mdwn b/doc/devblog/day_458__adeiu_MissingH.mdwn new file mode 100644 index 000000000..5d6a7870e --- /dev/null +++ b/doc/devblog/day_458__adeiu_MissingH.mdwn @@ -0,0 +1,18 @@ +Wasn't planning to, but spent the day making git-annex not depend on the +MissingH library. This has been a long-term goal, as MissingH pulls in +several other libraries and is not modern or principled. + +The first part was to using cryptonite for MD5 calculation. While +converting to the form git-annex uses to make hash directories involved +some math, this did make git-annex garbage-collect less, and +probably made it faster. + +Then I had to write my own progress meter display, since git-annex was +using MissingH's display. That was fairly simple (73 LoC), and let me +make it more efficient and tuned for the git-annex use case. As a bonus, it +got progress displays when transferring files of unknown sizes, which +wasn't done before. + +MissingH was handy training wheels when I was coming over from perl, +but it's been training wheels on some old cars in the middle of a +500 car train for a while, so glad that's over. diff --git a/doc/todo/make_copy_--fast__faster/comment_11_1ca8d9765e6e3a18ae09df74bc390a00._comment b/doc/todo/make_copy_--fast__faster/comment_11_1ca8d9765e6e3a18ae09df74bc390a00._comment new file mode 100644 index 000000000..619351d4c --- /dev/null +++ b/doc/todo/make_copy_--fast__faster/comment_11_1ca8d9765e6e3a18ae09df74bc390a00._comment @@ -0,0 +1,49 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 11""" + date="2017-05-15T21:56:52Z" + content=""" +Switched from MissingH to cryptonite for md5. It did move md5 out of the top CPU spot but +the overall runtime didn't change much. Memory allocations did go down by a +good amount. + +Updated profiles: + + git-annex +RTS -p -RTS find + + total time = 1.63 secs (1629 ticks @ 1000 us, 1 processor) + total alloc = 1,496,336,496 bytes (excludes profiling overheads) + + COST CENTRE MODULE SRC %time %alloc + + catchIO Utility.Exception Utility/Exception.hs:79:1-17 14.1 15.1 + inAnnex'.checkindirect Annex.Content Annex/Content.hs:(108,9)-(119,39) 10.6 4.8 + catches Control.Monad.Catch src/Control/Monad/Catch.hs:(432,1)-(436,76) 8.6 6.9 + spanList Data.List.Utils src/Data/List/Utils.hs:(150,1)-(155,36) 6.7 11.1 + isAnnexLink Annex.Link Annex/Link.hs:35:1-85 5.0 10.2 + keyFile Annex.Locations Annex/Locations.hs:(456,1)-(462,19) 5.0 7.0 + readish Utility.PartialPrelude Utility/PartialPrelude.hs:(48,1)-(50,20) 3.8 2.0 + startswith Data.List.Utils src/Data/List/Utils.hs:103:1-23 3.6 2.3 + splitc Utility.Misc Utility/Misc.hs:(52,1)-(54,25) 3.4 6.5 + s2w8 Data.Bits.Utils src/Data/Bits/Utils.hs:65:1-15 2.6 6.4 + keyPath Annex.Locations Annex/Locations.hs:(492,1)-(494,23) 2.5 4.4 + fileKey.unesc Annex.Locations Annex/Locations.hs:(469,9)-(474,39) 2.0 3.5 + copyAndFreeze Data.ByteArray.Methods Data/ByteArray/Methods.hs:(224,1)-(227,21) 1.8 0.5 + + git-annex +RTS -p -RTS find --not --in web + + total time = 5.33 secs (5327 ticks @ 1000 us, 1 processor) + total alloc = 2,908,489,000 bytes (excludes profiling overheads) + + COST CENTRE MODULE SRC %time %alloc + + catObjectDetails.\ Git.CatFile Git/CatFile.hs:(80,72)-(88,97) 7.8 2.8 + catchIO Utility.Exception Utility/Exception.hs:79:1-17 7.6 8.3 + spanList Data.List.Utils src/Data/List/Utils.hs:(150,1)-(155,36) 5.8 9.1 + readish Utility.PartialPrelude Utility/PartialPrelude.hs:(48,1)-(50,20) 4.5 4.0 + parseResp Git.CatFile Git/CatFile.hs:(113,1)-(124,28) 4.4 2.9 + readFileStrict Utility.Misc Utility/Misc.hs:33:1-59 3.7 1.6 + catches Control.Monad.Catch src/Control/Monad/Catch.hs:(432,1)-(436,76) 3.1 3.6 + encodeW8 Utility.FileSystemEncoding Utility/FileSystemEncoding.hs:(131,1)-(133,70) 3.1 2.3 + +"""]] diff --git a/git-annex.cabal b/git-annex.cabal index 48b2d6793..04b43d986 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -304,7 +304,7 @@ source-repository head location: git://git-annex.branchable.com/ custom-setup - Setup-Depends: base (>= 4.5), hslogger, MissingH, unix-compat, process, + Setup-Depends: base (>= 4.5), hslogger, split, unix-compat, process, unix, filepath, exceptions, bytestring, directory, IfElse, data-default, Cabal @@ -330,7 +330,6 @@ Executable git-annex directory (>= 1.2), filepath, IfElse, - MissingH, hslogger, monad-logger, free, @@ -361,12 +360,15 @@ Executable git-annex stm-chans, securemem, crypto-api, - cryptonite + cryptonite, + memory, + split CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs Extensions: PackageImports -- Some things don't work with the non-threaded RTS. GHC-Options: -threaded + Other-Extensions: TemplateHaskell -- Fully optimize for production. if flag(Production) @@ -1049,6 +1051,7 @@ Executable git-annex Utility.Scheduled.QuickCheck Utility.Shell Utility.SimpleProtocol + Utility.Split Utility.SshConfig Utility.Su Utility.SystemDirectory @@ -1059,6 +1062,7 @@ Executable git-annex Utility.Tmp Utility.Tor Utility.Touch + Utility.Tuple Utility.Url Utility.UserInfo Utility.Verifiable diff --git a/stack.yaml b/stack.yaml index 0d20fc3c5..d40b53ee9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -23,4 +23,4 @@ extra-deps: - yesod-default-1.2.0 explicit-setup-deps: git-annex: true -resolver: lts-8.6 +resolver: lts-8.13 |