summaryrefslogtreecommitdiff
path: root/src/Utility
diff options
context:
space:
mode:
authorJoey Hess2014-05-14 19:41:05 -0400
committerJoey Hess2014-05-14 19:41:05 -0400
commit7115d1ec162b4059b3e8e8f84bd8d5898c1db025 (patch)
tree42c1cce54e890e1d56484794ab33129132d8fee2 /src/Utility
parentffe371a9d42cded461236e972a24a142419d7fc4 (diff)
moved source code to src
This is to work around OSX's brain-damange regarding filename case insensitivity. Avoided moving config.hs, because it's a config file. Put in a symlink to make build work.
Diffstat (limited to 'src/Utility')
-rw-r--r--src/Utility/Applicative.hs16
-rw-r--r--src/Utility/Data.hs17
-rw-r--r--src/Utility/Directory.hs135
-rw-r--r--src/Utility/Env.hs81
-rw-r--r--src/Utility/Exception.hs59
-rw-r--r--src/Utility/FileMode.hs158
-rw-r--r--src/Utility/FileSystemEncoding.hs132
-rw-r--r--src/Utility/LinuxMkLibs.hs61
-rw-r--r--src/Utility/Misc.hs148
-rw-r--r--src/Utility/Monad.hs69
-rw-r--r--src/Utility/PartialPrelude.hs68
-rw-r--r--src/Utility/Path.hs293
-rw-r--r--src/Utility/PosixFiles.hs33
-rw-r--r--src/Utility/Process.hs364
-rw-r--r--src/Utility/QuickCheck.hs52
-rw-r--r--src/Utility/SafeCommand.hs120
-rw-r--r--src/Utility/Scheduled.hs396
-rw-r--r--src/Utility/ThreadScheduler.hs75
-rw-r--r--src/Utility/Tmp.hs100
-rw-r--r--src/Utility/UserInfo.hs55
20 files changed, 2432 insertions, 0 deletions
diff --git a/src/Utility/Applicative.hs b/src/Utility/Applicative.hs
new file mode 100644
index 00000000..fd8944b2
--- /dev/null
+++ b/src/Utility/Applicative.hs
@@ -0,0 +1,16 @@
+{- applicative stuff
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.Applicative where
+
+{- Like <$> , but supports one level of currying.
+ -
+ - foo v = bar <$> action v == foo = bar <$$> action
+ -}
+(<$$>) :: Functor f => (a -> b) -> (c -> f a) -> c -> f b
+f <$$> v = fmap f . v
+infixr 4 <$$>
diff --git a/src/Utility/Data.hs b/src/Utility/Data.hs
new file mode 100644
index 00000000..2df12b36
--- /dev/null
+++ b/src/Utility/Data.hs
@@ -0,0 +1,17 @@
+{- utilities for simple data types
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.Data where
+
+{- First item in the list that is not Nothing. -}
+firstJust :: Eq a => [Maybe a] -> Maybe a
+firstJust ms = case dropWhile (== Nothing) ms of
+ [] -> Nothing
+ (md:_) -> md
+
+eitherToMaybe :: Either a b -> Maybe b
+eitherToMaybe = either (const Nothing) Just
diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs
new file mode 100644
index 00000000..d92327c0
--- /dev/null
+++ b/src/Utility/Directory.hs
@@ -0,0 +1,135 @@
+{- directory manipulation
+ -
+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.Directory where
+
+import System.IO.Error
+import System.Directory
+import Control.Exception (throw)
+import Control.Monad
+import Control.Monad.IfElse
+import System.FilePath
+import Control.Applicative
+import System.IO.Unsafe (unsafeInterleaveIO)
+
+import Utility.PosixFiles
+import Utility.SafeCommand
+import Utility.Tmp
+import Utility.Exception
+import Utility.Monad
+import Utility.Applicative
+
+dirCruft :: FilePath -> Bool
+dirCruft "." = True
+dirCruft ".." = True
+dirCruft _ = False
+
+{- Lists the contents of a directory.
+ - Unlike getDirectoryContents, paths are not relative to the directory. -}
+dirContents :: FilePath -> IO [FilePath]
+dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
+
+{- Gets files in a directory, and then its subdirectories, recursively,
+ - and lazily.
+ -
+ - Does not follow symlinks to other subdirectories.
+ -
+ - When the directory does not exist, no exception is thrown,
+ - instead, [] is returned. -}
+dirContentsRecursive :: FilePath -> IO [FilePath]
+dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
+
+{- Skips directories whose basenames match the skipdir. -}
+dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
+dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
+ where
+ go [] = return []
+ go (dir:dirs)
+ | skipdir (takeFileName dir) = go dirs
+ | otherwise = unsafeInterleaveIO $ do
+ (files, dirs') <- collect [] []
+ =<< catchDefaultIO [] (dirContents dir)
+ files' <- go (dirs' ++ dirs)
+ return (files ++ files')
+ collect files dirs' [] = return (reverse files, reverse dirs')
+ collect files dirs' (entry:entries)
+ | dirCruft entry = collect files dirs' entries
+ | otherwise = do
+ let skip = collect (entry:files) dirs' entries
+ let recurse = collect files (entry:dirs') entries
+ ms <- catchMaybeIO $ getSymbolicLinkStatus entry
+ case ms of
+ (Just s)
+ | isDirectory s -> recurse
+ | isSymbolicLink s && followsubdirsymlinks ->
+ ifM (doesDirectoryExist entry)
+ ( recurse
+ , skip
+ )
+ _ -> skip
+
+{- Gets the directory tree from a point, recursively and lazily,
+ - with leaf directories **first**, skipping any whose basenames
+ - match the skipdir. Does not follow symlinks. -}
+dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
+dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]
+ where
+ go c [] = return c
+ go c (dir:dirs)
+ | skipdir (takeFileName dir) = go c dirs
+ | otherwise = unsafeInterleaveIO $ do
+ subdirs <- go c
+ =<< filterM (isDirectory <$$> getSymbolicLinkStatus)
+ =<< catchDefaultIO [] (dirContents dir)
+ go (subdirs++[dir]) dirs
+
+{- Moves one filename to another.
+ - First tries a rename, but falls back to moving across devices if needed. -}
+moveFile :: FilePath -> FilePath -> IO ()
+moveFile src dest = tryIO (rename src dest) >>= onrename
+ where
+ onrename (Right _) = noop
+ onrename (Left e)
+ | isPermissionError e = rethrow
+ | isDoesNotExistError e = rethrow
+ | otherwise = do
+ -- copyFile is likely not as optimised as
+ -- the mv command, so we'll use the latter.
+ -- But, mv will move into a directory if
+ -- dest is one, which is not desired.
+ whenM (isdir dest) rethrow
+ viaTmp mv dest undefined
+ where
+ rethrow = throw e
+ mv tmp _ = do
+ ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]
+ unless ok $ do
+ -- delete any partial
+ _ <- tryIO $ removeFile tmp
+ rethrow
+
+ isdir f = do
+ r <- tryIO $ getFileStatus f
+ case r of
+ (Left _) -> return False
+ (Right s) -> return $ isDirectory s
+
+{- Removes a file, which may or may not exist, and does not have to
+ - be a regular file.
+ -
+ - Note that an exception is thrown if the file exists but
+ - cannot be removed. -}
+nukeFile :: FilePath -> IO ()
+nukeFile file = void $ tryWhenExists go
+ where
+#ifndef mingw32_HOST_OS
+ go = removeLink file
+#else
+ go = removeFile file
+#endif
diff --git a/src/Utility/Env.hs b/src/Utility/Env.hs
new file mode 100644
index 00000000..6763c24e
--- /dev/null
+++ b/src/Utility/Env.hs
@@ -0,0 +1,81 @@
+{- portable environment variables
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.Env where
+
+#ifdef mingw32_HOST_OS
+import Utility.Exception
+import Control.Applicative
+import Data.Maybe
+import qualified System.Environment as E
+#else
+import qualified System.Posix.Env as PE
+#endif
+
+getEnv :: String -> IO (Maybe String)
+#ifndef mingw32_HOST_OS
+getEnv = PE.getEnv
+#else
+getEnv = catchMaybeIO . E.getEnv
+#endif
+
+getEnvDefault :: String -> String -> IO String
+#ifndef mingw32_HOST_OS
+getEnvDefault = PE.getEnvDefault
+#else
+getEnvDefault var fallback = fromMaybe fallback <$> getEnv var
+#endif
+
+getEnvironment :: IO [(String, String)]
+#ifndef mingw32_HOST_OS
+getEnvironment = PE.getEnvironment
+#else
+getEnvironment = E.getEnvironment
+#endif
+
+{- Returns True if it could successfully set the environment variable.
+ -
+ - There is, apparently, no way to do this in Windows. Instead,
+ - environment varuables must be provided when running a new process. -}
+setEnv :: String -> String -> Bool -> IO Bool
+#ifndef mingw32_HOST_OS
+setEnv var val overwrite = do
+ PE.setEnv var val overwrite
+ return True
+#else
+setEnv _ _ _ = return False
+#endif
+
+{- Returns True if it could successfully unset the environment variable. -}
+unsetEnv :: String -> IO Bool
+#ifndef mingw32_HOST_OS
+unsetEnv var = do
+ PE.unsetEnv var
+ return True
+#else
+unsetEnv _ = return False
+#endif
+
+{- Adds the environment variable to the input environment. If already
+ - present in the list, removes the old value.
+ -
+ - This does not really belong here, but Data.AssocList is for some reason
+ - buried inside hxt.
+ -}
+addEntry :: Eq k => k -> v -> [(k, v)] -> [(k, v)]
+addEntry k v l = ( (k,v) : ) $! delEntry k l
+
+addEntries :: Eq k => [(k, v)] -> [(k, v)] -> [(k, v)]
+addEntries = foldr (.) id . map (uncurry addEntry) . reverse
+
+delEntry :: Eq k => k -> [(k, v)] -> [(k, v)]
+delEntry _ [] = []
+delEntry k (x@(k1,_) : rest)
+ | k == k1 = rest
+ | otherwise = ( x : ) $! delEntry k rest
diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs
new file mode 100644
index 00000000..1fecf65d
--- /dev/null
+++ b/src/Utility/Exception.hs
@@ -0,0 +1,59 @@
+{- Simple IO exception handling (and some more)
+ -
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Utility.Exception where
+
+import Control.Exception
+import qualified Control.Exception as E
+import Control.Applicative
+import Control.Monad
+import System.IO.Error (isDoesNotExistError)
+import Utility.Data
+
+{- Catches IO errors and returns a Bool -}
+catchBoolIO :: IO Bool -> IO Bool
+catchBoolIO = catchDefaultIO False
+
+{- Catches IO errors and returns a Maybe -}
+catchMaybeIO :: IO a -> IO (Maybe a)
+catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a
+
+{- Catches IO errors and returns a default value. -}
+catchDefaultIO :: a -> IO a -> IO a
+catchDefaultIO def a = catchIO a (const $ return def)
+
+{- Catches IO errors and returns the error message. -}
+catchMsgIO :: IO a -> IO (Either String a)
+catchMsgIO a = either (Left . show) Right <$> tryIO a
+
+{- catch specialized for IO errors only -}
+catchIO :: IO a -> (IOException -> IO a) -> IO a
+catchIO = E.catch
+
+{- try specialized for IO errors only -}
+tryIO :: IO a -> IO (Either IOException a)
+tryIO = try
+
+{- Catches all exceptions except for async exceptions.
+ - This is often better to use than catching them all, so that
+ - ThreadKilled and UserInterrupt get through.
+ -}
+catchNonAsync :: IO a -> (SomeException -> IO a) -> IO a
+catchNonAsync a onerr = a `catches`
+ [ Handler (\ (e :: AsyncException) -> throw e)
+ , Handler (\ (e :: SomeException) -> onerr e)
+ ]
+
+tryNonAsync :: IO a -> IO (Either SomeException a)
+tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left)
+
+{- Catches only DoesNotExist exceptions, and lets all others through. -}
+tryWhenExists :: IO a -> IO (Maybe a)
+tryWhenExists a = eitherToMaybe <$>
+ tryJust (guard . isDoesNotExistError) a
diff --git a/src/Utility/FileMode.hs b/src/Utility/FileMode.hs
new file mode 100644
index 00000000..c2ef683a
--- /dev/null
+++ b/src/Utility/FileMode.hs
@@ -0,0 +1,158 @@
+{- File mode utilities.
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.FileMode where
+
+import System.IO
+import Control.Monad
+import Control.Exception (bracket)
+import System.PosixCompat.Types
+import Utility.PosixFiles
+#ifndef mingw32_HOST_OS
+import System.Posix.Files
+#endif
+import Foreign (complement)
+
+import Utility.Exception
+
+{- Applies a conversion function to a file's mode. -}
+modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()
+modifyFileMode f convert = void $ modifyFileMode' f convert
+modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode
+modifyFileMode' f convert = do
+ s <- getFileStatus f
+ let old = fileMode s
+ let new = convert old
+ when (new /= old) $
+ setFileMode f new
+ return old
+
+{- Adds the specified FileModes to the input mode, leaving the rest
+ - unchanged. -}
+addModes :: [FileMode] -> FileMode -> FileMode
+addModes ms m = combineModes (m:ms)
+
+{- Removes the specified FileModes from the input mode. -}
+removeModes :: [FileMode] -> FileMode -> FileMode
+removeModes ms m = m `intersectFileModes` complement (combineModes ms)
+
+{- Runs an action after changing a file's mode, then restores the old mode. -}
+withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
+withModifiedFileMode file convert a = bracket setup cleanup go
+ where
+ setup = modifyFileMode' file convert
+ cleanup oldmode = modifyFileMode file (const oldmode)
+ go _ = a
+
+writeModes :: [FileMode]
+writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]
+
+readModes :: [FileMode]
+readModes = [ownerReadMode, groupReadMode, otherReadMode]
+
+executeModes :: [FileMode]
+executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]
+
+otherGroupModes :: [FileMode]
+otherGroupModes =
+ [ groupReadMode, otherReadMode
+ , groupWriteMode, otherWriteMode
+ ]
+
+{- Removes the write bits from a file. -}
+preventWrite :: FilePath -> IO ()
+preventWrite f = modifyFileMode f $ removeModes writeModes
+
+{- Turns a file's owner write bit back on. -}
+allowWrite :: FilePath -> IO ()
+allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]
+
+{- Turns a file's owner read bit back on. -}
+allowRead :: FilePath -> IO ()
+allowRead f = modifyFileMode f $ addModes [ownerReadMode]
+
+{- Allows owner and group to read and write to a file. -}
+groupSharedModes :: [FileMode]
+groupSharedModes =
+ [ ownerWriteMode, groupWriteMode
+ , ownerReadMode, groupReadMode
+ ]
+
+groupWriteRead :: FilePath -> IO ()
+groupWriteRead f = modifyFileMode f $ addModes groupSharedModes
+
+checkMode :: FileMode -> FileMode -> Bool
+checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor
+
+{- Checks if a file mode indicates it's a symlink. -}
+isSymLink :: FileMode -> Bool
+#ifdef mingw32_HOST_OS
+isSymLink _ = False
+#else
+isSymLink = checkMode symbolicLinkMode
+#endif
+
+{- Checks if a file has any executable bits set. -}
+isExecutable :: FileMode -> Bool
+isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0
+
+{- Runs an action without that pesky umask influencing it, unless the
+ - passed FileMode is the standard one. -}
+noUmask :: FileMode -> IO a -> IO a
+#ifndef mingw32_HOST_OS
+noUmask mode a
+ | mode == stdFileMode = a
+ | otherwise = withUmask nullFileMode a
+#else
+noUmask _ a = a
+#endif
+
+withUmask :: FileMode -> IO a -> IO a
+#ifndef mingw32_HOST_OS
+withUmask umask a = bracket setup cleanup go
+ where
+ setup = setFileCreationMask umask
+ cleanup = setFileCreationMask
+ go _ = a
+#else
+withUmask _ a = a
+#endif
+
+combineModes :: [FileMode] -> FileMode
+combineModes [] = undefined
+combineModes [m] = m
+combineModes (m:ms) = foldl unionFileModes m ms
+
+isSticky :: FileMode -> Bool
+#ifdef mingw32_HOST_OS
+isSticky _ = False
+#else
+isSticky = checkMode stickyMode
+
+stickyMode :: FileMode
+stickyMode = 512
+
+setSticky :: FilePath -> IO ()
+setSticky f = modifyFileMode f $ addModes [stickyMode]
+#endif
+
+{- Writes a file, ensuring that its modes do not allow it to be read
+ - or written by anyone other than the current user,
+ - before any content is written.
+ -
+ - When possible, this is done using the umask.
+ -
+ - On a filesystem that does not support file permissions, this is the same
+ - as writeFile.
+ -}
+writeFileProtected :: FilePath -> String -> IO ()
+writeFileProtected file content = withUmask 0o0077 $
+ withFile file WriteMode $ \h -> do
+ void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
+ hPutStr h content
diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs
new file mode 100644
index 00000000..b81fdc53
--- /dev/null
+++ b/src/Utility/FileSystemEncoding.hs
@@ -0,0 +1,132 @@
+{- GHC File system encoding handling.
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.FileSystemEncoding (
+ fileEncoding,
+ withFilePath,
+ md5FilePath,
+ decodeBS,
+ decodeW8,
+ encodeW8,
+ truncateFilePath,
+) where
+
+import qualified GHC.Foreign as GHC
+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 qualified Data.ByteString.Lazy as L
+#ifdef mingw32_HOST_OS
+import qualified Data.ByteString.Lazy.UTF8 as L8
+#endif
+
+{- Sets a Handle to use the filesystem encoding. This causes data
+ - written or read from it to be encoded/decoded the same
+ - as ghc 7.4 does to filenames etc. This special encoding
+ - allows "arbitrary undecodable bytes to be round-tripped through it".
+ -}
+fileEncoding :: Handle -> IO ()
+#ifndef mingw32_HOST_OS
+fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding
+#else
+{- The file system encoding does not work well on Windows,
+ - and Windows only has utf FilePaths anyway. -}
+fileEncoding h = hSetEncoding h Encoding.utf8
+#endif
+
+{- Marshal a Haskell FilePath into a NUL terminated C string using temporary
+ - storage. The FilePath is encoded using the filesystem encoding,
+ - reversing the decoding that should have been done when the FilePath
+ - was obtained. -}
+withFilePath :: FilePath -> (CString -> IO a) -> IO a
+withFilePath fp f = Encoding.getFileSystemEncoding
+ >>= \enc -> GHC.withCString enc fp f
+
+{- Encodes a FilePath into a String, applying the filesystem encoding.
+ -
+ - There are very few things it makes sense to do with such an encoded
+ - string. It's not a legal filename; it should not be displayed.
+ - So this function is not exported, but instead used by the few functions
+ - that can usefully consume it.
+ -
+ - This use of unsafePerformIO is belived to be safe; GHC's interface
+ - only allows doing this conversion with CStrings, and the CString buffer
+ - is allocated, used, and deallocated within the call, with no side
+ - effects.
+ -}
+{-# NOINLINE _encodeFilePath #-}
+_encodeFilePath :: FilePath -> String
+_encodeFilePath fp = unsafePerformIO $ do
+ enc <- Encoding.getFileSystemEncoding
+ GHC.withCString enc fp $ GHC.peekCString Encoding.char8
+
+{- 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
+decodeBS = encodeW8 . L.unpack
+#else
+{- On Windows, we assume that the ByteString is utf-8, since Windows
+ - only uses unicode for filenames. -}
+decodeBS = L8.toString
+#endif
+
+{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.
+ -
+ - w82c produces a String, which may contain Chars that are invalid
+ - unicode. From there, this is really a simple matter of applying the
+ - file system encoding, only complicated by GHC's interface to doing so.
+ -}
+{-# NOINLINE encodeW8 #-}
+encodeW8 :: [Word8] -> FilePath
+encodeW8 w8 = unsafePerformIO $ do
+ enc <- Encoding.getFileSystemEncoding
+ GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc
+
+{- Useful when you want the actual number of bytes that will be used to
+ - represent the FilePath on disk. -}
+decodeW8 :: FilePath -> [Word8]
+decodeW8 = s2w8 . _encodeFilePath
+
+{- Truncates a FilePath to the given number of bytes (or less),
+ - as represented on disk.
+ -
+ - Avoids returning an invalid part of a unicode byte sequence, at the
+ - cost of efficiency when running on a large FilePath.
+ -}
+truncateFilePath :: Int -> FilePath -> FilePath
+#ifndef mingw32_HOST_OS
+truncateFilePath n = go . reverse
+ where
+ go f =
+ let bytes = decodeW8 f
+ in if length bytes <= n
+ then reverse f
+ else go (drop 1 f)
+#else
+{- On Windows, count the number of bytes used by each utf8 character. -}
+truncateFilePath n = reverse . go [] n . L8.fromString
+ where
+ go coll cnt bs
+ | cnt <= 0 = coll
+ | otherwise = case L8.decode bs of
+ Just (c, x) | c /= L8.replacement_char ->
+ let x' = fromIntegral x
+ in if cnt - x' < 0
+ then coll
+ else go (c:coll) (cnt - x') (L8.drop 1 bs)
+ _ -> coll
+#endif
diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs
new file mode 100644
index 00000000..1dc4e1ea
--- /dev/null
+++ b/src/Utility/LinuxMkLibs.hs
@@ -0,0 +1,61 @@
+{- Linux library copier and binary shimmer
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.LinuxMkLibs where
+
+import Control.Applicative
+import Data.Maybe
+import System.Directory
+import Data.List.Utils
+import System.Posix.Files
+import Data.Char
+import Control.Monad.IfElse
+
+import Utility.PartialPrelude
+import Utility.Directory
+import Utility.Process
+import Utility.Monad
+import Utility.Path
+
+{- Installs a library. If the library is a symlink to another file,
+ - install the file it links to, and update the symlink to be relative. -}
+installLib :: (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO (Maybe FilePath)
+installLib installfile top lib = ifM (doesFileExist lib)
+ ( do
+ installfile top lib
+ checksymlink lib
+ return $ Just $ parentDir lib
+ , return Nothing
+ )
+ where
+ checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do
+ l <- readSymbolicLink (inTop top f)
+ let absl = absPathFrom (parentDir f) l
+ let target = relPathDirToFile (parentDir f) absl
+ installfile top absl
+ nukeFile (top ++ f)
+ createSymbolicLink target (inTop top f)
+ checksymlink absl
+
+-- Note that f is not relative, so cannot use </>
+inTop :: FilePath -> FilePath -> FilePath
+inTop top f = top ++ f
+
+{- Parse ldd output, getting all the libraries that the input files
+ - link to. Note that some of the libraries may not exist
+ - (eg, linux-vdso.so) -}
+parseLdd :: String -> [FilePath]
+parseLdd = mapMaybe (getlib . dropWhile isSpace) . lines
+ where
+ getlib l = headMaybe . words =<< lastMaybe (split " => " l)
+
+{- Get all glibc libs and other support files, including gconv files
+ -
+ - XXX Debian specific. -}
+glibcLibs :: IO [FilePath]
+glibcLibs = lines <$> readProcess "sh"
+ ["-c", "dpkg -L libc6:$(dpkg --print-architecture) libgcc1:$(dpkg --print-architecture) | egrep '\\.so|gconv'"]
diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs
new file mode 100644
index 00000000..949f41e7
--- /dev/null
+++ b/src/Utility/Misc.hs
@@ -0,0 +1,148 @@
+{- misc utility functions
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.Misc where
+
+import System.IO
+import Control.Monad
+import Foreign
+import Data.Char
+import Data.List
+import Control.Applicative
+import System.Exit
+#ifndef mingw32_HOST_OS
+import System.Posix.Process (getAnyProcessStatus)
+import Utility.Exception
+#endif
+
+import Utility.FileSystemEncoding
+import Utility.Monad
+
+{- A version of hgetContents that is not lazy. Ensures file is
+ - all read before it gets closed. -}
+hGetContentsStrict :: Handle -> IO String
+hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s
+
+{- A version of readFile that is not lazy. -}
+readFileStrict :: FilePath -> IO String
+readFileStrict = readFile >=> \s -> length s `seq` return s
+
+{- Reads a file strictly, and using the FileSystemEncoding, so it will
+ - never crash on a badly encoded file. -}
+readFileStrictAnyEncoding :: FilePath -> IO String
+readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do
+ fileEncoding h
+ hClose h `after` hGetContentsStrict h
+
+{- Writes a file, using the FileSystemEncoding so it will never crash
+ - on a badly encoded content string. -}
+writeFileAnyEncoding :: FilePath -> String -> IO ()
+writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do
+ fileEncoding h
+ hPutStr h content
+
+{- Like break, but the item matching the condition is not included
+ - in the second result list.
+ -
+ - separate (== ':') "foo:bar" = ("foo", "bar")
+ - separate (== ':') "foobar" = ("foobar", "")
+ -}
+separate :: (a -> Bool) -> [a] -> ([a], [a])
+separate c l = unbreak $ break c l
+ where
+ unbreak r@(a, b)
+ | null b = r
+ | otherwise = (a, tail b)
+
+{- Breaks out the first line. -}
+firstLine :: String -> String
+firstLine = takeWhile (/= '\n')
+
+{- Splits a list into segments that are delimited by items matching
+ - a predicate. (The delimiters are not included in the segments.)
+ - Segments may be empty. -}
+segment :: (a -> Bool) -> [a] -> [[a]]
+segment p l = map reverse $ go [] [] l
+ where
+ go c r [] = reverse $ c:r
+ go c r (i:is)
+ | p i = go [] (c:r) is
+ | otherwise = go (i:c) r is
+
+prop_segment_regressionTest :: Bool
+prop_segment_regressionTest = all id
+ -- Even an empty list is a segment.
+ [ segment (== "--") [] == [[]]
+ -- There are two segements in this list, even though the first is empty.
+ , segment (== "--") ["--", "foo", "bar"] == [[],["foo","bar"]]
+ ]
+
+{- Includes the delimiters as segments of their own. -}
+segmentDelim :: (a -> Bool) -> [a] -> [[a]]
+segmentDelim p l = map reverse $ go [] [] l
+ where
+ go c r [] = reverse $ c:r
+ go c r (i:is)
+ | p i = go [] ([i]:c:r) is
+ | otherwise = go (i:c) r is
+
+{- Replaces multiple values in a string.
+ -
+ - Takes care to skip over just-replaced values, so that they are not
+ - mangled. For example, massReplace [("foo", "new foo")] does not
+ - replace the "new foo" with "new new foo".
+ -}
+massReplace :: [(String, String)] -> String -> String
+massReplace vs = go [] vs
+ where
+
+ go acc _ [] = concat $ reverse acc
+ go acc [] (c:cs) = go ([c]:acc) vs cs
+ go acc ((val, replacement):rest) s
+ | val `isPrefixOf` s =
+ go (replacement:acc) vs (drop (length val) s)
+ | otherwise = go acc rest s
+
+{- Wrapper around hGetBufSome that returns a String.
+ -
+ - The null string is returned on eof, otherwise returns whatever
+ - data is currently available to read from the handle, or waits for
+ - data to be written to it if none is currently available.
+ -
+ - Note on encodings: The normal encoding of the Handle is ignored;
+ - each byte is converted to a Char. Not unicode clean!
+ -}
+hGetSomeString :: Handle -> Int -> IO String
+hGetSomeString h sz = do
+ fp <- mallocForeignPtrBytes sz
+ len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz
+ map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len)
+ where
+ peekbytes :: Int -> Ptr Word8 -> IO [Word8]
+ peekbytes len buf = mapM (peekElemOff buf) [0..pred len]
+
+{- Reaps any zombie git processes.
+ -
+ - Warning: Not thread safe. Anything that was expecting to wait
+ - on a process and get back an exit status is going to be confused
+ - if this reap gets there first. -}
+reapZombies :: IO ()
+#ifndef mingw32_HOST_OS
+reapZombies = do
+ -- throws an exception when there are no child processes
+ catchDefaultIO Nothing (getAnyProcessStatus False True)
+ >>= maybe (return ()) (const reapZombies)
+
+#else
+reapZombies = return ()
+#endif
+
+exitBool :: Bool -> IO a
+exitBool False = exitFailure
+exitBool True = exitSuccess
diff --git a/src/Utility/Monad.hs b/src/Utility/Monad.hs
new file mode 100644
index 00000000..eba3c428
--- /dev/null
+++ b/src/Utility/Monad.hs
@@ -0,0 +1,69 @@
+{- monadic stuff
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.Monad where
+
+import Data.Maybe
+import Control.Monad
+
+{- Return the first value from a list, if any, satisfying the given
+ - predicate -}
+firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
+firstM _ [] = return Nothing
+firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs)
+
+{- Runs the action on values from the list until it succeeds, returning
+ - its result. -}
+getM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
+getM _ [] = return Nothing
+getM p (x:xs) = maybe (getM p xs) (return . Just) =<< p x
+
+{- Returns true if any value in the list satisfies the predicate,
+ - stopping once one is found. -}
+anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
+anyM p = liftM isJust . firstM p
+
+allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
+allM _ [] = return True
+allM p (x:xs) = p x <&&> allM p xs
+
+{- Runs an action on values from a list until it succeeds. -}
+untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool
+untilTrue = flip anyM
+
+{- if with a monadic conditional. -}
+ifM :: Monad m => m Bool -> (m a, m a) -> m a
+ifM cond (thenclause, elseclause) = do
+ c <- cond
+ if c then thenclause else elseclause
+
+{- short-circuiting monadic || -}
+(<||>) :: Monad m => m Bool -> m Bool -> m Bool
+ma <||> mb = ifM ma ( return True , mb )
+
+{- short-circuiting monadic && -}
+(<&&>) :: Monad m => m Bool -> m Bool -> m Bool
+ma <&&> mb = ifM ma ( mb , return False )
+
+{- Same fixity as && and || -}
+infixr 3 <&&>
+infixr 2 <||>
+
+{- Runs an action, passing its value to an observer before returning it. -}
+observe :: Monad m => (a -> m b) -> m a -> m a
+observe observer a = do
+ r <- a
+ _ <- observer r
+ return r
+
+{- b `after` a runs first a, then b, and returns the value of a -}
+after :: Monad m => m b -> m a -> m a
+after = observe . const
+
+{- do nothing -}
+noop :: Monad m => m ()
+noop = return ()
diff --git a/src/Utility/PartialPrelude.hs b/src/Utility/PartialPrelude.hs
new file mode 100644
index 00000000..6efa093f
--- /dev/null
+++ b/src/Utility/PartialPrelude.hs
@@ -0,0 +1,68 @@
+{- Parts of the Prelude are partial functions, which are a common source of
+ - bugs.
+ -
+ - This exports functions that conflict with the prelude, which avoids
+ - them being accidentially used.
+ -}
+
+module Utility.PartialPrelude where
+
+import qualified Data.Maybe
+
+{- read should be avoided, as it throws an error
+ - Instead, use: readish -}
+read :: Read a => String -> a
+read = Prelude.read
+
+{- head is a partial function; head [] is an error
+ - Instead, use: take 1 or headMaybe -}
+head :: [a] -> a
+head = Prelude.head
+
+{- tail is also partial
+ - Instead, use: drop 1 -}
+tail :: [a] -> [a]
+tail = Prelude.tail
+
+{- init too
+ - Instead, use: beginning -}
+init :: [a] -> [a]
+init = Prelude.init
+
+{- last too
+ - Instead, use: end or lastMaybe -}
+last :: [a] -> a
+last = Prelude.last
+
+{- Attempts to read a value from a String.
+ -
+ - Ignores leading/trailing whitespace, and throws away any trailing
+ - text after the part that can be read.
+ -
+ - readMaybe is available in Text.Read in new versions of GHC,
+ - but that one requires the entire string to be consumed.
+ -}
+readish :: Read a => String -> Maybe a
+readish s = case reads s of
+ ((x,_):_) -> Just x
+ _ -> Nothing
+
+{- Like head but Nothing on empty list. -}
+headMaybe :: [a] -> Maybe a
+headMaybe = Data.Maybe.listToMaybe
+
+{- Like last but Nothing on empty list. -}
+lastMaybe :: [a] -> Maybe a
+lastMaybe [] = Nothing
+lastMaybe v = Just $ Prelude.last v
+
+{- All but the last element of a list.
+ - (Like init, but no error on an empty list.) -}
+beginning :: [a] -> [a]
+beginning [] = []
+beginning l = Prelude.init l
+
+{- Like last, but no error on an empty list. -}
+end :: [a] -> [a]
+end [] = []
+end l = [Prelude.last l]
diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs
new file mode 100644
index 00000000..99c9438b
--- /dev/null
+++ b/src/Utility/Path.hs
@@ -0,0 +1,293 @@
+{- path manipulation
+ -
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE PackageImports, CPP #-}
+
+module Utility.Path where
+
+import Data.String.Utils
+import System.FilePath
+import System.Directory
+import Data.List
+import Data.Maybe
+import Data.Char
+import Control.Applicative
+
+#ifdef mingw32_HOST_OS
+import qualified System.FilePath.Posix as Posix
+#else
+import System.Posix.Files
+#endif
+
+import qualified "MissingH" System.Path as MissingH
+import Utility.Monad
+import Utility.UserInfo
+
+{- Simplifies a path, removing any ".." or ".", and removing the trailing
+ - path separator.
+ -
+ - On Windows, preserves whichever style of path separator might be used in
+ - the input FilePaths. This is done because some programs in Windows
+ - demand a particular path separator -- and which one actually varies!
+ -
+ - This does not guarantee that two paths that refer to the same location,
+ - and are both relative to the same location (or both absolute) will
+ - yeild the same result. Run both through normalise from System.FilePath
+ - to ensure that.
+ -}
+simplifyPath :: FilePath -> FilePath
+simplifyPath path = dropTrailingPathSeparator $
+ joinDrive drive $ joinPath $ norm [] $ splitPath path'
+ where
+ (drive, path') = splitDrive path
+
+ norm c [] = reverse c
+ norm c (p:ps)
+ | p' == ".." = norm (drop 1 c) ps
+ | p' == "." = norm c ps
+ | otherwise = norm (p:c) ps
+ where
+ p' = dropTrailingPathSeparator p
+
+{- Makes a path absolute.
+ -
+ - The first parameter is a base directory (ie, the cwd) to use if the path
+ - is not already absolute.
+ -
+ - Does not attempt to deal with edge cases or ensure security with
+ - untrusted inputs.
+ -}
+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. Resulting path will use / separators. -}
+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
+
+{- Returns the parent directory of a path.
+ -
+ - To allow this to be easily used in loops, which terminate upon reaching the
+ - top, the parent of / is "" -}
+parentDir :: FilePath -> FilePath
+parentDir dir
+ | null dirs = ""
+ | otherwise = joinDrive drive (join s $ init dirs)
+ where
+ -- 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]
+
+prop_parentDir_basics :: FilePath -> Bool
+prop_parentDir_basics dir
+ | null dir = True
+ | dir == "/" = parentDir dir == ""
+ | otherwise = p /= dir
+ where
+ p = parentDir dir
+
+{- Checks if the first FilePath is, or could be said to contain the second.
+ - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
+ - are all equivilant.
+ -}
+dirContains :: FilePath -> FilePath -> Bool
+dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'
+ where
+ a' = norm a
+ b' = norm b
+ norm = normalise . simplifyPath
+
+{- Converts a filename into an absolute path.
+ -
+ - Unlike Directory.canonicalizePath, this does not require the path
+ - already exists. -}
+absPath :: FilePath -> IO FilePath
+absPath file = do
+ cwd <- getCurrentDirectory
+ return $ absPathFrom cwd file
+
+{- Constructs a relative path from the CWD to a file.
+ -
+ - For example, assuming CWD is /tmp/foo/bar:
+ - relPathCwdToFile "/tmp/foo" == ".."
+ - relPathCwdToFile "/tmp/foo/bar" == ""
+ -}
+relPathCwdToFile :: FilePath -> IO FilePath
+relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f
+
+{- Constructs a relative path from a directory to a file.
+ -
+ - Both must be absolute, and cannot contain .. etc. (eg use absPath first).
+ -}
+relPathDirToFile :: FilePath -> FilePath -> FilePath
+relPathDirToFile from to = join s $ dotdots ++ uncommon
+ where
+ s = [pathSeparator]
+ pfrom = split s from
+ pto = split s to
+ common = map fst $ takeWhile same $ zip pfrom pto
+ same (c,d) = c == d
+ uncommon = drop numcommon pto
+ dotdots = replicate (length pfrom - numcommon) ".."
+ numcommon = length common
+
+prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
+prop_relPathDirToFile_basics from to
+ | from == to = null r
+ | otherwise = not (null r)
+ where
+ r = relPathDirToFile from to
+
+prop_relPathDirToFile_regressionTest :: Bool
+prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
+ where
+ {- Two paths have the same directory component at the same
+ - location, but it's not really the same directory.
+ - Code used to get this wrong. -}
+ same_dir_shortcurcuits_at_difference =
+ relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])
+ (joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
+ == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
+
+{- Given an original list of paths, and an expanded list derived from it,
+ - generates a list of lists, where each sublist corresponds to one of the
+ - original paths. When the original path is a directory, any items
+ - in the expanded list that are contained in that directory will appear in
+ - its segment.
+ -}
+segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]
+segmentPaths [] new = [new]
+segmentPaths [_] new = [new] -- optimisation
+segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest
+ where
+ (found, rest)=partition (l `dirContains`) new
+
+{- This assumes that it's cheaper to call segmentPaths on the result,
+ - than it would be to run the action separately with each path. In
+ - the case of git file list commands, that assumption tends to hold.
+ -}
+runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
+runSegmentPaths a paths = segmentPaths paths <$> a paths
+
+{- Converts paths in the home directory to use ~/ -}
+relHome :: FilePath -> IO String
+relHome path = do
+ home <- myHomeDir
+ return $ if dirContains home path
+ then "~/" ++ relPathDirToFile home path
+ else path
+
+{- Checks if a command is available in PATH.
+ -
+ - The command may be fully-qualified, in which case, this succeeds as
+ - long as it exists. -}
+inPath :: String -> IO Bool
+inPath command = isJust <$> searchPath command
+
+{- Finds a command in PATH and returns the full path to it.
+ -
+ - The command may be fully qualified already, in which case it will
+ - be returned if it exists.
+ -}
+searchPath :: String -> IO (Maybe FilePath)
+searchPath command
+ | isAbsolute command = check command
+ | otherwise = getSearchPath >>= getM indir
+ where
+ indir d = check $ d </> command
+ check f = firstM doesFileExist
+#ifdef mingw32_HOST_OS
+ [f, f ++ ".exe"]
+#else
+ [f]
+#endif
+
+{- Checks if a filename is a unix dotfile. All files inside dotdirs
+ - count as dotfiles. -}
+dotfile :: FilePath -> Bool
+dotfile file
+ | f == "." = False
+ | f == ".." = False
+ | f == "" = False
+ | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)
+ where
+ f = takeFileName file
+
+{- Converts a DOS style path to a Cygwin style path. Only on Windows.
+ - Any trailing '\' is preserved as a trailing '/' -}
+toCygPath :: FilePath -> FilePath
+#ifndef mingw32_HOST_OS
+toCygPath = id
+#else
+toCygPath p
+ | null drive = recombine parts
+ | otherwise = recombine $ "/cygdrive" : driveletter drive : parts
+ where
+ (drive, p') = splitDrive p
+ parts = splitDirectories p'
+ driveletter = map toLower . takeWhile (/= ':')
+ recombine = fixtrailing . Posix.joinPath
+ fixtrailing s
+ | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s
+ | otherwise = s
+#endif
+
+{- Maximum size to use for a file in a specified directory.
+ -
+ - Many systems have a 255 byte limit to the name of a file,
+ - so that's taken as the max if the system has a larger limit, or has no
+ - limit.
+ -}
+fileNameLengthLimit :: FilePath -> IO Int
+#ifdef mingw32_HOST_OS
+fileNameLengthLimit _ = return 255
+#else
+fileNameLengthLimit dir = do
+ l <- fromIntegral <$> getPathVar dir FileNameLimit
+ if l <= 0
+ then return 255
+ else return $ minimum [l, 255]
+ where
+#endif
+
+{- Given a string that we'd like to use as the basis for FilePath, but that
+ - was provided by a third party and is not to be trusted, returns the closest
+ - sane FilePath.
+ -
+ - All spaces and punctuation and other wacky stuff are replaced
+ - with '_', except for '.' "../" will thus turn into ".._", which is safe.
+ -}
+sanitizeFilePath :: String -> FilePath
+sanitizeFilePath = map sanitize
+ where
+ sanitize c
+ | c == '.' = c
+ | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_'
+ | otherwise = c
+
+{- Similar to splitExtensions, but knows that some things in FilePaths
+ - after a dot are too long to be extensions. -}
+splitShortExtensions :: FilePath -> (FilePath, [String])
+splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"
+splitShortExtensions' :: Int -> FilePath -> (FilePath, [String])
+splitShortExtensions' maxextension = go []
+ where
+ go c f
+ | len > 0 && len <= maxextension && not (null base) =
+ go (ext:c) base
+ | otherwise = (f, c)
+ where
+ (base, ext) = splitExtension f
+ len = length ext
diff --git a/src/Utility/PosixFiles.hs b/src/Utility/PosixFiles.hs
new file mode 100644
index 00000000..5abbb578
--- /dev/null
+++ b/src/Utility/PosixFiles.hs
@@ -0,0 +1,33 @@
+{- POSIX files (and compatablity wrappers).
+ -
+ - This is like System.PosixCompat.Files, except with a fixed rename.
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.PosixFiles (
+ module X,
+ rename
+) where
+
+import System.PosixCompat.Files as X hiding (rename)
+
+#ifndef mingw32_HOST_OS
+import System.Posix.Files (rename)
+#else
+import qualified System.Win32.File as Win32
+#endif
+
+{- System.PosixCompat.Files.rename on Windows calls renameFile,
+ - so cannot rename directories.
+ -
+ - Instead, use Win32 moveFile, which can. It needs to be told to overwrite
+ - any existing file. -}
+#ifdef mingw32_HOST_OS
+rename :: FilePath -> FilePath -> IO ()
+rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING
+#endif
diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs
new file mode 100644
index 00000000..549ae570
--- /dev/null
+++ b/src/Utility/Process.hs
@@ -0,0 +1,364 @@
+{- System.Process enhancements, including additional ways of running
+ - processes, and logging.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP, Rank2Types #-}
+
+module Utility.Process (
+ module X,
+ CreateProcess,
+ StdHandle(..),
+ readProcess,
+ readProcessEnv,
+ writeReadProcessEnv,
+ forceSuccessProcess,
+ checkSuccessProcess,
+ ignoreFailureProcess,
+ createProcessSuccess,
+ createProcessChecked,
+ createBackgroundProcess,
+ processTranscript,
+ processTranscript',
+ withHandle,
+ withBothHandles,
+ withQuietOutput,
+ createProcess,
+ startInteractiveProcess,
+ stdinHandle,
+ stdoutHandle,
+ stderrHandle,
+ processHandle,
+ devNull,
+) where
+
+import qualified System.Process
+import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)
+import System.Process hiding (createProcess, readProcess)
+import System.Exit
+import System.IO
+import System.Log.Logger
+import Control.Concurrent
+import qualified Control.Exception as E
+import Control.Monad
+#ifndef mingw32_HOST_OS
+import System.Posix.IO
+#else
+import Control.Applicative
+#endif
+import Data.Maybe
+
+import Utility.Misc
+import Utility.Exception
+
+type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
+
+data StdHandle = StdinHandle | StdoutHandle | StderrHandle
+ deriving (Eq)
+
+{- Normally, when reading from a process, it does not need to be fed any
+ - standard input. -}
+readProcess :: FilePath -> [String] -> IO String
+readProcess cmd args = readProcessEnv cmd args Nothing
+
+readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String
+readProcessEnv cmd args environ =
+ withHandle StdoutHandle createProcessSuccess p $ \h -> do
+ output <- hGetContentsStrict h
+ hClose h
+ return output
+ where
+ p = (proc cmd args)
+ { std_out = CreatePipe
+ , env = environ
+ }
+
+{- Runs an action to write to a process on its stdin,
+ - returns its output, and also allows specifying the environment.
+ -}
+writeReadProcessEnv
+ :: FilePath
+ -> [String]
+ -> Maybe [(String, String)]
+ -> (Maybe (Handle -> IO ()))
+ -> (Maybe (Handle -> IO ()))
+ -> IO String
+writeReadProcessEnv cmd args environ writestdin adjusthandle = 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 ()
+
+ -- 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
+ hClose outh
+
+ -- wait on the process
+ forceSuccessProcess p pid
+
+ return output
+
+ where
+ p = (proc cmd args)
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = Inherit
+ , env = environ
+ }
+
+{- Waits for a ProcessHandle, and throws an IOError if the process
+ - did not exit successfully. -}
+forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()
+forceSuccessProcess p pid = do
+ code <- waitForProcess pid
+ case code of
+ ExitSuccess -> return ()
+ ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n
+
+{- Waits for a ProcessHandle and returns True if it exited successfully.
+ - Note that using this with createProcessChecked will throw away
+ - the Bool, and is only useful to ignore the exit code of a process,
+ - while still waiting for it. -}
+checkSuccessProcess :: ProcessHandle -> IO Bool
+checkSuccessProcess pid = do
+ code <- waitForProcess pid
+ return $ code == ExitSuccess
+
+ignoreFailureProcess :: ProcessHandle -> IO Bool
+ignoreFailureProcess pid = do
+ void $ waitForProcess pid
+ return True
+
+{- Runs createProcess, then an action on its handles, and then
+ - forceSuccessProcess. -}
+createProcessSuccess :: CreateProcessRunner
+createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a
+
+{- Runs createProcess, then an action on its handles, and then
+ - a checker action on its exit code, which must wait for the process. -}
+createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner
+createProcessChecked checker p a = do
+ t@(_, _, _, pid) <- createProcess p
+ r <- tryNonAsync $ a t
+ _ <- checker pid
+ either E.throw return r
+
+{- Leaves the process running, suitable for lazy streaming.
+ - Note: Zombies will result, and must be waited on. -}
+createBackgroundProcess :: CreateProcessRunner
+createBackgroundProcess p a = a =<< createProcess p
+
+{- Runs a process, optionally feeding it some input, and
+ - returns a transcript combining its stdout and stderr, and
+ - whether it succeeded or failed. -}
+processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
+processTranscript cmd opts input = processTranscript' cmd opts Nothing input
+
+processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)
+#ifndef mingw32_HOST_OS
+{- This implementation interleves stdout and stderr in exactly the order
+ - the process writes them. -}
+processTranscript' cmd opts environ input = do
+ (readf, writef) <- createPipe
+ readh <- fdToHandle readf
+ writeh <- fdToHandle writef
+ p@(_, _, _, pid) <- createProcess $
+ (proc cmd opts)
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = UseHandle writeh
+ , std_err = UseHandle writeh
+ , env = environ
+ }
+ hClose writeh
+
+ get <- mkreader readh
+
+ -- now write and flush any input
+ case input of
+ Just s -> do
+ let inh = stdinHandle p
+ unless (null s) $ do
+ hPutStr inh s
+ hFlush inh
+ hClose inh
+ Nothing -> return ()
+
+ transcript <- get
+
+ ok <- checkSuccessProcess pid
+ return (transcript, ok)
+#else
+{- This implementation for Windows puts stderr after stdout. -}
+processTranscript' cmd opts environ input = do
+ p@(_, _, _, pid) <- createProcess $
+ (proc cmd opts)
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ , env = environ
+ }
+
+ getout <- mkreader (stdoutHandle p)
+ geterr <- mkreader (stderrHandle p)
+
+ case input of
+ Just s -> do
+ let inh = stdinHandle p
+ unless (null s) $ do
+ hPutStr inh s
+ hFlush inh
+ hClose inh
+ Nothing -> return ()
+
+ transcript <- (++) <$> getout <*> geterr
+ ok <- checkSuccessProcess pid
+ return (transcript, ok)
+#endif
+ where
+ mkreader h = do
+ s <- hGetContents h
+ v <- newEmptyMVar
+ void $ forkIO $ do
+ void $ E.evaluate (length s)
+ putMVar v ()
+ return $ do
+ takeMVar v
+ return s
+
+{- Runs a CreateProcessRunner, on a CreateProcess structure, that
+ - is adjusted to pipe only from/to a single StdHandle, and passes
+ - the resulting Handle to an action. -}
+withHandle
+ :: StdHandle
+ -> CreateProcessRunner
+ -> CreateProcess
+ -> (Handle -> IO a)
+ -> IO a
+withHandle h creator p a = creator p' $ a . select
+ where
+ base = p
+ { std_in = Inherit
+ , std_out = Inherit
+ , std_err = Inherit
+ }
+ (select, p')
+ | h == StdinHandle =
+ (stdinHandle, base { std_in = CreatePipe })
+ | h == StdoutHandle =
+ (stdoutHandle, base { std_out = CreatePipe })
+ | h == StderrHandle =
+ (stderrHandle, base { std_err = CreatePipe })
+
+{- Like withHandle, but passes (stdin, stdout) handles to the action. -}
+withBothHandles
+ :: CreateProcessRunner
+ -> CreateProcess
+ -> ((Handle, Handle) -> IO a)
+ -> IO a
+withBothHandles creator p a = creator p' $ a . bothHandles
+ where
+ p' = p
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = Inherit
+ }
+
+{- Forces the CreateProcessRunner to run quietly;
+ - both stdout and stderr are discarded. -}
+withQuietOutput
+ :: CreateProcessRunner
+ -> CreateProcess
+ -> IO ()
+withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
+ let p' = p
+ { std_out = UseHandle nullh
+ , std_err = UseHandle nullh
+ }
+ creator p' $ const $ return ()
+
+devNull :: FilePath
+#ifndef mingw32_HOST_OS
+devNull = "/dev/null"
+#else
+devNull = "NUL"
+#endif
+
+{- Extract a desired handle from createProcess's tuple.
+ - These partial functions are safe as long as createProcess is run
+ - with appropriate parameters to set up the desired handle.
+ - Get it wrong and the runtime crash will always happen, so should be
+ - easily noticed. -}
+type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle
+stdinHandle :: HandleExtractor
+stdinHandle (Just h, _, _, _) = h
+stdinHandle _ = error "expected stdinHandle"
+stdoutHandle :: HandleExtractor
+stdoutHandle (_, Just h, _, _) = h
+stdoutHandle _ = error "expected stdoutHandle"
+stderrHandle :: HandleExtractor
+stderrHandle (_, _, Just h, _) = h
+stderrHandle _ = error "expected stderrHandle"
+bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
+bothHandles (Just hin, Just hout, _, _) = (hin, hout)
+bothHandles _ = error "expected bothHandles"
+
+processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
+processHandle (_, _, _, pid) = pid
+
+{- Debugging trace for a CreateProcess. -}
+debugProcess :: CreateProcess -> IO ()
+debugProcess p = do
+ debugM "Utility.Process" $ unwords
+ [ action ++ ":"
+ , showCmd p
+ ]
+ where
+ action
+ | piped (std_in p) && piped (std_out p) = "chat"
+ | piped (std_in p) = "feed"
+ | piped (std_out p) = "read"
+ | otherwise = "call"
+ piped Inherit = False
+ piped _ = True
+
+{- Shows the command that a CreateProcess will run. -}
+showCmd :: CreateProcess -> String
+showCmd = go . cmdspec
+ where
+ go (ShellCommand s) = s
+ go (RawCommand c ps) = c ++ " " ++ show ps
+
+{- Starts an interactive process. Unlike runInteractiveProcess in
+ - System.Process, stderr is inherited. -}
+startInteractiveProcess
+ :: FilePath
+ -> [String]
+ -> Maybe [(String, String)]
+ -> IO (ProcessHandle, Handle, Handle)
+startInteractiveProcess cmd args environ = do
+ let p = (proc cmd args)
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = Inherit
+ , env = environ
+ }
+ (Just from, Just to, _, pid) <- createProcess p
+ return (pid, to, from)
+
+{- Wrapper around System.Process function that does debug logging. -}
+createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+createProcess p = do
+ debugProcess p
+ System.Process.createProcess p
diff --git a/src/Utility/QuickCheck.hs b/src/Utility/QuickCheck.hs
new file mode 100644
index 00000000..a498ee61
--- /dev/null
+++ b/src/Utility/QuickCheck.hs
@@ -0,0 +1,52 @@
+{- QuickCheck with additional instances
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Utility.QuickCheck
+ ( module X
+ , module Utility.QuickCheck
+ ) where
+
+import Test.QuickCheck as X
+import Data.Time.Clock.POSIX
+import System.Posix.Types
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Control.Applicative
+
+instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where
+ arbitrary = M.fromList <$> arbitrary
+
+instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where
+ arbitrary = S.fromList <$> arbitrary
+
+{- Times before the epoch are excluded. -}
+instance Arbitrary POSIXTime where
+ arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral
+
+instance Arbitrary EpochTime where
+ arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral
+
+{- Pids are never negative, or 0. -}
+instance Arbitrary ProcessID where
+ arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)
+
+{- Inodes are never negative. -}
+instance Arbitrary FileID where
+ arbitrary = nonNegative arbitrarySizedIntegral
+
+{- File sizes are never negative. -}
+instance Arbitrary FileOffset where
+ arbitrary = nonNegative arbitrarySizedIntegral
+
+nonNegative :: (Num a, Ord a) => Gen a -> Gen a
+nonNegative g = g `suchThat` (>= 0)
+
+positive :: (Num a, Ord a) => Gen a -> Gen a
+positive g = g `suchThat` (> 0)
diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs
new file mode 100644
index 00000000..04fcf390
--- /dev/null
+++ b/src/Utility/SafeCommand.hs
@@ -0,0 +1,120 @@
+{- safely running shell commands
+ -
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.SafeCommand where
+
+import System.Exit
+import Utility.Process
+import System.Process (env)
+import Data.String.Utils
+import Control.Applicative
+import System.FilePath
+import Data.Char
+
+{- A type for parameters passed to a shell command. A command can
+ - be passed either some Params (multiple parameters can be included,
+ - whitespace-separated, or a single Param (for when parameters contain
+ - whitespace), or a File.
+ -}
+data CommandParam = Params String | Param String | File FilePath
+ deriving (Eq, Show, Ord)
+
+{- Used to pass a list of CommandParams to a function that runs
+ - a command and expects Strings. -}
+toCommand :: [CommandParam] -> [String]
+toCommand = concatMap unwrap
+ where
+ unwrap (Param s) = [s]
+ unwrap (Params s) = filter (not . null) (split " " s)
+ -- Files that start with a non-alphanumeric that is not a path
+ -- separator are modified to avoid the command interpreting them as
+ -- options or other special constructs.
+ unwrap (File s@(h:_))
+ | isAlphaNum h || h `elem` pathseps = [s]
+ | otherwise = ["./" ++ s]
+ unwrap (File s) = [s]
+ -- '/' is explicitly included because it's an alternative
+ -- path separator on Windows.
+ pathseps = pathSeparator:"./"
+
+{- Run a system command, and returns True or False
+ - if it succeeded or failed.
+ -}
+boolSystem :: FilePath -> [CommandParam] -> IO Bool
+boolSystem command params = boolSystemEnv command params Nothing
+
+boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
+boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ
+ where
+ dispatch ExitSuccess = True
+ dispatch _ = False
+
+{- Runs a system command, returning the exit status. -}
+safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
+safeSystem command params = safeSystemEnv command params Nothing
+
+safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode
+safeSystemEnv command params environ = do
+ (_, _, _, pid) <- createProcess (proc command $ toCommand params)
+ { env = environ }
+ waitForProcess pid
+
+{- Wraps a shell command line inside sh -c, allowing it to be run in a
+ - login shell that may not support POSIX shell, eg csh. -}
+shellWrap :: String -> String
+shellWrap cmdline = "sh -c " ++ shellEscape cmdline
+
+{- Escapes a filename or other parameter to be safely able to be exposed to
+ - the shell.
+ -
+ - This method works for POSIX shells, as well as other shells like csh.
+ -}
+shellEscape :: String -> String
+shellEscape f = "'" ++ escaped ++ "'"
+ where
+ -- replace ' with '"'"'
+ escaped = join "'\"'\"'" $ split "'" f
+
+{- Unescapes a set of shellEscaped words or filenames. -}
+shellUnEscape :: String -> [String]
+shellUnEscape [] = []
+shellUnEscape s = word : shellUnEscape rest
+ where
+ (word, rest) = findword "" s
+ findword w [] = (w, "")
+ findword w (c:cs)
+ | c == ' ' = (w, cs)
+ | c == '\'' = inquote c w cs
+ | c == '"' = inquote c w cs
+ | otherwise = findword (w++[c]) cs
+ inquote _ w [] = (w, "")
+ inquote q w (c:cs)
+ | c == q = findword w cs
+ | otherwise = inquote q (w++[c]) cs
+
+{- For quickcheck. -}
+prop_idempotent_shellEscape :: String -> Bool
+prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s
+prop_idempotent_shellEscape_multiword :: [String] -> Bool
+prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s
+
+{- Segements a list of filenames into groups that are all below the manximum
+ - command-line length limit. Does not preserve order. -}
+segmentXargs :: [FilePath] -> [[FilePath]]
+segmentXargs l = go l [] 0 []
+ where
+ go [] c _ r = c:r
+ go (f:fs) c accumlen r
+ | len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r)
+ | otherwise = go fs (f:c) newlen r
+ where
+ len = length f
+ newlen = accumlen + len
+
+ {- 10k of filenames per command, well under Linux's 20k limit;
+ - allows room for other parameters etc. -}
+ maxlen = 10240
diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs
new file mode 100644
index 00000000..305410c5
--- /dev/null
+++ b/src/Utility/Scheduled.hs
@@ -0,0 +1,396 @@
+{- scheduled activities
+ -
+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.Scheduled (
+ Schedule(..),
+ Recurrance(..),
+ ScheduledTime(..),
+ NextTime(..),
+ WeekDay,
+ MonthDay,
+ YearDay,
+ nextTime,
+ calcNextTime,
+ startTime,
+ fromSchedule,
+ fromScheduledTime,
+ toScheduledTime,
+ fromRecurrance,
+ toRecurrance,
+ toSchedule,
+ parseSchedule,
+ prop_schedule_roundtrips,
+ prop_past_sane,
+) where
+
+import Utility.Data
+import Utility.QuickCheck
+import Utility.PartialPrelude
+import Utility.Misc
+
+import Control.Applicative
+import Data.List
+import Data.Time.Clock
+import Data.Time.LocalTime
+import Data.Time.Calendar
+import Data.Time.Calendar.WeekDate
+import Data.Time.Calendar.OrdinalDate
+import Data.Tuple.Utils
+import Data.Char
+
+{- Some sort of scheduled event. -}
+data Schedule = Schedule Recurrance ScheduledTime
+ deriving (Eq, Read, Show, Ord)
+
+data Recurrance
+ = Daily
+ | Weekly (Maybe WeekDay)
+ | Monthly (Maybe MonthDay)
+ | Yearly (Maybe YearDay)
+ | Divisible Int Recurrance
+ -- ^ Days, Weeks, or Months of the year evenly divisible by a number.
+ -- (Divisible Year is years evenly divisible by a number.)
+ deriving (Eq, Read, Show, Ord)
+
+type WeekDay = Int
+type MonthDay = Int
+type YearDay = Int
+
+data ScheduledTime
+ = AnyTime
+ | SpecificTime Hour Minute
+ deriving (Eq, Read, Show, Ord)
+
+type Hour = Int
+type Minute = Int
+
+-- | Next time a Schedule should take effect. The NextTimeWindow is used
+-- when a Schedule is allowed to start at some point within the window.
+data NextTime
+ = NextTimeExactly LocalTime
+ | NextTimeWindow LocalTime LocalTime
+ deriving (Eq, Read, Show)
+
+startTime :: NextTime -> LocalTime
+startTime (NextTimeExactly t) = t
+startTime (NextTimeWindow t _) = t
+
+nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime)
+nextTime schedule lasttime = do
+ now <- getCurrentTime
+ tz <- getTimeZone now
+ return $ calcNextTime schedule lasttime $ utcToLocalTime tz now
+
+-- | Calculate the next time that fits a Schedule, based on the
+-- last time it occurred, and the current time.
+calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime
+calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime
+ | scheduledtime == AnyTime = do
+ next <- findfromtoday True
+ return $ case next of
+ NextTimeWindow _ _ -> next
+ NextTimeExactly t -> window (localDay t) (localDay t)
+ | otherwise = NextTimeExactly . startTime <$> findfromtoday False
+ where
+ findfromtoday anytime = findfrom recurrance afterday today
+ where
+ today = localDay currenttime
+ afterday = sameaslastrun || toolatetoday
+ toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime
+ sameaslastrun = lastrun == Just today
+ lastrun = localDay <$> lasttime
+ nexttime = case scheduledtime of
+ AnyTime -> TimeOfDay 0 0 0
+ SpecificTime h m -> TimeOfDay h m 0
+ exactly d = NextTimeExactly $ LocalTime d nexttime
+ window startd endd = NextTimeWindow
+ (LocalTime startd nexttime)
+ (LocalTime endd (TimeOfDay 23 59 0))
+ findfrom r afterday candidate
+ | ynum candidate > (ynum (localDay currenttime)) + 100 =
+ -- avoid possible infinite recusion
+ error $ "bug: calcNextTime did not find a time within 100 years to run " ++
+ show (schedule, lasttime, currenttime)
+ | otherwise = findfromChecked r afterday candidate
+ findfromChecked r afterday candidate = case r of
+ Daily
+ | afterday -> Just $ exactly $ addDays 1 candidate
+ | otherwise -> Just $ exactly candidate
+ Weekly Nothing
+ | afterday -> skip 1
+ | otherwise -> case (wday <$> lastrun, wday candidate) of
+ (Nothing, _) -> Just $ window candidate (addDays 6 candidate)
+ (Just old, curr)
+ | old == curr -> Just $ window candidate (addDays 6 candidate)
+ | otherwise -> skip 1
+ Monthly Nothing
+ | afterday -> skip 1
+ | maybe True (candidate `oneMonthPast`) lastrun ->
+ Just $ window candidate (endOfMonth candidate)
+ | otherwise -> skip 1
+ Yearly Nothing
+ | afterday -> skip 1
+ | maybe True (candidate `oneYearPast`) lastrun ->
+ Just $ window candidate (endOfYear candidate)
+ | otherwise -> skip 1
+ Weekly (Just w)
+ | w < 0 || w > maxwday -> Nothing
+ | w == wday candidate -> if afterday
+ then Just $ exactly $ addDays 7 candidate
+ else Just $ exactly candidate
+ | otherwise -> Just $ exactly $
+ addDays (fromIntegral $ (w - wday candidate) `mod` 7) candidate
+ Monthly (Just m)
+ | m < 0 || m > maxmday -> Nothing
+ -- TODO can be done more efficiently than recursing
+ | m == mday candidate -> if afterday
+ then skip 1
+ else Just $ exactly candidate
+ | otherwise -> skip 1
+ Yearly (Just y)
+ | y < 0 || y > maxyday -> Nothing
+ | y == yday candidate -> if afterday
+ then skip 365
+ else Just $ exactly candidate
+ | otherwise -> skip 1
+ Divisible n r'@Daily -> handlediv n r' yday (Just maxyday)
+ Divisible n r'@(Weekly _) -> handlediv n r' wnum (Just maxwnum)
+ Divisible n r'@(Monthly _) -> handlediv n r' mnum (Just maxmnum)
+ Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing
+ Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate
+ where
+ skip n = findfrom r False (addDays n candidate)
+ handlediv n r' getval mmax
+ | n > 0 && maybe True (n <=) mmax =
+ findfromwhere r' (divisible n . getval) afterday candidate
+ | otherwise = Nothing
+ findfromwhere r p afterday candidate
+ | maybe True (p . getday) next = next
+ | otherwise = maybe Nothing (findfromwhere r p True . getday) next
+ where
+ next = findfrom r afterday candidate
+ getday = localDay . startTime
+ divisible n v = v `rem` n == 0
+
+-- Check if the new Day occurs one month or more past the old Day.
+oneMonthPast :: Day -> Day -> Bool
+new `oneMonthPast` old = fromGregorian y (m+1) d <= new
+ where
+ (y,m,d) = toGregorian old
+
+-- Check if the new Day occurs one year or more past the old Day.
+oneYearPast :: Day -> Day -> Bool
+new `oneYearPast` old = fromGregorian (y+1) m d <= new
+ where
+ (y,m,d) = toGregorian old
+
+endOfMonth :: Day -> Day
+endOfMonth day =
+ let (y,m,_d) = toGregorian day
+ in fromGregorian y m (gregorianMonthLength y m)
+
+endOfYear :: Day -> Day
+endOfYear day =
+ let (y,_m,_d) = toGregorian day
+ in endOfMonth (fromGregorian y maxmnum 1)
+
+-- extracting various quantities from a Day
+wday :: Day -> Int
+wday = thd3 . toWeekDate
+wnum :: Day -> Int
+wnum = snd3 . toWeekDate
+mday :: Day -> Int
+mday = thd3 . toGregorian
+mnum :: Day -> Int
+mnum = snd3 . toGregorian
+yday :: Day -> Int
+yday = snd . toOrdinalDate
+ynum :: Day -> Int
+ynum = fromIntegral . fst . toOrdinalDate
+
+-- Calendar max values.
+maxyday :: Int
+maxyday = 366 -- with leap days
+maxwnum :: Int
+maxwnum = 53 -- some years have more than 52
+maxmday :: Int
+maxmday = 31
+maxmnum :: Int
+maxmnum = 12
+maxwday :: Int
+maxwday = 7
+
+fromRecurrance :: Recurrance -> String
+fromRecurrance (Divisible n r) =
+ fromRecurrance' (++ "s divisible by " ++ show n) r
+fromRecurrance r = fromRecurrance' ("every " ++) r
+
+fromRecurrance' :: (String -> String) -> Recurrance -> String
+fromRecurrance' a Daily = a "day"
+fromRecurrance' a (Weekly n) = onday n (a "week")
+fromRecurrance' a (Monthly n) = onday n (a "month")
+fromRecurrance' a (Yearly n) = onday n (a "year")
+fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used
+
+onday :: Maybe Int -> String -> String
+onday (Just n) s = "on day " ++ show n ++ " of " ++ s
+onday Nothing s = s
+
+toRecurrance :: String -> Maybe Recurrance
+toRecurrance s = case words s of
+ ("every":"day":[]) -> Just Daily
+ ("on":"day":sd:"of":"every":something:[]) -> withday sd something
+ ("every":something:[]) -> noday something
+ ("days":"divisible":"by":sn:[]) ->
+ Divisible <$> getdivisor sn <*> pure Daily
+ ("on":"day":sd:"of":something:"divisible":"by":sn:[]) ->
+ Divisible
+ <$> getdivisor sn
+ <*> withday sd something
+ ("every":something:"divisible":"by":sn:[]) ->
+ Divisible
+ <$> getdivisor sn
+ <*> noday something
+ (something:"divisible":"by":sn:[]) ->
+ Divisible
+ <$> getdivisor sn
+ <*> noday something
+ _ -> Nothing
+ where
+ constructor "week" = Just Weekly
+ constructor "month" = Just Monthly
+ constructor "year" = Just Yearly
+ constructor u
+ | "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u
+ | otherwise = Nothing
+ withday sd u = do
+ c <- constructor u
+ d <- readish sd
+ Just $ c (Just d)
+ noday u = do
+ c <- constructor u
+ Just $ c Nothing
+ getdivisor sn = do
+ n <- readish sn
+ if n > 0
+ then Just n
+ else Nothing
+
+fromScheduledTime :: ScheduledTime -> String
+fromScheduledTime AnyTime = "any time"
+fromScheduledTime (SpecificTime h m) =
+ show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm
+ where
+ pad n s = take (n - length s) (repeat '0') ++ s
+ (h', ampm)
+ | h == 0 = (12, "AM")
+ | h < 12 = (h, "AM")
+ | h == 12 = (h, "PM")
+ | otherwise = (h - 12, "PM")
+
+toScheduledTime :: String -> Maybe ScheduledTime
+toScheduledTime "any time" = Just AnyTime
+toScheduledTime v = case words v of
+ (s:ampm:[])
+ | map toUpper ampm == "AM" ->
+ go s h0
+ | map toUpper ampm == "PM" ->
+ go s (\h -> (h0 h) + 12)
+ | otherwise -> Nothing
+ (s:[]) -> go s id
+ _ -> Nothing
+ where
+ h0 h
+ | h == 12 = 0
+ | otherwise = h
+ go :: String -> (Int -> Int) -> Maybe ScheduledTime
+ go s adjust =
+ let (h, m) = separate (== ':') s
+ in SpecificTime
+ <$> (adjust <$> readish h)
+ <*> if null m then Just 0 else readish m
+
+fromSchedule :: Schedule -> String
+fromSchedule (Schedule recurrance scheduledtime) = unwords
+ [ fromRecurrance recurrance
+ , "at"
+ , fromScheduledTime scheduledtime
+ ]
+
+toSchedule :: String -> Maybe Schedule
+toSchedule = eitherToMaybe . parseSchedule
+
+parseSchedule :: String -> Either String Schedule
+parseSchedule s = do
+ r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right
+ (toRecurrance recurrance)
+ t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right
+ (toScheduledTime scheduledtime)
+ Right $ Schedule r t
+ where
+ (rws, tws) = separate (== "at") (words s)
+ recurrance = unwords rws
+ scheduledtime = unwords tws
+
+instance Arbitrary Schedule where
+ arbitrary = Schedule <$> arbitrary <*> arbitrary
+
+instance Arbitrary ScheduledTime where
+ arbitrary = oneof
+ [ pure AnyTime
+ , SpecificTime
+ <$> choose (0, 23)
+ <*> choose (1, 59)
+ ]
+
+instance Arbitrary Recurrance where
+ arbitrary = oneof
+ [ pure Daily
+ , Weekly <$> arbday
+ , Monthly <$> arbday
+ , Yearly <$> arbday
+ , Divisible
+ <$> positive arbitrary
+ <*> oneof -- no nested Divisibles
+ [ pure Daily
+ , Weekly <$> arbday
+ , Monthly <$> arbday
+ , Yearly <$> arbday
+ ]
+ ]
+ where
+ arbday = oneof
+ [ Just <$> nonNegative arbitrary
+ , pure Nothing
+ ]
+
+prop_schedule_roundtrips :: Schedule -> Bool
+prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s
+
+prop_past_sane :: Bool
+prop_past_sane = and
+ [ all (checksout oneMonthPast) (mplus1 ++ yplus1)
+ , all (not . (checksout oneMonthPast)) (map swap (mplus1 ++ yplus1))
+ , all (checksout oneYearPast) yplus1
+ , all (not . (checksout oneYearPast)) (map swap yplus1)
+ ]
+ where
+ mplus1 = -- new date old date, 1+ months before it
+ [ (fromGregorian 2014 01 15, fromGregorian 2013 12 15)
+ , (fromGregorian 2014 01 15, fromGregorian 2013 02 15)
+ , (fromGregorian 2014 02 15, fromGregorian 2013 01 15)
+ , (fromGregorian 2014 03 01, fromGregorian 2013 01 15)
+ , (fromGregorian 2014 03 01, fromGregorian 2013 12 15)
+ , (fromGregorian 2015 01 01, fromGregorian 2010 01 01)
+ ]
+ yplus1 = -- new date old date, 1+ years before it
+ [ (fromGregorian 2014 01 15, fromGregorian 2012 01 16)
+ , (fromGregorian 2014 01 15, fromGregorian 2013 01 14)
+ , (fromGregorian 2022 12 31, fromGregorian 2000 01 01)
+ ]
+ checksout cmp (new, old) = new `cmp` old
+ swap (a,b) = (b,a)
diff --git a/src/Utility/ThreadScheduler.hs b/src/Utility/ThreadScheduler.hs
new file mode 100644
index 00000000..fc026d7e
--- /dev/null
+++ b/src/Utility/ThreadScheduler.hs
@@ -0,0 +1,75 @@
+{- thread scheduling
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2011 Bas van Dijk & Roel van Dijk
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.ThreadScheduler where
+
+import Control.Monad
+import Control.Concurrent
+#ifndef mingw32_HOST_OS
+import Control.Monad.IfElse
+import System.Posix.IO
+#endif
+#ifndef mingw32_HOST_OS
+import System.Posix.Signals
+#ifndef __ANDROID__
+import System.Posix.Terminal
+#endif
+#endif
+
+newtype Seconds = Seconds { fromSeconds :: Int }
+ deriving (Eq, Ord, Show)
+
+type Microseconds = Integer
+
+{- Runs an action repeatedly forever, sleeping at least the specified number
+ - of seconds in between. -}
+runEvery :: Seconds -> IO a -> IO a
+runEvery n a = forever $ do
+ threadDelaySeconds n
+ a
+
+threadDelaySeconds :: Seconds -> IO ()
+threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)
+
+{- Like threadDelay, but not bounded by an Int.
+ -
+ - There is no guarantee that the thread will be rescheduled promptly when the
+ - delay has expired, but the thread will never continue to run earlier than
+ - specified.
+ -
+ - Taken from the unbounded-delay package to avoid a dependency for 4 lines
+ - of code.
+ -}
+unboundDelay :: Microseconds -> IO ()
+unboundDelay time = do
+ let maxWait = min time $ toInteger (maxBound :: Int)
+ threadDelay $ fromInteger maxWait
+ when (maxWait /= time) $ unboundDelay (time - maxWait)
+
+{- Pauses the main thread, letting children run until program termination. -}
+waitForTermination :: IO ()
+waitForTermination = do
+#ifdef mingw32_HOST_OS
+ runEvery (Seconds 600) $
+ void getLine
+#else
+ lock <- newEmptyMVar
+ let check sig = void $
+ installHandler sig (CatchOnce $ putMVar lock ()) Nothing
+ check softwareTermination
+#ifndef __ANDROID__
+ whenM (queryTerminal stdInput) $
+ check keyboardSignal
+#endif
+ takeMVar lock
+#endif
+
+oneSecond :: Microseconds
+oneSecond = 1000000
diff --git a/src/Utility/Tmp.hs b/src/Utility/Tmp.hs
new file mode 100644
index 00000000..0dc9f2c0
--- /dev/null
+++ b/src/Utility/Tmp.hs
@@ -0,0 +1,100 @@
+{- Temporary files and directories.
+ -
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.Tmp where
+
+import Control.Exception (bracket)
+import System.IO
+import System.Directory
+import Control.Monad.IfElse
+import System.FilePath
+
+import Utility.Exception
+import Utility.FileSystemEncoding
+import Utility.PosixFiles
+
+type Template = String
+
+{- Runs an action like writeFile, writing to a temp file first and
+ - then moving it into place. The temp file is stored in the same
+ - directory as the final file to avoid cross-device renames. -}
+viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO ()
+viaTmp a file content = do
+ let (dir, base) = splitFileName file
+ createDirectoryIfMissing True dir
+ (tmpfile, handle) <- openTempFile dir (base ++ ".tmp")
+ hClose handle
+ a tmpfile content
+ rename tmpfile file
+
+{- Runs an action with a tmp file located in the system's tmp directory
+ - (or in "." if there is none) then removes the file. -}
+withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a
+withTmpFile template a = do
+ tmpdir <- catchDefaultIO "." getTemporaryDirectory
+ withTmpFileIn tmpdir template a
+
+{- Runs an action with a tmp file located in the specified directory,
+ - then removes the file. -}
+withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a
+withTmpFileIn tmpdir template a = bracket create remove use
+ where
+ create = openTempFile tmpdir template
+ remove (name, handle) = do
+ hClose handle
+ catchBoolIO (removeFile name >> return True)
+ use (name, handle) = a name handle
+
+{- Runs an action with a tmp directory located within the system's tmp
+ - directory (or within "." if there is none), then removes the tmp
+ - directory and all its contents. -}
+withTmpDir :: Template -> (FilePath -> IO a) -> IO a
+withTmpDir template a = do
+ tmpdir <- catchDefaultIO "." getTemporaryDirectory
+ withTmpDirIn tmpdir template a
+
+{- Runs an action with a tmp directory located within a specified directory,
+ - then removes the tmp directory and all its contents. -}
+withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a
+withTmpDirIn tmpdir template = bracket create remove
+ where
+ remove d = whenM (doesDirectoryExist d) $ do
+#if mingw32_HOST_OS
+ -- Windows will often refuse to delete a file
+ -- after a process has just written to it and exited.
+ -- Because it's crap, presumably. So, ignore failure
+ -- to delete the temp directory.
+ _ <- tryIO $ removeDirectoryRecursive d
+ return ()
+#else
+ removeDirectoryRecursive d
+#endif
+ create = do
+ createDirectoryIfMissing True tmpdir
+ makenewdir (tmpdir </> template) (0 :: Int)
+ makenewdir t n = do
+ let dir = t ++ "." ++ show n
+ either (const $ makenewdir t $ n + 1) (const $ return dir)
+ =<< tryIO (createDirectory dir)
+
+{- It's not safe to use a FilePath of an existing file as the template
+ - for openTempFile, because if the FilePath is really long, the tmpfile
+ - will be longer, and may exceed the maximum filename length.
+ -
+ - This generates a template that is never too long.
+ - (Well, it allocates 20 characters for use in making a unique temp file,
+ - anyway, which is enough for the current implementation and any
+ - likely implementation.)
+ -}
+relatedTemplate :: FilePath -> FilePath
+relatedTemplate f
+ | len > 20 = truncateFilePath (len - 20) f
+ | otherwise = f
+ where
+ len = length f
diff --git a/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs
new file mode 100644
index 00000000..617c3e94
--- /dev/null
+++ b/src/Utility/UserInfo.hs
@@ -0,0 +1,55 @@
+{- user info
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.UserInfo (
+ myHomeDir,
+ myUserName,
+ myUserGecos,
+) where
+
+import Control.Applicative
+import System.PosixCompat
+
+import Utility.Env
+
+{- Current user's home directory.
+ -
+ - getpwent will fail on LDAP or NIS, so use HOME if set. -}
+myHomeDir :: IO FilePath
+myHomeDir = myVal env homeDirectory
+ where
+#ifndef mingw32_HOST_OS
+ env = ["HOME"]
+#else
+ env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin
+#endif
+
+{- Current user's user name. -}
+myUserName :: IO String
+myUserName = myVal env userName
+ where
+#ifndef mingw32_HOST_OS
+ env = ["USER", "LOGNAME"]
+#else
+ env = ["USERNAME", "USER", "LOGNAME"]
+#endif
+
+myUserGecos :: IO String
+#ifdef __ANDROID__
+myUserGecos = return "" -- userGecos crashes on Android
+#else
+myUserGecos = myVal [] userGecos
+#endif
+
+myVal :: [String] -> (UserEntry -> String) -> IO String
+myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars
+ where
+ check [] = return Nothing
+ check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v
+ getpwent = getUserEntryForID =<< getEffectiveUserID