summaryrefslogtreecommitdiff
path: root/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 /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 'Utility')
-rw-r--r--Utility/Applicative.hs16
-rw-r--r--Utility/Data.hs17
-rw-r--r--Utility/Directory.hs135
-rw-r--r--Utility/Env.hs81
-rw-r--r--Utility/Exception.hs59
-rw-r--r--Utility/FileMode.hs158
-rw-r--r--Utility/FileSystemEncoding.hs132
-rw-r--r--Utility/LinuxMkLibs.hs61
-rw-r--r--Utility/Misc.hs148
-rw-r--r--Utility/Monad.hs69
-rw-r--r--Utility/PartialPrelude.hs68
-rw-r--r--Utility/Path.hs293
-rw-r--r--Utility/PosixFiles.hs33
-rw-r--r--Utility/Process.hs364
-rw-r--r--Utility/QuickCheck.hs52
-rw-r--r--Utility/SafeCommand.hs120
-rw-r--r--Utility/Scheduled.hs396
-rw-r--r--Utility/ThreadScheduler.hs75
-rw-r--r--Utility/Tmp.hs100
-rw-r--r--Utility/UserInfo.hs55
20 files changed, 0 insertions, 2432 deletions
diff --git a/Utility/Applicative.hs b/Utility/Applicative.hs
deleted file mode 100644
index fd8944b2..00000000
--- a/Utility/Applicative.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{- 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/Utility/Data.hs b/Utility/Data.hs
deleted file mode 100644
index 2df12b36..00000000
--- a/Utility/Data.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{- 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/Utility/Directory.hs b/Utility/Directory.hs
deleted file mode 100644
index d92327c0..00000000
--- a/Utility/Directory.hs
+++ /dev/null
@@ -1,135 +0,0 @@
-{- 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/Utility/Env.hs b/Utility/Env.hs
deleted file mode 100644
index 6763c24e..00000000
--- a/Utility/Env.hs
+++ /dev/null
@@ -1,81 +0,0 @@
-{- 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/Utility/Exception.hs b/Utility/Exception.hs
deleted file mode 100644
index 1fecf65d..00000000
--- a/Utility/Exception.hs
+++ /dev/null
@@ -1,59 +0,0 @@
-{- 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/Utility/FileMode.hs b/Utility/FileMode.hs
deleted file mode 100644
index c2ef683a..00000000
--- a/Utility/FileMode.hs
+++ /dev/null
@@ -1,158 +0,0 @@
-{- 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/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs
deleted file mode 100644
index b81fdc53..00000000
--- a/Utility/FileSystemEncoding.hs
+++ /dev/null
@@ -1,132 +0,0 @@
-{- 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/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs
deleted file mode 100644
index 1dc4e1ea..00000000
--- a/Utility/LinuxMkLibs.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{- 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/Utility/Misc.hs b/Utility/Misc.hs
deleted file mode 100644
index 949f41e7..00000000
--- a/Utility/Misc.hs
+++ /dev/null
@@ -1,148 +0,0 @@
-{- 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/Utility/Monad.hs b/Utility/Monad.hs
deleted file mode 100644
index eba3c428..00000000
--- a/Utility/Monad.hs
+++ /dev/null
@@ -1,69 +0,0 @@
-{- 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/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs
deleted file mode 100644
index 6efa093f..00000000
--- a/Utility/PartialPrelude.hs
+++ /dev/null
@@ -1,68 +0,0 @@
-{- 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/Utility/Path.hs b/Utility/Path.hs
deleted file mode 100644
index 99c9438b..00000000
--- a/Utility/Path.hs
+++ /dev/null
@@ -1,293 +0,0 @@
-{- 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/Utility/PosixFiles.hs b/Utility/PosixFiles.hs
deleted file mode 100644
index 5abbb578..00000000
--- a/Utility/PosixFiles.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{- 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/Utility/Process.hs b/Utility/Process.hs
deleted file mode 100644
index 549ae570..00000000
--- a/Utility/Process.hs
+++ /dev/null
@@ -1,364 +0,0 @@
-{- 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/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
deleted file mode 100644
index a498ee61..00000000
--- a/Utility/QuickCheck.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-{- 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/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
deleted file mode 100644
index 04fcf390..00000000
--- a/Utility/SafeCommand.hs
+++ /dev/null
@@ -1,120 +0,0 @@
-{- 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/Utility/Scheduled.hs b/Utility/Scheduled.hs
deleted file mode 100644
index 305410c5..00000000
--- a/Utility/Scheduled.hs
+++ /dev/null
@@ -1,396 +0,0 @@
-{- 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/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs
deleted file mode 100644
index fc026d7e..00000000
--- a/Utility/ThreadScheduler.hs
+++ /dev/null
@@ -1,75 +0,0 @@
-{- 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/Utility/Tmp.hs b/Utility/Tmp.hs
deleted file mode 100644
index 0dc9f2c0..00000000
--- a/Utility/Tmp.hs
+++ /dev/null
@@ -1,100 +0,0 @@
-{- 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/Utility/UserInfo.hs b/Utility/UserInfo.hs
deleted file mode 100644
index 617c3e94..00000000
--- a/Utility/UserInfo.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-{- 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