code:
{- Simple IO exception handling (and some more)
 -
 - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE ScopedTypeVariables #-}

module Utility.Exception where

import Control.Exception
import qualified Control.Exception as E
import Control.Applicative
import Control.Monad
import System.IO.Error (isDoesNotExistError)
import Utility.Data

{- Catches IO errors and returns a Bool -}
catchBoolIO :: IO Bool -> IO Bool
catchBoolIO = catchDefaultIO False

{- Catches IO errors and returns a Maybe -}
catchMaybeIO :: IO a -> IO (Maybe a)
catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a

{- Catches IO errors and returns a default value. -}
catchDefaultIO :: a -> IO a -> IO a
catchDefaultIO def a = catchIO a (const $ return def)

{- Catches IO errors and returns the error message. -}
catchMsgIO :: IO a -> IO (Either String a)
catchMsgIO a = either (Left . show) Right <$> tryIO a

{- catch specialized for IO errors only -}
catchIO :: IO a -> (IOException -> IO a) -> IO a
catchIO = E.catch

{- try specialized for IO errors only -}
tryIO :: IO a -> IO (Either IOException a)
tryIO = try

{- Catches all exceptions except for async exceptions.
 - This is often better to use than catching them all, so that
 - ThreadKilled and UserInterrupt get through.
 -}
catchNonAsync :: IO a -> (SomeException -> IO a) -> IO a
catchNonAsync a onerr = a `catches`
	[ Handler (\ (e :: AsyncException) -> throw e)
	, Handler (\ (e :: SomeException) -> onerr e)
	]

tryNonAsync :: IO a -> IO (Either SomeException a)
tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left)

{- Catches only DoesNotExist exceptions, and lets all others through. -}
tryWhenExists :: IO a -> IO (Maybe a)
tryWhenExists a = eitherToMaybe <$>
	tryJust (guard . isDoesNotExistError) a


code:
{- Calculating a SHA checksum with an external command.
 -
 - 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>
 -
 - License: BSD-2-clause
 -}

module Utility.ExternalSHA (externalSHA) where

import Utility.SafeCommand
import Utility.Process
import Utility.FileSystemEncoding
import Utility.Misc
import Utility.Exception

import Data.List
import Data.Char
import Control.Applicative
import System.IO

externalSHA :: String -> Int -> FilePath -> IO (Either String String)
externalSHA command shasize file = do
	ls <- lines <$> catchDefaultIO "" (readsha (toCommand [File file]))
	return $ sanitycheck =<< parse ls
  where
	{- sha commands output the filename, so need to set fileEncoding -}
	readsha args =
		withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ \h -> do
			fileEncoding h
			output  <- hGetContentsStrict h
			hClose h
			return output
	  where
		p = (proc command args) { std_out = CreatePipe }

	{- The first word of the output is taken to be the sha. -}
	parse [] = bad
	parse (l:_)
		| null sha = bad
		-- sha is prefixed with \ when filename contains certian chars
		| "\\" `isPrefixOf` sha = Right $ drop 1 sha
		| otherwise = Right sha
	  where
		sha = fst $ separate (== ' ') l
	bad = Left $ command ++ " parse error"

	{- Check that we've correctly parsing the output of the command,
	 - by making sure the sha we read is of the expected length
	 - and contains only the right characters. -}
	sanitycheck sha
		| length sha /= expectedSHALength shasize =
			Left $ "Failed to parse the output of " ++ command
		| any (`notElem` "0123456789abcdef") sha' =
			Left $ "Unexpected character in output of " ++ command ++ "\"" ++ sha ++ "\""
		| otherwise = Right sha'
	  where
	  	sha' = map toLower sha

expectedSHALength :: Int -> Int
expectedSHALength 1 = 40
expectedSHALength 256 = 64
expectedSHALength 512 = 128
expectedSHALength 224 = 56
expectedSHALength 384 = 96
expectedSHALength _ = 0

repo_name: kakafarm/git

license: unknown


