diff options
Diffstat (limited to 'Utility')
80 files changed, 1558 insertions, 673 deletions
diff --git a/Utility/Applicative.hs b/Utility/Applicative.hs index 64400c801..fce3c0485 100644 --- a/Utility/Applicative.hs +++ b/Utility/Applicative.hs @@ -1,8 +1,8 @@ {- applicative stuff - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Applicative where diff --git a/Utility/Base64.hs b/Utility/Base64.hs index 0c6c8677a..56637a117 100644 --- a/Utility/Base64.hs +++ b/Utility/Base64.hs @@ -1,8 +1,8 @@ {- Simple Base64 access - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2011 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Base64 (toB64, fromB64Maybe, fromB64) where diff --git a/Utility/Batch.hs b/Utility/Batch.hs index 3f21478cf..d96f9d3f3 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -1,8 +1,8 @@ {- Running a long or expensive batch operation niced. - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} @@ -16,7 +16,6 @@ import Control.Concurrent.Async import System.Posix.Process #endif import qualified Control.Exception as E -import System.Process (env) {- Runs an operation, at batch priority. - @@ -33,7 +32,7 @@ batch :: IO a -> IO a #if defined(linux_HOST_OS) || defined(__ANDROID__) batch a = wait =<< batchthread where - batchthread = asyncBound $ do + batchthread = asyncBound $ do setProcessPriority 0 maxNice a #else diff --git a/Utility/Bloom.hs b/Utility/Bloom.hs new file mode 100644 index 000000000..aee760a1d --- /dev/null +++ b/Utility/Bloom.hs @@ -0,0 +1,60 @@ +{- bloomfilter compatability wrapper + - + - Copyright 2014 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.Bloom ( + Bloom, + safeSuggestSizing, + Hashable, + cheapHashes, + notElemB, + + newMB, + insertMB, + unsafeFreezeMB, +) where + +#if MIN_VERSION_bloomfilter(2,0,0) +import qualified Data.BloomFilter.Mutable as MBloom +import qualified Data.BloomFilter as Bloom +#else +import qualified Data.BloomFilter as Bloom +#endif +import Data.BloomFilter.Easy (safeSuggestSizing, Bloom) +import Data.BloomFilter.Hash (Hashable, cheapHashes) +import Control.Monad.ST.Safe (ST) + +#if MIN_VERSION_bloomfilter(2,0,0) + +notElemB :: a -> Bloom a -> Bool +notElemB = Bloom.notElem + +newMB :: (a -> [Bloom.Hash]) -> Int -> ST s (MBloom.MBloom s a) +newMB = MBloom.new + +insertMB :: MBloom.MBloom s a -> a -> ST s () +insertMB = MBloom.insert + +unsafeFreezeMB :: MBloom.MBloom s a -> ST s (Bloom a) +unsafeFreezeMB = Bloom.unsafeFreeze + +#else + +notElemB :: a -> Bloom a -> Bool +notElemB = Bloom.notElemB + +newMB :: (a -> [Bloom.Hash]) -> Int -> ST s (Bloom.MBloom s a) +newMB = Bloom.newMB + +insertMB :: Bloom.MBloom s a -> a -> ST s () +insertMB = Bloom.insertMB + +unsafeFreezeMB :: Bloom.MBloom s a -> ST s (Bloom a) +unsafeFreezeMB = Bloom.unsafeFreezeMB + +#endif diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs index c1134011b..9854b47fc 100644 --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -1,9 +1,9 @@ {- Interface for running a shell command as a coprocess, - sending it queries and getting back results. - - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} @@ -37,8 +37,8 @@ data CoProcessSpec = CoProcessSpec } start :: Int -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle -start numrestarts cmd params env = do - s <- start' $ CoProcessSpec numrestarts cmd params env +start numrestarts cmd params environ = do + s <- start' $ CoProcessSpec numrestarts cmd params environ newMVar s start' :: CoProcessSpec -> IO CoProcessState @@ -62,10 +62,10 @@ query ch send receive = do s <- readMVar ch restartable s (send $ coProcessTo s) $ const $ restartable s (hFlush $ coProcessTo s) $ const $ - restartable s (receive $ coProcessFrom s) $ + restartable s (receive $ coProcessFrom s) return where - restartable s a cont + restartable s a cont | coProcessNumRestarts (coProcessSpec s) > 0 = maybe restart cont =<< catchMaybeIO a | otherwise = cont =<< a @@ -87,7 +87,7 @@ rawMode ch = do raw $ coProcessTo s return ch where - raw h = do + raw h = do fileEncoding h #ifdef mingw32_HOST_OS hSetNewlineMode h noNewlineTranslation diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs index 4a609fd16..b123d006d 100644 --- a/Utility/CopyFile.hs +++ b/Utility/CopyFile.hs @@ -1,24 +1,28 @@ {- file copying - - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - Copyright 2010-2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} module Utility.CopyFile ( copyFileExternal, - createLinkOrCopy + createLinkOrCopy, + CopyMetaData(..) ) where import Common import qualified Build.SysConfig as SysConfig +data CopyMetaData = CopyTimeStamps | CopyAllMetaData + deriving (Eq) + {- The cp command is used, because I hate reinventing the wheel, - and because this allows easy access to features like cp --reflink. -} -copyFileExternal :: FilePath -> FilePath -> IO Bool -copyFileExternal src dest = do +copyFileExternal :: CopyMetaData -> FilePath -> FilePath -> IO Bool +copyFileExternal meta src dest = do whenM (doesFileExist dest) $ removeFile dest boolSystem "cp" $ params ++ [File src, File dest] @@ -26,12 +30,16 @@ copyFileExternal src dest = do #ifndef __ANDROID__ params = map snd $ filter fst [ (SysConfig.cp_reflink_auto, Param "--reflink=auto") - , (SysConfig.cp_a, Param "-a") - , (SysConfig.cp_p && not SysConfig.cp_a, Param "-p") + , (allmeta && SysConfig.cp_a, Param "-a") + , (allmeta && SysConfig.cp_p && not SysConfig.cp_a + , Param "-p") + , (not allmeta && SysConfig.cp_preserve_timestamps + , Param "--preserve=timestamps") ] #else params = [] #endif + allmeta = meta == CopyAllMetaData {- Create a hard link if the filesystem allows it, and fall back to copying - the file. -} @@ -39,10 +47,10 @@ createLinkOrCopy :: FilePath -> FilePath -> IO Bool #ifndef mingw32_HOST_OS createLinkOrCopy src dest = go `catchIO` const fallback where - go = do + go = do createLink src dest return True - fallback = copyFileExternal src dest + fallback = copyFileExternal CopyAllMetaData src dest #else -createLinkOrCopy = copyFileExternal +createLinkOrCopy = copyFileExternal CopyAllMetaData #endif diff --git a/Utility/DBus.hs b/Utility/DBus.hs index 3523a3aa3..5b0470301 100644 --- a/Utility/DBus.hs +++ b/Utility/DBus.hs @@ -1,14 +1,15 @@ {- DBus utilities - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} module Utility.DBus where +import Utility.PartialPrelude import Utility.Exception import DBus.Client @@ -22,7 +23,7 @@ type ServiceName = String listServiceNames :: Client -> IO [ServiceName] listServiceNames client = do reply <- callDBus client "ListNames" [] - return $ fromMaybe [] $ fromVariant (methodReturnBody reply !! 0) + return $ fromMaybe [] $ fromVariant =<< headMaybe (methodReturnBody reply) callDBus :: Client -> MemberName -> [Variant] -> IO MethodReturn callDBus client name params = call_ client $ diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs index 11aa57686..d7f0407be 100644 --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -1,8 +1,8 @@ {- daemon support - - - Copyright 2012-2014 Joey Hess <joey@kitenet.net> + - Copyright 2012-2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} @@ -15,7 +15,7 @@ import Utility.PID import Utility.LogFile #else import Utility.WinProcess -import Utility.WinLock +import Utility.LockFile #endif #ifndef mingw32_HOST_OS @@ -36,10 +36,10 @@ daemonize logfd pidfile changedirectory a = do _ <- forkProcess child1 out where - checkalreadyrunning f = maybe noop (const $ alreadyRunning) + checkalreadyrunning f = maybe noop (const alreadyRunning) =<< checkDaemon f child1 = do - _ <- createSession + _ <- tryIO createSession _ <- forkProcess child2 out child2 = do @@ -49,13 +49,33 @@ daemonize logfd pidfile changedirectory a = do nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags redir nullfd stdInput redirLog logfd - {- forkProcess masks async exceptions; unmask them inside - - the action. -} + {- In old versions of ghc, forkProcess masks async exceptions; + - unmask them inside the action. -} wait =<< asyncWithUnmask (\unmask -> unmask a) out out = exitImmediately ExitSuccess #endif +{- To run an action that is normally daemonized in the forground. -} +#ifndef mingw32_HOST_OS +foreground :: Fd -> Maybe FilePath -> IO () -> IO () +foreground logfd pidfile a = do +#else +foreground :: Maybe FilePath -> IO () -> IO () +foreground pidfile a = do +#endif + maybe noop lockPidFile pidfile +#ifndef mingw32_HOST_OS + _ <- tryIO createSession + redirLog logfd +#endif + a +#ifndef mingw32_HOST_OS + exitImmediately ExitSuccess +#else + exitWith ExitSuccess +#endif + {- Locks the pid file, with an exclusive, non-blocking lock, - and leaves it locked on return. - @@ -153,7 +173,7 @@ winLockFile pid pidfile = do cleanstale return $ prefix ++ show pid ++ suffix where - prefix = pidfile ++ "." + prefix = pidfile ++ "." suffix = ".lck" cleanstale = mapM_ (void . tryIO . removeFile) =<< (filter iswinlockfile <$> dirContents (parentDir pidfile)) diff --git a/Utility/Data.hs b/Utility/Data.hs index 359258296..5ecd218fb 100644 --- a/Utility/Data.hs +++ b/Utility/Data.hs @@ -1,8 +1,8 @@ {- utilities for simple data types - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Data where diff --git a/Utility/DataUnits.hs b/Utility/DataUnits.hs index 2a936f1fd..2ece14305 100644 --- a/Utility/DataUnits.hs +++ b/Utility/DataUnits.hs @@ -1,8 +1,8 @@ {- data size display and parsing - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2011 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause - - - And now a rant: @@ -41,6 +41,7 @@ module Utility.DataUnits ( memoryUnits, bandwidthUnits, oldSchoolUnits, + Unit(..), roughSize, compareSizes, @@ -111,7 +112,7 @@ roughSize units short i | i < 0 = '-' : findUnit units' (negate i) | otherwise = findUnit units' i where - units' = reverse $ sort units -- largest first + units' = sortBy (flip compare) units -- largest first findUnit (u@(Unit s _ _):us) i' | i' >= s = showUnit i' u @@ -120,7 +121,7 @@ roughSize units short i showUnit x (Unit size abbrev name) = s ++ " " ++ unit where - v = (fromInteger x :: Double) / fromInteger size + v = (fromInteger x :: Double) / fromInteger size s = showImprecise 2 v unit | short = abbrev diff --git a/Utility/DirWatcher.hs b/Utility/DirWatcher.hs index 077410575..3d3c14619 100644 --- a/Utility/DirWatcher.hs +++ b/Utility/DirWatcher.hs @@ -4,9 +4,9 @@ - (and subdirectories) for changes, and runs hooks for different - sorts of events as they occur. - - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} diff --git a/Utility/DirWatcher/FSEvents.hs b/Utility/DirWatcher/FSEvents.hs index 26e1f7671..a07139c44 100644 --- a/Utility/DirWatcher/FSEvents.hs +++ b/Utility/DirWatcher/FSEvents.hs @@ -1,8 +1,8 @@ {- FSEvents interface - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.DirWatcher.FSEvents where @@ -19,9 +19,9 @@ watchDir dir ignored scanevents hooks = do unlessM fileLevelEventsSupported $ error "Need at least OSX 10.7.0 for file-level FSEvents" scan dir - eventStreamCreate [dir] 1.0 True True True handle + eventStreamCreate [dir] 1.0 True True True dispatch where - handle evt + dispatch evt | ignoredPath ignored (eventPath evt) = noop | otherwise = do {- More than one flag may be set, if events occurred diff --git a/Utility/DirWatcher/INotify.hs b/Utility/DirWatcher/INotify.hs index 016858b1b..4d11b95a8 100644 --- a/Utility/DirWatcher/INotify.hs +++ b/Utility/DirWatcher/INotify.hs @@ -1,8 +1,8 @@ {- higher-level inotify interface - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.DirWatcher.INotify where diff --git a/Utility/DirWatcher/Kqueue.hs b/Utility/DirWatcher/Kqueue.hs index 3ddef603f..b0a6ed84f 100644 --- a/Utility/DirWatcher/Kqueue.hs +++ b/Utility/DirWatcher/Kqueue.hs @@ -1,8 +1,8 @@ {- BSD kqueue file modification notification interface - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE ForeignFunctionInterface #-} diff --git a/Utility/DirWatcher/Types.hs b/Utility/DirWatcher/Types.hs index 8cfa69d34..75ef69f83 100644 --- a/Utility/DirWatcher/Types.hs +++ b/Utility/DirWatcher/Types.hs @@ -1,8 +1,8 @@ {- generic directory watching types - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.DirWatcher.Types where diff --git a/Utility/DirWatcher/Win32Notify.hs b/Utility/DirWatcher/Win32Notify.hs index f095e5d0e..3428f3db3 100644 --- a/Utility/DirWatcher/Win32Notify.hs +++ b/Utility/DirWatcher/Win32Notify.hs @@ -1,8 +1,8 @@ {- Win32-notify interface - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.DirWatcher.Win32Notify where @@ -17,10 +17,10 @@ watchDir :: FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO WatchMana watchDir dir ignored scanevents hooks = do scan dir wm <- initWatchManager - void $ watchDirectory wm dir True [Create, Delete, Modify, Move] handle + void $ watchDirectory wm dir True [Create, Delete, Modify, Move] dispatch return wm where - handle evt + dispatch evt | ignoredPath ignored (filePath evt) = noop | otherwise = case evt of (Deleted _ _) diff --git a/Utility/Directory.hs b/Utility/Directory.hs index f1bcfada3..85ec8bf45 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -1,8 +1,8 @@ -{- directory manipulation +{- directory traversal and manipulation - - - Copyright 2011-2014 Joey Hess <joey@kitenet.net> + - Copyright 2011-2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} @@ -11,12 +11,19 @@ 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 Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) +import Data.Maybe + +#ifdef mingw32_HOST_OS +import qualified System.Win32 as Win32 +#else +import qualified System.Posix as Posix +#endif import Utility.PosixFiles import Utility.SafeCommand @@ -43,13 +50,13 @@ dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d - When the directory does not exist, no exception is thrown, - instead, [] is returned. -} dirContentsRecursive :: FilePath -> IO [FilePath] -dirContentsRecursive topdir = dirContentsRecursiveSkipping (const False) True topdir +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 [] = return [] go (dir:dirs) | skipdir (takeFileName dir) = go dirs | otherwise = unsafeInterleaveIO $ do @@ -80,7 +87,7 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir] dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath] dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] where - go c [] = return c + go c [] = return c go c (dir:dirs) | skipdir (takeFileName dir) = go c dirs | otherwise = unsafeInterleaveIO $ do @@ -106,7 +113,7 @@ moveFile src dest = tryIO (rename src dest) >>= onrename whenM (isdir dest) rethrow viaTmp mv dest undefined where - rethrow = throw e + rethrow = throwM e mv tmp _ = do ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] unless ok $ do @@ -133,3 +140,90 @@ nukeFile file = void $ tryWhenExists go #else go = removeFile file #endif + +#ifndef mingw32_HOST_OS +data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream +#else +data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ()) +#endif + +type IsOpen = MVar () -- full when the handle is open + +openDirectory :: FilePath -> IO DirectoryHandle +openDirectory path = do +#ifndef mingw32_HOST_OS + dirp <- Posix.openDirStream path + isopen <- newMVar () + return (DirectoryHandle isopen dirp) +#else + (h, fdat) <- Win32.findFirstFile (path </> "*") + -- Indicate that the fdat contains a filename that readDirectory + -- has not yet returned, by making the MVar be full. + -- (There's always at least a "." entry.) + alreadyhave <- newMVar () + isopen <- newMVar () + return (DirectoryHandle isopen h fdat alreadyhave) +#endif + +closeDirectory :: DirectoryHandle -> IO () +#ifndef mingw32_HOST_OS +closeDirectory (DirectoryHandle isopen dirp) = + whenOpen isopen $ + Posix.closeDirStream dirp +#else +closeDirectory (DirectoryHandle isopen h _ alreadyhave) = + whenOpen isopen $ do + _ <- tryTakeMVar alreadyhave + Win32.findClose h +#endif + where + whenOpen :: IsOpen -> IO () -> IO () + whenOpen mv f = do + v <- tryTakeMVar mv + when (isJust v) f + +{- |Reads the next entry from the handle. Once the end of the directory +is reached, returns Nothing and automatically closes the handle. +-} +readDirectory :: DirectoryHandle -> IO (Maybe FilePath) +#ifndef mingw32_HOST_OS +readDirectory hdl@(DirectoryHandle _ dirp) = do + e <- Posix.readDirStream dirp + if null e + then do + closeDirectory hdl + return Nothing + else return (Just e) +#else +readDirectory hdl@(DirectoryHandle _ h fdat mv) = do + -- If the MVar is full, then the filename in fdat has + -- not yet been returned. Otherwise, need to find the next + -- file. + r <- tryTakeMVar mv + case r of + Just () -> getfn + Nothing -> do + more <- Win32.findNextFile h fdat + if more + then getfn + else do + closeDirectory hdl + return Nothing + where + getfn = do + filename <- Win32.getFindDataFileName fdat + return (Just filename) +#endif + +-- True only when directory exists and contains nothing. +-- Throws exception if directory does not exist. +isDirectoryEmpty :: FilePath -> IO Bool +isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check + where + check h = do + v <- readDirectory h + case v of + Nothing -> return True + Just f + | not (dirCruft f) -> return False + | otherwise -> check h diff --git a/Utility/DiskFree.hs b/Utility/DiskFree.hs index 2f296e2cb..c4125d4f0 100644 --- a/Utility/DiskFree.hs +++ b/Utility/DiskFree.hs @@ -1,8 +1,8 @@ {- disk free space checking - - - Copyright 2012, 2014 Joey Hess <joey@kitenet.net> + - Copyright 2012, 2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE ForeignFunctionInterface, CPP #-} diff --git a/Utility/Dot.hs b/Utility/Dot.hs index e57bf009f..e21915d32 100644 --- a/Utility/Dot.hs +++ b/Utility/Dot.hs @@ -1,8 +1,8 @@ {- a simple graphviz / dot(1) digraph description generator library - - - Copyright 2010 Joey Hess <joey@kitenet.net> + - Copyright 2010 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Dot where -- import qualified diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs new file mode 100644 index 000000000..67e40ff3c --- /dev/null +++ b/Utility/DottedVersion.hs @@ -0,0 +1,36 @@ +{- dotted versions, such as 1.0.1 + - + - Copyright 2011-2014 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +module Utility.DottedVersion where + +import Common + +data DottedVersion = DottedVersion String Integer + deriving (Eq) + +instance Ord DottedVersion where + compare (DottedVersion _ x) (DottedVersion _ y) = compare x y + +instance Show DottedVersion where + show (DottedVersion s _) = s + +{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to + - a somewhat arbitrary integer representation. -} +normalize :: String -> DottedVersion +normalize v = DottedVersion v $ + sum $ mult 1 $ reverse $ extend precision $ take precision $ + map readi $ split "." v + where + extend n l = l ++ replicate (n - length l) 0 + mult _ [] = [] + mult n (x:xs) = (n*x) : mult (n*10^width) xs + readi :: String -> Integer + readi s = case reads s of + ((x,_):_) -> x + _ -> 0 + precision = 10 -- number of segments of the version to compare + width = length "yyyymmddhhmmss" -- maximum width of a segment diff --git a/Utility/Env.hs b/Utility/Env.hs index 90ed58f6b..fdf06d807 100644 --- a/Utility/Env.hs +++ b/Utility/Env.hs @@ -1,8 +1,8 @@ {- portable environment variables - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} @@ -14,6 +14,7 @@ import Utility.Exception import Control.Applicative import Data.Maybe import qualified System.Environment as E +import qualified System.SetEnv #else import qualified System.Posix.Env as PE #endif @@ -39,27 +40,27 @@ getEnvironment = PE.getEnvironment getEnvironment = E.getEnvironment #endif -{- Returns True if it could successfully set the environment variable. +{- Sets an environment variable. To overwrite an existing variable, + - overwrite must be True. - - - 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 + - On Windows, setting a variable to "" unsets it. -} +setEnv :: String -> String -> Bool -> IO () #ifndef mingw32_HOST_OS -setEnv var val overwrite = do - PE.setEnv var val overwrite - return True +setEnv var val overwrite = PE.setEnv var val overwrite #else -setEnv _ _ _ = return False +setEnv var val True = System.SetEnv.setEnv var val +setEnv var val False = do + r <- getEnv var + case r of + Nothing -> setEnv var val True + Just _ -> return () #endif -{- Returns True if it could successfully unset the environment variable. -} -unsetEnv :: String -> IO Bool +unsetEnv :: String -> IO () #ifndef mingw32_HOST_OS -unsetEnv var = do - PE.unsetEnv var - return True +unsetEnv = PE.unsetEnv #else -unsetEnv _ = return False +unsetEnv = System.SetEnv.unsetEnv #endif {- Adds the environment variable to the input environment. If already diff --git a/Utility/Exception.hs b/Utility/Exception.hs index cf2c615c7..ab47ae95f 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -1,59 +1,88 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2012 Joey Hess <joey@kitenet.net> + - Copyright 2011-2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE ScopedTypeVariables #-} -module Utility.Exception where +module Utility.Exception ( + module X, + catchBoolIO, + catchMaybeIO, + catchDefaultIO, + catchMsgIO, + catchIO, + tryIO, + bracketIO, + catchNonAsync, + tryNonAsync, + tryWhenExists, +) where -import Control.Exception -import qualified Control.Exception as E -import Control.Applicative +import Control.Monad.Catch as X hiding (Handler) +import qualified Control.Monad.Catch as M +import Control.Exception (IOException, AsyncException) import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError) import Utility.Data {- Catches IO errors and returns a Bool -} -catchBoolIO :: IO Bool -> IO Bool -catchBoolIO a = catchDefaultIO False a +catchBoolIO :: MonadCatch m => m Bool -> m Bool +catchBoolIO = catchDefaultIO False {- Catches IO errors and returns a Maybe -} -catchMaybeIO :: IO a -> IO (Maybe a) -catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a +catchMaybeIO :: MonadCatch m => m a -> m (Maybe a) +catchMaybeIO a = do + catchDefaultIO Nothing $ do + v <- a + return (Just v) {- Catches IO errors and returns a default value. -} -catchDefaultIO :: a -> IO a -> IO a +catchDefaultIO :: MonadCatch m => a -> m a -> m 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 +catchMsgIO :: MonadCatch m => m a -> m (Either String a) +catchMsgIO a = do + v <- tryIO a + return $ either (Left . show) Right v {- catch specialized for IO errors only -} -catchIO :: IO a -> (IOException -> IO a) -> IO a -catchIO = E.catch +catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a +catchIO = M.catch {- try specialized for IO errors only -} -tryIO :: IO a -> IO (Either IOException a) -tryIO = try +tryIO :: MonadCatch m => m a -> m (Either IOException a) +tryIO = M.try + +{- bracket with setup and cleanup actions lifted to IO. + - + - Note that unlike catchIO and tryIO, this catches all exceptions. -} +bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a +bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup) {- 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 :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` - [ Handler (\ (e :: AsyncException) -> throw e) - , Handler (\ (e :: SomeException) -> onerr e) + [ M.Handler (\ (e :: AsyncException) -> throwM e) + , M.Handler (\ (e :: SomeException) -> onerr e) ] -tryNonAsync :: IO a -> IO (Either SomeException a) -tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left) +tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a) +tryNonAsync a = go `catchNonAsync` (return . Left) + where + go = do + v <- a + return (Right v) {- Catches only DoesNotExist exceptions, and lets all others through. -} -tryWhenExists :: IO a -> IO (Maybe a) -tryWhenExists a = eitherToMaybe <$> - tryJust (guard . isDoesNotExistError) a +tryWhenExists :: MonadCatch m => m a -> m (Maybe a) +tryWhenExists a = do + v <- tryJust (guard . isDoesNotExistError) a + return (eitherToMaybe v) diff --git a/Utility/ExternalSHA.hs b/Utility/ExternalSHA.hs index adbde795a..6cef2830d 100644 --- a/Utility/ExternalSHA.hs +++ b/Utility/ExternalSHA.hs @@ -3,9 +3,9 @@ - This is typically a bit faster than using Haskell libraries, - by around 1% to 10%. Worth it for really big files. - - - Copyright 2011-2013 Joey Hess <joey@kitenet.net> + - Copyright 2011-2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.ExternalSHA (externalSHA) where @@ -14,8 +14,8 @@ import Utility.SafeCommand import Utility.Process import Utility.FileSystemEncoding import Utility.Misc +import Utility.Exception -import System.Process import Data.List import Data.Char import Control.Applicative @@ -23,7 +23,7 @@ import System.IO externalSHA :: String -> Int -> FilePath -> IO (Either String String) externalSHA command shasize file = do - ls <- lines <$> readsha (toCommand [File file]) + ls <- lines <$> catchDefaultIO "" (readsha (toCommand [File file])) return $ sanitycheck =<< parse ls where {- sha commands output the filename, so need to set fileEncoding -} @@ -57,7 +57,7 @@ externalSHA command shasize file = do Left $ "Unexpected character in output of " ++ command ++ "\"" ++ sha ++ "\"" | otherwise = Right sha' where - sha' = map toLower sha + sha' = map toLower sha expectedSHALength :: Int -> Int expectedSHALength 1 = 40 diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index d8fb866ae..5c4001ed8 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -1,23 +1,25 @@ {- File mode utilities. - - - Copyright 2010-2012 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} module Utility.FileMode where -import Common - -import Control.Exception (bracket) +import System.IO +import Control.Monad 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 @@ -56,6 +58,12 @@ 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 @@ -145,9 +153,5 @@ setSticky f = modifyFileMode f $ addModes [stickyMode] writeFileProtected :: FilePath -> String -> IO () writeFileProtected file content = withUmask 0o0077 $ withFile file WriteMode $ \h -> do - void $ tryIO $ modifyFileMode file $ - removeModes - [ groupReadMode, otherReadMode - , groupWriteMode, otherWriteMode - ] + void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes hPutStr h content diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs new file mode 100644 index 000000000..1055754cb --- /dev/null +++ b/Utility/FileSize.hs @@ -0,0 +1,35 @@ +{- File size. + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.FileSize where + +import System.PosixCompat.Files +#ifdef mingw32_HOST_OS +import Control.Exception (bracket) +import System.IO +#endif + +{- Gets the size of a file. + - + - This is better than using fileSize, because on Windows that returns a + - FileOffset which maxes out at 2 gb. + - See https://github.com/jystic/unix-compat/issues/16 + -} +getFileSize :: FilePath -> IO Integer +#ifndef mingw32_HOST_OS +getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f) +#else +getFileSize f = bracket (openFile f ReadMode) hClose hFileSize +#endif + +{- Gets the size of the file, when its FileStatus is already known. -} +getFileSize' :: FilePath -> FileStatus -> IO Integer +#ifndef mingw32_HOST_OS +getFileSize' _ s = return $ fromIntegral $ fileSize s +#else +getFileSize' f _ = getFileSize f +#endif diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index 690942cba..844e81e59 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -1,8 +1,8 @@ {- GHC File system encoding handling. - - - Copyright 2012-2014 Joey Hess <joey@kitenet.net> + - Copyright 2012-2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} @@ -111,7 +111,7 @@ truncateFilePath :: Int -> FilePath -> FilePath #ifndef mingw32_HOST_OS truncateFilePath n = go . reverse where - go f = + go f = let bytes = decodeW8 f in if length bytes <= n then reverse f diff --git a/Utility/Format.hs b/Utility/Format.hs index e7a27515e..0a6f6ce7d 100644 --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -1,8 +1,8 @@ {- Formatted string handling. - - - Copyright 2010, 2011 Joey Hess <joey@kitenet.net> + - Copyright 2010, 2011 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Format ( @@ -117,7 +117,7 @@ decode_c s = unescape ("", s) handle (x:'x':n1:n2:rest) | isescape x && allhex = (fromhex, rest) where - allhex = isHexDigit n1 && isHexDigit n2 + allhex = isHexDigit n1 && isHexDigit n2 fromhex = [chr $ readhex [n1, n2]] readhex h = Prelude.read $ "0x" ++ h :: Int handle (x:n1:n2:n3:rest) diff --git a/Utility/FreeDesktop.hs b/Utility/FreeDesktop.hs index da9d7b618..ee1c2f302 100644 --- a/Utility/FreeDesktop.hs +++ b/Utility/FreeDesktop.hs @@ -5,9 +5,9 @@ - http://standards.freedesktop.org/menu-spec/latest/ - http://standards.freedesktop.org/icon-theme-spec/latest/ - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.FreeDesktop ( diff --git a/Utility/Glob.hs b/Utility/Glob.hs index 1a77da7d3..d35a96849 100644 --- a/Utility/Glob.hs +++ b/Utility/Glob.hs @@ -3,9 +3,9 @@ - This uses TDFA when available, with a fallback to regex-compat. - TDFA is less buggy in its support for non-unicode characters. - - - Copyright 2014 Joey Hess <joey@kitenet.net> + - Copyright 2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 05c03d6ef..37508a495 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -1,6 +1,6 @@ {- gpg interface - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2011 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -11,6 +11,7 @@ module Utility.Gpg where import Control.Applicative import Control.Concurrent +import Control.Monad.IO.Class import qualified Data.Map as M import Common @@ -18,7 +19,7 @@ import qualified Build.SysConfig as SysConfig #ifndef mingw32_HOST_OS import System.Posix.Types -import Control.Exception (bracket) +import qualified System.Posix.IO import System.Path import Utility.Env #else @@ -104,23 +105,23 @@ pipeStrict params input = do - - Note that to avoid deadlock with the cleanup stage, - the reader must fully consume gpg's input before returning. -} -feedRead :: [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a +feedRead :: (MonadIO m, MonadMask m) => [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> m a) -> m a feedRead params passphrase feeder reader = do #ifndef mingw32_HOST_OS -- pipe the passphrase into gpg on a fd - (frompipe, topipe) <- createPipe - void $ forkIO $ do + (frompipe, topipe) <- liftIO System.Posix.IO.createPipe + liftIO $ void $ forkIO $ do toh <- fdToHandle topipe hPutStrLn toh passphrase hClose toh let Fd pfd = frompipe let passphrasefd = [Param "--passphrase-fd", Param $ show pfd] - closeFd frompipe `after` go (passphrasefd ++ params) + liftIO (closeFd frompipe) `after` go (passphrasefd ++ params) #else -- store the passphrase in a temp file for gpg withTmpFile "gpg" $ \tmpfile h -> do - hPutStr h passphrase - hClose h + liftIO $ hPutStr h passphrase + liftIO $ hClose h let passphrasefile = [Param "--passphrase-file", File tmpfile] go $ passphrasefile ++ params #endif @@ -128,15 +129,24 @@ feedRead params passphrase feeder reader = do go params' = pipeLazy params' feeder reader {- Like feedRead, but without passphrase. -} -pipeLazy :: [CommandParam] -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a +pipeLazy :: (MonadIO m, MonadMask m) => [CommandParam] -> (Handle -> IO ()) -> (Handle -> m a) -> m a pipeLazy params feeder reader = do - params' <- stdParams $ Param "--batch" : params - withBothHandles createProcessSuccess (proc gpgcmd params') - $ \(to, from) -> do - void $ forkIO $ do - feeder to - hClose to - reader from + params' <- liftIO $ stdParams $ Param "--batch" : params + let p = (proc gpgcmd params') + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + } + bracket (setup p) (cleanup p) go + where + setup = liftIO . createProcess + cleanup p (_, _, _, pid) = liftIO $ forceSuccessProcess p pid + go p = do + let (to, from) = bothHandles p + liftIO $ void $ forkIO $ do + feeder to + hClose to + reader from {- Finds gpg public keys matching some string. (Could be an email address, - a key id, or a name; See the section 'HOW TO SPECIFY A USER ID' of @@ -145,7 +155,7 @@ findPubKeys :: String -> IO KeyIds findPubKeys for = KeyIds . parse . lines <$> readStrict params where params = [Params "--with-colons --list-public-keys", Param for] - parse = catMaybes . map (keyIdField . split ":") + parse = mapMaybe (keyIdField . split ":") keyIdField ("pub":_:_:_:f:_) = Just f keyIdField _ = Nothing @@ -154,9 +164,10 @@ type UserId = String {- All of the user's secret keys, with their UserIds. - Note that the UserId may be empty. -} secretKeys :: IO (M.Map KeyId UserId) -secretKeys = M.fromList . parse . lines <$> readStrict params +secretKeys = catchDefaultIO M.empty makemap where - params = [Params "--with-colons --list-secret-keys --fixed-list-mode"] + makemap = M.fromList . parse . lines <$> readStrict params + params = [Params "--with-colons --list-secret-keys --fixed-list-mode"] parse = extract [] Nothing . map (split ":") extract c (Just keyid) (("uid":_:_:_:_:_:_:_:_:userid:_):rest) = extract ((keyid, decode_c userid):c) Nothing rest @@ -186,7 +197,7 @@ genSecretKey keytype passphrase userid keysize = withHandle StdinHandle createProcessSuccess (proc gpgcmd params) feeder where params = ["--batch", "--gen-key"] - feeder h = do + feeder h = do hPutStr h $ unlines $ catMaybes [ Just $ "Key-Type: " ++ case keytype of @@ -195,7 +206,7 @@ genSecretKey keytype passphrase userid keysize = Algo n -> show n , Just $ "Key-Length: " ++ show keysize , Just $ "Name-Real: " ++ userid - , Just $ "Expire-Date: 0" + , Just "Expire-Date: 0" , if null passphrase then Nothing else Just $ "Passphrase: " ++ passphrase @@ -222,7 +233,7 @@ genRandom highQuality size = checksize <$> readStrict randomquality :: Int randomquality = if highQuality then 2 else 1 - {- The size is the number of bytes of entropy desired; the data is + {- The size is the number of bytes of entropy desired; the data is - base64 encoded, so needs 8 bits to represent every 6 bytes of - entropy. -} expectedlength = size * 8 `div` 6 @@ -324,7 +335,7 @@ testHarness a = do setup = do base <- getTemporaryDirectory dir <- mktmpdir $ base </> "gpgtmpXXXXXX" - void $ setEnv var dir True + setEnv var dir True -- For some reason, recent gpg needs a trustdb to be set up. _ <- pipeStrict [Params "--trust-model auto --update-trustdb"] [] _ <- pipeStrict [Params "--import -q"] $ unlines diff --git a/Utility/Hash.hs b/Utility/Hash.hs index cecc6af3e..9881815bd 100644 --- a/Utility/Hash.hs +++ b/Utility/Hash.hs @@ -1,8 +1,4 @@ -{- Convenience wrapper around cryptohash. - - Falls back to SHA if it's not available. - -} - -{-# LANGUAGE CPP #-} +{- Convenience wrapper around cryptohash. -} module Utility.Hash ( sha1, @@ -10,19 +6,16 @@ module Utility.Hash ( sha256, sha384, sha512, -#ifdef WITH_CRYPTOHASH skein256, skein512, -#endif + md5, prop_hashes_stable ) where import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Char8 as C8 +import qualified Data.Text as T +import qualified Data.Text.Encoding as T -#ifndef WITH_CRYPTOHASH -import Data.Digest.Pure.SHA -#else import Crypto.Hash sha1 :: L.ByteString -> Digest SHA1 @@ -50,7 +43,8 @@ skein256 = hashlazy skein512 :: L.ByteString -> Digest Skein512_512 skein512 = hashlazy -#endif +md5 :: L.ByteString -> Digest MD5 +md5 = hashlazy {- Check that all the hashes continue to hash the same. -} prop_hashes_stable :: Bool @@ -60,10 +54,9 @@ prop_hashes_stable = all (\(hasher, result) -> hasher foo == result) , (show . sha256, "2c26b46b68ffc68ff99b453c1d30413413422d706483bfa0f98a5e886266e7ae") , (show . sha384, "98c11ffdfdd540676b1a137cb1a22b2a70350c9a44171d6b1180c6be5cbb2ee3f79d532c8a1dd9ef2e8e08e752a3babb") , (show . sha512, "f7fbba6e0636f890e56fbbf3283e524c6fa3204ae298382d624741d0dc6638326e282c41be5e4254d8820772c5518a2c5a8c0c7f7eda19594a7eb539453e1ed7") -#ifdef WITH_CRYPTOHASH , (show . skein256, "a04efd9a0aeed6ede40fe5ce0d9361ae7b7d88b524aa19917b9315f1ecf00d33") , (show . skein512, "fd8956898113510180aa4658e6c0ac85bd74fb47f4a4ba264a6b705d7a8e8526756e75aecda12cff4f1aca1a4c2830fbf57f458012a66b2b15a3dd7d251690a7") -#endif + , (show . md5, "acbd18db4cc2f85cedef654fccc4a4d8") ] where - foo = L.fromChunks [C8.pack "foo"] + foo = L.fromChunks [T.encodeUtf8 $ T.pack "foo"] diff --git a/Utility/HumanNumber.hs b/Utility/HumanNumber.hs index 904135987..c3fede95f 100644 --- a/Utility/HumanNumber.hs +++ b/Utility/HumanNumber.hs @@ -1,8 +1,8 @@ {- numbers for humans - - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.HumanNumber where @@ -17,5 +17,5 @@ showImprecise precision n int :: Integer (int, frac) = properFraction n remainder = round (frac * 10 ^ precision) :: Integer - pad0s s = (take (precision - length s) (repeat '0')) ++ s + pad0s s = replicate (precision - length s) '0' ++ s striptrailing0s = reverse . dropWhile (== '0') . reverse diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs index 297b2bd97..85a9e15b6 100644 --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -1,8 +1,8 @@ {- Time for humans. - - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.HumanTime ( @@ -27,7 +27,7 @@ import Control.Applicative import qualified Data.Map as M newtype Duration = Duration { durationSeconds :: Integer } - deriving (Eq, Ord, Read, Show) + deriving (Eq, Ord, Read, Show) durationSince :: UTCTime -> IO Duration durationSince pasttime = do @@ -47,8 +47,8 @@ daysToDuration i = Duration $ i * dsecs parseDuration :: String -> Maybe Duration parseDuration = Duration <$$> go 0 where - go n [] = return n - go n s = do + go n [] = return n + go n s = do num <- readish s :: Maybe Integer case dropWhile isDigit s of (c:rest) -> do @@ -59,7 +59,7 @@ parseDuration = Duration <$$> go 0 fromDuration :: Duration -> String fromDuration Duration { durationSeconds = d } | d == 0 = "0s" - | otherwise = concat $ map showunit $ go [] units d + | otherwise = concatMap showunit $ go [] units d where showunit (u, n) | n > 0 = show n ++ [u] diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs index 46ca87bd9..b5fe9034e 100644 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -1,17 +1,51 @@ -{- Caching a file's inode, size, and modification time to see when it's changed. +{- Caching a file's inode, size, and modification time + - to see when it's changed. - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013, 2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} -module Utility.InodeCache where +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Utility.InodeCache ( + InodeCache, + InodeComparisonType(..), + + compareStrong, + compareWeak, + compareBy, + + readInodeCache, + showInodeCache, + genInodeCache, + toInodeCache, + + InodeCacheKey, + inodeCacheToKey, + inodeCacheToMtime, + + SentinalFile(..), + SentinalStatus(..), + TSDelta, + noTSDelta, + writeSentinalFile, + checkSentinalFile, + sentinalFileExists, + + prop_read_show_inodecache +) where import Common import System.PosixCompat.Types import Utility.QuickCheck -data InodeCachePrim = InodeCachePrim FileID FileOffset EpochTime +#ifdef mingw32_HOST_OS +import Data.Word (Word64) +#endif + +data InodeCachePrim = InodeCachePrim FileID Integer EpochTime deriving (Show, Eq, Ord) newtype InodeCache = InodeCache InodeCachePrim @@ -28,10 +62,17 @@ compareStrong (InodeCache x) (InodeCache y) = x == y {- Weak comparison of the inode caches, comparing the size and mtime, - but not the actual inode. Useful when inodes have changed, perhaps - - due to some filesystems being remounted. -} + - due to some filesystems being remounted. + - + - The weak mtime comparison treats any mtimes that are within 2 seconds + - of one-anther as the same. This is because FAT has only a 2 second + - resolution. When a FAT filesystem is used on Linux, higher resolution + - timestamps are cached and used by Linux, but this is lost on unmount, + - so after a remount, the timestamp can appear to have changed. + -} compareWeak :: InodeCache -> InodeCache -> Bool compareWeak (InodeCache (InodeCachePrim _ size1 mtime1)) (InodeCache (InodeCachePrim _ size2 mtime2)) = - size1 == size2 && mtime1 == mtime2 + size1 == size2 && (abs (mtime1 - mtime2) < 2) compareBy :: InodeComparisonType -> InodeCache -> InodeCache -> Bool compareBy Strongly = compareStrong @@ -69,16 +110,100 @@ readInodeCache s = case words s of in InodeCache <$> prim _ -> Nothing -genInodeCache :: FilePath -> IO (Maybe InodeCache) -genInodeCache f = catchDefaultIO Nothing $ toInodeCache <$> getFileStatus f +genInodeCache :: FilePath -> TSDelta -> IO (Maybe InodeCache) +genInodeCache f delta = catchDefaultIO Nothing $ + toInodeCache delta f =<< getFileStatus f + +toInodeCache :: TSDelta -> FilePath -> FileStatus -> IO (Maybe InodeCache) +toInodeCache (TSDelta getdelta) f s + | isRegularFile s = do + delta <- getdelta + sz <- getFileSize' f s + return $ Just $ InodeCache $ InodeCachePrim + (fileID s) + sz + (modificationTime s + delta) + | otherwise = pure Nothing + +{- Some filesystem get new random inodes each time they are mounted. + - To detect this and other problems, a sentinal file can be created. + - Its InodeCache at the time of its creation is written to the cache file, + - so changes can later be detected. -} +data SentinalFile = SentinalFile + { sentinalFile :: FilePath + , sentinalCacheFile :: FilePath + } + deriving (Show) -toInodeCache :: FileStatus -> Maybe InodeCache -toInodeCache s - | isRegularFile s = Just $ InodeCache $ InodeCachePrim - (fileID s) - (fileSize s) - (modificationTime s) - | otherwise = Nothing +{- On Windows, the mtime of a file appears to change when the time zone is + - changed. To deal with this, a TSDelta can be used; the delta is added to + - the mtime when generating an InodeCache. The current delta can be found + - by looking at the SentinalFile. Effectively, this makes all InodeCaches + - use the same time zone that was in use when the sential file was + - originally written. -} +newtype TSDelta = TSDelta (IO EpochTime) + +noTSDelta :: TSDelta +noTSDelta = TSDelta (pure 0) + +writeSentinalFile :: SentinalFile -> IO () +writeSentinalFile s = do + writeFile (sentinalFile s) "" + maybe noop (writeFile (sentinalCacheFile s) . showInodeCache) + =<< genInodeCache (sentinalFile s) noTSDelta + +data SentinalStatus = SentinalStatus + { sentinalInodesChanged :: Bool + , sentinalTSDelta :: TSDelta + } + +{- Checks if the InodeCache of the sentinal file is the same + - as it was when it was originally created. + - + - On Windows, time stamp differences are ignored, since they change + - with the timezone. + - + - When the sential file does not exist, InodeCaches canot reliably be + - compared, so the assumption is that there is has been a change. + -} +checkSentinalFile :: SentinalFile -> IO SentinalStatus +checkSentinalFile s = do + mold <- loadoldcache + case mold of + Nothing -> return dummy + (Just old) -> do + mnew <- gennewcache + case mnew of + Nothing -> return dummy + Just new -> return $ calc old new + where + loadoldcache = catchDefaultIO Nothing $ + readInodeCache <$> readFile (sentinalCacheFile s) + gennewcache = genInodeCache (sentinalFile s) noTSDelta + calc (InodeCache (InodeCachePrim oldinode oldsize oldmtime)) (InodeCache (InodeCachePrim newinode newsize newmtime)) = + SentinalStatus (not unchanged) tsdelta + where +#ifdef mingw32_HOST_OS + -- Since mtime can appear to change when the time zone is + -- changed in windows, we cannot look at the mtime for the + -- sentinal file. + unchanged = oldinode == newinode && oldsize == newsize && (newmtime == newmtime) + tsdelta = TSDelta $ do + -- Run when generating an InodeCache, + -- to get the current delta. + mnew <- gennewcache + return $ case mnew of + Just (InodeCache (InodeCachePrim _ _ currmtime)) -> + oldmtime - currmtime + Nothing -> 0 +#else + unchanged = oldinode == newinode && oldsize == newsize && oldmtime == newmtime + tsdelta = noTSDelta +#endif + dummy = SentinalStatus True noTSDelta + +sentinalFileExists :: SentinalFile -> IO Bool +sentinalFileExists s = allM doesFileExist [sentinalCacheFile s, sentinalFile s] instance Arbitrary InodeCache where arbitrary = @@ -88,6 +213,11 @@ instance Arbitrary InodeCache where <*> arbitrary in InodeCache <$> prim +#ifdef mingw32_HOST_OS +instance Arbitrary FileID where + arbitrary = fromIntegral <$> (arbitrary :: Gen Word64) +#endif + prop_read_show_inodecache :: InodeCache -> Bool prop_read_show_inodecache c = case readInodeCache (showInodeCache c) of Nothing -> False diff --git a/Utility/JSONStream.hs b/Utility/JSONStream.hs index f3e93c3da..2746678cc 100644 --- a/Utility/JSONStream.hs +++ b/Utility/JSONStream.hs @@ -1,8 +1,8 @@ {- Streaming JSON output. - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2011 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.JSONStream ( diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs new file mode 100644 index 000000000..db64d1236 --- /dev/null +++ b/Utility/LinuxMkLibs.hs @@ -0,0 +1,62 @@ +{- Linux library copier and binary shimmer + - + - Copyright 2013 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +module Utility.LinuxMkLibs where + +import Control.Applicative +import Data.Maybe +import System.Directory +import System.FilePath +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 + target <- relPathDirToFile (takeDirectory 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/LockFile.hs b/Utility/LockFile.hs new file mode 100644 index 000000000..f9a0e6783 --- /dev/null +++ b/Utility/LockFile.hs @@ -0,0 +1,20 @@ +{- Lock files + - + - Posix and Windows lock files are extremely different. + - This module does *not* attempt to be a portability shim, it just exposes + - the native locking of the OS. + - + - Copyright 2014 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.LockFile (module X) where + +#ifndef mingw32_HOST_OS +import Utility.LockFile.Posix as X +#else +import Utility.LockFile.Windows as X +#endif diff --git a/Utility/LockFile/Posix.hs b/Utility/LockFile/Posix.hs new file mode 100644 index 000000000..a5775dba1 --- /dev/null +++ b/Utility/LockFile/Posix.hs @@ -0,0 +1,99 @@ +{- Posix lock files + - + - Copyright 2014 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +module Utility.LockFile.Posix ( + LockHandle, + lockShared, + lockExclusive, + tryLockExclusive, + createLockFile, + openExistingLockFile, + isLocked, + checkLocked, + getLockStatus, + dropLock, +) where + +import Utility.Exception +import Utility.Applicative + +import System.IO +import System.Posix +import Data.Maybe + +type LockFile = FilePath + +newtype LockHandle = LockHandle Fd + +-- Takes a shared lock, blocking until the lock is available. +lockShared :: Maybe FileMode -> LockFile -> IO LockHandle +lockShared = lock ReadLock + +-- Takes an exclusive lock, blocking until the lock is available. +lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle +lockExclusive = lock WriteLock + +-- Tries to take an exclusive lock, but does not block. +tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) +tryLockExclusive mode lockfile = do + l <- openLockFile mode lockfile + v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0) + case v of + Left _ -> do + closeFd l + return Nothing + Right _ -> return $ Just $ LockHandle l + +-- Setting the FileMode allows creation of a new lock file. +-- If it's Nothing then this only succeeds when the lock file already exists. +lock :: LockRequest -> Maybe FileMode -> LockFile -> IO LockHandle +lock lockreq mode lockfile = do + l <- openLockFile mode lockfile + waitToSetLock l (lockreq, AbsoluteSeek, 0, 0) + return (LockHandle l) + +-- Create and opens lock file; does not lock it. +createLockFile :: FileMode -> LockFile -> IO Fd +createLockFile filemode = openLockFile (Just filemode) + +-- Opens an existing lock file; does not lock it, and if it does not exist, +-- returns Nothing. +openExistingLockFile :: LockFile -> IO (Maybe Fd) +openExistingLockFile = catchMaybeIO . openLockFile Nothing + +-- Close on exec flag is set so child processes do not inherit the lock. +openLockFile :: Maybe FileMode -> LockFile -> IO Fd +openLockFile filemode lockfile = do + l <- openFd lockfile ReadWrite filemode defaultFileFlags + setFdOption l CloseOnExec True + return l + +-- Check if a file is locked, either exclusively, or with shared lock. +-- When the file doesn't exist, it's considered not locked. +isLocked :: LockFile -> IO Bool +isLocked = fromMaybe False <$$> checkLocked + +-- Returns Nothing when the file doesn't exist, for cases where +-- that is different from it not being locked. +checkLocked :: LockFile -> IO (Maybe Bool) +checkLocked = maybe Nothing (Just . isJust) <$$> getLockStatus' + +getLockStatus :: LockFile -> IO (Maybe (ProcessID, FileLock)) +getLockStatus = fromMaybe Nothing <$$> getLockStatus' + +getLockStatus' :: LockFile -> IO (Maybe (Maybe (ProcessID, FileLock))) +getLockStatus' lockfile = go =<< catchMaybeIO open + where + open = openFd lockfile ReadOnly Nothing defaultFileFlags + go Nothing = return Nothing + go (Just h) = do + ret <- getLock h (ReadLock, AbsoluteSeek, 0, 0) + closeFd h + return (Just ret) + +dropLock :: LockHandle -> IO () +dropLock (LockHandle fd) = closeFd fd diff --git a/Utility/WinLock.hs b/Utility/LockFile/Windows.hs index 7b7cf7132..eff129cee 100644 --- a/Utility/WinLock.hs +++ b/Utility/LockFile/Windows.hs @@ -1,11 +1,11 @@ {- Windows lock files - - - Copyright 2014 Joey Hess <joey@kitenet.net> + - Copyright 2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} -module Utility.WinLock ( +module Utility.LockFile.Windows ( lockShared, lockExclusive, dropLock, @@ -17,9 +17,6 @@ import System.Win32.Types import System.Win32.File import Control.Concurrent -{- Locking is exclusive, and prevents the file from being opened for read - - or write by any other process. So for advisory locking of a file, a - - different LockFile should be used. -} type LockFile = FilePath type LockHandle = HANDLE @@ -30,7 +27,11 @@ lockShared :: LockFile -> IO (Maybe LockHandle) lockShared = openLock fILE_SHARE_READ {- Tries to take an exclusive lock on a file. Fails if another process has - - a shared or exclusive lock. -} + - a shared or exclusive lock. + - + - Note that exclusive locking also prevents the file from being opened for + - read or write by any other progess. So for advisory locking of a file's + - content, a different LockFile should be used. -} lockExclusive :: LockFile -> IO (Maybe LockHandle) lockExclusive = openLock fILE_SHARE_NONE @@ -44,15 +45,20 @@ lockExclusive = openLock fILE_SHARE_NONE - Note that createFile busy-waits to try to avoid failing when some other - process briefly has a file open. But that would make checking locks - much more expensive, so is not done here. Thus, the use of c_CreateFile. + - + - Also, passing Nothing for SECURITY_ATTRIBUTES ensures that the lock file + - is not inheerited by any child process. -} openLock :: ShareMode -> LockFile -> IO (Maybe LockHandle) openLock sharemode f = do h <- withTString f $ \c_f -> - c_CreateFile c_f gENERIC_READ sharemode (maybePtr Nothing) + c_CreateFile c_f gENERIC_READ sharemode security_attributes oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing) return $ if h == iNVALID_HANDLE_VALUE then Nothing else Just h + where + security_attributes = maybePtr Nothing dropLock :: LockHandle -> IO () dropLock = closeHandle diff --git a/Utility/LogFile.hs b/Utility/LogFile.hs index 73fbf820e..bc6d92ca9 100644 --- a/Utility/LogFile.hs +++ b/Utility/LogFile.hs @@ -1,8 +1,8 @@ {- log files - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} @@ -15,13 +15,10 @@ import Common import System.Posix.Types #endif -#ifndef mingw32_HOST_OS -openLog :: FilePath -> IO Fd +openLog :: FilePath -> IO Handle openLog logfile = do rotateLog logfile - openFd logfile WriteOnly (Just stdFileMode) - defaultFileFlags { append = True } -#endif + openFile logfile AppendMode rotateLog :: FilePath -> IO () rotateLog logfile = go 0 diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs index 63009f723..433b7c679 100644 --- a/Utility/Lsof.hs +++ b/Utility/Lsof.hs @@ -1,11 +1,11 @@ {- lsof interface - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} -{-# LANGUAGE BangPatterns, CPP #-} +{-# LANGUAGE CPP #-} module Utility.Lsof where @@ -32,7 +32,7 @@ setup = do when (isAbsolute cmd) $ do path <- getSearchPath let path' = takeDirectory cmd : path - void $ setEnv "PATH" (intercalate [searchPathSeparator] path') True + setEnv "PATH" (intercalate [searchPathSeparator] path') True {- Checks each of the files in a directory to find open files. - Note that this will find hard links to files elsewhere that are open. -} @@ -93,11 +93,15 @@ parseFormatted s = bundle $ go [] $ lines s _ -> parsefail parsefiles c [] = (c, []) - parsefiles c (l:ls) = case splitnull l of - ['a':mode, 'n':file, ""] -> - parsefiles ((file, parsemode mode):c) ls - (('p':_):_) -> (c, l:ls) - _ -> parsefail + parsefiles c (l:ls) = parsefiles' c (splitnull l) l ls + + parsefiles' c ['a':mode, 'n':file, ""] _ ls = + parsefiles ((file, parsemode mode):c) ls + parsefiles' c (('p':_):_) l ls = (c, l:ls) + -- Some buggy versions of lsof emit a f field + -- that was not requested, so ignore it. + parsefiles' c (('f':_):rest) l ls = parsefiles' c rest l ls + parsefiles' _ _ _ _ = parsefail parsemode ('r':_) = OpenReadOnly parsemode ('w':_) = OpenWriteOnly @@ -110,7 +114,7 @@ parseFormatted s = bundle $ go [] $ lines s {- Parses lsof's default output format. -} parseDefault :: LsofParser -parseDefault = catMaybes . map parseline . drop 1 . lines +parseDefault = mapMaybe parseline . drop 1 . lines where parseline l = case words l of (command : spid : _user : _fd : _type : _device : _size : _node : rest) -> diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs index e0a51ff6a..19a77201c 100644 --- a/Utility/Matcher.hs +++ b/Utility/Matcher.hs @@ -10,16 +10,16 @@ - Is forgiving about misplaced closing parens, so "foo and (bar or baz" - will be handled, as will "foo and ( bar or baz ) )" - - - Copyright 2011-2013 Joey Hess <joey@kitenet.net> + - Copyright 2011-2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE Rank2Types, KindSignatures #-} module Utility.Matcher ( Token(..), - Matcher, + Matcher(..), token, tokens, generate, @@ -64,10 +64,10 @@ generate = simplify . process MAny . tokenGroups process m [] = m process m ts = uncurry process $ consume m ts - consume m ((One And):rest) = term (m `MAnd`) rest - consume m ((One Or):rest) = term (m `MOr`) rest - consume m ((One Not):rest) = term (\p -> m `MAnd` (MNot p)) rest - consume m ((One (Operation o)):rest) = (m `MAnd` MOp o, rest) + consume m (One And:rest) = term (m `MAnd`) rest + consume m (One Or:rest) = term (m `MOr`) rest + consume m (One Not:rest) = term (\p -> m `MAnd` (MNot p)) rest + consume m (One (Operation o):rest) = (m `MAnd` MOp o, rest) consume m (Group g:rest) = (process m g, rest) consume m (_:rest) = consume m rest consume m [] = (m, []) @@ -90,7 +90,7 @@ tokenGroups :: [Token op] -> [TokenGroup op] tokenGroups [] = [] tokenGroups (t:ts) = go t where - go Open = + go Open = let (gr, rest) = findClose ts in gr : tokenGroups rest go Close = tokenGroups ts -- not picky about missing Close @@ -101,14 +101,14 @@ findClose l = let (g, rest) = go [] l in (Group (reverse g), rest) where - go c [] = (c, []) -- not picky about extra Close - go c (t:ts) = handle t + go c [] = (c, []) -- not picky about extra Close + go c (t:ts) = dispatch t where - handle Close = (c, ts) - handle Open = + dispatch Close = (c, ts) + dispatch Open = let (c', ts') = go [] ts in go (Group (reverse c') : c) ts' - handle _ = go (One t:c) ts + dispatch _ = go (One t:c) ts {- Checks if a Matcher matches, using a supplied function to check - the value of Operations. -} diff --git a/Utility/Metered.hs b/Utility/Metered.hs index 7ad9b1215..7d6e71cdd 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,8 +1,8 @@ {- Metered IO - - - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2105 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE TypeSynonymInstances #-} @@ -16,6 +16,8 @@ import qualified Data.ByteString as S import System.IO.Unsafe import Foreign.Storable (Storable(sizeOf)) import System.Posix.Types +import Data.Int +import Data.Bits.Utils {- An action that can be run repeatedly, updating it on the bytes processed. - @@ -23,6 +25,9 @@ import System.Posix.Types - far, *not* an incremental amount since the last call. -} type MeterUpdate = (BytesProcessed -> IO ()) +nullMeterUpdate :: MeterUpdate +nullMeterUpdate _ = return () + {- Total number of bytes processed so far. -} newtype BytesProcessed = BytesProcessed Integer deriving (Eq, Ord, Show) @@ -31,6 +36,10 @@ class AsBytesProcessed a where toBytesProcessed :: a -> BytesProcessed fromBytesProcessed :: BytesProcessed -> a +instance AsBytesProcessed BytesProcessed where + toBytesProcessed = id + fromBytesProcessed = id + instance AsBytesProcessed Integer where toBytesProcessed i = BytesProcessed i fromBytesProcessed (BytesProcessed i) = i @@ -39,6 +48,10 @@ instance AsBytesProcessed Int where toBytesProcessed i = BytesProcessed $ toInteger i fromBytesProcessed (BytesProcessed i) = fromInteger i +instance AsBytesProcessed Int64 where + toBytesProcessed i = BytesProcessed $ toInteger i + fromBytesProcessed (BytesProcessed i) = fromInteger i + instance AsBytesProcessed FileOffset where toBytesProcessed sz = BytesProcessed $ toInteger sz fromBytesProcessed (BytesProcessed sz) = fromInteger sz @@ -77,36 +90,53 @@ meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO () meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h -> meteredWrite meterupdate h b +{- Applies an offset to a MeterUpdate. This can be useful when + - performing a sequence of actions, such as multiple meteredWriteFiles, + - that all update a common meter progressively. Or when resuming. + -} +offsetMeterUpdate :: MeterUpdate -> BytesProcessed -> MeterUpdate +offsetMeterUpdate base offset = \n -> base (offset `addBytesProcessed` n) + {- This is like L.hGetContents, but after each chunk is read, a meter - is updated based on the size of the chunk. - + - All the usual caveats about using unsafeInterleaveIO apply to the + - meter updates, so use caution. + -} +hGetContentsMetered :: Handle -> MeterUpdate -> IO L.ByteString +hGetContentsMetered h = hGetUntilMetered h (const True) + +{- Reads from the Handle, updating the meter after each chunk. + - - Note that the meter update is run in unsafeInterleaveIO, which means that - it can be run at any time. It's even possible for updates to run out - of order, as different parts of the ByteString are consumed. - - - All the usual caveats about using unsafeInterleaveIO apply to the - - meter updates, so use caution. + - Stops at EOF, or when keepgoing evaluates to False. + - Closes the Handle at EOF, but otherwise leaves it open. -} -hGetContentsMetered :: Handle -> MeterUpdate -> IO L.ByteString -hGetContentsMetered h meterupdate = lazyRead zeroBytesProcessed +hGetUntilMetered :: Handle -> (Integer -> Bool) -> MeterUpdate -> IO L.ByteString +hGetUntilMetered h keepgoing meterupdate = lazyRead zeroBytesProcessed where lazyRead sofar = unsafeInterleaveIO $ loop sofar loop sofar = do - c <- S.hGetSome h defaultChunkSize + c <- S.hGet h defaultChunkSize if S.null c then do hClose h return $ L.empty else do - let sofar' = addBytesProcessed sofar $ - S.length c + let sofar' = addBytesProcessed sofar (S.length c) meterupdate sofar' - {- unsafeInterleaveIO causes this to be - - deferred until the data is read from the - - ByteString. -} - cs <- lazyRead sofar' - return $ L.append (L.fromChunks [c]) cs + if keepgoing (fromBytesProcessed sofar') + then do + {- unsafeInterleaveIO causes this to be + - deferred until the data is read from the + - ByteString. -} + cs <- lazyRead sofar' + return $ L.append (L.fromChunks [c]) cs + else return $ L.fromChunks [c] {- Same default chunk size Lazy ByteStrings use. -} defaultChunkSize :: Int @@ -114,3 +144,37 @@ defaultChunkSize = 32 * k - chunkOverhead where k = 1024 chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific + +{- Parses the String looking for a command's progress output, and returns + - Maybe the number of bytes rsynced so far, and any any remainder of the + - string that could be an incomplete progress output. That remainder + - should be prepended to future output, and fed back in. This interface + - allows the command's output to be read in any desired size chunk, or + - even one character at a time. + -} +type ProgressParser = String -> (Maybe BytesProcessed, String) + +{- Runs a command and runs a ProgressParser on its output, in order + - to update the meter. The command's output is also sent to stdout. -} +commandMeter :: ProgressParser -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool +commandMeter progressparser meterupdate cmd params = liftIO $ catchBoolIO $ + withHandle StdoutHandle createProcessSuccess p $ + feedprogress zeroBytesProcessed [] + where + p = proc cmd (toCommand params) + + feedprogress prev buf h = do + b <- S.hGetSome h 80 + if S.null b + then return True + else do + S.hPut stdout b + hFlush stdout + let s = w82s (S.unpack b) + let (mbytes, buf') = progressparser (buf++s) + case mbytes of + Nothing -> feedprogress prev buf' h + (Just bytes) -> do + when (bytes /= prev) $ + meterupdate bytes + feedprogress bytes buf' h diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 9c19df833..e4eccac43 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -1,8 +1,8 @@ {- misc utility functions - - - Copyright 2010-2011 Joey Hess <joey@kitenet.net> + - Copyright 2010-2011 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} diff --git a/Utility/Monad.hs b/Utility/Monad.hs index 1ba43c5f8..878e0da67 100644 --- a/Utility/Monad.hs +++ b/Utility/Monad.hs @@ -1,8 +1,8 @@ {- monadic stuff - - - Copyright 2010-2012 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Monad where diff --git a/Utility/Mounts.hsc b/Utility/Mounts.hsc index b6defda43..1fb2362df 100644 --- a/Utility/Mounts.hsc +++ b/Utility/Mounts.hsc @@ -4,7 +4,7 @@ - Volker Wysk <hsss@volker-wysk.de> - - Modified to support BSD, Mac OS X, and Android by - - Joey Hess <joey@kitenet.net> + - Joey Hess <id@joeyh.name> - - Licensed under the GNU LGPL version 2.1 or higher. -} diff --git a/Utility/Network.hs b/Utility/Network.hs index 62523c9e9..7f228e155 100644 --- a/Utility/Network.hs +++ b/Utility/Network.hs @@ -1,8 +1,8 @@ {- network functions - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Network where diff --git a/Utility/NotificationBroadcaster.hs b/Utility/NotificationBroadcaster.hs index 60353116c..6f7cabf10 100644 --- a/Utility/NotificationBroadcaster.hs +++ b/Utility/NotificationBroadcaster.hs @@ -6,9 +6,9 @@ - - Multiple clients are supported. Each has a unique id. - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.NotificationBroadcaster ( diff --git a/Utility/OSX.hs b/Utility/OSX.hs index f9d992575..22028e210 100644 --- a/Utility/OSX.hs +++ b/Utility/OSX.hs @@ -1,8 +1,8 @@ {- OSX stuff - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.OSX where diff --git a/Utility/PID.hs b/Utility/PID.hs index 4867bd6de..ac63045a7 100644 --- a/Utility/PID.hs +++ b/Utility/PID.hs @@ -1,8 +1,8 @@ {- process ids - - - Copyright 2014 Joey Hess <joey@kitenet.net> + - Copyright 2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} diff --git a/Utility/Parallel.hs b/Utility/Parallel.hs index b39880355..2352ba706 100644 --- a/Utility/Parallel.hs +++ b/Utility/Parallel.hs @@ -1,8 +1,8 @@ {- parallel processing via threads - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Parallel where @@ -10,7 +10,6 @@ module Utility.Parallel where import Common import Control.Concurrent -import Control.Exception {- Runs an action in parallel with a set of values, in a set of threads. - In order for the actions to truely run in parallel, requires GHC's diff --git a/Utility/Path.hs b/Utility/Path.hs index 570350d61..6ecec2c5f 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -1,8 +1,8 @@ {- path manipulation - - - Copyright 2010-2014 Joey Hess <joey@kitenet.net> + - Copyright 2010-2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE PackageImports, CPP #-} @@ -21,6 +21,7 @@ import Control.Applicative import qualified System.FilePath.Posix as Posix #else import System.Posix.Files +import Utility.Exception #endif import qualified "MissingH" System.Path as MissingH @@ -65,7 +66,7 @@ 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. -} + - MissingH's absNormPath on them. -} absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath #ifndef mingw32_HOST_OS absNormPathUnix dir path = MissingH.absNormPath dir path @@ -76,27 +77,29 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos 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 "" -} +{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} parentDir :: FilePath -> FilePath -parentDir dir - | null dirs = "" - | otherwise = joinDrive drive (join s $ init dirs) +parentDir = takeDirectory . dropTrailingPathSeparator + +{- Just the parent directory of a path, or Nothing if the path has no +- parent (ie for "/" or ".") -} +upFrom :: FilePath -> Maybe FilePath +upFrom dir + | length dirs < 2 = Nothing + | otherwise = Just $ 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 +prop_upFrom_basics :: FilePath -> Bool +prop_upFrom_basics dir | null dir = True - | dir == "/" = parentDir dir == "" - | otherwise = p /= dir + | dir == "/" = p == Nothing + | otherwise = p /= Just dir where - p = parentDir dir + p = upFrom 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 @@ -125,14 +128,19 @@ absPath file = do - relPathCwdToFile "/tmp/foo/bar" == "" -} relPathCwdToFile :: FilePath -> IO FilePath -relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f +relPathCwdToFile f = do + c <- getCurrentDirectory + relPathDirToFile c f -{- Constructs a relative path from a directory to a file. - - - - Both must be absolute, and cannot contain .. etc. (eg use absPath first). +{- Constructs a relative path from a directory to a file. -} +relPathDirToFile :: FilePath -> FilePath -> IO FilePath +relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to + +{- This requires the first path to be absolute, and the + - second path cannot contain ../ or ./ -} -relPathDirToFile :: FilePath -> FilePath -> FilePath -relPathDirToFile from to = join s $ dotdots ++ uncommon +relPathDirToFileAbs :: FilePath -> FilePath -> FilePath +relPathDirToFileAbs from to = join s $ dotdots ++ uncommon where s = [pathSeparator] pfrom = split s from @@ -148,7 +156,7 @@ prop_relPathDirToFile_basics from to | from == to = null r | otherwise = not (null r) where - r = relPathDirToFile from to + r = relPathDirToFileAbs from to prop_relPathDirToFile_regressionTest :: Bool prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference @@ -157,7 +165,7 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference - 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"]) + relPathDirToFileAbs (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"] @@ -186,7 +194,7 @@ relHome :: FilePath -> IO String relHome path = do home <- myHomeDir return $ if dirContains home path - then "~/" ++ relPathDirToFile home path + then "~/" ++ relPathDirToFileAbs home path else path {- Checks if a command is available in PATH. @@ -235,11 +243,11 @@ toCygPath p | null drive = recombine parts | otherwise = recombine $ "/cygdrive" : driveletter drive : parts where - (drive, p') = splitDrive p + (drive, p') = splitDrive p parts = splitDirectories p' - driveletter = map toLower . takeWhile (/= ':') + driveletter = map toLower . takeWhile (/= ':') recombine = fixtrailing . Posix.joinPath - fixtrailing s + fixtrailing s | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s | otherwise = s #endif @@ -255,7 +263,9 @@ fileNameLengthLimit :: FilePath -> IO Int fileNameLengthLimit _ = return 255 #else fileNameLengthLimit dir = do - l <- fromIntegral <$> getPathVar dir FileNameLimit + -- getPathVar can fail due to statfs(2) overflow + l <- catchDefaultIO 0 $ + fromIntegral <$> getPathVar dir FileNameLimit if l <= 0 then return 255 else return $ minimum [l, 255] @@ -267,12 +277,13 @@ fileNameLengthLimit dir = do - sane FilePath. - - All spaces and punctuation and other wacky stuff are replaced - - with '_', except for '.' "../" will thus turn into ".._", which is safe. + - with '_', except for '.' + - "../" will thus turn into ".._", which is safe. -} sanitizeFilePath :: String -> FilePath sanitizeFilePath = map sanitize where - sanitize c + sanitize c | c == '.' = c | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' | otherwise = c diff --git a/Utility/Percentage.hs b/Utility/Percentage.hs index d4b2da429..a30c26037 100644 --- a/Utility/Percentage.hs +++ b/Utility/Percentage.hs @@ -1,8 +1,8 @@ {- percentages - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Percentage ( diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs index 23edc25c9..5a94ead01 100644 --- a/Utility/PosixFiles.hs +++ b/Utility/PosixFiles.hs @@ -2,9 +2,9 @@ - - This is like System.PosixCompat.Files, except with a fixed rename. - - - Copyright 2014 Joey Hess <joey@kitenet.net> + - Copyright 2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} diff --git a/Utility/Process.hs b/Utility/Process.hs index 1945e4b9d..8fefaa54c 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -1,18 +1,19 @@ {- System.Process enhancements, including additional ways of running - processes, and logging. - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP, Rank2Types #-} module Utility.Process ( module X, - CreateProcess, + CreateProcess(..), StdHandle(..), readProcess, + readProcess', readProcessEnv, writeReadProcessEnv, forceSuccessProcess, @@ -31,11 +32,13 @@ module Utility.Process ( stdinHandle, stdoutHandle, stderrHandle, + bothHandles, + processHandle, devNull, ) where import qualified System.Process -import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess) +import qualified 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 @@ -44,7 +47,7 @@ import Control.Concurrent import qualified Control.Exception as E import Control.Monad #ifndef mingw32_HOST_OS -import System.Posix.IO +import qualified System.Posix.IO #else import Control.Applicative #endif @@ -64,17 +67,19 @@ 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 +readProcessEnv cmd args environ = readProcess' p where p = (proc cmd args) { std_out = CreatePipe , env = environ } +readProcess' :: CreateProcess -> IO String +readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do + output <- hGetContentsStrict h + hClose h + return output + {- Runs an action to write to a process on its stdin, - returns its output, and also allows specifying the environment. -} @@ -166,13 +171,13 @@ 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) +processTranscript' cmd opts environ input = do #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 + (readf, writef) <- System.Posix.IO.createPipe + readh <- System.Posix.IO.fdToHandle readf + writeh <- System.Posix.IO.fdToHandle writef p@(_, _, _, pid) <- createProcess $ (proc cmd opts) { std_in = if isJust input then CreatePipe else Inherit @@ -183,24 +188,13 @@ processTranscript' cmd opts environ input = do 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 () - + writeinput input p 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 @@ -211,17 +205,9 @@ processTranscript' cmd opts environ input = do 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 () - + writeinput input p transcript <- (++) <$> getout <*> geterr + ok <- checkSuccessProcess pid return (transcript, ok) #endif @@ -236,6 +222,14 @@ processTranscript' cmd opts environ input = do takeMVar v return s + writeinput (Just s) p = do + let inh = stdinHandle p + unless (null s) $ do + hPutStr inh s + hFlush inh + hClose inh + writeinput Nothing _ = return () + {- 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. -} @@ -313,6 +307,9 @@ bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Han 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 diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index 7f7234c7c..54200d3f7 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -1,8 +1,8 @@ {- QuickCheck with additional instances - - - Copyright 2012-2014 Joey Hess <joey@kitenet.net> + - Copyright 2012-2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/Utility/Quvi.hs b/Utility/Quvi.hs index bb4975cbe..33653b07b 100644 --- a/Utility/Quvi.hs +++ b/Utility/Quvi.hs @@ -1,8 +1,8 @@ {- querying quvi (import qualified) - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE OverloadedStrings #-} @@ -22,6 +22,7 @@ data QuviVersion = Quvi04 | Quvi09 | NoQuvi + deriving (Show) data Page = Page { pageTitle :: String @@ -61,7 +62,8 @@ parseEnum s = Page m = M.fromList $ map (separate (== '=')) $ lines s probeVersion :: IO QuviVersion -probeVersion = examine <$> processTranscript "quvi" ["--version"] Nothing +probeVersion = catchDefaultIO NoQuvi $ + examine <$> processTranscript "quviaaa" ["--version"] Nothing where examine (s, True) | "quvi v0.4" `isInfixOf` s = Quvi04 @@ -113,7 +115,7 @@ supported Quvi04 url = boolSystem "quvi" supported Quvi09 url = (firstlevel <&&> secondlevel) `catchNonAsync` (\_ -> return False) where - firstlevel = case uriAuthority =<< parseURIRelaxed url of + firstlevel = case uriAuthority =<< parseURIRelaxed url of Nothing -> return False Just auth -> do let domain = map toLower $ uriRegName auth diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index 2c5e39b6e..241202813 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -1,10 +1,12 @@ {- various rsync stuff - - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - Copyright 2010-2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} +{-# LANGUAGE CPP #-} + module Utility.Rsync where import Common @@ -53,43 +55,18 @@ rsync = boolSystem "rsync" . rsyncParamsFixup {- On Windows, rsync is from Cygwin, and expects to get Cygwin formatted - paths to files. (It thinks that C:foo refers to a host named "C"). - - Fix up all Files in the Params appropriately. -} + - Fix up the Params appropriately. -} rsyncParamsFixup :: [CommandParam] -> [CommandParam] +#ifdef mingw32_HOST_OS rsyncParamsFixup = map fixup where - fixup (File f) = File (toCygPath f) + fixup (File f) = File (toCygPath f) + fixup (Param s) + | rsyncUrlIsPath s = Param (toCygPath s) fixup p = p - -{- Runs rsync, but intercepts its progress output and updates a meter. - - The progress output is also output to stdout. - - - - The params must enable rsync's --progress mode for this to work. - -} -rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool -rsyncProgress meterupdate params = do - r <- catchBoolIO $ - withHandle StdoutHandle createProcessSuccess p (feedprogress 0 []) - {- For an unknown reason, piping rsync's output like this does - - causes it to run a second ssh process, which it neglects to wait - - on. Reap the resulting zombie. -} - reapZombies - return r - where - p = proc "rsync" (toCommand $ rsyncParamsFixup params) - feedprogress prev buf h = do - s <- hGetSomeString h 80 - if null s - then return True - else do - putStr s - hFlush stdout - let (mbytes, buf') = parseRsyncProgress (buf++s) - case mbytes of - Nothing -> feedprogress prev buf' h - (Just bytes) -> do - when (bytes /= prev) $ - meterupdate $ toBytesProcessed bytes - feedprogress bytes buf' h +#else +rsyncParamsFixup = id +#endif {- Checks if an rsync url involves the remote shell (ssh or rsh). - Use of such urls with rsync requires additional shell @@ -109,40 +86,50 @@ rsyncUrlIsShell s {- Checks if a rsync url is really just a local path. -} rsyncUrlIsPath :: String -> Bool rsyncUrlIsPath s +#ifdef mingw32_HOST_OS + | not (null (takeDrive s)) = True +#endif | rsyncUrlIsShell s = False | otherwise = ':' `notElem` s -{- Parses the String looking for rsync progress output, and returns - - Maybe the number of bytes rsynced so far, and any any remainder of the - - string that could be an incomplete progress output. That remainder - - should be prepended to future output, and fed back in. This interface - - allows the output to be read in any desired size chunk, or even one - - character at a time. +{- Runs rsync, but intercepts its progress output and updates a meter. + - The progress output is also output to stdout. - - - Strategy: Look for chunks prefixed with \r (rsync writes a \r before + - The params must enable rsync's --progress mode for this to work. + -} +rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool +rsyncProgress meterupdate = commandMeter parseRsyncProgress meterupdate "rsync" . rsyncParamsFixup + +{- Strategy: Look for chunks prefixed with \r (rsync writes a \r before - the first progress output, and each thereafter). The first number - after the \r is the number of bytes processed. After the number, - there must appear some whitespace, or we didn't get the whole number, - and return the \r and part we did get, for later processing. + - + - In some locales, the number will have one or more commas in the middle + - of it. -} -parseRsyncProgress :: String -> (Maybe Integer, String) +parseRsyncProgress :: ProgressParser parseRsyncProgress = go [] . reverse . progresschunks where go remainder [] = (Nothing, remainder) go remainder (x:xs) = case parsebytes (findbytesstart x) of Nothing -> go (delim:x++remainder) xs - Just b -> (Just b, remainder) + Just b -> (Just (toBytesProcessed b), remainder) delim = '\r' + {- Find chunks that each start with delim. - The first chunk doesn't start with it - (it's empty when delim is at the start of the string). -} progresschunks = drop 1 . split [delim] findbytesstart s = dropWhile isSpace s + + parsebytes :: String -> Maybe Integer parsebytes s = case break isSpace s of ([], _) -> Nothing (_, []) -> Nothing - (b, _) -> readish b + (b, _) -> readish $ filter (/= ',') b {- Filters options to those that are safe to pass to rsync in server mode, - without causing it to eg, expose files. -} diff --git a/Utility/SRV.hs b/Utility/SRV.hs index a2ee704f7..203585a7e 100644 --- a/Utility/SRV.hs +++ b/Utility/SRV.hs @@ -3,9 +3,9 @@ - Uses either the ADNS Haskell library, or the standalone Haskell DNS - package, or the host command. - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} @@ -74,7 +74,7 @@ lookupSRV (SRV srv) = do maybe [] use r #endif where - use = orderHosts . map tohosts + use = orderHosts . map tohosts tohosts (priority, weight, port, hostname) = ( (priority, weight) , (B8.toString hostname, PortNumber $ fromIntegral port) diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index c8318ec2e..a5556200a 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -1,15 +1,14 @@ {- safely running shell commands - - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - Copyright 2010-2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - 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 diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs index acbee70ff..e077a1fea 100644 --- a/Utility/Scheduled.hs +++ b/Utility/Scheduled.hs @@ -1,8 +1,8 @@ {- scheduled activities - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013-2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Scheduled ( @@ -10,7 +10,12 @@ module Utility.Scheduled ( Recurrance(..), ScheduledTime(..), NextTime(..), + WeekDay, + MonthDay, + YearDay, nextTime, + calcNextTime, + startTime, fromSchedule, fromScheduledTime, toScheduledTime, @@ -18,12 +23,17 @@ module Utility.Scheduled ( toRecurrance, toSchedule, parseSchedule, - prop_schedule_roundtrips + prop_schedule_roundtrips, + prop_past_sane, ) where -import Common +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 @@ -34,17 +44,17 @@ import Data.Char {- Some sort of scheduled event. -} data Schedule = Schedule Recurrance ScheduledTime - deriving (Eq, Read, Show, Ord) + deriving (Eq, Read, Show, Ord) data Recurrance = Daily | Weekly (Maybe WeekDay) | Monthly (Maybe MonthDay) | Yearly (Maybe YearDay) - -- Days, Weeks, or Months of the year evenly divisible by a number. - -- (Divisible Year is years evenly divisible by a number.) | Divisible Int Recurrance - deriving (Eq, Read, Show, Ord) + -- ^ 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 @@ -53,17 +63,17 @@ type YearDay = Int data ScheduledTime = AnyTime | SpecificTime Hour Minute - deriving (Eq, Read, Show, Ord) + 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. -} +-- | 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) + deriving (Eq, Read, Show) startTime :: NextTime -> LocalTime startTime (NextTimeExactly t) = t @@ -75,10 +85,10 @@ nextTime schedule lasttime = do 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. -} +-- | 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 recurrance scheduledtime) lasttime currenttime +calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime | scheduledtime == AnyTime = do next <- findfromtoday True return $ case next of @@ -86,13 +96,13 @@ calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime NextTimeExactly t -> window (localDay t) (localDay t) | otherwise = NextTimeExactly . startTime <$> findfromtoday False where - findfromtoday anytime = findfrom recurrance afterday today + findfromtoday anytime = findfrom recurrance afterday today where - today = localDay currenttime - afterday = sameaslastday || toolatetoday + today = localDay currenttime + afterday = sameaslastrun || toolatetoday toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime - sameaslastday = lastday == Just today - lastday = localDay <$> lasttime + sameaslastrun = lastrun == Just today + lastrun = localDay <$> lasttime nexttime = case scheduledtime of AnyTime -> TimeOfDay 0 0 0 SpecificTime h m -> TimeOfDay h m 0 @@ -100,68 +110,84 @@ calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime window startd endd = NextTimeWindow (LocalTime startd nexttime) (LocalTime endd (TimeOfDay 23 59 0)) - findfrom r afterday day = case r of + 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 day - | otherwise -> Just $ exactly day + | afterday -> Just $ exactly $ addDays 1 candidate + | otherwise -> Just $ exactly candidate Weekly Nothing | afterday -> skip 1 - | otherwise -> case (wday <$> lastday, wday day) of - (Nothing, _) -> Just $ window day (addDays 6 day) + | otherwise -> case (wday <$> lastrun, wday candidate) of + (Nothing, _) -> Just $ window candidate (addDays 6 candidate) (Just old, curr) - | old == curr -> Just $ window day (addDays 6 day) + | old == curr -> Just $ window candidate (addDays 6 candidate) | otherwise -> skip 1 Monthly Nothing | afterday -> skip 1 - | maybe True (\old -> mnum day > mday old && mday day >= (mday old `mod` minmday)) lastday -> - -- Window only covers current month, - -- in case there is a Divisible requirement. - Just $ window day (endOfMonth day) + | maybe True (candidate `oneMonthPast`) lastrun -> + Just $ window candidate (endOfMonth candidate) | otherwise -> skip 1 Yearly Nothing | afterday -> skip 1 - | maybe True (\old -> ynum day > ynum old && yday day >= (yday old `mod` minyday)) lastday -> - Just $ window day (endOfYear day) + | maybe True (candidate `oneYearPast`) lastrun -> + Just $ window candidate (endOfYear candidate) | otherwise -> skip 1 Weekly (Just w) | w < 0 || w > maxwday -> Nothing - | w == wday day -> if afterday - then Just $ exactly $ addDays 7 day - else Just $ exactly day + | w == wday candidate -> if afterday + then Just $ exactly $ addDays 7 candidate + else Just $ exactly candidate | otherwise -> Just $ exactly $ - addDays (fromIntegral $ (w - wday day) `mod` 7) day + 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 day -> if afterday + | m == mday candidate -> if afterday then skip 1 - else Just $ exactly day + else Just $ exactly candidate | otherwise -> skip 1 Yearly (Just y) | y < 0 || y > maxyday -> Nothing - | y == yday day -> if afterday + | y == yday candidate -> if afterday then skip 365 - else Just $ exactly day + 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 day + Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate where - skip n = findfrom r False (addDays n day) - handlediv n r' getval mmax + 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 day + findfromwhere r' (divisible n . getval) afterday candidate | otherwise = Nothing - findfromwhere r p afterday day + 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 day + 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 @@ -186,17 +212,13 @@ yday = snd . toOrdinalDate ynum :: Day -> Int ynum = fromIntegral . fst . toOrdinalDate -{- Calendar max and mins. -} +-- Calendar max values. maxyday :: Int maxyday = 366 -- with leap days -minyday :: Int -minyday = 365 maxwnum :: Int maxwnum = 53 -- some years have more than 52 maxmday :: Int maxmday = 31 -minmday :: Int -minmday = 28 maxmnum :: Int maxmnum = 12 maxwday :: Int @@ -245,7 +267,7 @@ toRecurrance s = case words s of constructor u | "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u | otherwise = Nothing - withday sd u = do + withday sd u = do c <- constructor u d <- readish sd Just $ c (Just d) @@ -263,7 +285,7 @@ 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 + pad n s = take (n - length s) (repeat '0') ++ s (h', ampm) | h == 0 = (12, "AM") | h < 12 = (h, "AM") @@ -282,10 +304,10 @@ toScheduledTime v = case words v of (s:[]) -> go s id _ -> Nothing where - h0 h + h0 h | h == 12 = 0 | otherwise = h - go :: String -> (Int -> Int) -> Maybe ScheduledTime + go :: String -> (Int -> Int) -> Maybe ScheduledTime go s adjust = let (h, m) = separate (== ':') s in SpecificTime @@ -341,10 +363,34 @@ instance Arbitrary Recurrance where ] ] where - arbday = oneof + 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/Shell.hs b/Utility/Shell.hs index 2227dc767..e71ca53aa 100644 --- a/Utility/Shell.hs +++ b/Utility/Shell.hs @@ -1,8 +1,8 @@ {- /bin/sh handling - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs new file mode 100644 index 000000000..4a2d8635e --- /dev/null +++ b/Utility/SimpleProtocol.hs @@ -0,0 +1,90 @@ +{- Simple line-based protocols. + - + - Copyright 2013-2014 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +module Utility.SimpleProtocol ( + Sendable(..), + Receivable(..), + parseMessage, + Serializable(..), + Parser, + parseFail, + parse0, + parse1, + parse2, + parse3, + ioHandles, +) where + +import Data.Char +import GHC.IO.Handle + +import Common + +-- Messages that can be sent. +class Sendable m where + formatMessage :: m -> [String] + +-- Messages that can be received. +class Receivable m where + -- Passed the first word of the message, returns + -- a Parser that can be be fed the rest of the message to generate + -- the value. + parseCommand :: String -> Parser m + +parseMessage :: (Receivable m) => String -> Maybe m +parseMessage s = parseCommand command rest + where + (command, rest) = splitWord s + +class Serializable a where + serialize :: a -> String + deserialize :: String -> Maybe a + +{- Parsing the parameters of messages. Using the right parseN ensures + - that the string is split into exactly the requested number of words, + - which allows the last parameter of a message to contain arbitrary + - whitespace, etc, without needing any special quoting. + -} +type Parser a = String -> Maybe a + +parseFail :: Parser a +parseFail _ = Nothing + +parse0 :: a -> Parser a +parse0 mk "" = Just mk +parse0 _ _ = Nothing + +parse1 :: Serializable p1 => (p1 -> a) -> Parser a +parse1 mk p1 = mk <$> deserialize p1 + +parse2 :: (Serializable p1, Serializable p2) => (p1 -> p2 -> a) -> Parser a +parse2 mk s = mk <$> deserialize p1 <*> deserialize p2 + where + (p1, p2) = splitWord s + +parse3 :: (Serializable p1, Serializable p2, Serializable p3) => (p1 -> p2 -> p3 -> a) -> Parser a +parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 + where + (p1, rest) = splitWord s + (p2, p3) = splitWord rest + +splitWord :: String -> (String, String) +splitWord = separate isSpace + +{- When a program speaks a simple protocol over stdio, any other output + - to stdout (or anything that attempts to read from stdin) + - will mess up the protocol. To avoid that, close stdin, and + - and duplicate stderr to stdout. Return two new handles + - that are duplicates of the original (stdin, stdout). -} +ioHandles :: IO (Handle, Handle) +ioHandles = do + readh <- hDuplicate stdin + writeh <- hDuplicate stdout + nullh <- openFile devNull ReadMode + nullh `hDuplicateTo` stdin + stderr `hDuplicateTo` stdout + return (readh, writeh) diff --git a/Utility/SshConfig.hs b/Utility/SshConfig.hs index 080f6479f..ca336a4b8 100644 --- a/Utility/SshConfig.hs +++ b/Utility/SshConfig.hs @@ -1,8 +1,8 @@ {- ssh config file parsing and modification - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.SshConfig where @@ -56,7 +56,7 @@ parseSshConfig = go [] . lines | iscomment l = hoststanza host c ((Left $ mkcomment l):hc) ls | otherwise = case splitline l of (indent, k, v) - | isHost k -> hoststanza v + | isHost k -> hoststanza v (HostConfig host (reverse hc):c) [] ls | otherwise -> hoststanza host c ((Right $ SshSetting indent k v):hc) ls @@ -87,7 +87,7 @@ genSshConfig = unlines . concatMap gen findHostConfigKey :: SshConfig -> Key -> Maybe Value findHostConfigKey (HostConfig _ cs) wantk = go (rights cs) (map toLower wantk) where - go [] _ = Nothing + go [] _ = Nothing go ((SshSetting _ k v):rest) wantk' | map toLower k == wantk' = Just v | otherwise = go rest wantk' @@ -98,7 +98,7 @@ addToHostConfig :: SshConfig -> Key -> Value -> SshConfig addToHostConfig (HostConfig host cs) k v = HostConfig host $ Right (SshSetting indent k v) : cs where - {- The indent is taken from any existing SshSetting + {- The indent is taken from any existing SshSetting - in the HostConfig (largest indent wins). -} indent = fromMaybe "\t" $ headMaybe $ reverse $ sortBy (comparing length) $ map getindent cs diff --git a/Utility/TList.hs b/Utility/TList.hs index 4b91b767f..033c8ca02 100644 --- a/Utility/TList.hs +++ b/Utility/TList.hs @@ -6,7 +6,7 @@ - Unlike a TQueue, the entire contents of a TList can be efficiently - read without modifying it. - - - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <id@joeyh.name> -} {-# LANGUAGE BangPatterns #-} @@ -57,7 +57,7 @@ modifyTList tlist a = do unless (emptyDList dl') $ putTMVar tlist dl' where - emptyDList = D.list True (\_ _ -> False) + emptyDList = D.list True (\_ _ -> False) consTList :: TList a -> a -> STM () consTList tlist v = modifyTList tlist $ \dl -> D.cons v dl diff --git a/Utility/Tense.hs b/Utility/Tense.hs index 60b3fa513..ef2454bdc 100644 --- a/Utility/Tense.hs +++ b/Utility/Tense.hs @@ -1,8 +1,8 @@ {- Past and present tense text. - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE OverloadedStrings #-} diff --git a/Utility/ThreadLock.hs b/Utility/ThreadLock.hs index c029a2b0c..e212fc11f 100644 --- a/Utility/ThreadLock.hs +++ b/Utility/ThreadLock.hs @@ -1,8 +1,8 @@ {- locking between threads - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.ThreadLock where diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs index dbb6cb317..da05e9966 100644 --- a/Utility/ThreadScheduler.hs +++ b/Utility/ThreadScheduler.hs @@ -1,19 +1,22 @@ {- thread scheduling - - - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> + - Copyright 2012, 2013 Joey Hess <id@joeyh.name> - Copyright 2011 Bas van Dijk & Roel van Dijk - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} module Utility.ThreadScheduler where -import Common - +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 @@ -54,8 +57,7 @@ unboundDelay time = do waitForTermination :: IO () waitForTermination = do #ifdef mingw32_HOST_OS - runEvery (Seconds 600) $ - void getLine + forever $ threadDelaySeconds (Seconds 6000) #else lock <- newEmptyMVar let check sig = void $ diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index f46e1a5ee..dc5598137 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -1,19 +1,19 @@ {- Temporary files and directories. - - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - Copyright 2010-2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - 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 Control.Monad.IO.Class import Utility.Exception import Utility.FileSystemEncoding @@ -24,45 +24,52 @@ 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 +viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m () +viaTmp a file content = bracketIO setup cleanup use + where + (dir, base) = splitFileName file + template = base ++ ".tmp" + setup = do + createDirectoryIfMissing True dir + openTempFile dir template + cleanup (tmpfile, h) = do + _ <- tryIO $ hClose h + tryIO $ removeFile tmpfile + use (tmpfile, h) = do + liftIO $ hClose h + a tmpfile content + liftIO $ 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 :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a withTmpFile template a = do - tmpdir <- catchDefaultIO "." getTemporaryDirectory + tmpdir <- liftIO $ 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 :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use where - create = openTempFile tmpdir template - remove (name, handle) = do - hClose handle + create = liftIO $ openTempFile tmpdir template + remove (name, h) = liftIO $ do + hClose h catchBoolIO (removeFile name >> return True) - use (name, handle) = a name handle + use (name, h) = a name h {- 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 :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a withTmpDir template a = do - tmpdir <- catchDefaultIO "." getTemporaryDirectory + tmpdir <- liftIO $ 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 +withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a +withTmpDirIn tmpdir template = bracketIO create remove where remove d = whenM (doesDirectoryExist d) $ do #if mingw32_HOST_OS diff --git a/Utility/Touch.hsc b/Utility/Touch.hsc index 53dd719fb..f87bb62d6 100644 --- a/Utility/Touch.hsc +++ b/Utility/Touch.hsc @@ -1,8 +1,8 @@ {- More control over touching a file. - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2011 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE ForeignFunctionInterface #-} @@ -13,11 +13,25 @@ module Utility.Touch ( touch ) where +#include <sys/types.h> +#include <sys/stat.h> +#include <fcntl.h> +#include <sys/time.h> + +#ifndef _BSD_SOURCE +#define _BSD_SOURCE +#endif + +#if (defined UTIME_OMIT && defined UTIME_NOW && defined AT_FDCWD && defined AT_SYMLINK_NOFOLLOW) +#define use_utimensat 1 + import Utility.FileSystemEncoding +import Control.Monad (when) import Foreign +#endif + import Foreign.C -import Control.Monad (when) newtype TimeSpec = TimeSpec CTime @@ -28,16 +42,7 @@ touchBoth :: FilePath -> TimeSpec -> TimeSpec -> Bool -> IO () touch :: FilePath -> TimeSpec -> Bool -> IO () touch file mtime = touchBoth file mtime mtime -#include <sys/types.h> -#include <sys/stat.h> -#include <fcntl.h> -#include <sys/time.h> - -#ifndef _BSD_SOURCE -#define _BSD_SOURCE -#endif - -#if (defined UTIME_OMIT && defined UTIME_NOW && defined AT_FDCWD && defined AT_SYMLINK_NOFOLLOW) +#ifdef use_utimensat at_fdcwd :: CInt at_fdcwd = #const AT_FDCWD diff --git a/Utility/URI.hs b/Utility/URI.hs new file mode 100644 index 000000000..e68fda58d --- /dev/null +++ b/Utility/URI.hs @@ -0,0 +1,18 @@ +{- Network.URI + - + - Copyright 2014 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} + +module Utility.URI where + +-- Old versions of network lacked an Ord for URI +#if ! MIN_VERSION_network(2,4,0) +import Network.URI + +instance Ord URI where + a `compare` b = show a `compare` show b +#endif diff --git a/Utility/Url.hs b/Utility/Url.hs index 3ab14ebe4..ddf5eea40 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -1,19 +1,24 @@ {- Url downloading. - - - Copyright 2011,2013 Joey Hess <joey@kitenet.net> + - Copyright 2011-2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Utility.Url ( URLString, UserAgent, - UrlOptions(..), + UrlOptions, + mkUrlOptions, check, checkBoth, exists, + UrlInfo(..), + getUrlInfo, download, downloadQuiet, parseURIRelaxed @@ -21,10 +26,11 @@ module Utility.Url ( import Common import Network.URI -import qualified Network.Browser as Browser -import Network.HTTP -import Data.Either -import Data.Default +import Network.HTTP.Conduit +import Network.HTTP.Types +import qualified Data.CaseInsensitive as CI +import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as B8 import qualified Build.SysConfig @@ -38,11 +44,39 @@ data UrlOptions = UrlOptions { userAgent :: Maybe UserAgent , reqHeaders :: Headers , reqParams :: [CommandParam] +#if MIN_VERSION_http_conduit(2,0,0) + , applyRequest :: Request -> Request +#else + , applyRequest :: forall m. Request m -> Request m +#endif } instance Default UrlOptions where - def = UrlOptions Nothing [] [] + def = UrlOptions Nothing [] [] id + +mkUrlOptions :: Maybe UserAgent -> Headers -> [CommandParam] -> UrlOptions +mkUrlOptions useragent reqheaders reqparams = + UrlOptions useragent reqheaders reqparams applyrequest + where + applyrequest = \r -> r { requestHeaders = requestHeaders r ++ addedheaders } + addedheaders = uaheader ++ otherheaders + uaheader = case useragent of + Nothing -> [] + Just ua -> [(hUserAgent, B8.fromString ua)] + otherheaders = map toheader reqheaders + toheader s = + let (h, v) = separate (== ':') s + h' = CI.mk (B8.fromString h) + in case v of + (' ':v') -> (h', B8.fromString v') + _ -> (h', B8.fromString v) + +addUserAgent :: UrlOptions -> [CommandParam] -> [CommandParam] +addUserAgent uo ps = case userAgent uo of + Nothing -> ps + -- --user-agent works for both wget and curl commands + Just ua -> ps ++ [Param "--user-agent", Param ua] {- Checks that an url exists and could be successfully downloaded, - also checking that its size, if available, matches a specified size. -} @@ -51,44 +85,53 @@ checkBoth url expected_size uo = do v <- check url expected_size uo return (fst v && snd v) check :: URLString -> Maybe Integer -> UrlOptions -> IO (Bool, Bool) -check url expected_size = handle <$$> exists url +check url expected_size = go <$$> getUrlInfo url where - handle (False, _) = (False, False) - handle (True, Nothing) = (True, True) - handle (True, s) = case expected_size of + go (UrlInfo False _ _) = (False, False) + go (UrlInfo True Nothing _) = (True, True) + go (UrlInfo True s _) = case expected_size of Just _ -> (True, expected_size == s) Nothing -> (True, True) +exists :: URLString -> UrlOptions -> IO Bool +exists url uo = urlExists <$> getUrlInfo url uo + +data UrlInfo = UrlInfo + { urlExists :: Bool + , urlSize :: Maybe Integer + , urlSuggestedFile :: Maybe FilePath + } + {- Checks that an url exists and could be successfully downloaded, - - also returning its size if available. - - - - For a file: url, check it directly. - - - - Uses curl otherwise, when available, since curl handles https better - - than does Haskell's Network.Browser. - -} -exists :: URLString -> UrlOptions -> IO (Bool, Maybe Integer) -exists url uo = case parseURIRelaxed url of - Just u - | uriScheme u == "file:" -> do - s <- catchMaybeIO $ getFileStatus (unEscapeString $ uriPath u) - case s of - Just stat -> return (True, Just $ fromIntegral $ fileSize stat) - Nothing -> dne - | otherwise -> if Build.SysConfig.curl - then do - output <- readProcess "curl" $ toCommand curlparams + - also returning its size and suggested filename if available. -} +getUrlInfo :: URLString -> UrlOptions -> IO UrlInfo +getUrlInfo url uo = case parseURIRelaxed url of + Just u -> case parseUrl (show u) of + Just req -> existsconduit req `catchNonAsync` const dne + -- http-conduit does not support file:, ftp:, etc urls, + -- so fall back to reading files and using curl. + Nothing + | uriScheme u == "file:" -> do + let f = unEscapeString (uriPath u) + s <- catchMaybeIO $ getFileStatus f + case s of + Just stat -> do + sz <- getFileSize' f stat + found (Just sz) Nothing + Nothing -> dne + | Build.SysConfig.curl -> do + output <- catchDefaultIO "" $ + readProcess "curl" $ toCommand curlparams case lastMaybe (lines output) of - Just ('2':_:_) -> return (True, extractsize output) + Just ('2':_:_) -> found + (extractlencurl output) + Nothing _ -> dne - else do - r <- request u HEAD uo - case rspCode r of - (2,_,_) -> return (True, size r) - _ -> return (False, Nothing) + | otherwise -> dne Nothing -> dne where - dne = return (False, Nothing) + dne = return $ UrlInfo False Nothing Nothing + found sz f = return $ UrlInfo True sz f curlparams = addUserAgent uo $ [ Param "-s" @@ -97,19 +140,55 @@ exists url uo = case parseURIRelaxed url of , Param "-w", Param "%{http_code}" ] ++ concatMap (\h -> [Param "-H", Param h]) (reqHeaders uo) ++ (reqParams uo) - extractsize s = case lastMaybe $ filter ("Content-Length:" `isPrefixOf`) (lines s) of + extractlencurl s = case lastMaybe $ filter ("Content-Length:" `isPrefixOf`) (lines s) of Just l -> case lastMaybe $ words l of Just sz -> readish sz _ -> Nothing _ -> Nothing + + extractlen = readish . B8.toString <=< firstheader hContentLength - size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders + extractfilename = contentDispositionFilename . B8.toString + <=< firstheader hContentDisposition --- works for both wget and curl commands -addUserAgent :: UrlOptions -> [CommandParam] -> [CommandParam] -addUserAgent uo ps = case userAgent uo of - Nothing -> ps - Just ua -> ps ++ [Param "--user-agent", Param ua] + firstheader h = headMaybe . map snd . + filter (\p -> fst p == h) . responseHeaders + + existsconduit req = withManager $ \mgr -> do + let req' = headRequest (applyRequest uo req) + resp <- http req' mgr + -- forces processing the response before the + -- manager is closed + ret <- liftIO $ if responseStatus resp == ok200 + then found + (extractlen resp) + (extractfilename resp) + else dne + liftIO $ closeManager mgr + return ret + +-- Parse eg: attachment; filename="fname.ext" +-- per RFC 2616 +contentDispositionFilename :: String -> Maybe FilePath +contentDispositionFilename s + | "attachment; filename=\"" `isPrefixOf` s && "\"" `isSuffixOf` s = + Just $ reverse $ drop 1 $ reverse $ + drop 1 $ dropWhile (/= '"') s + | otherwise = Nothing + +#if MIN_VERSION_http_conduit(2,0,0) +headRequest :: Request -> Request +#else +headRequest :: Request m -> Request m +#endif +headRequest r = r + { method = methodHead + -- remove defaut Accept-Encoding header, to get actual, + -- not gzip compressed size. + , requestHeaders = (hAcceptEncoding, B.empty) : + filter (\(h, _) -> h /= hAcceptEncoding) + (requestHeaders r) + } {- Used to download large files, such as the contents of keys. - @@ -141,9 +220,18 @@ download' quiet url file uo = wget = go "wget" $ headerparams ++ quietopt "-q" ++ wgetparams {- Regular wget needs --clobber to continue downloading an existing - file. On Android, busybox wget is used, which does not - - support, or need that option. -} + - support, or need that option. + - + - When the wget version is new enough, pass options for + - a less cluttered download display. + -} #ifndef __ANDROID__ - wgetparams = [Params "--clobber -c -O"] + wgetparams = catMaybes + [ if Build.SysConfig.wgetquietprogress + then Just $ Params "-q --show-progress" + else Nothing + , Just $ Params "--clobber -c -O" + ] #else wgetparams = [Params "-c -O"] #endif @@ -160,52 +248,20 @@ download' quiet url file uo = | quiet = [Param s] | otherwise = [] -{- Uses Network.Browser to make a http request of an url. - - For example, HEAD can be used to check if the url exists, - - or GET used to get the url content (best for small urls). - - - - This does its own redirect following because Browser's is buggy for HEAD - - requests. - - - - Unfortunately, does not handle https, so should only be used - - when curl is not available. - -} -request :: URI -> RequestMethod -> UrlOptions -> IO (Response String) -request url requesttype uo = go 5 url - where - go :: Int -> URI -> IO (Response String) - go 0 _ = error "Too many redirects " - go n u = do - rsp <- Browser.browse $ do - maybe noop Browser.setUserAgent (userAgent uo) - Browser.setErrHandler ignore - Browser.setOutHandler ignore - Browser.setAllowRedirects False - let req = mkRequest requesttype u :: Request_String - snd <$> Browser.request (addheaders req) - case rspCode rsp of - (3,0,x) | x /= 5 -> redir (n - 1) u rsp - _ -> return rsp - addheaders req = setHeaders req (rqHeaders req ++ userheaders) - userheaders = rights $ map parseHeader (reqHeaders uo) - ignore = const noop - redir n u rsp = case retrieveHeaders HdrLocation rsp of - [] -> return rsp - (Header _ newu:_) -> - case parseURIReference newu of - Nothing -> return rsp - Just newURI -> go n $ -#if defined VERSION_network -#if ! MIN_VERSION_network(2,4,0) -#define WITH_OLD_URI -#endif -#endif -#ifdef WITH_OLD_URI - fromMaybe newURI (newURI `relativeTo` u) -#else - newURI `relativeTo` u -#endif - {- Allows for spaces and other stuff in urls, properly escaping them. -} parseURIRelaxed :: URLString -> Maybe URI parseURIRelaxed = parseURI . escapeURIString isAllowedInURI + +hAcceptEncoding :: CI.CI B.ByteString +hAcceptEncoding = "Accept-Encoding" + +hContentDisposition :: CI.CI B.ByteString +hContentDisposition = "Content-Disposition" + +#if ! MIN_VERSION_http_types(0,7,0) +hContentLength :: CI.CI B.ByteString +hContentLength = "Content-Length" + +hUserAgent :: CI.CI B.ByteString +hUserAgent = "User-Agent" +#endif diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index 9c3bfd42f..5bf8d5c09 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -1,8 +1,8 @@ {- user info - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} @@ -13,8 +13,10 @@ module Utility.UserInfo ( myUserGecos, ) where -import Control.Applicative import System.PosixCompat +#ifndef mingw32_HOST_OS +import Control.Applicative +#endif import Utility.Env @@ -40,16 +42,20 @@ myUserName = myVal env userName env = ["USERNAME", "USER", "LOGNAME"] #endif -myUserGecos :: IO String -#ifdef __ANDROID__ -myUserGecos = return "" -- userGecos crashes on Android +myUserGecos :: IO (Maybe String) +-- userGecos crashes on Android and is not available on Windows. +#if defined(__ANDROID__) || defined(mingw32_HOST_OS) +myUserGecos = return Nothing #else -myUserGecos = myVal [] userGecos +myUserGecos = Just <$> myVal [] userGecos #endif myVal :: [String] -> (UserEntry -> String) -> IO String -myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars +myVal envvars extract = go envvars where - check [] = return Nothing - check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v - getpwent = getUserEntryForID =<< getEffectiveUserID +#ifndef mingw32_HOST_OS + go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID) +#else + go [] = error $ "environment not set: " ++ show envvars +#endif + go (v:vs) = maybe (go vs) return =<< getEnv v diff --git a/Utility/Verifiable.hs b/Utility/Verifiable.hs index 4f88cb9f2..a861416e2 100644 --- a/Utility/Verifiable.hs +++ b/Utility/Verifiable.hs @@ -1,8 +1,8 @@ {- values verified using a shared secret - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Verifiable where diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index 8e08ab9e0..54f2d6f2b 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -1,8 +1,8 @@ {- Yesod webapp - - - Copyright 2012-2014 Joey Hess <joey@kitenet.net> + - Copyright 2012-2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE OverloadedStrings, CPP, RankNTypes #-} @@ -18,22 +18,17 @@ import qualified Yesod import qualified Network.Wai as Wai import Network.Wai.Handler.Warp import Network.Wai.Handler.WarpTLS -import Network.Wai.Logger -import Control.Monad.IO.Class import Network.HTTP.Types -import System.Log.Logger import qualified Data.CaseInsensitive as CI import Network.Socket import "crypto-api" Crypto.Random import qualified Web.ClientSession as CS import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.UTF8 as L8 import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Blaze.ByteString.Builder (Builder) -import Data.Monoid import Control.Arrow ((***)) import Control.Concurrent #ifdef WITH_WEBAPP_SECURE @@ -43,10 +38,6 @@ import Data.Byteable #ifdef __ANDROID__ import Data.Endian #endif -#if defined(__ANDROID__) || defined (mingw32_HOST_OS) -#else -import Control.Exception (bracketOnError) -#endif localhost :: HostName localhost = "localhost" @@ -62,6 +53,10 @@ browserProc url = proc "am" ["start", "-a", "android.intent.action.VIEW", "-d", url] #else #ifdef mingw32_HOST_OS +-- Warning: On Windows, no quoting or escaping of the url seems possible, +-- so spaces in it will cause problems. One approach is to make the url +-- be a relative filename, and adjust the returned CreateProcess to change +-- to the directory it's in. browserProc url = proc "cmd" ["/c start " ++ url] #else browserProc url = proc "xdg-open" [url] @@ -96,11 +91,16 @@ fixSockAddr (SockAddrInet (PortNum port) addr) = SockAddrInet (PortNum $ swapEnd #endif fixSockAddr addr = addr +-- disable buggy sloworis attack prevention code webAppSettings :: Settings -webAppSettings = defaultSettings - -- disable buggy sloworis attack prevention code - { settingsTimeout = 30 * 60 - } + +#if MIN_VERSION_warp(2,1,0) +webAppSettings = setTimeout halfhour defaultSettings +#else +webAppSettings = defaultSettings { settingsTimeout = halfhour } +#endif + where + halfhour = 30 * 60 {- Binds to a local socket, or if specified, to a socket on the specified - hostname or address. Selects any free port, unless the hostname ends with @@ -117,7 +117,7 @@ getSocket h = do when (isJust h) $ error "getSocket with HostName not supported on this OS" addr <- inet_addr "127.0.0.1" - sock <- socket AF_INET Stream defaultProtocol + sock <- socket AF_INET Stream defaultProtocol preparesocket sock bindSocket sock (SockAddrInet aNY_PORT addr) use sock @@ -150,35 +150,6 @@ getSocket h = do listen sock maxListenQueue return sock -{- Checks if debugging is actually enabled. -} -debugEnabled :: IO Bool -debugEnabled = do - l <- getRootLogger - return $ getLevel l <= Just DEBUG - -{- WAI middleware that logs using System.Log.Logger at debug level. - - - - Recommend only inserting this middleware when debugging is actually - - enabled, as it's not optimised at all. - -} -httpDebugLogger :: Wai.Middleware -httpDebugLogger waiApp req = do - logRequest req - waiApp req - -logRequest :: MonadIO m => Wai.Request -> m () -logRequest req = do - liftIO $ debugM "WebApp" $ unwords - [ showSockAddr $ Wai.remoteHost req - , frombs $ Wai.requestMethod req - , frombs $ Wai.rawPathInfo req - --, show $ Wai.httpVersion req - --, frombs $ lookupRequestField "referer" req - , frombs $ lookupRequestField "user-agent" req - ] - where - frombs v = L8.toString $ L.fromChunks [v] - lookupRequestField :: CI.CI B.ByteString -> Wai.Request -> B.ByteString lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req diff --git a/Utility/WinProcess.hs b/Utility/WinProcess.hs index 7a566dcba..36f079d04 100644 --- a/Utility/WinProcess.hs +++ b/Utility/WinProcess.hs @@ -1,8 +1,8 @@ {- Windows processes - - - Copyright 2014 Joey Hess <joey@kitenet.net> + - Copyright 2014 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE ForeignFunctionInterface #-} diff --git a/Utility/Yesod.hs b/Utility/Yesod.hs index 2853b3369..231bb291e 100644 --- a/Utility/Yesod.hs +++ b/Utility/Yesod.hs @@ -1,9 +1,9 @@ {- Yesod stuff, that's typically found in the scaffolded site. - - Also a bit of a compatability layer to make it easier to support yesod - - 1.1 and 1.2 in the same code base. + - 1.1-1.4 in the same code base. - - - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2014 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -17,8 +17,10 @@ module Utility.Yesod , widgetFile , hamletTemplate #endif +#if ! MIN_VERSION_yesod(1,4,0) + , withUrlRenderer +#endif #if ! MIN_VERSION_yesod(1,2,0) - , giveUrlRenderer , Html #endif ) where @@ -28,6 +30,11 @@ import Yesod as Y #else import Yesod as Y hiding (Html) #endif +#if MIN_VERSION_yesod_form(1,3,8) +import Yesod.Form.Bootstrap3 as Y hiding (bfs) +#else +import Assistant.WebApp.Bootstrap3 as Y hiding (bfs) +#endif #ifndef __NO_TH__ import Yesod.Default.Util import Language.Haskell.TH.Syntax (Q, Exp) @@ -36,6 +43,11 @@ import Data.Default (def) import Text.Hamlet hiding (Html) #endif #endif +#if ! MIN_VERSION_yesod(1,4,0) +#if MIN_VERSION_yesod(1,2,0) +import Data.Text (Text) +#endif +#endif #ifndef __NO_TH__ widgetFile :: String -> Q Exp @@ -64,8 +76,13 @@ liftH = lift {- Misc new names for stuff. -} #if ! MIN_VERSION_yesod(1,2,0) -giveUrlRenderer :: forall master sub. HtmlUrl (Route master) -> GHandler sub master RepHtml -giveUrlRenderer = hamletToRepHtml +withUrlRenderer :: forall master sub. HtmlUrl (Route master) -> GHandler sub master RepHtml +withUrlRenderer = hamletToRepHtml type Html = RepHtml +#else +#if ! MIN_VERSION_yesod_core(1,2,20) +withUrlRenderer :: MonadHandler m => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) -> m output +withUrlRenderer = giveUrlRenderer +#endif #endif diff --git a/Utility/libdiskfree.c b/Utility/libdiskfree.c index 8c9ab6145..c2f8368f0 100644 --- a/Utility/libdiskfree.c +++ b/Utility/libdiskfree.c @@ -1,19 +1,17 @@ /* disk free space checking, C mini-library * - * Copyright 2012, 2014 Joey Hess <joey@kitenet.net> + * Copyright 2012, 2014 Joey Hess <id@joeyh.name> * - * Licensed under the GNU GPL version 3 or higher. + * License: BSD-2-clause */ /* Include appropriate headers for the OS, and define what will be used to * check the free space. */ #if defined(__APPLE__) +# define _DARWIN_FEATURE_64_BIT_INODE 1 # include <sys/param.h> # include <sys/mount.h> -/* In newer OSX versions, statfs64 is deprecated, in favor of statfs, - * which is 64 bit only with a build option -- but statfs64 still works, - * and this keeps older OSX also supported. */ -# define STATCALL statfs64 +# define STATCALL statfs # define STATSTRUCT statfs64 #else #if defined (__FreeBSD__) diff --git a/Utility/libkqueue.c b/Utility/libkqueue.c index a87f65102..3f40465e3 100644 --- a/Utility/libkqueue.c +++ b/Utility/libkqueue.c @@ -1,8 +1,8 @@ /* kqueue interface, C mini-library * - * Copyright 2012 Joey Hess <joey@kitenet.net> + * Copyright 2012 Joey Hess <id@joeyh.name> * - * Licensed under the GNU GPL version 3 or higher. + * License: BSD-2-clause */ #include <stdio.h> diff --git a/Utility/libmounts.c b/Utility/libmounts.c index 8669f33ea..c469d7710 100644 --- a/Utility/libmounts.c +++ b/Utility/libmounts.c @@ -5,7 +5,7 @@ * Copyright (c) 2001 * David Rufino <daverufino@btinternet.com> * Copyright 2012 - * Joey Hess <joey@kitenet.net> + * Joey Hess <id@joeyh.name> * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions @@ -63,7 +63,7 @@ static struct mntent *statfs_to_mntent (struct statfs *mntbuf) { _mntent.mnt_dir = mntbuf->f_mntonname; _mntent.mnt_type = mntbuf->f_fstypename; - _mntent.mnt_opts = '\0'; + _mntent.mnt_opts = NULL; _mntent.mnt_freq = 0; _mntent.mnt_passno = 0; |