summaryrefslogtreecommitdiff
path: root/Utility
diff options
context:
space:
mode:
authorJoey Hess <joeyh@joeyh.name>2020-05-04 15:38:39 -0400
committerJoey Hess <joeyh@joeyh.name>2020-05-04 15:38:39 -0400
commit8c4352a0a544b2e5a4ed717999fc7c6ecb0a328f (patch)
treed57aca56117598b06bf30e5a1ed96f4b77e51f09 /Utility
parent6ea7eac330f73699d965cef7b8ee23d7218415a8 (diff)
downloadgit-repair-8c4352a0a544b2e5a4ed717999fc7c6ecb0a328f.tar.gz
merge from git-annex
* Improve fetching from a remote with an url in host:path format. * Merge from git-annex.
Diffstat (limited to 'Utility')
-rw-r--r--Utility/CoProcess.hs1
-rw-r--r--Utility/Directory.hs81
-rw-r--r--Utility/FileSystemEncoding.hs15
-rw-r--r--Utility/HumanTime.hs5
-rw-r--r--Utility/InodeCache.hs307
-rw-r--r--Utility/Misc.hs8
-rw-r--r--Utility/Path.hs17
-rw-r--r--Utility/Process.hs16
-rw-r--r--Utility/RawFilePath.hs50
-rw-r--r--Utility/TimeStamp.hs58
10 files changed, 527 insertions, 31 deletions
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs
index 2bae40f..e091d43 100644
--- a/Utility/CoProcess.hs
+++ b/Utility/CoProcess.hs
@@ -10,6 +10,7 @@
module Utility.CoProcess (
CoProcessHandle,
+ CoProcessState(..),
start,
stop,
query,
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index e2c6a94..8b5b88b 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -1,11 +1,12 @@
{- directory traversal and manipulation
-
- - Copyright 2011-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Directory (
@@ -13,25 +14,28 @@ module Utility.Directory (
module Utility.SystemDirectory
) where
-import System.IO.Error
import Control.Monad
import System.FilePath
import System.PosixCompat.Files
import Control.Applicative
+import Control.Monad.IO.Class
+import Control.Monad.IfElse
import System.IO.Unsafe (unsafeInterleaveIO)
+import System.IO.Error
import Data.Maybe
import Prelude
#ifndef mingw32_HOST_OS
import Utility.SafeCommand
-import Control.Monad.IfElse
#endif
import Utility.SystemDirectory
+import Utility.Path
import Utility.Tmp
import Utility.Exception
import Utility.Monad
import Utility.Applicative
+import Utility.PartialPrelude
dirCruft :: FilePath -> Bool
dirCruft "." = True
@@ -154,3 +158,74 @@ nukeFile file = void $ tryWhenExists go
#else
go = removeFile file
#endif
+
+{- Like createDirectoryIfMissing True, but it will only create
+ - missing parent directories up to but not including the directory
+ - in the first parameter.
+ -
+ - For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz"
+ - will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist,
+ - it will throw an exception.
+ -
+ - The exception thrown is the same that createDirectory throws if the
+ - parent directory does not exist.
+ -
+ - If the second FilePath is not under the first
+ - FilePath (or the same as it), it will fail with an exception
+ - even if the second FilePath's parent directory already exists.
+ -
+ - Either or both of the FilePaths can be relative, or absolute.
+ - They will be normalized as necessary.
+ -
+ - Note that, the second FilePath, if relative, is relative to the current
+ - working directory, not to the first FilePath.
+ -}
+createDirectoryUnder :: FilePath -> FilePath -> IO ()
+createDirectoryUnder topdir dir =
+ createDirectoryUnder' topdir dir createDirectory
+
+createDirectoryUnder'
+ :: (MonadIO m, MonadCatch m)
+ => FilePath
+ -> FilePath
+ -> (FilePath -> m ())
+ -> m ()
+createDirectoryUnder' topdir dir0 mkdir = do
+ p <- liftIO $ relPathDirToFile topdir dir0
+ let dirs = splitDirectories p
+ -- Catch cases where the dir is not beneath the topdir.
+ -- If the relative path between them starts with "..",
+ -- it's not. And on Windows, if they are on different drives,
+ -- the path will not be relative.
+ if headMaybe dirs == Just ".." || isAbsolute p
+ then liftIO $ ioError $ customerror userErrorType
+ ("createDirectoryFrom: not located in " ++ topdir)
+ -- If dir0 is the same as the topdir, don't try to create
+ -- it, but make sure it does exist.
+ else if null dirs
+ then liftIO $ unlessM (doesDirectoryExist topdir) $
+ ioError $ customerror doesNotExistErrorType
+ "createDirectoryFrom: does not exist"
+ else createdirs $
+ map (topdir </>) (reverse (scanl1 (</>) dirs))
+ where
+ customerror t s = mkIOError t s Nothing (Just dir0)
+
+ createdirs [] = pure ()
+ createdirs (dir:[]) = createdir dir (liftIO . ioError)
+ createdirs (dir:dirs) = createdir dir $ \_ -> do
+ createdirs dirs
+ createdir dir (liftIO . ioError)
+
+ -- This is the same method used by createDirectoryIfMissing,
+ -- in particular the handling of errors that occur when the
+ -- directory already exists. See its source for explanation
+ -- of several subtleties.
+ createdir dir notexisthandler = tryIO (mkdir dir) >>= \case
+ Right () -> pure ()
+ Left e
+ | isDoesNotExistError e -> notexisthandler e
+ | isAlreadyExistsError e || isPermissionError e ->
+ liftIO $ unlessM (doesDirectoryExist dir) $
+ ioError e
+ | otherwise -> liftIO $ ioError e
diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs
index f9e9814..4c099ff 100644
--- a/Utility/FileSystemEncoding.hs
+++ b/Utility/FileSystemEncoding.hs
@@ -43,6 +43,7 @@ import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.UTF8 as S8
import qualified Data.ByteString.Lazy.UTF8 as L8
#endif
+import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath)
import Utility.Exception
import Utility.Split
@@ -171,21 +172,11 @@ encodeBL' = L.pack . decodeW8
encodeBL' = L8.fromString
#endif
-{- Recent versions of the unix package have this alias; defined here
- - for backwards compatibility. -}
-type RawFilePath = S.ByteString
-
-{- Note that the RawFilePath is assumed to never contain NUL,
- - since filename's don't. This should only be used with actual
- - RawFilePaths not arbitrary ByteString that may contain NUL. -}
fromRawFilePath :: RawFilePath -> FilePath
-fromRawFilePath = decodeBS'
+fromRawFilePath = decodeFilePath
-{- Note that the FilePath is assumed to never contain NUL,
- - since filename's don't. This should only be used with actual FilePaths
- - not arbitrary String that may contain NUL. -}
toRawFilePath :: FilePath -> RawFilePath
-toRawFilePath = encodeBS'
+toRawFilePath = encodeFilePath
{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.
-
diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs
index 01fbeac..d90143e 100644
--- a/Utility/HumanTime.hs
+++ b/Utility/HumanTime.hs
@@ -19,6 +19,7 @@ module Utility.HumanTime (
import Utility.PartialPrelude
import Utility.QuickCheck
+import Control.Monad.Fail as Fail (MonadFail(..))
import qualified Data.Map as M
import Data.Time.Clock
import Data.Time.Clock.POSIX (POSIXTime)
@@ -44,7 +45,7 @@ daysToDuration :: Integer -> Duration
daysToDuration i = Duration $ i * dsecs
{- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -}
-parseDuration :: Monad m => String -> m Duration
+parseDuration :: MonadFail m => String -> m Duration
parseDuration = maybe parsefail (return . Duration) . go 0
where
go n [] = return n
@@ -55,7 +56,7 @@ parseDuration = maybe parsefail (return . Duration) . go 0
u <- M.lookup c unitmap
go (n + num * u) rest
_ -> return $ n + num
- parsefail = fail "duration parse error; expected eg \"5m\" or \"1h5m\""
+ parsefail = Fail.fail "duration parse error; expected eg \"5m\" or \"1h5m\""
fromDuration :: Duration -> String
fromDuration Duration { durationSeconds = d }
diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs
new file mode 100644
index 0000000..d890fc7
--- /dev/null
+++ b/Utility/InodeCache.hs
@@ -0,0 +1,307 @@
+{- Caching a file's inode, size, and modification time
+ - to see when it's changed.
+ -
+ - Copyright 2013-2019 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Utility.InodeCache (
+ InodeCache,
+ mkInodeCache,
+ InodeComparisonType(..),
+ inodeCacheFileSize,
+
+ compareStrong,
+ compareWeak,
+ compareBy,
+
+ readInodeCache,
+ showInodeCache,
+ genInodeCache,
+ toInodeCache,
+
+ InodeCacheKey,
+ inodeCacheToKey,
+ inodeCacheToFileSize,
+ inodeCacheToMtime,
+ inodeCacheToEpochTime,
+ inodeCacheEpochTimeRange,
+
+ SentinalFile(..),
+ SentinalStatus(..),
+ TSDelta,
+ noTSDelta,
+ writeSentinalFile,
+ checkSentinalFile,
+ sentinalFileExists,
+
+ prop_read_show_inodecache
+) where
+
+import Common
+import Utility.TimeStamp
+import Utility.QuickCheck
+import qualified Utility.RawFilePath as R
+
+import System.PosixCompat.Types
+import Data.Time.Clock.POSIX
+
+#ifdef mingw32_HOST_OS
+import Data.Word (Word64)
+#else
+import System.Posix.Files
+#endif
+
+data InodeCachePrim = InodeCachePrim FileID FileSize MTime
+ deriving (Show, Eq, Ord)
+
+newtype InodeCache = InodeCache InodeCachePrim
+ deriving (Show)
+
+mkInodeCache :: FileID -> FileSize -> POSIXTime -> InodeCache
+mkInodeCache inode sz mtime = InodeCache $
+ InodeCachePrim inode sz (MTimeHighRes mtime)
+
+inodeCacheFileSize :: InodeCache -> FileSize
+inodeCacheFileSize (InodeCache (InodeCachePrim _ sz _)) = sz
+
+{- Inode caches can be compared in two different ways, either weakly
+ - or strongly. -}
+data InodeComparisonType = Weakly | Strongly
+ deriving (Eq, Ord, Show)
+
+{- Strong comparison, including inodes. -}
+compareStrong :: InodeCache -> InodeCache -> Bool
+compareStrong (InodeCache x) (InodeCache y) = x == y
+
+{- 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.
+ -
+ - The weak mtime comparison treats any mtimes that are within 2 seconds
+ - of one-another as the same. This is because FAT has only a 2 second
+ - resolution. When a FAT filesystem is used on Linux, higher resolution
+ - timestamps maybe are cached and used by Linux, but they are 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 && (abs (lowResTime mtime1 - lowResTime mtime2) < 2)
+
+compareBy :: InodeComparisonType -> InodeCache -> InodeCache -> Bool
+compareBy Strongly = compareStrong
+compareBy Weakly = compareWeak
+
+{- For use in a Map; it's determined at creation time whether this
+ - uses strong or weak comparison for Eq. -}
+data InodeCacheKey = InodeCacheKey InodeComparisonType InodeCachePrim
+ deriving (Ord, Show)
+
+instance Eq InodeCacheKey where
+ (InodeCacheKey ctx x) == (InodeCacheKey cty y) =
+ compareBy (maximum [ctx,cty]) (InodeCache x ) (InodeCache y)
+
+inodeCacheToKey :: InodeComparisonType -> InodeCache -> InodeCacheKey
+inodeCacheToKey ct (InodeCache prim) = InodeCacheKey ct prim
+
+inodeCacheToFileSize :: InodeCache -> FileSize
+inodeCacheToFileSize (InodeCache (InodeCachePrim _ sz _)) = sz
+
+inodeCacheToMtime :: InodeCache -> POSIXTime
+inodeCacheToMtime (InodeCache (InodeCachePrim _ _ mtime)) = highResTime mtime
+
+inodeCacheToEpochTime :: InodeCache -> EpochTime
+inodeCacheToEpochTime (InodeCache (InodeCachePrim _ _ mtime)) = lowResTime mtime
+
+-- Returns min, max EpochTime that weakly match the time of the InodeCache.
+inodeCacheEpochTimeRange :: InodeCache -> (EpochTime, EpochTime)
+inodeCacheEpochTimeRange i =
+ let t = inodeCacheToEpochTime i
+ in (t-1, t+1)
+
+{- For backwards compatability, support low-res mtime with no
+ - fractional seconds. -}
+data MTime = MTimeLowRes EpochTime | MTimeHighRes POSIXTime
+ deriving (Show, Ord)
+
+{- A low-res time compares equal to any high-res time in the same second. -}
+instance Eq MTime where
+ MTimeLowRes a == MTimeLowRes b = a == b
+ MTimeHighRes a == MTimeHighRes b = a == b
+ MTimeHighRes a == MTimeLowRes b = lowResTime a == b
+ MTimeLowRes a == MTimeHighRes b = a == lowResTime b
+
+class MultiResTime t where
+ lowResTime :: t -> EpochTime
+ highResTime :: t -> POSIXTime
+
+instance MultiResTime EpochTime where
+ lowResTime = id
+ highResTime = realToFrac
+
+instance MultiResTime POSIXTime where
+ lowResTime = fromInteger . floor
+ highResTime = id
+
+instance MultiResTime MTime where
+ lowResTime (MTimeLowRes t) = t
+ lowResTime (MTimeHighRes t) = lowResTime t
+ highResTime (MTimeLowRes t) = highResTime t
+ highResTime (MTimeHighRes t) = t
+
+showInodeCache :: InodeCache -> String
+showInodeCache (InodeCache (InodeCachePrim inode size (MTimeHighRes mtime))) =
+ let (t, d) = separate (== '.') (takeWhile (/= 's') (show mtime))
+ in unwords
+ [ show inode
+ , show size
+ , t
+ , d
+ ]
+showInodeCache (InodeCache (InodeCachePrim inode size (MTimeLowRes mtime))) =
+ unwords
+ [ show inode
+ , show size
+ , show mtime
+ ]
+
+readInodeCache :: String -> Maybe InodeCache
+readInodeCache s = case words s of
+ (inode:size:mtime:[]) -> do
+ i <- readish inode
+ sz <- readish size
+ t <- readish mtime
+ return $ InodeCache $ InodeCachePrim i sz (MTimeLowRes t)
+ (inode:size:mtime:mtimedecimal:_) -> do
+ i <- readish inode
+ sz <- readish size
+ t <- parsePOSIXTime $ mtime ++ '.' : mtimedecimal
+ return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t)
+ _ -> Nothing
+
+genInodeCache :: RawFilePath -> TSDelta -> IO (Maybe InodeCache)
+genInodeCache f delta = catchDefaultIO Nothing $
+ toInodeCache delta (fromRawFilePath f) =<< R.getFileStatus f
+
+toInodeCache :: TSDelta -> FilePath -> FileStatus -> IO (Maybe InodeCache)
+toInodeCache (TSDelta getdelta) f s
+ | isRegularFile s = do
+ delta <- getdelta
+ sz <- getFileSize' f s
+#ifdef mingw32_HOST_OS
+ mtime <- utcTimeToPOSIXSeconds <$> getModificationTime f
+#else
+ let mtime = modificationTimeHiRes s
+#endif
+ return $ Just $ InodeCache $ InodeCachePrim (fileID s) sz (MTimeHighRes (mtime + highResTime 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 :: RawFilePath
+ , sentinalCacheFile :: RawFilePath
+ }
+ 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 (fromRawFilePath (sentinalFile s)) ""
+ maybe noop (writeFile (fromRawFilePath (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 (fromRawFilePath (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
+ -- Since mtime can appear to change when the time zone is
+ -- changed in windows, we cannot look at the mtime for the
+ -- sentinal file.
+ unchanged = oldinode == newinode && oldsize == newsize && (newmtime == newmtime)
+ tsdelta = TSDelta $ do
+ -- Run when generating an InodeCache,
+ -- to get the current delta.
+ mnew <- gennewcache
+ return $ case mnew of
+ Just (InodeCache (InodeCachePrim _ _ currmtime)) ->
+ lowResTime oldmtime - lowResTime 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 R.doesPathExist [sentinalCacheFile s, sentinalFile s]
+
+instance Arbitrary InodeCache where
+ arbitrary =
+ let prim = InodeCachePrim
+ <$> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ in InodeCache <$> prim
+
+instance Arbitrary MTime where
+ arbitrary = frequency
+ -- timestamp is not usually negative
+ [ (50, MTimeLowRes <$> (abs . fromInteger <$> arbitrary))
+ , (50, MTimeHighRes <$> arbitrary)
+ ]
+
+#ifdef mingw32_HOST_OS
+instance Arbitrary FileID where
+ arbitrary = fromIntegral <$> (arbitrary :: Gen Word64)
+#endif
+
+prop_read_show_inodecache :: InodeCache -> Bool
+prop_read_show_inodecache c = case readInodeCache (showInodeCache c) of
+ Nothing -> False
+ Just c' -> compareStrong c c'
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 2f1766e..01ae178 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -11,6 +11,7 @@ module Utility.Misc (
hGetContentsStrict,
readFileStrict,
separate,
+ separate',
firstLine,
firstLine',
segment,
@@ -54,6 +55,13 @@ separate c l = unbreak $ break c l
| null b = r
| otherwise = (a, tail b)
+separate' :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString)
+separate' c l = unbreak $ S.break c l
+ where
+ unbreak r@(a, b)
+ | S.null b = r
+ | otherwise = (a, S.tail b)
+
{- Breaks out the first line. -}
firstLine :: String -> String
firstLine = takeWhile (/= '\n')
diff --git a/Utility/Path.hs b/Utility/Path.hs
index ecc752c..a8ab918 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -41,7 +41,7 @@ import Prelude
import Utility.Monad
import Utility.UserInfo
-import Utility.Directory
+import Utility.SystemDirectory
import Utility.Split
import Utility.FileSystemEncoding
@@ -74,6 +74,8 @@ simplifyPath path = dropTrailingPathSeparator $
{- Makes a path absolute.
-
+ - Also simplifies it using simplifyPath.
+ -
- The first parameter is a base directory (ie, the cwd) to use if the path
- is not already absolute, and should itsef be absolute.
-
@@ -124,12 +126,19 @@ dirContains a b = a == b
{- Converts a filename into an absolute path.
-
+ - Also simplifies it using simplifyPath.
+ -
- Unlike Directory.canonicalizePath, this does not require the path
- already exists. -}
absPath :: FilePath -> IO FilePath
-absPath file = do
- cwd <- getCurrentDirectory
- return $ absPathFrom cwd file
+absPath file
+ -- Avoid unncessarily getting the current directory when the path
+ -- is already absolute. absPathFrom uses simplifyPath
+ -- so also used here for consistency.
+ | isAbsolute file = return $ simplifyPath file
+ | otherwise = do
+ cwd <- getCurrentDirectory
+ return $ absPathFrom cwd file
{- Constructs a relative path from the CWD to a file.
-
diff --git a/Utility/Process.hs b/Utility/Process.hs
index af3a5f4..e7142b9 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -1,7 +1,7 @@
{- System.Process enhancements, including additional ways of running
- processes, and logging.
-
- - Copyright 2012-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -53,6 +53,7 @@ import System.Log.Logger
import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad
+import qualified Data.ByteString as S
type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
@@ -85,25 +86,20 @@ writeReadProcessEnv
-> [String]
-> Maybe [(String, String)]
-> (Maybe (Handle -> IO ()))
- -> (Maybe (Handle -> IO ()))
- -> IO String
-writeReadProcessEnv cmd args environ writestdin adjusthandle = do
+ -> IO S.ByteString
+writeReadProcessEnv cmd args environ writestdin = do
(Just inh, Just outh, _, pid) <- createProcess p
- maybe (return ()) (\a -> a inh) adjusthandle
- maybe (return ()) (\a -> a outh) adjusthandle
-
-- fork off a thread to start consuming the output
- output <- hGetContents outh
outMVar <- newEmptyMVar
- _ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()
+ _ <- forkIO $ putMVar outMVar =<< S.hGetContents outh
-- now write and flush any input
maybe (return ()) (\a -> a inh >> hFlush inh) writestdin
hClose inh -- done with stdin
-- wait on the output
- takeMVar outMVar
+ output <- takeMVar outMVar
hClose outh
-- wait on the process
diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs
new file mode 100644
index 0000000..6a5f704
--- /dev/null
+++ b/Utility/RawFilePath.hs
@@ -0,0 +1,50 @@
+{- Portability shim around System.Posix.Files.ByteString
+ -
+ - On unix, this makes syscalls using RawFilesPaths as efficiently as
+ - possible.
+ -
+ - On Windows, filenames are in unicode, so RawFilePaths have to be
+ - decoded. So this library will work, but less efficiently than using
+ - FilePath would.
+ -
+ - Copyright 2019 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.RawFilePath (
+ RawFilePath,
+ readSymbolicLink,
+ getFileStatus,
+ getSymbolicLinkStatus,
+ doesPathExist,
+) where
+
+#ifndef mingw32_HOST_OS
+import Utility.FileSystemEncoding (RawFilePath)
+import System.Posix.Files.ByteString
+
+doesPathExist :: RawFilePath -> IO Bool
+doesPathExist = fileExist
+
+#else
+import qualified Data.ByteString as B
+import System.PosixCompat (FileStatus)
+import qualified System.PosixCompat as P
+import qualified System.Directory as D
+import Utility.FileSystemEncoding
+
+readSymbolicLink :: RawFilePath -> IO RawFilePath
+readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f)
+
+getFileStatus :: RawFilePath -> IO FileStatus
+getFileStatus = P.getFileStatus . fromRawFilePath
+
+getSymbolicLinkStatus :: RawFilePath -> IO FileStatus
+getSymbolicLinkStatus = P.getSymbolicLinkStatus . fromRawFilePath
+
+doesPathExist :: RawFilePath -> IO Bool
+doesPathExist = D.doesPathExist . fromRawFilePath
+#endif
diff --git a/Utility/TimeStamp.hs b/Utility/TimeStamp.hs
new file mode 100644
index 0000000..b740d7b
--- /dev/null
+++ b/Utility/TimeStamp.hs
@@ -0,0 +1,58 @@
+{- timestamp parsing and formatting
+ -
+ - Copyright 2015-2019 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.TimeStamp (
+ parserPOSIXTime,
+ parsePOSIXTime,
+ formatPOSIXTime,
+) where
+
+import Utility.Data
+
+import Data.Time.Clock.POSIX
+import Data.Time
+import Data.Ratio
+import Control.Applicative
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.Attoparsec.ByteString as A
+import Data.Attoparsec.ByteString.Char8 (char, decimal, signed, isDigit_w8)
+
+{- Parses how POSIXTime shows itself: "1431286201.113452s"
+ - (The "s" is included for historical reasons and is optional.)
+ - Also handles the format with no decimal seconds. -}
+parserPOSIXTime :: A.Parser POSIXTime
+parserPOSIXTime = mkPOSIXTime
+ <$> signed decimal
+ <*> (declen <|> pure (0, 0))
+ <* optional (char 's')
+ where
+ declen :: A.Parser (Integer, Int)
+ declen = do
+ _ <- char '.'
+ b <- A.takeWhile isDigit_w8
+ let len = B.length b
+ d <- either fail pure $
+ A.parseOnly (decimal <* A.endOfInput) b
+ return (d, len)
+
+parsePOSIXTime :: String -> Maybe POSIXTime
+parsePOSIXTime s = eitherToMaybe $
+ A.parseOnly (parserPOSIXTime <* A.endOfInput) (B8.pack s)
+
+{- This implementation allows for higher precision in a POSIXTime than
+ - supported by the system's Double, and avoids the complications of
+ - floating point. -}
+mkPOSIXTime :: Integer -> (Integer, Int) -> POSIXTime
+mkPOSIXTime n (d, dlen)
+ | n < 0 = fromIntegral n - fromRational r
+ | otherwise = fromIntegral n + fromRational r
+ where
+ r = d % (10 ^ dlen)
+
+formatPOSIXTime :: String -> POSIXTime -> String
+formatPOSIXTime fmt t = formatTime defaultTimeLocale fmt (posixSecondsToUTCTime t)