code:
{- File mode utilities.
 -
 - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.FileMode where

import System.IO
import Control.Monad
import Control.Exception (bracket)
import System.PosixCompat.Types
import Utility.PosixFiles
#ifndef mingw32_HOST_OS
import System.Posix.Files
#endif
import Foreign (complement)

import Utility.Exception

{- Applies a conversion function to a file's mode. -}
modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()
modifyFileMode f convert = void $ modifyFileMode' f convert
modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode
modifyFileMode' f convert = do
	s <- getFileStatus f
	let old = fileMode s
	let new = convert old
	when (new /= old) $
		setFileMode f new
	return old

{- Adds the specified FileModes to the input mode, leaving the rest
 - unchanged. -}
addModes :: [FileMode] -> FileMode -> FileMode
addModes ms m = combineModes (m:ms)

{- Removes the specified FileModes from the input mode. -}
removeModes :: [FileMode] -> FileMode -> FileMode
removeModes ms m = m `intersectFileModes` complement (combineModes ms)

{- Runs an action after changing a file's mode, then restores the old mode. -}
withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
withModifiedFileMode file convert a = bracket setup cleanup go
  where
	setup = modifyFileMode' file convert
	cleanup oldmode = modifyFileMode file (const oldmode)
	go _ = a

writeModes :: [FileMode]
writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]

readModes :: [FileMode]
readModes = [ownerReadMode, groupReadMode, otherReadMode]

executeModes :: [FileMode]
executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]

otherGroupModes :: [FileMode]
otherGroupModes =
	[ groupReadMode, otherReadMode
	, groupWriteMode, otherWriteMode
	]

{- Removes the write bits from a file. -}
preventWrite :: FilePath -> IO ()
preventWrite f = modifyFileMode f $ removeModes writeModes

{- Turns a file's owner write bit back on. -}
allowWrite :: FilePath -> IO ()
allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]

{- Turns a file's owner read bit back on. -}
allowRead :: FilePath -> IO ()
allowRead f = modifyFileMode f $ addModes [ownerReadMode]

{- Allows owner and group to read and write to a file. -}
groupSharedModes :: [FileMode]
groupSharedModes =
	[ ownerWriteMode, groupWriteMode
	, ownerReadMode, groupReadMode
	]

groupWriteRead :: FilePath -> IO ()
groupWriteRead f = modifyFileMode f $ addModes groupSharedModes

checkMode :: FileMode -> FileMode -> Bool
checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor

{- Checks if a file mode indicates it's a symlink. -}
isSymLink :: FileMode -> Bool
#ifdef mingw32_HOST_OS
isSymLink _ = False
#else
isSymLink = checkMode symbolicLinkMode
#endif

{- Checks if a file has any executable bits set. -}
isExecutable :: FileMode -> Bool
isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0

{- Runs an action without that pesky umask influencing it, unless the
 - passed FileMode is the standard one. -}
noUmask :: FileMode -> IO a -> IO a
#ifndef mingw32_HOST_OS
noUmask mode a
	| mode == stdFileMode = a
	| otherwise = withUmask nullFileMode a
#else
noUmask _ a = a
#endif

withUmask :: FileMode -> IO a -> IO a
#ifndef mingw32_HOST_OS
withUmask umask a = bracket setup cleanup go
  where
	setup = setFileCreationMask umask
	cleanup = setFileCreationMask
	go _ = a
#else
withUmask _ a = a
#endif

combineModes :: [FileMode] -> FileMode
combineModes [] = undefined
combineModes [m] = m
combineModes (m:ms) = foldl unionFileModes m ms

isSticky :: FileMode -> Bool
#ifdef mingw32_HOST_OS
isSticky _ = False
#else
isSticky = checkMode stickyMode

stickyMode :: FileMode
stickyMode = 512

setSticky :: FilePath -> IO ()
setSticky f = modifyFileMode f $ addModes [stickyMode]
#endif

{- Writes a file, ensuring that its modes do not allow it to be read
 - or written by anyone other than the current user,
 - before any content is written.
 -
 - When possible, this is done using the umask.
 -
 - On a filesystem that does not support file permissions, this is the same
 - as writeFile.
 -}
writeFileProtected :: FilePath -> String -> IO ()
writeFileProtected file content = withUmask 0o0077 $
	withFile file WriteMode $ \h -> do
		void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
		hPutStr h content


code:
{- GHC File system encoding handling.
 -
 - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.FileSystemEncoding (
	fileEncoding,
	withFilePath,
	md5FilePath,
	decodeBS,
	decodeW8,
	encodeW8,
	truncateFilePath,
) where

import qualified GHC.Foreign as GHC
import qualified GHC.IO.Encoding as Encoding
import Foreign.C
import System.IO
import System.IO.Unsafe
import qualified Data.Hash.MD5 as MD5
import Data.Word
import Data.Bits.Utils
import qualified Data.ByteString.Lazy as L
#ifdef mingw32_HOST_OS
import qualified Data.ByteString.Lazy.UTF8 as L8
#endif

{- Sets a Handle to use the filesystem encoding. This causes data
 - written or read from it to be encoded/decoded the same
 - as ghc 7.4 does to filenames etc. This special encoding
 - allows "arbitrary undecodable bytes to be round-tripped through it".
 -}
fileEncoding :: Handle -> IO ()
#ifndef mingw32_HOST_OS
fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding
#else
{- The file system encoding does not work well on Windows,
 - and Windows only has utf FilePaths anyway. -}
fileEncoding h = hSetEncoding h Encoding.utf8
#endif

{- Marshal a Haskell FilePath into a NUL terminated C string using temporary
 - storage. The FilePath is encoded using the filesystem encoding,
 - reversing the decoding that should have been done when the FilePath
 - was obtained. -}
withFilePath :: FilePath -> (CString -> IO a) -> IO a
withFilePath fp f = Encoding.getFileSystemEncoding
	>>= \enc -> GHC.withCString enc fp f

{- Encodes a FilePath into a String, applying the filesystem encoding.
 -
 - There are very few things it makes sense to do with such an encoded
 - string. It's not a legal filename; it should not be displayed.
 - So this function is not exported, but instead used by the few functions
 - that can usefully consume it.
 -
 - This use of unsafePerformIO is belived to be safe; GHC's interface
 - only allows doing this conversion with CStrings, and the CString buffer
 - is allocated, used, and deallocated within the call, with no side
 - effects.
 -}
{-# NOINLINE _encodeFilePath #-}
_encodeFilePath :: FilePath -> String
_encodeFilePath fp = unsafePerformIO $ do
	enc <- Encoding.getFileSystemEncoding
	GHC.withCString enc fp $ GHC.peekCString Encoding.char8

{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -}
md5FilePath :: FilePath -> MD5.Str
md5FilePath = MD5.Str . _encodeFilePath

{- Decodes a ByteString into a FilePath, applying the filesystem encoding. -}
decodeBS :: L.ByteString -> FilePath
#ifndef mingw32_HOST_OS
decodeBS = encodeW8 . L.unpack
#else
{- On Windows, we assume that the ByteString is utf-8, since Windows
 - only uses unicode for filenames. -}
decodeBS = L8.toString
#endif

{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.
 -
 - w82c produces a String, which may contain Chars that are invalid
 - unicode. From there, this is really a simple matter of applying the
 - file system encoding, only complicated by GHC's interface to doing so.
 -}
{-# NOINLINE encodeW8 #-}
encodeW8 :: [Word8] -> FilePath
encodeW8 w8 = unsafePerformIO $ do
	enc <- Encoding.getFileSystemEncoding
	GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc

{- Useful when you want the actual number of bytes that will be used to
 - represent the FilePath on disk. -}
decodeW8 :: FilePath -> [Word8]
decodeW8 = s2w8 . _encodeFilePath

{- Truncates a FilePath to the given number of bytes (or less),
 - as represented on disk.
 -
 - Avoids returning an invalid part of a unicode byte sequence, at the
 - cost of efficiency when running on a large FilePath.
 -}
truncateFilePath :: Int -> FilePath -> FilePath
#ifndef mingw32_HOST_OS
truncateFilePath n = go . reverse
  where
  	go f =
		let bytes = decodeW8 f
		in if length bytes <= n
			then reverse f
			else go (drop 1 f)
#else
{- On Windows, count the number of bytes used by each utf8 character. -}
truncateFilePath n = reverse . go [] n . L8.fromString
  where
	go coll cnt bs
		| cnt <= 0 = coll
		| otherwise = case L8.decode bs of
			Just (c, x) | c /= L8.replacement_char ->
				let x' = fromIntegral x
				in if cnt - x' < 0
					then coll
					else go (c:coll) (cnt - x') (L8.drop 1 bs)
			_ -> coll
#endif


code:
{- Formatted string handling.
 -
 - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.Format (
	Format,
	gen,
	format,
	decode_c,
	encode_c,
	prop_idempotent_deencode
) where

import Text.Printf (printf)
import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord)
import Data.Maybe (fromMaybe)
import Data.Word (Word8)
import Data.List (isPrefixOf)
import qualified Codec.Binary.UTF8.String
import qualified Data.Map as M

import Utility.PartialPrelude

type FormatString = String

{- A format consists of a list of fragments. -}
type Format = [Frag]

{- A fragment is either a constant string,
 - or a variable, with a justification. -}
data Frag = Const String | Var String Justify
	deriving (Show)

data Justify = LeftJustified Int | RightJustified Int | UnJustified
	deriving (Show)

type Variables = M.Map String String

{- Expands a Format using some variables, generating a formatted string.
 - This can be repeatedly called, efficiently. -}
format :: Format -> Variables -> String
format f vars = concatMap expand f
  where
	expand (Const s) = s
	expand (Var name j)
		| "escaped_" `isPrefixOf` name =
			justify j $ encode_c_strict $
				getvar $ drop (length "escaped_") name
		| otherwise = justify j $ getvar name
	getvar name = fromMaybe "" $ M.lookup name vars
	justify UnJustified s        = s
	justify (LeftJustified i) s  = s ++ pad i s
	justify (RightJustified i) s = pad i s ++ s
	pad i s = take (i - length s) spaces
	spaces = repeat ' '

{- Generates a Format that can be used to expand variables in a
 - format string, such as "${foo} ${bar;10} ${baz;-10}\n"
 -
 - (This is the same type of format string used by dpkg-query.)
 -}
gen :: FormatString -> Format
gen = filter (not . empty) . fuse [] . scan [] . decode_c
  where
	-- The Format is built up in reverse, for efficiency,
	-- and can have many adjacent Consts. Fusing it fixes both
	-- problems.
	fuse f [] = f
	fuse f (Const c1:Const c2:vs) = fuse f $ Const (c2++c1) : vs
	fuse f (v:vs) = fuse (v:f) vs

	scan f (a:b:cs)
		| a == '$' && b == '{' = invar f [] cs
		| otherwise = scan (Const [a] : f ) (b:cs)
	scan f v = Const v : f

	invar f var [] = Const (novar var) : f
	invar f var (c:cs)
		| c == '}' = foundvar f var UnJustified cs
		| isAlphaNum c || c == '_' = invar f (c:var) cs
		| c == ';' = inpad "" f var cs
		| otherwise = scan ((Const $ novar $ c:var):f) cs

	inpad p f var (c:cs)
		| c == '}' = foundvar f var (readjustify $ reverse p) cs
		| otherwise = inpad (c:p) f var cs
	inpad p f var [] = Const (novar $ p++";"++var) : f
	readjustify = getjustify . fromMaybe 0 . readish
	getjustify i
		| i == 0 = UnJustified
		| i < 0 = LeftJustified (-1 * i)
		| otherwise = RightJustified i
	novar v = "${" ++ reverse v
	foundvar f v p = scan (Var (reverse v) p : f)

empty :: Frag -> Bool
empty (Const "") = True
empty _ = False

{- Decodes a C-style encoding, where \n is a newline, \NNN is an octal
 - encoded character, and \xNN is a hex encoded character.
 -}
decode_c :: FormatString -> FormatString
decode_c [] = []
decode_c s = unescape ("", s)
  where
	e = '\\'
	unescape (b, []) = b
	-- look for escapes starting with '\'
	unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair)
	  where
		pair = span (/= e) v
	isescape x = x == e
	handle (x:'x':n1:n2:rest)
		| isescape x && allhex = (fromhex, rest)
	  where
	  	allhex = isHexDigit n1 && isHexDigit n2
		fromhex = [chr $ readhex [n1, n2]]
		readhex h = Prelude.read $ "0x" ++ h :: Int
	handle (x:n1:n2:n3:rest)
		| isescape x && alloctal = (fromoctal, rest)
	  where
		alloctal = isOctDigit n1 && isOctDigit n2 && isOctDigit n3
		fromoctal = [chr $ readoctal [n1, n2, n3]]
		readoctal o = Prelude.read $ "0o" ++ o :: Int
	-- \C is used for a few special characters
	handle (x:nc:rest)
		| isescape x = ([echar nc], rest)
	  where
		echar 'a' = '\a'
		echar 'b' = '\b'
		echar 'f' = '\f'
		echar 'n' = '\n'
		echar 'r' = '\r'
		echar 't' = '\t'
		echar 'v' = '\v'
		echar a = a
	handle n = ("", n)

{- Inverse of decode_c. -}
encode_c :: FormatString -> FormatString
encode_c = encode_c' (const False)

{- Encodes more strictly, including whitespace. -}
encode_c_strict :: FormatString -> FormatString
encode_c_strict = encode_c' isSpace

encode_c' :: (Char -> Bool) -> FormatString -> FormatString
encode_c' p = concatMap echar
  where
	e c = '\\' : [c]
	echar '\a' = e 'a'
	echar '\b' = e 'b'
	echar '\f' = e 'f'
	echar '\n' = e 'n'
	echar '\r' = e 'r'
	echar '\t' = e 't'
	echar '\v' = e 'v'
	echar '\\' = e '\\'
	echar '"'  = e '"'
	echar c
		| ord c < 0x20 = e_asc c -- low ascii
		| ord c >= 256 = e_utf c -- unicode
		| ord c > 0x7E = e_asc c -- high ascii
		| p c          = e_asc c -- unprintable ascii
		| otherwise    = [c]     -- printable ascii
	-- unicode character is decomposed to individual Word8s,
	-- and each is shown in octal
	e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8])
	e_asc c = showoctal $ ord c
	showoctal i = '\\' : printf "%03o" i

{- for quickcheck -}
prop_idempotent_deencode :: String -> Bool
prop_idempotent_deencode s = s == decode_c (encode_c s)


code:
{- Freedesktop.org specifications
 -
 - http://standards.freedesktop.org/basedir-spec/latest/
 - http://standards.freedesktop.org/desktop-entry-spec/latest/
 - http://standards.freedesktop.org/menu-spec/latest/
 - http://standards.freedesktop.org/icon-theme-spec/latest/
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.FreeDesktop (
	DesktopEntry,
	genDesktopEntry,
	buildDesktopMenuFile,
	writeDesktopMenuFile,
	desktopMenuFilePath,
	autoStartPath,
	iconDir,
	iconFilePath,
	systemDataDir,
	systemConfigDir,
	userDataDir,
	userConfigDir,
	userDesktopDir
) where

import Utility.Exception
import Utility.Path
import Utility.UserInfo
import Utility.Process
import Utility.PartialPrelude

import System.Environment
import System.Directory
import System.FilePath
import Data.List
import Data.String.Utils
import Data.Maybe
import Control.Applicative

type DesktopEntry = [(Key, Value)]

type Key = String

data Value = StringV String | BoolV Bool | NumericV Float | ListV [Value]

toString :: Value -> String
toString (StringV s) = s
toString (BoolV b)
	| b = "true"
	| otherwise = "false"
toString(NumericV f) = show f
toString (ListV l)
	| null l = ""
	| otherwise = (intercalate ";" $ map (escapesemi . toString) l) ++ ";"
  where
	escapesemi = join "\\;" . split ";"

genDesktopEntry :: String -> String -> Bool -> FilePath -> Maybe String -> [String] -> DesktopEntry
genDesktopEntry name comment terminal program icon categories = catMaybes
	[ item "Type" StringV "Application"
	, item "Version" NumericV 1.0
	, item "Name" StringV name
	, item "Comment" StringV comment
	, item "Terminal" BoolV terminal
	, item "Exec" StringV program
	, maybe Nothing (item "Icon" StringV) icon
	, item "Categories" ListV (map StringV categories)
	]
  where
	item x c y = Just (x, c y)

buildDesktopMenuFile :: DesktopEntry -> String
buildDesktopMenuFile d = unlines ("[Desktop Entry]" : map keyvalue d) ++ "\n"
  where
	keyvalue (k, v) = k ++ "=" ++ toString v

writeDesktopMenuFile :: DesktopEntry -> String -> IO ()
writeDesktopMenuFile d file = do
	createDirectoryIfMissing True (parentDir file)
	writeFile file $ buildDesktopMenuFile d

{- Path to use for a desktop menu file, in either the systemDataDir or
 - the userDataDir -}
desktopMenuFilePath :: String -> FilePath -> FilePath
desktopMenuFilePath basename datadir =
	datadir </> "applications" </> desktopfile basename

{- Path to use for a desktop autostart file, in either the systemDataDir
 - or the userDataDir -}
autoStartPath :: String -> FilePath -> FilePath
autoStartPath basename configdir =
	configdir </> "autostart" </> desktopfile basename

{- Base directory to install an icon file, in either the systemDataDir
 - or the userDatadir. -}
iconDir :: FilePath -> FilePath
iconDir datadir = datadir </> "icons" </> "hicolor"

{- Filename of an icon, given the iconDir to use.
 -
 - The resolution is something like "48x48" or "scalable". -}
iconFilePath :: FilePath -> String -> FilePath -> FilePath
iconFilePath file resolution icondir =
	icondir </> resolution </> "apps" </> file

desktopfile :: FilePath -> FilePath
desktopfile f = f ++ ".desktop"

{- Directory used for installation of system wide data files.. -}
systemDataDir :: FilePath
systemDataDir = "/usr/share"

{- Directory used for installation of system wide config files. -}
systemConfigDir :: FilePath
systemConfigDir = "/etc/xdg"

{- Directory for user data files. -}
userDataDir :: IO FilePath
userDataDir = xdgEnvHome "DATA_HOME" ".local/share"

{- Directory for user config files. -}
userConfigDir :: IO FilePath
userConfigDir = xdgEnvHome "CONFIG_HOME" ".config"

{- Directory for the user's Desktop, may be localized.
 -
 - This is not looked up very fast; the config file is in a shell format
 - that is best parsed by shell, so xdg-user-dir is used, with a fallback
 - to ~/Desktop. -}
userDesktopDir :: IO FilePath
userDesktopDir = maybe fallback return =<< (parse <$> xdg_user_dir)
  where
	parse = maybe Nothing (headMaybe . lines)
	xdg_user_dir = catchMaybeIO $ readProcess "xdg-user-dir" ["DESKTOP"]
	fallback = xdgEnvHome "DESKTOP_DIR" "Desktop"

xdgEnvHome :: String -> String -> IO String
xdgEnvHome envbase homedef = do
	home <- myHomeDir
	catchDefaultIO (home </> homedef) $
		getEnv $ "XDG_" ++ envbase


code:
{- file globbing
 -
 - 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>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.Glob (
	Glob,
	GlobCase(..),
	compileGlob,
	matchGlob
) where

import System.Path.WildMatch

#ifdef WITH_TDFA
import Text.Regex.TDFA
import Text.Regex.TDFA.String
#else
import Text.Regex
import Data.Maybe
#endif

newtype Glob = Glob Regex

data GlobCase = CaseSensative | CaseInsensative

{- Compiles a glob to a regex, that can be repeatedly used. -}
compileGlob :: String -> GlobCase -> Glob
compileGlob glob globcase = Glob $
#ifdef WITH_TDFA
	case compile (defaultCompOpt {caseSensitive = casesentitive}) defaultExecOpt regex of
		Right r -> r
		Left _ -> error $ "failed to compile regex: " ++ regex
#else
	mkRegexWithOpts regex casesentitive True
#endif
  where
	regex = '^':wildToRegex glob
	casesentitive = case globcase of
		CaseSensative -> True
		CaseInsensative -> False

matchGlob :: Glob -> String -> Bool
matchGlob (Glob regex) val =
#ifdef WITH_TDFA
	case execute regex val of
		Right (Just _) -> True
		_ -> False
#else
	isJust $ matchRegex regex val
#endif


code:
{- gpg interface
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Utility.Gpg where

import Control.Applicative
import Control.Concurrent
import Control.Monad.IO.Class
import qualified Data.Map as M
import Control.Monad.Catch (bracket, MonadMask)

import Common
import qualified Build.SysConfig as SysConfig

#ifndef mingw32_HOST_OS
import System.Posix.Types
import System.Path
import Utility.Env
#else
import Utility.Tmp
#endif
import Utility.Format (decode_c)

type KeyId = String

newtype KeyIds = KeyIds { keyIds :: [KeyId] }
	deriving (Ord, Eq)

{- If a specific gpg command was found at configure time, use it.
 - Otherwise, try to run gpg. -}
gpgcmd :: FilePath
gpgcmd = fromMaybe "gpg" SysConfig.gpg

-- Generate an argument list to asymetrically encrypt to the given recipients.
pkEncTo :: [String] -> [CommandParam]
pkEncTo = concatMap (\r -> [Param "--recipient", Param r])

stdParams :: [CommandParam] -> IO [String]
stdParams params = do
#ifndef mingw32_HOST_OS
	-- Enable batch mode if GPG_AGENT_INFO is set, to avoid extraneous
	-- gpg output about password prompts. GPG_BATCH is set by the test
	-- suite for a similar reason.
	e <- getEnv "GPG_AGENT_INFO"
	b <- getEnv "GPG_BATCH"
	let batch = if isNothing e && isNothing b
		then []
		else ["--batch", "--no-tty", "--use-agent"]
	return $ batch ++ defaults ++ toCommand params
#else
	return $ defaults ++ toCommand params
#endif
  where
	-- Be quiet, even about checking the trustdb.
	defaults = ["--quiet", "--trust-model", "always"]

{- Usual options for symmetric / public-key encryption. -}
stdEncryptionParams :: Bool -> [CommandParam]
stdEncryptionParams symmetric =
	[ enc symmetric
	, Param "--force-mdc"
	, Param "--no-textmode"
	]
  where
	enc True = Param "--symmetric"
	-- Force gpg to only encrypt to the specified recipients, not
	-- configured defaults. Recipients are assumed to be specified in
	-- elsewhere.
	enc False = Params "--encrypt --no-encrypt-to --no-default-recipient"

{- Runs gpg with some params and returns its stdout, strictly. -}
readStrict :: [CommandParam] -> IO String
readStrict params = do
	params' <- stdParams params
	withHandle StdoutHandle createProcessSuccess (proc gpgcmd params') $ \h -> do
		hSetBinaryMode h True
		hGetContentsStrict h

{- Runs gpg, piping an input value to it, and returning its stdout,
 - strictly. -}
pipeStrict :: [CommandParam] -> String -> IO String
pipeStrict params input = do
	params' <- stdParams params
	withBothHandles createProcessSuccess (proc gpgcmd params') $ \(to, from) -> do
		hSetBinaryMode to True
		hSetBinaryMode from True
		hPutStr to input
		hClose to
		hGetContentsStrict from

{- Runs gpg with some parameters. First sends it a passphrase (unless it
 - is empty) via '--passphrase-fd'. Then runs a feeder action that is
 - passed a handle and should write to it all the data to input to gpg.
 - Finally, runs a reader action that is passed a handle to gpg's
 - output.
 -
 - Runs gpg in batch mode; this is necessary to avoid gpg 2.x prompting for
 - the passphrase.
 -
 - Note that to avoid deadlock with the cleanup stage,
 - the reader must fully consume gpg's input before returning. -}
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) <- liftIO 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]
	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
		let passphrasefile = [Param "--passphrase-file", File tmpfile]
		go $ passphrasefile ++ params
#endif
  where
	go params' = pipeLazy params' feeder reader

{- Like feedRead, but without passphrase. -}
pipeLazy :: (MonadIO m, MonadMask m) => [CommandParam] -> (Handle -> IO ()) -> (Handle -> m a) -> m a
pipeLazy params feeder reader = do
	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
 - GnuPG's manpage.) -}
findPubKeys :: String -> IO KeyIds
findPubKeys for = KeyIds . parse . lines <$> readStrict params
  where
	params = [Params "--with-colons --list-public-keys", Param for]
	parse = mapMaybe (keyIdField . split ":")
	keyIdField ("pub":_:_:_:f:_) = Just f
	keyIdField _ = Nothing

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
  where
  	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
	extract c (Just keyid) rest =
		extract ((keyid, ""):c) Nothing rest
	extract c _ [] = c
	extract c _ (("sec":_:_:_:keyid:_):rest) =
		extract c (Just keyid) rest
	extract c k (_:rest) =
		extract c k rest

type Passphrase = String
type Size = Int
data KeyType = Algo Int | DSA | RSA

{- The maximum key size that gpg currently offers in its UI when
 - making keys. -}
maxRecommendedKeySize :: Size
maxRecommendedKeySize = 4096

{- Generates a secret key using the experimental batch mode.
 - The key is added to the secret key ring.
 - Can take a very long time, depending on system entropy levels.
 -}
genSecretKey :: KeyType -> Passphrase -> UserId -> Size -> IO ()
genSecretKey keytype passphrase userid keysize =
	withHandle StdinHandle createProcessSuccess (proc gpgcmd params) feeder
  where
	params = ["--batch", "--gen-key"]
  	feeder h = do
		hPutStr h $ unlines $ catMaybes
			[ Just $  "Key-Type: " ++
				case keytype of
					DSA -> "DSA"
					RSA -> "RSA"
					Algo n -> show n
			, Just $ "Key-Length: " ++ show keysize
			, Just $ "Name-Real: " ++ userid
			, Just "Expire-Date: 0"
			, if null passphrase
				then Nothing
				else Just $ "Passphrase: " ++ passphrase
			]
		hClose h

{- Creates a block of high-quality random data suitable to use as a cipher.
 - It is armored, to avoid newlines, since gpg only reads ciphers up to the
 - first newline. -}
genRandom :: Bool -> Size -> IO String
genRandom highQuality size = checksize <$> readStrict
	[ Params params
	, Param $ show randomquality
	, Param $ show size
	]
  where
	params = "--gen-random --armor"

	-- See http://www.gnupg.org/documentation/manuals/gcrypt/Quality-of-random-numbers.html
	-- for the meaning of random quality levels.
	-- The highest available is 2, which is the default for OpenPGP
	-- key generation; Note that it uses the blocking PRNG /dev/random
	-- on the Linux kernel, hence the running time may take a while.
	randomquality :: Int
	randomquality = if highQuality then 2 else 1

 	{- 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

	checksize s = let len = length s in
		if len >= expectedlength
			then s
			else shortread len

	shortread got = error $ unwords
		[ "Not enough bytes returned from gpg", params
		, "(got", show got, "; expected", show expectedlength, ")"
		]

{- A test key. This is provided pre-generated since generating a new gpg
 - key is too much work (requires too much entropy) for a test suite to
 - do.
 -
 - This key was generated with no exipiration date, and a small keysize.
 - It has an empty passphrase. -}
testKeyId :: String
testKeyId = "129D6E0AC537B9C7"
testKey :: String
testKey = keyBlock True
	[ "mI0ETvFAZgEEAKnqwWgZqznMhi1RQExem2H8t3OyKDxaNN3rBN8T6LWGGqAYV4wT"
	, "r8In5tfsnz64bKpE1Qi68JURFwYmthgUL9N48tbODU8t3xzijdjLOSaTyqkH1ik6"
	, "EyulfKN63xLne9i4F9XqNwpiZzukXYbNfHkDA2yb0M6g4UFKLY/fNzGXABEBAAG0"
	, "W2luc2VjdXJlIHRlc3Qga2V5ICh0aGlzIGlzIGEgdGVzdCBrZXksIGRvIG5vdCB1"
	, "c2UgZm9yIGFjdHVhbCBlbmNyeXB0aW9uKSA8dGVzdEBleGFtcGxlLmNvbT6IuAQT"
	, "AQgAIgUCTvFAZgIbAwYLCQgHAwIGFQgCCQoLBBYCAwECHgECF4AACgkQEp1uCsU3"
	, "uceQ9wP/YMd1f0+/eLLcwGXNBvGqyVhUOfAKknO1bMzGbqTsq9g60qegy/cldqee"
	, "xVxNfy0VN//JeMfgdcb8+RgJYLoaMrTy9CcsUcFPxtwN9tcLmsM0V2/fNmmFBO9t"
	, "v75iH+zeFbNg0/FbPkHiN6Mjw7P2gXYKQXgTvQZBWaphk8oQlBm4jQRO8UBmAQQA"
	, "vdi50M/WRCkOLt2RsUve8V8brMWYTJBJTTWoHUeRr82v4NCdX7OE1BsoVK8cy/1Q"
	, "Y+gLOH9PqinuGGNWRmPV2Ju/RYn5H7sdewXA8E80xWhc4phHRMJ8Jjhg/GVPamkJ"
	, "8B5zeKF0jcLFl7cuVdOyQakhoeDWJd0CyfW837nmPtMAEQEAAYifBBgBCAAJBQJO"
	, "8UBmAhsMAAoJEBKdbgrFN7nHclAEAKBShuP/toH03atDUQTbGE34CA4yEC9BVghi"
	, "7kviOZlOz2s8xAfp/8AYsrECx1kgbXcA7JD902eNyp7NzXsdJX0zJwHqiuZW0XlD"
	, "T8ZJu4qrYRYgl/790WPESZ+ValvHD/fqkR38RF4tfxvyoMhhp0roGmJY33GASIG/"
	, "+gQkDF9/"
	, "=1k11"
	]
testSecretKey :: String
testSecretKey = keyBlock False
	[ "lQHYBE7xQGYBBACp6sFoGas5zIYtUUBMXpth/Ldzsig8WjTd6wTfE+i1hhqgGFeM"
	, "E6/CJ+bX7J8+uGyqRNUIuvCVERcGJrYYFC/TePLWzg1PLd8c4o3Yyzkmk8qpB9Yp"
	, "OhMrpXyjet8S53vYuBfV6jcKYmc7pF2GzXx5AwNsm9DOoOFBSi2P3zcxlwARAQAB"
	, "AAP+PlRboxy7Z0XjuG70N6+CrzSddQbW5KCwgPFrxYsPk7sAPFcBkmRMVlv9vZpS"
	, "phbP4bvDK+MrSntM51g+9uE802yhPhSWdmEbImiWfV2ucEhlLjD8gw7JDex9XZ0a"
	, "EbTOV56wOsILuedX/jF/6i6IQzy5YmuMeo+ip1XQIsIN+80CAMyXepOBJgHw/gBD"
	, "VdXh/l//vUkQQlhInQYwgkKbr0POCTdr8DM1qdKLcUD9Q1khgNRp0vZGGz+5xsrc"
	, "KaODUlMCANSczLJcYWa8yPqB3S14yTe7qmtDiOS362+SeVUwQA7eQ06PcHLPsN+p"
	, "NtWoHRfYazxrs+g0JvmoQOYdj4xSQy0CAMq7H/l6aeG1n8tpyMxqE7OvBOsvzdu5"
	, "XS7I1AnwllVFgvTadVvqgf7b+hdYd91doeHDUGqSYO78UG1GgaBHJdylqrRbaW5z"
	, "ZWN1cmUgdGVzdCBrZXkgKHRoaXMgaXMgYSB0ZXN0IGtleSwgZG8gbm90IHVzZSBm"
	, "b3IgYWN0dWFsIGVuY3J5cHRpb24pIDx0ZXN0QGV4YW1wbGUuY29tPoi4BBMBCAAi"
	, "BQJO8UBmAhsDBgsJCAcDAgYVCAIJCgsEFgIDAQIeAQIXgAAKCRASnW4KxTe5x5D3"
	, "A/9gx3V/T794stzAZc0G8arJWFQ58AqSc7VszMZupOyr2DrSp6DL9yV2p57FXE1/"
	, "LRU3/8l4x+B1xvz5GAlguhoytPL0JyxRwU/G3A321wuawzRXb982aYUE722/vmIf"
	, "7N4Vs2DT8Vs+QeI3oyPDs/aBdgpBeBO9BkFZqmGTyhCUGZ0B2ARO8UBmAQQAvdi5"
	, "0M/WRCkOLt2RsUve8V8brMWYTJBJTTWoHUeRr82v4NCdX7OE1BsoVK8cy/1QY+gL"
	, "OH9PqinuGGNWRmPV2Ju/RYn5H7sdewXA8E80xWhc4phHRMJ8Jjhg/GVPamkJ8B5z"
	, "eKF0jcLFl7cuVdOyQakhoeDWJd0CyfW837nmPtMAEQEAAQAD/RaVtFFTkF1udun7"
	, "YOwzJvQXCO9OWHZvSdEeG4BUNdAwy4YWu0oZzKkBDBS6+lWILqqb/c28U4leUJ1l"
	, "H+viz5svN9BWWyj/UpI00uwUo9JaIqalemwfLx6vsh69b54L1B4exLZHYGLvy/B3"
	, "5T6bT0gpOE+53BRtKcJaOh/McQeJAgDTOCBU5weWOf6Bhqnw3Vr/gRfxntAz2okN"
	, "gqz/h79mWbCc/lHKoYQSsrCdMiwziHSjXwvehUrdWE/AcomtW0vbAgDmGJqJ2fNr"
	, "HvdsGx4Ld/BxyiZbCURJLUQ5CwzfHGIvBu9PMT8zM26NOSncaXRjxDna2Ggh8Uum"
	, "ANEwbnhxFwZpAf9L9RLYIMTtAqwBjfXJg/lHcc2R+VP0hL5c8zFz+S+w7bRqINwL"
	, "ff1JstKuHT2nJnu0ustK66by8YI3T0hDFFahnNCInwQYAQgACQUCTvFAZgIbDAAK"
	, "CRASnW4KxTe5x3JQBACgUobj/7aB9N2rQ1EE2xhN+AgOMhAvQVYIYu5L4jmZTs9r"
	, "PMQH6f/AGLKxAsdZIG13AOyQ/dNnjcqezc17HSV9MycB6ormVtF5Q0/GSbuKq2EW"
	, "IJf+/dFjxEmflWpbxw/36pEd/EReLX8b8qDIYadK6BpiWN9xgEiBv/oEJAxffw=="
	, "=LDsg"
	]
keyBlock :: Bool -> [String] -> String
keyBlock public ls = unlines
	[ "-----BEGIN PGP "++t++" KEY BLOCK-----"
	, "Version: GnuPG v1.4.11 (GNU/Linux)"
	, ""
	, unlines ls
	, "-----END PGP "++t++" KEY BLOCK-----"
	]
  where
	t
		| public = "PUBLIC"
		| otherwise = "PRIVATE"

#ifndef mingw32_HOST_OS
{- Runs an action using gpg in a test harness, in which gpg does
 - not use ~/.gpg/, but a directory with the test key set up to be used. -}
testHarness :: IO a -> IO a
testHarness a = do
	orig <- getEnv var
	bracket setup (cleanup orig) (const a)
  where
	var = "GNUPGHOME"

	setup = do
		base <- getTemporaryDirectory
		dir <- mktmpdir $ base </> "gpgtmpXXXXXX"
		void $ 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
			[testSecretKey, testKey]
		return dir

	cleanup orig tmpdir = removeDirectoryRecursive tmpdir >> reset orig
	reset (Just v) = setEnv var v True
	reset _ = unsetEnv var

{- Tests the test harness. -}
testTestHarness :: IO Bool
testTestHarness = do
	keys <- testHarness $ findPubKeys testKeyId
	return $ KeyIds [testKeyId] == keys
#endif

#ifndef mingw32_HOST_OS
checkEncryptionFile :: FilePath -> Maybe KeyIds -> IO Bool
checkEncryptionFile filename keys =
	checkGpgPackets keys =<< readStrict params
  where
	params = [Params "--list-packets --list-only", File filename]

checkEncryptionStream :: String -> Maybe KeyIds -> IO Bool
checkEncryptionStream stream keys =
	checkGpgPackets keys =<< pipeStrict params stream
  where
	params = [Params "--list-packets --list-only"]

{- Parses an OpenPGP packet list, and checks whether data is
 - symmetrically encrypted (keys is Nothing), or encrypted to some
 - public key(s).
 - /!\ The key needs to be in the keyring! -}
checkGpgPackets :: Maybe KeyIds -> String -> IO Bool
checkGpgPackets keys str = do
	let (asym,sym) = partition (pubkeyEncPacket `isPrefixOf`) $
			filter (\l' -> pubkeyEncPacket `isPrefixOf` l' ||
				symkeyEncPacket `isPrefixOf` l') $
			takeWhile (/= ":encrypted data packet:") $
			lines str
	case (keys,asym,sym) of
		(Nothing, [], [_]) -> return True
		(Just (KeyIds ks), ls, []) -> do
			-- Find the master key associated with the
			-- encryption subkey.
			ks' <- concat <$> mapM (keyIds <$$> findPubKeys)
					[ k | k:"keyid":_ <- map (reverse . words) ls ]
			return $ sort (nub ks) == sort (nub ks')
		_ -> return False
  where
	pubkeyEncPacket = ":pubkey enc packet: "
	symkeyEncPacket = ":symkey enc packet: "
#endif


code:
{- Convenience wrapper around cryptohash.
 - Falls back to SHA if it's not available.
 -}

{-# LANGUAGE CPP #-}

module Utility.Hash (
	sha1,
	sha224,
	sha256,
	sha384,
	sha512,
#ifdef WITH_CRYPTOHASH
	skein256,
	skein512,
#endif
	prop_hashes_stable
) where

import qualified Data.ByteString.Lazy as L
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
sha1 = hashlazy

sha224 :: L.ByteString -> Digest SHA224
sha224 = hashlazy

sha256 :: L.ByteString -> Digest SHA256
sha256 = hashlazy

sha384 :: L.ByteString -> Digest SHA384
sha384 = hashlazy

sha512 :: L.ByteString -> Digest SHA512
sha512 = hashlazy

-- sha3 is not yet fully standardized
--sha3 :: L.ByteString -> Digest SHA3
--sha3 = hashlazy

skein256 :: L.ByteString -> Digest Skein256_256
skein256 = hashlazy

skein512 :: L.ByteString -> Digest Skein512_512
skein512 = hashlazy

#endif

{- Check that all the hashes continue to hash the same. -}
prop_hashes_stable :: Bool
prop_hashes_stable = all (\(hasher, result) -> hasher foo == result)
	[ (show . sha1, "0beec7b5ea3f0fdbc95d0dd47f3c5bc275da8a33")
	, (show . sha224, "0808f64e60d58979fcb676c96ec938270dea42445aeefcd3a4e6f8db")
	, (show . sha256, "2c26b46b68ffc68ff99b453c1d30413413422d706483bfa0f98a5e886266e7ae")
	, (show . sha384, "98c11ffdfdd540676b1a137cb1a22b2a70350c9a44171d6b1180c6be5cbb2ee3f79d532c8a1dd9ef2e8e08e752a3babb")
	, (show . sha512, "f7fbba6e0636f890e56fbbf3283e524c6fa3204ae298382d624741d0dc6638326e282c41be5e4254d8820772c5518a2c5a8c0c7f7eda19594a7eb539453e1ed7")
#ifdef WITH_CRYPTOHASH
	, (show . skein256, "a04efd9a0aeed6ede40fe5ce0d9361ae7b7d88b524aa19917b9315f1ecf00d33")
	, (show . skein512, "fd8956898113510180aa4658e6c0ac85bd74fb47f4a4ba264a6b705d7a8e8526756e75aecda12cff4f1aca1a4c2830fbf57f458012a66b2b15a3dd7d251690a7")
#endif
	]
  where
	foo = L.fromChunks [T.encodeUtf8 $ T.pack "foo"]


code:
{- numbers for humans
 -
 - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.HumanNumber where

{- Displays a fractional value as a string with a limited number
 - of decimal digits. -}
showImprecise :: RealFrac a => Int -> a -> String
showImprecise precision n
	| precision == 0 || remainder == 0 = show (round n :: Integer)
	| otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder)
  where
	int :: Integer
	(int, frac) = properFraction n
	remainder = round (frac * 10 ^ precision) :: Integer
	pad0s s = replicate (precision - length s) '0' ++ s
	striptrailing0s = reverse . dropWhile (== '0') . reverse


code:
{- Time for humans.
 -
 - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.HumanTime (
	Duration(..),
	durationSince,
	durationToPOSIXTime,
	durationToDays,
	daysToDuration,
	parseDuration,
	fromDuration,
	prop_duration_roundtrips
) where

import Utility.PartialPrelude
import Utility.Applicative
import Utility.QuickCheck

import Data.Time.Clock
import Data.Time.Clock.POSIX (POSIXTime)
import Data.Char
import Control.Applicative
import qualified Data.Map as M

newtype Duration = Duration { durationSeconds :: Integer }
  deriving (Eq, Ord, Read, Show)

durationSince :: UTCTime -> IO Duration
durationSince pasttime = do
	now <- getCurrentTime
	return $ Duration $ round $ diffUTCTime now pasttime

durationToPOSIXTime :: Duration -> POSIXTime
durationToPOSIXTime = fromIntegral . durationSeconds

durationToDays :: Duration -> Integer
durationToDays d = durationSeconds d `div` dsecs

daysToDuration :: Integer -> Duration
daysToDuration i = Duration $ i * dsecs

{- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -}
parseDuration :: String -> Maybe Duration
parseDuration = Duration <$$> go 0
  where
  	go n [] = return n
  	go n s = do
		num <- readish s :: Maybe Integer
		case dropWhile isDigit s of
			(c:rest) -> do
				u <- M.lookup c unitmap
				go (n + num * u) rest
			_ -> return $ n + num

fromDuration :: Duration -> String
fromDuration Duration { durationSeconds = d }
	| d == 0 = "0s"
	| otherwise = concatMap showunit $ go [] units d
  where
	showunit (u, n)
		| n > 0 = show n ++ [u]
		| otherwise = ""
	go c [] _ = reverse c
	go c ((u, n):us) v =
		let (q,r) = v `quotRem` n
		in go ((u, q):c) us r

units :: [(Char, Integer)]
units =
	[ ('y', ysecs)
	, ('d', dsecs)
	, ('h', hsecs)
	, ('m', msecs)
	, ('s', 1)
	]

unitmap :: M.Map Char Integer
unitmap = M.fromList units

ysecs :: Integer
ysecs = dsecs * 365

dsecs :: Integer
dsecs = hsecs * 24

hsecs :: Integer
hsecs = msecs * 60

msecs :: Integer
msecs = 60

-- Durations cannot be negative.
instance Arbitrary Duration where
	arbitrary = Duration <$> nonNegative arbitrary

prop_duration_roundtrips :: Duration -> Bool
prop_duration_roundtrips d = parseDuration (fromDuration d) == Just d


code:
{- Caching a file's inode, size, and modification time
 - to see when it's changed.
 -
 - Copyright 2013, 2014 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

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
	deriving (Show, Eq, Ord)

newtype InodeCache = InodeCache InodeCachePrim
	deriving (Show)

{- Inode caches can be compared in two different ways, either weakly
 - or strongly. -}
data InodeComparisonType = Weakly | Strongly
	deriving (Eq, Ord)

{- Strong comparison, including inodes. -}
compareStrong :: InodeCache -> InodeCache -> Bool
compareStrong (InodeCache x) (InodeCache y) = x == y

{- Weak comparison of the inode caches, comparing the size and mtime,
 - but not the actual inode.  Useful when inodes have changed, perhaps
 - due to some filesystems being remounted.
 -
 - The weak mtime comparison treats any mtimes that are within 2 seconds
 - of one-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 && (abs (mtime1 - mtime2) < 2)

compareBy :: InodeComparisonType -> InodeCache -> InodeCache -> Bool
compareBy Strongly = compareStrong
compareBy Weakly = compareWeak

{- For use in a Map; it's determined at creation time whether this
 - uses strong or weak comparison for Eq. -}
data InodeCacheKey = InodeCacheKey InodeComparisonType InodeCachePrim
	deriving (Ord)

instance Eq InodeCacheKey where
	(InodeCacheKey ctx x) == (InodeCacheKey cty y) =
		compareBy (maximum [ctx,cty]) (InodeCache x ) (InodeCache y)

inodeCacheToKey :: InodeComparisonType -> InodeCache -> InodeCacheKey
inodeCacheToKey ct (InodeCache prim) = InodeCacheKey ct prim

inodeCacheToMtime :: InodeCache -> EpochTime
inodeCacheToMtime (InodeCache (InodeCachePrim _ _ mtime)) = mtime

showInodeCache :: InodeCache -> String
showInodeCache (InodeCache (InodeCachePrim inode size mtime)) = unwords
	[ show inode
	, show size
	, show mtime
	]

readInodeCache :: String -> Maybe InodeCache
readInodeCache s = case words s of
	(inode:size:mtime:_) ->
		let prim = InodeCachePrim
			<$> readish inode
			<*> readish size
			<*> readish mtime
		in InodeCache <$> prim
	_ -> Nothing

genInodeCache :: FilePath -> TSDelta -> IO (Maybe InodeCache)
genInodeCache f delta = catchDefaultIO Nothing $
	toInodeCache delta =<< getFileStatus f

toInodeCache :: TSDelta -> FileStatus -> IO (Maybe InodeCache)
toInodeCache (TSDelta getdelta) s
	| isRegularFile s = do
		delta <- getdelta
		return $ Just $ InodeCache $ InodeCachePrim
			(fileID s)
			(fileSize s)
			(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)

{- 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
	  	unchanged = oldinode == newinode && oldsize == newsize
		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 =
		let prim = InodeCachePrim
			<$> arbitrary
			<*> arbitrary
			<*> arbitrary
		in InodeCache <$> prim

prop_read_show_inodecache :: InodeCache -> Bool
prop_read_show_inodecache c = case readInodeCache (showInodeCache c) of
	Nothing -> False
	Just c' -> compareStrong c c'


code:
{- Streaming JSON output.
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.JSONStream (
	start,
	add,
	end
) where

import Text.JSON

{- Text.JSON does not support building up a larger JSON document piece by
 - piece as a stream. To support streaming, a hack. The JSObject is converted
 - to a string with its final "}" is left off, allowing it to be added to
 - later. -}
start :: JSON a => [(String, a)] -> String
start l
	| last s == endchar = init s
	| otherwise = bad s
  where
	s = encodeStrict $ toJSObject l

add :: JSON a => [(String, a)] -> String
add l
	| head s == startchar = ',' : drop 1 s
	| otherwise = bad s
  where
	s = start l

end :: String
end = [endchar, '\n']

startchar :: Char
startchar = '{'

endchar :: Char
endchar = '}'

bad :: String -> a
bad s = error $ "Text.JSON returned unexpected string: " ++ s


code:
{- Linux library copier and binary shimmer
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.LinuxMkLibs where

import Control.Applicative
import Data.Maybe
import System.Directory
import Data.List.Utils
import System.Posix.Files
import Data.Char
import Control.Monad.IfElse

import Utility.PartialPrelude
import Utility.Directory
import Utility.Process
import Utility.Monad
import Utility.Path

{- Installs a library. If the library is a symlink to another file,
 - install the file it links to, and update the symlink to be relative. -}
installLib :: (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO (Maybe FilePath)
installLib installfile top lib = ifM (doesFileExist lib)
	( do
		installfile top lib
		checksymlink lib
		return $ Just $ parentDir lib
	, return Nothing
	)
  where
	checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do
		l <- readSymbolicLink (inTop top f)
		let absl = absPathFrom (parentDir f) l
		let target = relPathDirToFile (parentDir f) absl
		installfile top absl
		nukeFile (top ++ f)
		createSymbolicLink target (inTop top f)
		checksymlink absl

-- Note that f is not relative, so cannot use </>
inTop :: FilePath -> FilePath -> FilePath
inTop top f = top ++ f

{- Parse ldd output, getting all the libraries that the input files
 - link to. Note that some of the libraries may not exist
 - (eg, linux-vdso.so) -}
parseLdd :: String -> [FilePath]
parseLdd = mapMaybe (getlib . dropWhile isSpace) . lines
  where
	getlib l = headMaybe . words =<< lastMaybe (split " => " l)

{- Get all glibc libs and other support files, including gconv files
 -
 - XXX Debian specific. -}
glibcLibs :: IO [FilePath]
glibcLibs = lines <$> readProcess "sh"
	["-c", "dpkg -L libc6:$(dpkg --print-architecture) libgcc1:$(dpkg --print-architecture) | egrep '\\.so|gconv'"]


code:
{- log files
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.LogFile where

import Common

#ifndef mingw32_HOST_OS
import System.Posix.Types
#endif

openLog :: FilePath -> IO Handle
openLog logfile = do
	rotateLog logfile
	openFile logfile AppendMode

rotateLog :: FilePath -> IO ()
rotateLog logfile = go 0
  where
	go num
		| num > maxLogs = return ()
		| otherwise = whenM (doesFileExist currfile) $ do
			go (num + 1)
			rename currfile nextfile
	  where
		currfile = filename num
		nextfile = filename (num + 1)
		filename n
			| n == 0 = logfile
			| otherwise = rotatedLog logfile n

rotatedLog :: FilePath -> Int -> FilePath
rotatedLog logfile n = logfile ++ "." ++ show n

{- Lists most recent logs last. -}
listLogs :: FilePath -> IO [FilePath]
listLogs logfile = filterM doesFileExist $ reverse $
	logfile : map (rotatedLog logfile) [1..maxLogs]

maxLogs :: Int
maxLogs = 9

#ifndef mingw32_HOST_OS
redirLog :: Fd -> IO ()
redirLog logfd = do
	mapM_ (redir logfd) [stdOutput, stdError]
	closeFd logfd

redir :: Fd -> Fd -> IO ()
redir newh h = do
	closeFd h
	void $ dupTo newh h
#endif


code:
{- lsof interface
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.Lsof where

import Common
import Build.SysConfig as SysConfig
import Utility.Env

import System.Posix.Types

data LsofOpenMode = OpenReadWrite | OpenReadOnly | OpenWriteOnly | OpenUnknown
	deriving (Show, Eq)

type CmdLine = String

data ProcessInfo = ProcessInfo ProcessID CmdLine
	deriving (Show)

{- lsof is not in PATH on all systems, so SysConfig may have the absolute
 - path where the program was found. Make sure at runtime that lsof is
 - available, and if it's not in PATH, adjust PATH to contain it. -}
setup :: IO ()
setup = do
	let cmd = fromMaybe "lsof" SysConfig.lsof
	when (isAbsolute cmd) $ do
		path <- getSearchPath
		let path' = takeDirectory cmd : path
		void $ 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. -}
queryDir :: FilePath -> IO [(FilePath, LsofOpenMode, ProcessInfo)]
queryDir path = query ["+d", path]

{- Runs lsof with some parameters.
 -
 - Ignores nonzero exit code; lsof returns that when no files are open.
 -
 - Note: If lsof is not available, this always returns [] !
 -}
query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)]
query opts =
	withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ \h -> do
		fileEncoding h
		parse <$> hGetContentsStrict h
  where
	p = proc "lsof" ("-F0can" : opts)

type LsofParser = String -> [(FilePath, LsofOpenMode, ProcessInfo)]

parse :: LsofParser
#ifdef __ANDROID__
parse = parseDefault
#else
parse = parseFormatted
#endif

{- Parsing null-delimited output like:
 -
 - pPID\0cCMDLINE\0
 - aMODE\0nFILE\0
 - aMODE\0nFILE\0
 - pPID\0[...]
 -
 - Where each new process block is started by a pid, and a process can
 - have multiple files open.
 -}
parseFormatted :: LsofParser
parseFormatted s = bundle $ go [] $ lines s
  where
	bundle = concatMap (\(fs, p) -> map (\(f, m) -> (f, m, p)) fs)

	go c [] = c
	go c ((t:r):ls)
		| t == 'p' =
			let (fs, ls') = parsefiles [] ls
			in go ((fs, parseprocess r):c) ls'
		| otherwise = parsefail
	go _ _ = parsefail

	parseprocess l = case splitnull l of
		[pid, 'c':cmdline, ""] ->
			case readish pid of
				(Just n) -> ProcessInfo n cmdline
				Nothing -> parsefail
		_ -> 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

	parsemode ('r':_) = OpenReadOnly
	parsemode ('w':_) = OpenWriteOnly
	parsemode ('u':_) = OpenReadWrite
	parsemode _ = OpenUnknown

	splitnull = split "\0"

	parsefail = error $ "failed to parse lsof output: " ++ show s

{- Parses lsof's default output format. -}
parseDefault :: LsofParser
parseDefault = mapMaybe parseline . drop 1 . lines
  where
	parseline l = case words l of
		(command : spid : _user : _fd : _type : _device : _size : _node : rest) ->
			case readish spid of
				Nothing -> Nothing
				Just pid -> Just (unwords rest, OpenUnknown, ProcessInfo pid command)
		_ -> Nothing


code:
{- A generic matcher.
 -
 - Can be used to check if a user-supplied condition,
 - like "foo and ( bar or not baz )" matches. The condition must already
 - be tokenized, and can contain arbitrary operations.
 -
 - If operations are not separated by and/or, they are defaulted to being
 - anded together, so "foo bar baz" all must match.
 -
 - 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>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE Rank2Types, KindSignatures #-}

module Utility.Matcher (
	Token(..),
	Matcher(..),
	token,
	tokens,
	generate,
	match,
	matchM,
	matchMrun,
	isEmpty,

	prop_matcher_sane
) where

import Common

{- A Token can be an Operation of an arbitrary type, or one of a few
 - predefined peices of syntax. -}
data Token op = Operation op | And | Or | Not | Open | Close
	deriving (Show, Eq)

data Matcher op = MAny
	| MAnd (Matcher op) (Matcher op)
	| MOr (Matcher op) (Matcher op)
	| MNot (Matcher op)
	| MOp op
	deriving (Show, Eq)

{- Converts a word of syntax into a token. Doesn't handle operations. -}
token :: String -> Token op
token "and" = And
token "or" = Or
token "not" = Not
token "(" = Open
token ")" = Close
token t = error $ "unknown token " ++ t

tokens :: [String]
tokens = words "and or not ( )"

{- Converts a list of Tokens into a Matcher. -}
generate :: [Token op] -> Matcher op
generate = simplify . process MAny . tokenGroups
  where
	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 (Group g:rest) = (process m g, rest)
	consume m (_:rest) = consume m rest
	consume m [] = (m, [])

	term a l =
		let (p, l') = consume MAny l
		in (a p, l')

	simplify (MAnd MAny x) = simplify x
	simplify (MAnd x MAny) = simplify x
	simplify (MAnd x y) = MAnd (simplify x) (simplify y)
	simplify (MOr x y) = MOr (simplify x) (simplify y)
	simplify (MNot x) = MNot (simplify x)
	simplify x = x

data TokenGroup op = One (Token op) | Group [TokenGroup op]
	deriving (Show, Eq)

tokenGroups :: [Token op] -> [TokenGroup op]
tokenGroups [] = []
tokenGroups (t:ts) = go t
  where
  	go Open =
		let (gr, rest) = findClose ts
		in gr : tokenGroups rest
	go Close = tokenGroups ts -- not picky about missing Close
	go _ = One t : tokenGroups ts

findClose :: [Token op] -> (TokenGroup op, [Token op])
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
	  where
		handle Close = (c, ts)
		handle Open =
			let (c', ts') = go [] ts
			in go (Group (reverse c') : c) ts'
		handle _ = go (One t:c) ts

{- Checks if a Matcher matches, using a supplied function to check
 - the value of Operations. -}
match :: (op -> v -> Bool) -> Matcher op -> v -> Bool
match a m v = go m
  where
	go MAny = True
	go (MAnd m1 m2) = go m1 && go m2
	go (MOr m1 m2) =  go m1 || go m2
	go (MNot m1) = not $ go m1
	go (MOp o) = a o v

{- Runs a monadic Matcher, where Operations are actions in the monad. -}
matchM :: Monad m => Matcher (v -> m Bool) -> v -> m Bool
matchM m v = matchMrun m $ \o -> o v

{- More generic running of a monadic Matcher, with full control over running
 - of Operations. Mostly useful in order to match on more than one
 - parameter. -}
matchMrun :: forall o (m :: * -> *). Monad m => Matcher o -> (o -> m Bool) -> m Bool
matchMrun m run = go m
  where
	go MAny = return True
	go (MAnd m1 m2) = go m1 <&&> go m2
	go (MOr m1 m2) =  go m1 <||> go m2
	go (MNot m1) = liftM not (go m1)
	go (MOp o) = run o

{- Checks if a matcher contains no limits. -}
isEmpty :: Matcher a -> Bool
isEmpty MAny = True
isEmpty _ = False

prop_matcher_sane :: Bool
prop_matcher_sane = all (\m -> match dummy m ()) $ map generate
	[ [Operation True]
	, []
	, [Operation False, Or, Operation True, Or, Operation False]
	, [Operation True, Or, Operation True]
	, [Operation True, And, Operation True]
	, [Not, Open, Operation True, And, Operation False, Close]
	, [Not, Open, Not, Open, Not, Operation False, Close, Close]
	, [Not, Open, Not, Open, Not, Open, Not, Operation True, Close, Close]
	, [Operation True, And, Not, Operation False]
	, [Operation True, Not, Operation False]
	, [Operation True, Not, Not, Not, Operation False]
	, [Operation True, Not, Not, Not, Operation False, And, Operation True]
	, [Operation True, Not, Not, Not, Operation False, Operation True]
	, [Not, Open, Operation True, And, Operation False, Close,
		And, Open,
			Open, Operation True, And, Operation False, Close,
			Or,
			Open, Operation True, And, Open, Not, Operation False, Close, Close,
		Close, And,
			Open, Not, Operation False, Close]
	]
  where
	dummy b _ = b


code:
{- Metered IO
 -
 - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE TypeSynonymInstances #-}

module Utility.Metered where

import Common

import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S
import System.IO.Unsafe
import Foreign.Storable (Storable(sizeOf))
import System.Posix.Types
import Data.Int

{- An action that can be run repeatedly, updating it on the bytes processed.
 -
 - Note that each call receives the total number of bytes processed, so
 - 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)

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

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

addBytesProcessed :: AsBytesProcessed v => BytesProcessed -> v -> BytesProcessed
addBytesProcessed (BytesProcessed i) v =
	let (BytesProcessed n) = toBytesProcessed v
	in BytesProcessed $! i + n

zeroBytesProcessed :: BytesProcessed
zeroBytesProcessed = BytesProcessed 0

{- Sends the content of a file to an action, updating the meter as it's
 - consumed. -}
withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a
withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h ->
	hGetContentsMetered h meterupdate >>= a

{- Sends the content of a file to a Handle, updating the meter as it's
 - written. -}
streamMeteredFile :: FilePath -> MeterUpdate -> Handle -> IO ()
streamMeteredFile f meterupdate h = withMeteredFile f meterupdate $ L.hPut h

{- Writes a ByteString to a Handle, updating a meter as it's written. -}
meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO ()
meteredWrite meterupdate h = go zeroBytesProcessed . L.toChunks
  where
	go _ [] = return ()
	go sofar (c:cs) = do
		S.hPut h c
		let sofar' = addBytesProcessed sofar $ S.length c
		meterupdate sofar'
		go sofar' cs

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.
 -
 - 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.
 -}
hGetContentsMetered :: Handle -> MeterUpdate -> IO L.ByteString
hGetContentsMetered h meterupdate = lazyRead zeroBytesProcessed
  where
	lazyRead sofar = unsafeInterleaveIO $ loop sofar

	loop sofar = do
		c <- S.hGetSome h defaultChunkSize
		if S.null c
			then do
				hClose h
				return $ L.empty
			else do
				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

{- Same default chunk size Lazy ByteStrings use. -}
defaultChunkSize :: Int
defaultChunkSize = 32 * k - chunkOverhead
  where
	k = 1024
	chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific


code:
{- misc utility functions
 -
 - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.Misc where

import System.IO
import Control.Monad
import Foreign
import Data.Char
import Data.List
import Control.Applicative
import System.Exit
#ifndef mingw32_HOST_OS
import System.Posix.Process (getAnyProcessStatus)
import Utility.Exception
#endif

import Utility.FileSystemEncoding
import Utility.Monad

{- A version of hgetContents that is not lazy. Ensures file is
 - all read before it gets closed. -}
hGetContentsStrict :: Handle -> IO String
hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s

{- A version of readFile that is not lazy. -}
readFileStrict :: FilePath -> IO String
readFileStrict = readFile >=> \s -> length s `seq` return s

{-  Reads a file strictly, and using the FileSystemEncoding, so it will
 -  never crash on a badly encoded file. -}
readFileStrictAnyEncoding :: FilePath -> IO String
readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do
	fileEncoding h
	hClose h `after` hGetContentsStrict h

{- Writes a file, using the FileSystemEncoding so it will never crash
 - on a badly encoded content string. -}
writeFileAnyEncoding :: FilePath -> String -> IO ()
writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do
	fileEncoding h
	hPutStr h content

{- Like break, but the item matching the condition is not included
 - in the second result list.
 -
 - separate (== ':') "foo:bar" = ("foo", "bar")
 - separate (== ':') "foobar" = ("foobar", "")
 -}
separate :: (a -> Bool) -> [a] -> ([a], [a])
separate c l = unbreak $ break c l
  where
	unbreak r@(a, b)
		| null b = r
		| otherwise = (a, tail b)

{- Breaks out the first line. -}
firstLine :: String -> String
firstLine = takeWhile (/= '\n')

{- Splits a list into segments that are delimited by items matching
 - a predicate. (The delimiters are not included in the segments.)
 - Segments may be empty. -}
segment :: (a -> Bool) -> [a] -> [[a]]
segment p l = map reverse $ go [] [] l
  where
	go c r [] = reverse $ c:r
	go c r (i:is)
		| p i = go [] (c:r) is
		| otherwise = go (i:c) r is

prop_segment_regressionTest :: Bool
prop_segment_regressionTest = all id
	-- Even an empty list is a segment.
	[ segment (== "--") [] == [[]]
	-- There are two segements in this list, even though the first is empty.
	, segment (== "--") ["--", "foo", "bar"] == [[],["foo","bar"]]
	]

{- Includes the delimiters as segments of their own. -}
segmentDelim :: (a -> Bool) -> [a] -> [[a]]
segmentDelim p l = map reverse $ go [] [] l
  where
	go c r [] = reverse $ c:r
	go c r (i:is)
		| p i = go [] ([i]:c:r) is
		| otherwise = go (i:c) r is

{- Replaces multiple values in a string.
 -
 - Takes care to skip over just-replaced values, so that they are not
 - mangled. For example, massReplace [("foo", "new foo")] does not
 - replace the "new foo" with "new new foo".
 -}
massReplace :: [(String, String)] -> String -> String
massReplace vs = go [] vs
  where

	go acc _ [] = concat $ reverse acc
	go acc [] (c:cs) = go ([c]:acc) vs cs
	go acc ((val, replacement):rest) s
		| val `isPrefixOf` s =
			go (replacement:acc) vs (drop (length val) s)
		| otherwise = go acc rest s

{- Wrapper around hGetBufSome that returns a String.
 -
 - The null string is returned on eof, otherwise returns whatever
 - data is currently available to read from the handle, or waits for
 - data to be written to it if none is currently available.
 -
 - Note on encodings: The normal encoding of the Handle is ignored;
 - each byte is converted to a Char. Not unicode clean!
 -}
hGetSomeString :: Handle -> Int -> IO String
hGetSomeString h sz = do
	fp <- mallocForeignPtrBytes sz
	len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz
	map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len)
  where
	peekbytes :: Int -> Ptr Word8 -> IO [Word8]
	peekbytes len buf = mapM (peekElemOff buf) [0..pred len]

{- Reaps any zombie git processes.
 -
 - Warning: Not thread safe. Anything that was expecting to wait
 - on a process and get back an exit status is going to be confused
 - if this reap gets there first. -}
reapZombies :: IO ()
#ifndef mingw32_HOST_OS
reapZombies = do
	-- throws an exception when there are no child processes
	catchDefaultIO Nothing (getAnyProcessStatus False True)
		>>= maybe (return ()) (const reapZombies)

#else
reapZombies = return ()
#endif

exitBool :: Bool -> IO a
exitBool False = exitFailure
exitBool True = exitSuccess


code:
{- monadic stuff
 -
 - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.Monad where

import Data.Maybe
import Control.Monad

{- Return the first value from a list, if any, satisfying the given
 - predicate -}
firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
firstM _ [] = return Nothing
firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs)

{- Runs the action on values from the list until it succeeds, returning
 - its result. -}
getM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
getM _ [] = return Nothing
getM p (x:xs) = maybe (getM p xs) (return . Just) =<< p x

{- Returns true if any value in the list satisfies the predicate,
 - stopping once one is found. -}
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
anyM p = liftM isJust . firstM p

allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM _ [] = return True
allM p (x:xs) = p x <&&> allM p xs

{- Runs an action on values from a list until it succeeds. -}
untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool
untilTrue = flip anyM

{- if with a monadic conditional. -}
ifM :: Monad m => m Bool -> (m a, m a) -> m a
ifM cond (thenclause, elseclause) = do
	c <- cond
	if c then thenclause else elseclause

{- short-circuiting monadic || -}
(<||>) :: Monad m => m Bool -> m Bool -> m Bool
ma <||> mb = ifM ma ( return True , mb )

{- short-circuiting monadic && -}
(<&&>) :: Monad m => m Bool -> m Bool -> m Bool
ma <&&> mb = ifM ma ( mb , return False )

{- Same fixity as && and || -}
infixr 3 <&&>
infixr 2 <||>

{- Runs an action, passing its value to an observer before returning it. -}
observe :: Monad m => (a -> m b) -> m a -> m a
observe observer a = do
	r <- a
	_ <- observer r
	return r

{- b `after` a runs first a, then b, and returns the value of a -}
after :: Monad m => m b -> m a -> m a
after = observe . const

{- do nothing -}
noop :: Monad m => m ()
noop = return ()


code:
{- Interface to mtab (and fstab)
 -
 - Derived from hsshellscript, originally written by
 - Volker Wysk <hsss@volker-wysk.de>
 -
 - Modified to support BSD, Mac OS X, and Android by
 - Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU LGPL version 2.1 or higher.
 -}

{-# LANGUAGE ForeignFunctionInterface #-}

module Utility.Mounts (
	Mntent(..),
	getMounts
) where

#ifndef __ANDROID__
import Control.Monad
import Foreign
import Foreign.C
#include "libmounts.h"
#else
import Utility.Exception
import Data.Maybe
import Control.Applicative
#endif

{- This is a stripped down mntent, containing only
 - fields available everywhere. -}
data Mntent = Mntent
	{ mnt_fsname :: String
	, mnt_dir :: FilePath
	, mnt_type :: String
	} deriving (Read, Show, Eq, Ord)

#ifndef __ANDROID__

getMounts :: IO [Mntent]
getMounts = do
	h <- c_mounts_start
	when (h == nullPtr) $
		throwErrno "getMounts"
	mntent <- getmntent h []
	_ <- c_mounts_end h
	return mntent

  where
	getmntent h c = do
		ptr <- c_mounts_next h
		if (ptr == nullPtr)
			then return $ reverse c
			else do
				mnt_fsname_str <- #{peek struct mntent, mnt_fsname} ptr >>= peekCString
				mnt_dir_str <- #{peek struct mntent, mnt_dir} ptr >>= peekCString
				mnt_type_str <- #{peek struct mntent, mnt_type} ptr >>= peekCString
				let ent = Mntent
					{ mnt_fsname = mnt_fsname_str
					, mnt_dir = mnt_dir_str
					, mnt_type = mnt_type_str
					}
				getmntent h (ent:c)

{- Using unsafe imports because the C functions are belived to never block.
 - Note that getmntinfo is called with MNT_NOWAIT to avoid possibly blocking;
 - while getmntent only accesses a file in /etc (or /proc) that should not
 - block. -}
foreign import ccall unsafe "libmounts.h mounts_start" c_mounts_start
        :: IO (Ptr ())
foreign import ccall unsafe "libmounts.h mounts_next" c_mounts_next
        :: Ptr () -> IO (Ptr ())
foreign import ccall unsafe "libmounts.h mounts_end" c_mounts_end
        :: Ptr () -> IO CInt

#else

{- Android does not support getmntent (well, it's a no-op stub in Bionic).
 -
 - But, the linux kernel's /proc/mounts is available to be parsed.
 -}
getMounts :: IO [Mntent]
getMounts = catchDefaultIO [] $
	mapMaybe (parse . words) . lines <$> readFile "/proc/mounts"
  where
  	parse (device:mountpoint:fstype:_rest) = Just $ Mntent
		{ mnt_fsname = device
		, mnt_dir = mountpoint
		, mnt_type = fstype
		}
	parse _ = Nothing

#endif


code:
{- network functions
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.Network where

import Utility.Process
import Utility.Exception

import Control.Applicative

{- Haskell lacks uname(2) bindings, except in the
 - Bindings.Uname addon. Rather than depend on that,
 - use uname -n when available. -}
getHostname :: IO (Maybe String)
getHostname = catchMaybeIO uname_node
  where
	uname_node = takeWhile (/= '\n') <$> readProcess "uname" ["-n"]


code:
{- notification broadcaster
 -
 - This is used to allow clients to block until there is a new notification
 - that some thing occurred. It does not communicate what the change is,
 - it only provides blocking reads to wait on notifications.
 -
 - Multiple clients are supported. Each has a unique id.
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.NotificationBroadcaster (
	NotificationBroadcaster,
	NotificationHandle,
	NotificationId,
	newNotificationBroadcaster,
	newNotificationHandle,
	notificationHandleToId,
	notificationHandleFromId,
	sendNotification,
	waitNotification,
	checkNotification,
) where

import Common

import Control.Concurrent.STM

{- One TMVar per client, which are empty when no notification is pending,
 - and full when a notification has been sent but not yet seen by the
 - client. The list TMVar is never empty, so never blocks. -}
type NotificationBroadcaster = TMVar [TMVar ()]

newtype NotificationId = NotificationId Int
	deriving (Read, Show, Eq, Ord)

{- Handle given out to an individual client. -}
data NotificationHandle = NotificationHandle NotificationBroadcaster NotificationId

newNotificationBroadcaster :: IO NotificationBroadcaster
newNotificationBroadcaster = atomically $ newTMVar []

{- Allocates a notification handle for a client to use.
 -
 - An immediate notification can be forced the first time waitNotification
 - is called on the handle. This is useful in cases where a notification
 - may be sent while the new handle is being constructed. Normally,
 - such a notification would be missed. Forcing causes extra work,
 - but ensures such notifications get seen.
 -}
newNotificationHandle :: Bool -> NotificationBroadcaster -> IO NotificationHandle
newNotificationHandle force b = NotificationHandle
	<$> pure b
	<*> addclient
  where
	addclient = atomically $ do
		s <- if force
			then newTMVar ()
			else newEmptyTMVar
		l <- takeTMVar b
		putTMVar b $ l ++ [s]
		return $ NotificationId $ length l

{- Extracts the identifier from a notification handle.
 - This can be used to eg, pass the identifier through to a WebApp. -}
notificationHandleToId :: NotificationHandle -> NotificationId
notificationHandleToId (NotificationHandle _ i) = i

notificationHandleFromId :: NotificationBroadcaster -> NotificationId -> NotificationHandle
notificationHandleFromId = NotificationHandle

{- Sends a notification to all clients. -}
sendNotification :: NotificationBroadcaster -> IO ()
sendNotification b = do
	l <- atomically $ readTMVar b
	mapM_ notify l
  where
	notify s = atomically $
		whenM (isEmptyTMVar s) $
			putTMVar s ()

{- Used by a client to block until a new notification is available since
 - the last time it tried. -}
waitNotification :: NotificationHandle -> IO ()
waitNotification (NotificationHandle b (NotificationId i)) = do
	l <- atomically $ readTMVar b
	atomically $ takeTMVar (l !! i)

{- Used by a client to check if there has been a new notification since the
 - last time it checked, without blocking. -}
checkNotification :: NotificationHandle -> IO Bool
checkNotification (NotificationHandle b (NotificationId i)) = do
	l <- atomically $ readTMVar b
	maybe False (const True) <$> atomically (tryTakeTMVar (l !! i))


code:
{- OSX stuff
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.OSX where

import Utility.UserInfo

import System.FilePath

autoStartBase :: String -> FilePath
autoStartBase label = "Library" </> "LaunchAgents" </> label ++ ".plist"

systemAutoStart :: String -> FilePath
systemAutoStart label = "/" </> autoStartBase label

userAutoStart :: String -> IO FilePath
userAutoStart label = do
	home <- myHomeDir
	return $ home </> autoStartBase label

{- Generates an OSX autostart plist file with a given label, command, and
 - params to run at boot or login. -}
genOSXAutoStartFile :: String -> String -> [String] -> String
genOSXAutoStartFile label command params = unlines
	[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
	, "<!DOCTYPE plist PUBLIC \"-//Apple//DTD PLIST 1.0//EN\" \"http://www.apple.com/DTDs/PropertyList-1.0.dtd\">"
	, "<plist version=\"1.0\">"
	, "<dict>"
	, "<key>Label</key>"
	, "<string>" ++ label ++ "</string>"
	, "<key>ProgramArguments</key>"
	, "<array>"
	, unlines $ map (\v -> "<string>" ++ v ++ "</string>") (command:params)
	, "</array>"
	, "<key>RunAtLoad</key>"
	, "<true/>"
	, "</dict>"
	, "</plist>"
	]


code:
{- process ids
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.PID where

#ifndef mingw32_HOST_OS
import System.Posix.Types (ProcessID)
import System.Posix.Process (getProcessID)
#else
import System.Win32.Process (ProcessId)
import System.Win32.Process.Current (getCurrentProcessId)
#endif

#ifndef mingw32_HOST_OS
type PID = ProcessID
#else
type PID = ProcessId
#endif

getPID :: IO PID
#ifndef mingw32_HOST_OS
getPID = getProcessID
#else
getPID = getCurrentProcessId
#endif


code:
{- parallel processing via threads
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

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
 - threaded runtime,
 -
 - Returns the values partitioned into ones with which the action succeeded,
 - and ones with which it failed. -}
inParallel :: (v -> IO Bool) -> [v] -> IO ([v], [v])
inParallel a l = do
	mvars <- mapM thread l
	statuses <- mapM takeMVar mvars
	return $ reduce $ partition snd $ zip l statuses
  where
	reduce (x,y) = (map fst x, map fst y)
	thread v = do
		mvar <- newEmptyMVar
		_ <- forkIO $ do
			r <- try (a v) :: IO (Either SomeException Bool)
			case r of
				Left _ -> putMVar mvar False
				Right b -> putMVar mvar b
		return mvar


code:
{- Parts of the Prelude are partial functions, which are a common source of
 - bugs.
 -
 - This exports functions that conflict with the prelude, which avoids
 - them being accidentially used.
 -}

module Utility.PartialPrelude where

import qualified Data.Maybe

{- read should be avoided, as it throws an error
 - Instead, use: readish -}
read :: Read a => String -> a
read = Prelude.read

{- head is a partial function; head [] is an error
 - Instead, use: take 1 or headMaybe -}
head :: [a] -> a
head = Prelude.head

{- tail is also partial
 - Instead, use: drop 1 -}
tail :: [a] -> [a]
tail = Prelude.tail

{- init too
 - Instead, use: beginning -}
init :: [a] -> [a]
init = Prelude.init

{- last too
 - Instead, use: end or lastMaybe -}
last :: [a] -> a
last = Prelude.last

{- Attempts to read a value from a String.
 -
 - Ignores leading/trailing whitespace, and throws away any trailing
 - text after the part that can be read.
 -
 - readMaybe is available in Text.Read in new versions of GHC,
 - but that one requires the entire string to be consumed.
 -}
readish :: Read a => String -> Maybe a
readish s = case reads s of
	((x,_):_) -> Just x
	_ -> Nothing

{- Like head but Nothing on empty list. -}
headMaybe :: [a] -> Maybe a
headMaybe = Data.Maybe.listToMaybe

{- Like last but Nothing on empty list. -}
lastMaybe :: [a] -> Maybe a
lastMaybe [] = Nothing
lastMaybe v = Just $ Prelude.last v

{- All but the last element of a list.
 - (Like init, but no error on an empty list.) -}
beginning :: [a] -> [a]
beginning [] = []
beginning l = Prelude.init l

{- Like last, but no error on an empty list. -}
end :: [a] -> [a]
end [] = []
end l = [Prelude.last l]


code:
{- path manipulation
 -
 - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE PackageImports, CPP #-}

module Utility.Path where

import Data.String.Utils
import System.FilePath
import System.Directory
import Data.List
import Data.Maybe
import Data.Char
import Control.Applicative

#ifdef mingw32_HOST_OS
import qualified System.FilePath.Posix as Posix
#else
import System.Posix.Files
#endif

import qualified "MissingH" System.Path as MissingH
import Utility.Monad
import Utility.UserInfo

{- Simplifies a path, removing any ".." or ".", and removing the trailing
 - path separator.
 -
 - On Windows, preserves whichever style of path separator might be used in
 - the input FilePaths. This is done because some programs in Windows
 - demand a particular path separator -- and which one actually varies!
 -
 - This does not guarantee that two paths that refer to the same location,
 - and are both relative to the same location (or both absolute) will
 - yeild the same result. Run both through normalise from System.FilePath
 - to ensure that.
 -}
simplifyPath :: FilePath -> FilePath
simplifyPath path = dropTrailingPathSeparator $
	joinDrive drive $ joinPath $ norm [] $ splitPath path'
  where
	(drive, path') = splitDrive path

	norm c [] = reverse c
	norm c (p:ps)
		| p' == ".." = norm (drop 1 c) ps
		| p' == "." = norm c ps
		| otherwise = norm (p:c) ps
	  where
		p' = dropTrailingPathSeparator p

{- Makes a path absolute.
 -
 - The first parameter is a base directory (ie, the cwd) to use if the path
 - is not already absolute.
 -
 - Does not attempt to deal with edge cases or ensure security with
 - untrusted inputs.
 -}
absPathFrom :: FilePath -> FilePath -> FilePath
absPathFrom dir path = simplifyPath (combine dir path)

{- On Windows, this converts the paths to unix-style, in order to run
 - MissingH's absNormPath on them. Resulting path will use / separators. -}
absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath
#ifndef mingw32_HOST_OS
absNormPathUnix dir path = MissingH.absNormPath dir path
#else
absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path)
  where
	fromdos = replace "\\" "/"
	todos = replace "/" "\\"
#endif

{- Returns the parent directory of a path.
 -
 - To allow this to be easily used in loops, which terminate upon reaching the
 - top, the parent of / is "" -}
parentDir :: FilePath -> FilePath
parentDir dir
	| null dirs = ""
	| otherwise = joinDrive drive (join s $ init dirs)
  where
	-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""
	(drive, path) = splitDrive dir
	dirs = filter (not . null) $ split s path
	s = [pathSeparator]

prop_parentDir_basics :: FilePath -> Bool
prop_parentDir_basics dir
	| null dir = True
	| dir == "/" = parentDir dir == ""
	| otherwise = p /= dir
  where
	p = parentDir dir

{- Checks if the first FilePath is, or could be said to contain the second.
 - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
 - are all equivilant.
 -}
dirContains :: FilePath -> FilePath -> Bool
dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'
  where
	a' = norm a
	b' = norm b
	norm = normalise . simplifyPath

{- Converts a filename into an absolute path.
 -
 - Unlike Directory.canonicalizePath, this does not require the path
 - already exists. -}
absPath :: FilePath -> IO FilePath
absPath file = do
	cwd <- getCurrentDirectory
	return $ absPathFrom cwd file

{- Constructs a relative path from the CWD to a file.
 -
 - For example, assuming CWD is /tmp/foo/bar:
 -    relPathCwdToFile "/tmp/foo" == ".."
 -    relPathCwdToFile "/tmp/foo/bar" == ""
 -}
relPathCwdToFile :: FilePath -> IO FilePath
relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f

{- Constructs a relative path from a directory to a file.
 -
 - Both must be absolute, and cannot contain .. etc. (eg use absPath first).
 -}
relPathDirToFile :: FilePath -> FilePath -> FilePath
relPathDirToFile from to = join s $ dotdots ++ uncommon
  where
	s = [pathSeparator]
	pfrom = split s from
	pto = split s to
	common = map fst $ takeWhile same $ zip pfrom pto
	same (c,d) = c == d
	uncommon = drop numcommon pto
	dotdots = replicate (length pfrom - numcommon) ".."
	numcommon = length common

prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFile_basics from to
	| from == to = null r
	| otherwise = not (null r)
  where
	r = relPathDirToFile from to

prop_relPathDirToFile_regressionTest :: Bool
prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
  where
	{- Two paths have the same directory component at the same
	 - location, but it's not really the same directory.
	 - Code used to get this wrong. -}
	same_dir_shortcurcuits_at_difference =
		relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])
			(joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
				== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]

{- Given an original list of paths, and an expanded list derived from it,
 - generates a list of lists, where each sublist corresponds to one of the
 - original paths. When the original path is a directory, any items
 - in the expanded list that are contained in that directory will appear in
 - its segment.
 -}
segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]
segmentPaths [] new = [new]
segmentPaths [_] new = [new] -- optimisation
segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest
  where
	(found, rest)=partition (l `dirContains`) new

{- This assumes that it's cheaper to call segmentPaths on the result,
 - than it would be to run the action separately with each path. In
 - the case of git file list commands, that assumption tends to hold.
 -}
runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
runSegmentPaths a paths = segmentPaths paths <$> a paths

{- Converts paths in the home directory to use ~/ -}
relHome :: FilePath -> IO String
relHome path = do
	home <- myHomeDir
	return $ if dirContains home path
		then "~/" ++ relPathDirToFile home path
		else path

{- Checks if a command is available in PATH.
 -
 - The command may be fully-qualified, in which case, this succeeds as
 - long as it exists. -}
inPath :: String -> IO Bool
inPath command = isJust <$> searchPath command

{- Finds a command in PATH and returns the full path to it.
 -
 - The command may be fully qualified already, in which case it will
 - be returned if it exists.
 -}
searchPath :: String -> IO (Maybe FilePath)
searchPath command
	| isAbsolute command = check command
	| otherwise = getSearchPath >>= getM indir
  where
	indir d = check $ d </> command
	check f = firstM doesFileExist
#ifdef mingw32_HOST_OS
		[f, f ++ ".exe"]
#else
		[f]
#endif

{- Checks if a filename is a unix dotfile. All files inside dotdirs
 - count as dotfiles. -}
dotfile :: FilePath -> Bool
dotfile file
	| f == "." = False
	| f == ".." = False
	| f == "" = False
	| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)
  where
	f = takeFileName file

{- Converts a DOS style path to a Cygwin style path. Only on Windows.
 - Any trailing '\' is preserved as a trailing '/' -}
toCygPath :: FilePath -> FilePath
#ifndef mingw32_HOST_OS
toCygPath = id
#else
toCygPath p
	| null drive = recombine parts
	| otherwise = recombine $ "/cygdrive" : driveletter drive : parts
  where
  	(drive, p') = splitDrive p
	parts = splitDirectories p'
  	driveletter = map toLower . takeWhile (/= ':')
	recombine = fixtrailing . Posix.joinPath
  	fixtrailing s
		| hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s
		| otherwise = s
#endif

{- Maximum size to use for a file in a specified directory.
 -
 - Many systems have a 255 byte limit to the name of a file,
 - so that's taken as the max if the system has a larger limit, or has no
 - limit.
 -}
fileNameLengthLimit :: FilePath -> IO Int
#ifdef mingw32_HOST_OS
fileNameLengthLimit _ = return 255
#else
fileNameLengthLimit dir = do
	l <- fromIntegral <$> getPathVar dir FileNameLimit
	if l <= 0
		then return 255
		else return $ minimum [l, 255]
  where
#endif

{- Given a string that we'd like to use as the basis for FilePath, but that
 - was provided by a third party and is not to be trusted, returns the closest
 - sane FilePath.
 -
 - All spaces and punctuation and other wacky stuff are replaced
 - with '_', except for '.' "../" will thus turn into ".._", which is safe.
 -}
sanitizeFilePath :: String -> FilePath
sanitizeFilePath = map sanitize
  where
  	sanitize c
		| c == '.' = c
		| isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_'
		| otherwise = c

{- Similar to splitExtensions, but knows that some things in FilePaths
 - after a dot are too long to be extensions. -}
splitShortExtensions :: FilePath -> (FilePath, [String])
splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"
splitShortExtensions' :: Int -> FilePath -> (FilePath, [String])
splitShortExtensions' maxextension = go []
  where
	go c f
		| len > 0 && len <= maxextension && not (null base) =
			go (ext:c) base
		| otherwise = (f, c)
	  where
		(base, ext) = splitExtension f
		len = length ext


code:
{- percentages
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.Percentage (
	Percentage,
	percentage,
	showPercentage
) where

import Data.Ratio

import Utility.HumanNumber

newtype Percentage = Percentage (Ratio Integer)

instance Show Percentage where
	show = showPercentage 0

{- Normally the big number comes first. But 110% is allowed if desired. :) -}
percentage :: Integer -> Integer -> Percentage
percentage 0 _ = Percentage 0
percentage full have = Percentage $ have * 100 % full

{- Pretty-print a Percentage, with a specified level of precision. -}
showPercentage :: Int -> Percentage -> String
showPercentage precision (Percentage p) = v ++ "%"
  where
	v = showImprecise precision n
	n = fromRational p :: Double


code:
{- POSIX files (and compatablity wrappers).
 -
 - This is like System.PosixCompat.Files, except with a fixed rename.
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.PosixFiles (
	module X,
	rename
) where

import System.PosixCompat.Files as X hiding (rename)

#ifndef mingw32_HOST_OS
import System.Posix.Files (rename)
#else
import qualified System.Win32.File as Win32
#endif

{- System.PosixCompat.Files.rename on Windows calls renameFile,
 - so cannot rename directories.
 -
 - Instead, use Win32 moveFile, which can. It needs to be told to overwrite
 - any existing file. -}
#ifdef mingw32_HOST_OS
rename :: FilePath -> FilePath -> IO ()
rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING
#endif