From 8c4352a0a544b2e5a4ed717999fc7c6ecb0a328f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 4 May 2020 15:38:39 -0400 Subject: merge from git-annex * Improve fetching from a remote with an url in host:path format. * Merge from git-annex. --- Utility/CoProcess.hs | 1 + Utility/Directory.hs | 81 ++++++++++- Utility/FileSystemEncoding.hs | 15 +-- Utility/HumanTime.hs | 5 +- Utility/InodeCache.hs | 307 ++++++++++++++++++++++++++++++++++++++++++ Utility/Misc.hs | 8 ++ Utility/Path.hs | 17 ++- Utility/Process.hs | 16 +-- Utility/RawFilePath.hs | 50 +++++++ Utility/TimeStamp.hs | 58 ++++++++ 10 files changed, 527 insertions(+), 31 deletions(-) create mode 100644 Utility/InodeCache.hs create mode 100644 Utility/RawFilePath.hs create mode 100644 Utility/TimeStamp.hs (limited to 'Utility') 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 + - Copyright 2011-2020 Joey Hess - - 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 + - + - 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 @@ -73,6 +73,8 @@ simplifyPath path = dropTrailingPathSeparator $ p' = dropTrailingPathSeparator p {- 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. @@ -123,13 +125,20 @@ dirContains a b = a == b norm = normalise . simplifyPath {- 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 + - Copyright 2012-2020 Joey Hess - - 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 + - + - 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 + - + - 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) -- cgit v1.2.3