code:
{- git-annex general metadata
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Types.MetaData (
	MetaData(..),
	MetaField(..),
	MetaValue(..),
	CurrentlySet(..),
	serialize,
	deserialize,
	MetaSerializable,
	toMetaField,
	mkMetaField,
	mkMetaFieldUnchecked,
	fromMetaField,
	toMetaValue,
	mkMetaValue,
	unsetMetaValue,
	unsetMetaData,
	fromMetaValue,
	fromMetaData,
	emptyMetaData,
	updateMetaData,
	unionMetaData,
	combineMetaData,
	differenceMetaData,
	isSet,
	currentMetaData,
	currentMetaDataValues,
	metaDataValues,
	ModMeta(..),
	modMeta,
	parseModMeta,
	parseMetaData,
	prop_metadata_sane,
	prop_metadata_serialize
) where

import Common
import Utility.Base64
import Utility.QuickCheck

import qualified Data.Set as S
import qualified Data.Map as M
import Data.Char
import qualified Data.CaseInsensitive as CI

newtype MetaData = MetaData (M.Map MetaField (S.Set MetaValue))
	deriving (Show, Eq, Ord)

{- A metadata value can be currently be set (True), or may have been
 - set before and we're remembering it no longer is (False). -}
newtype CurrentlySet = CurrentlySet Bool
	deriving (Read, Show, Eq, Ord, Arbitrary)

{- Fields are case insensitive. -}
newtype MetaField = MetaField (CI.CI String)
	deriving (Read, Show, Eq, Ord)

data MetaValue = MetaValue CurrentlySet String
	deriving (Read, Show)

{- Metadata values compare and order the same whether currently set or not. -}
instance Eq MetaValue where
	MetaValue _ a == MetaValue _ b = a == b
instance Ord MetaValue where
	compare (MetaValue _ x) (MetaValue _ y) = compare x y

{- MetaData is serialized to a format like:
 -
 - field1 +val1 +val2 -val3 field2 +val4 +val5
 -}
class MetaSerializable v where
	serialize :: v -> String
	deserialize :: String -> Maybe v

instance MetaSerializable MetaData where
	serialize (MetaData m) = unwords $ concatMap go $ M.toList m
	  where
		go (f, vs) = serialize f : map serialize (S.toList vs)
	deserialize = Just . getfield emptyMetaData . words
	  where
		getfield m [] = m
		getfield m (w:ws) = maybe m (getvalues m ws) (deserialize w)
		getvalues m [] _ = m
		getvalues m l@(w:ws) f = case deserialize w of
			Just v -> getvalues (updateMetaData f v m) ws f
			Nothing -> getfield m l

instance MetaSerializable MetaField where
	serialize (MetaField f) = CI.original f
	deserialize = Just . mkMetaFieldUnchecked

{- Base64 problimatic values. -}
instance MetaSerializable MetaValue where
	serialize (MetaValue isset v) =
		serialize isset ++
		if any isSpace v || "!" `isPrefixOf` v
			then '!' : toB64 v
			else v
	deserialize (isset:'!':v) = MetaValue
		<$> deserialize [isset]
		<*> fromB64Maybe v
	deserialize (isset:v) = MetaValue
		<$> deserialize [isset]
		<*> pure v
	deserialize [] = Nothing

instance MetaSerializable CurrentlySet where
	serialize (CurrentlySet True) = "+"
	serialize (CurrentlySet False) = "-"
	deserialize "+" = Just (CurrentlySet True)
	deserialize "-" = Just (CurrentlySet False)
	deserialize _ = Nothing

mkMetaField :: String -> Either String MetaField
mkMetaField f = maybe (Left $ badField f) Right (toMetaField f)

badField :: String -> String
badField f = "Illegal metadata field name, \"" ++ f ++ "\""

{- Does not check that the field name is valid. Use with caution. -}
mkMetaFieldUnchecked :: String -> MetaField
mkMetaFieldUnchecked = MetaField . CI.mk

toMetaField :: String -> Maybe MetaField
toMetaField f
	| legalField f = Just $ MetaField $ CI.mk f
	| otherwise = Nothing

{- Fields cannot be empty, contain whitespace, or start with "+-" as
 - that would break the serialization.
 -
 - Additionally, fields should not contain any form of path separator, as
 - that would break views.
 -
 - So, require they have an alphanumeric first letter, with the remainder
 - being either alphanumeric or a small set of whitelisted common punctuation.
 -}
legalField :: String -> Bool
legalField [] = False
legalField (c1:cs)
	| not (isAlphaNum c1) = False
	| otherwise = all legalchars cs
  where
	legalchars c
		| isAlphaNum c = True
		| otherwise = c `elem` "_-."

toMetaValue :: String -> MetaValue
toMetaValue = MetaValue (CurrentlySet True)

mkMetaValue :: CurrentlySet -> String -> MetaValue
mkMetaValue = MetaValue

unsetMetaValue :: MetaValue -> MetaValue
unsetMetaValue (MetaValue _ s) = MetaValue (CurrentlySet False) s

{- Marks all MetaValues as no longer currently set. -}
unsetMetaData :: MetaData -> MetaData
unsetMetaData (MetaData m) = MetaData $ M.map (S.map unsetMetaValue) m

fromMetaField :: MetaField -> String
fromMetaField (MetaField f) = CI.original f

fromMetaValue :: MetaValue -> String
fromMetaValue (MetaValue _ f) = f

fromMetaData :: MetaData -> [(MetaField, S.Set MetaValue)]
fromMetaData (MetaData m) = M.toList m

emptyMetaData :: MetaData
emptyMetaData = MetaData M.empty

{- Can be used to set a value, or to unset it, depending on whether
 - the MetaValue has CurrentlySet or not. -}
updateMetaData :: MetaField -> MetaValue -> MetaData -> MetaData
updateMetaData f v (MetaData m) = MetaData $
	M.insertWith' S.union f (S.singleton v) m

{- New metadata overrides old._-}
unionMetaData :: MetaData -> MetaData -> MetaData
unionMetaData (MetaData old) (MetaData new) = MetaData $
	M.unionWith S.union new old

combineMetaData :: [MetaData] -> MetaData
combineMetaData = foldl' unionMetaData emptyMetaData

differenceMetaData :: MetaData -> MetaData -> MetaData
differenceMetaData (MetaData m) (MetaData excludem) = MetaData $
	M.differenceWith diff m excludem
  where
	diff sl sr =
		let s = S.difference sl sr
		in if S.null s then Nothing else Just s

isSet :: MetaValue -> Bool
isSet (MetaValue (CurrentlySet isset) _) = isset

{- Gets only currently set values -}
currentMetaDataValues :: MetaField -> MetaData -> S.Set MetaValue
currentMetaDataValues f m = S.filter isSet (metaDataValues f m)

currentMetaData :: MetaData -> MetaData
currentMetaData (MetaData m) = removeEmptyFields $ MetaData $
	M.map (S.filter isSet) m

removeEmptyFields :: MetaData -> MetaData
removeEmptyFields (MetaData m) = MetaData $ M.filter (not . S.null) m

{- Gets currently set values, but also values that have been unset. -}
metaDataValues :: MetaField -> MetaData -> S.Set MetaValue
metaDataValues f (MetaData m) = fromMaybe S.empty (M.lookup f m)

{- Ways that existing metadata can be modified -}
data ModMeta
	= AddMeta MetaField MetaValue
	| DelMeta MetaField MetaValue
	| SetMeta MetaField MetaValue -- removes any existing values
	| MaybeSetMeta MetaField MetaValue -- when field has no existing value

{- Applies a ModMeta, generating the new MetaData.
 - Note that the new MetaData does not include all the
 - values set in the input metadata. It only contains changed values. -}
modMeta :: MetaData -> ModMeta -> MetaData
modMeta _ (AddMeta f v) = updateMetaData f v emptyMetaData
modMeta _ (DelMeta f oldv) = updateMetaData f (unsetMetaValue oldv) emptyMetaData
modMeta m (SetMeta f v) = updateMetaData f v $
	foldr (updateMetaData f) emptyMetaData $
		map unsetMetaValue $ S.toList $ currentMetaDataValues f m
modMeta m (MaybeSetMeta f v)
	| S.null (currentMetaDataValues f m) = updateMetaData f v emptyMetaData
	| otherwise = emptyMetaData

{- Parses field=value, field+=value, field-=value, field?=value -}
parseModMeta :: String -> Either String ModMeta
parseModMeta p = case lastMaybe f of
	Just '+' -> AddMeta <$> mkMetaField f' <*> v
	Just '-' -> DelMeta <$> mkMetaField f' <*> v
	Just '?' -> MaybeSetMeta <$> mkMetaField f' <*> v
	_ -> SetMeta <$> mkMetaField f <*> v
  where
	(f, sv) = separate (== '=') p
	f' = beginning f
	v = pure (toMetaValue sv)

{- Parses field=value -}
parseMetaData :: String -> Either String (MetaField, MetaValue)
parseMetaData p = (,)
	<$> mkMetaField f
	<*> pure (toMetaValue v)
  where
	(f, v) = separate (== '=') p

{- Avoid putting too many fields in the map; extremely large maps make
 - the seriaization test slow due to the sheer amount of data.
 - It's unlikely that more than 100 fields of metadata will be used. -}
instance Arbitrary MetaData where
	arbitrary = do
		size <- arbitrarySizedBoundedIntegral `suchThat` (< 500)
		MetaData . M.filterWithKey legal . M.fromList <$> vector size
	  where
		legal k _v = legalField $ fromMetaField k

instance Arbitrary MetaValue where
	arbitrary = MetaValue <$> arbitrary <*> arbitrary

instance Arbitrary MetaField where
	arbitrary = MetaField . CI.mk <$> arbitrary `suchThat` legalField

prop_metadata_sane :: MetaData -> MetaField -> MetaValue -> Bool
prop_metadata_sane m f v = and
	[ S.member v $ metaDataValues f m'
	, not (isSet v) || S.member v (currentMetaDataValues f m')
	, differenceMetaData m' emptyMetaData == m'
	]
  where
	m' = updateMetaData f v m

prop_metadata_serialize :: MetaField -> MetaValue -> MetaData -> Bool
prop_metadata_serialize f v m = and
	[ deserialize (serialize f) == Just f
	, deserialize (serialize v) == Just v
	, deserialize (serialize m') == Just m'
	]
  where
  	m' = removeEmptyFields m


code:
{- git-annex numcopies type
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Types.NumCopies where

newtype NumCopies = NumCopies Int
	deriving (Ord, Eq)

fromNumCopies :: NumCopies -> Int
fromNumCopies (NumCopies n) = n

repo_name: kakafarm/git

license: unknown


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

module Types.Option where

import System.Console.GetOpt

import Annex

{- Each dashed command-line option results in generation of an action
 - in the Annex monad that performs the necessary setting.
 -}
type Option = OptDescr (Annex ())


code:
{- git-annex remotes types
 -
 - Most things should not need this, using Types instead
 -
 - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Types.Remote
	( RemoteConfigKey
	, RemoteConfig
	, RemoteTypeA(..)
	, RemoteA(..)
	, Availability(..)
	)
	where

import Data.Map as M
import Data.Ord

import qualified Git
import Types.Key
import Types.UUID
import Types.GitConfig
import Types.Availability
import Types.Creds
import Config.Cost
import Utility.Metered
import Git.Types
import Utility.SafeCommand

type RemoteConfigKey = String
type RemoteConfig = M.Map RemoteConfigKey String

{- There are different types of remotes. -}
data RemoteTypeA a = RemoteType {
	-- human visible type name
	typename :: String,
	-- enumerates remotes of this type
	enumerate :: a [Git.Repo],
	-- generates a remote of this type
	generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)),
	-- initializes or changes a remote
	setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> a (RemoteConfig, UUID)
}

instance Eq (RemoteTypeA a) where
	x == y = typename x == typename y

{- An individual remote. -}
data RemoteA a = Remote {
	-- each Remote has a unique uuid
	uuid :: UUID,
	-- each Remote has a human visible name
	name :: RemoteName,
	-- Remotes have a use cost; higher is more expensive
	cost :: Cost,
	-- Transfers a key's contents from disk to the remote.
	-- The key should not appear to be present on the remote until
	-- all of its contents have been transferred.
	storeKey :: Key -> AssociatedFile -> MeterUpdate -> a Bool,
	-- Retrieves a key's contents to a file.
	-- (The MeterUpdate does not need to be used if it retrieves
	-- directly to the file, and not to an intermediate file.)
	retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> a Bool,
	-- retrieves a key's contents to a tmp file, if it can be done cheaply
	retrieveKeyFileCheap :: Key -> FilePath -> a Bool,
	-- removes a key's contents (succeeds if the contents are not present)
	removeKey :: Key -> a Bool,
	-- Checks if a key is present in the remote; if the remote
	-- cannot be accessed returns a Left error message.
	hasKey :: Key -> a (Either String Bool),
	-- Some remotes can check hasKey without an expensive network
	-- operation.
	hasKeyCheap :: Bool,
	-- Some remotes can provide additional details for whereis.
	whereisKey :: Maybe (Key -> a [String]),
	-- Some remotes can run a fsck operation on the remote,
	-- without transferring all the data to the local repo
	-- The parameters are passed to the fsck command on the remote.
	remoteFsck :: Maybe ([CommandParam] -> a (IO Bool)),
	-- Runs an action to repair the remote's git repository.
	repairRepo :: Maybe (a Bool -> a (IO Bool)),
	-- a Remote has a persistent configuration store
	config :: RemoteConfig,
	-- git repo for the Remote
	repo :: Git.Repo,
	-- a Remote's configuration from git
	gitconfig :: RemoteGitConfig,
	-- a Remote can be assocated with a specific local filesystem path
	localpath :: Maybe FilePath,
	-- a Remote can be known to be readonly
	readonly :: Bool,
	-- a Remote can be globally available. (Ie, "in the cloud".)
	availability :: Availability,
	-- the type of the remote
	remotetype :: RemoteTypeA a
}

instance Show (RemoteA a) where
	show remote = "Remote { name =\"" ++ name remote ++ "\" }"

-- two remotes are the same if they have the same uuid
instance Eq (RemoteA a) where
	x == y = uuid x == uuid y

instance Ord (RemoteA a) where
	compare = comparing uuid


code:
{- git-annex scheduled activities
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Types.ScheduledActivity where

import Common
import Utility.Scheduled
import Utility.HumanTime
import Types.UUID

import Data.Either

data ScheduledActivity
	= ScheduledSelfFsck Schedule Duration
	| ScheduledRemoteFsck UUID Schedule Duration
  deriving (Eq, Read, Show, Ord)

{- Activities that run on a remote, within a time window, so
 - should be run when the remote gets connected. -}
connectActivityUUID :: ScheduledActivity -> Maybe UUID
connectActivityUUID (ScheduledRemoteFsck u (Schedule _ AnyTime) _) = Just u
connectActivityUUID _ = Nothing

getSchedule :: ScheduledActivity -> Schedule
getSchedule (ScheduledSelfFsck s _) = s
getSchedule (ScheduledRemoteFsck _ s _) = s

getDuration :: ScheduledActivity -> Duration
getDuration (ScheduledSelfFsck _ d) = d
getDuration (ScheduledRemoteFsck _ _ d) = d

fromScheduledActivity :: ScheduledActivity -> String
fromScheduledActivity (ScheduledSelfFsck s d) = unwords
	[ "fsck self", fromDuration d, fromSchedule s ]
fromScheduledActivity (ScheduledRemoteFsck u s d) = unwords
	[ "fsck", fromUUID u, fromDuration d, fromSchedule s ]

toScheduledActivity :: String -> Maybe ScheduledActivity
toScheduledActivity = eitherToMaybe . parseScheduledActivity

parseScheduledActivity :: String -> Either String ScheduledActivity
parseScheduledActivity s = case words s of
	("fsck":"self":d:rest) -> qualified $ ScheduledSelfFsck
		<$> parseSchedule (unwords rest)
		<*> getduration d
	("fsck":u:d:rest) -> qualified $ ScheduledRemoteFsck
		<$> pure (toUUID u)
		<*> parseSchedule (unwords rest)
		<*> getduration d
	_ -> qualified $ Left "unknown activity"
  where
	qualified (Left e) = Left $ e ++ " in \"" ++ s ++ "\""
	qualified v = v
	getduration d = maybe (Left $ "failed to parse duration \""++d++"\"") Right (parseDuration d)

fromScheduledActivities :: [ScheduledActivity] -> String
fromScheduledActivities = intercalate "; " . map fromScheduledActivity

parseScheduledActivities :: String -> Either String [ScheduledActivity]
parseScheduledActivities s
	| null bad = Right good
	| otherwise = Left $ intercalate "; " bad
  where
	(bad, good) = partitionEithers $
		map parseScheduledActivity $ split "; " s


code:
{- git-annex standard repository groups
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Types.StandardGroups where

import Types.Remote (RemoteConfig)
import Types.Group

import qualified Data.Map as M
import Data.Maybe

type PreferredContentExpression = String

data StandardGroup
	= ClientGroup
	| TransferGroup
	| BackupGroup
	| IncrementalBackupGroup
	| SmallArchiveGroup
	| FullArchiveGroup
	| SourceGroup
	| ManualGroup
	| PublicGroup
	| UnwantedGroup
	deriving (Eq, Ord, Enum, Bounded, Show)

fromStandardGroup :: StandardGroup -> Group
fromStandardGroup ClientGroup = "client"
fromStandardGroup TransferGroup = "transfer"
fromStandardGroup BackupGroup = "backup"
fromStandardGroup IncrementalBackupGroup = "incrementalbackup"
fromStandardGroup SmallArchiveGroup = "smallarchive"
fromStandardGroup FullArchiveGroup = "archive"
fromStandardGroup SourceGroup = "source"
fromStandardGroup ManualGroup = "manual"
fromStandardGroup PublicGroup = "public"
fromStandardGroup UnwantedGroup = "unwanted"

toStandardGroup :: Group -> Maybe StandardGroup
toStandardGroup "client" = Just ClientGroup
toStandardGroup "transfer" = Just TransferGroup
toStandardGroup "backup" = Just BackupGroup
toStandardGroup "incrementalbackup" = Just IncrementalBackupGroup
toStandardGroup "smallarchive" = Just SmallArchiveGroup
toStandardGroup "archive" = Just FullArchiveGroup
toStandardGroup "source" = Just SourceGroup
toStandardGroup "manual" = Just ManualGroup
toStandardGroup "public" = Just PublicGroup
toStandardGroup "unwanted" = Just UnwantedGroup
toStandardGroup _ = Nothing

descStandardGroup :: StandardGroup -> String
descStandardGroup ClientGroup = "client: a repository on your computer"
descStandardGroup TransferGroup = "transfer: distributes files to clients"
descStandardGroup BackupGroup = "full backup: backs up all files"
descStandardGroup IncrementalBackupGroup = "incremental backup: backs up files not backed up elsewhere"
descStandardGroup SmallArchiveGroup = "small archive: archives files located in \"archive\" directories"
descStandardGroup FullArchiveGroup = "full archive: archives all files not archived elsewhere"
descStandardGroup SourceGroup = "file source: moves files on to other repositories"
descStandardGroup ManualGroup = "manual mode: only stores files you manually choose"
descStandardGroup UnwantedGroup = "unwanted: remove content from this repository"
descStandardGroup PublicGroup = "public: publishes files located in an associated directory"

associatedDirectory :: Maybe RemoteConfig -> StandardGroup -> Maybe FilePath
associatedDirectory _ SmallArchiveGroup = Just "archive"
associatedDirectory _ FullArchiveGroup = Just "archive"
associatedDirectory (Just c) PublicGroup = Just $
	fromMaybe "public" $ M.lookup "preferreddir" c
associatedDirectory Nothing PublicGroup = Just "public"
associatedDirectory _ _ = Nothing

specialRemoteOnly :: StandardGroup -> Bool
specialRemoteOnly PublicGroup = True
specialRemoteOnly _ = False

{- See doc/preferred_content.mdwn for explanations of these expressions. -}
standardPreferredContent :: StandardGroup -> PreferredContentExpression
standardPreferredContent ClientGroup = lastResort $
	"((exclude=*/archive/* and exclude=archive/*) or (" ++ notArchived ++ ")) and not unused"
standardPreferredContent TransferGroup = lastResort $
	"not (inallgroup=client and copies=client:2) and (" ++ standardPreferredContent ClientGroup ++ ")"
standardPreferredContent BackupGroup = "include=* or unused"
standardPreferredContent IncrementalBackupGroup = lastResort
	"(include=* or unused) and (not copies=incrementalbackup:1)"
standardPreferredContent SmallArchiveGroup = lastResort $
	"(include=*/archive/* or include=archive/*) and (" ++ standardPreferredContent FullArchiveGroup ++ ")"
standardPreferredContent FullArchiveGroup = lastResort notArchived
standardPreferredContent SourceGroup = "not (copies=1)"
standardPreferredContent ManualGroup = "present and (" ++ standardPreferredContent ClientGroup ++ ")"
standardPreferredContent PublicGroup = "inpreferreddir"
standardPreferredContent UnwantedGroup = "exclude=*"

notArchived :: String
notArchived = "not (copies=archive:1 or copies=smallarchive:1)"

{- Most repositories want any content that is only on untrusted
 - or dead repositories, or that otherwise does not have enough copies.
 - Does not look at .gitattributes since that is quite a lot slower.
 -}
lastResort :: String -> PreferredContentExpression
lastResort s = "(" ++ s ++ ") or approxlackingcopies=1"


code:
{- Types for Storer and Retriever actions for remotes.
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE Rank2Types #-}

module Types.StoreRetrieve where

import Common.Annex
import Utility.Metered

import qualified Data.ByteString.Lazy as L

-- Prepares for and then runs an action that will act on a Key's
-- content, passing it a helper when the preparation is successful.
type Preparer helper = forall a. Key -> (Maybe helper -> Annex a) -> Annex a

-- A source of a Key's content.
data ContentSource
	= FileContent FilePath
	| ByteContent L.ByteString

isByteContent :: ContentSource -> Bool
isByteContent (ByteContent _) = True
isByteContent (FileContent _) = False

-- Action that stores a Key's content on a remote.
-- Can throw exceptions.
type Storer = Key -> ContentSource -> MeterUpdate -> Annex Bool

-- Action that retrieves a Key's content from a remote, passing it to a
-- callback.
-- Throws exception if key is not present, or remote is not accessible.
type Retriever = Key -> MeterUpdate -> (ContentSource -> Annex Bool) -> Annex Bool


code:
{- git-annex trust levels
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Types.TrustLevel (
	TrustLevel(..),
	TrustMap,
	readTrustLevel,
	showTrustLevel,
	prop_read_show_TrustLevel
) where

import qualified Data.Map as M

import Types.UUID

-- This order may seem backwards, but we generally want to list dead
-- remotes last and trusted ones first.
data TrustLevel = Trusted | SemiTrusted | UnTrusted | DeadTrusted
	deriving (Eq, Enum, Ord, Bounded)

type TrustMap = M.Map UUID TrustLevel

readTrustLevel :: String -> Maybe TrustLevel
readTrustLevel "trusted" = Just Trusted
readTrustLevel "untrusted" = Just UnTrusted
readTrustLevel "semitrusted" = Just SemiTrusted
readTrustLevel "dead" = Just DeadTrusted
readTrustLevel _ = Nothing

showTrustLevel :: TrustLevel -> String
showTrustLevel Trusted = "trusted"
showTrustLevel UnTrusted = "untrusted"
showTrustLevel SemiTrusted = "semitrusted"
showTrustLevel DeadTrusted = "dead"

prop_read_show_TrustLevel :: Bool
prop_read_show_TrustLevel = all check [minBound .. maxBound]
  where
	check l = readTrustLevel (showTrustLevel l) == Just l


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

module Types.UUID where

import qualified Data.Map as M
import qualified Data.UUID as U
import Data.Maybe

-- A UUID is either an arbitrary opaque string, or UUID info may be missing.
data UUID = NoUUID | UUID String
	deriving (Eq, Ord, Show, Read)

fromUUID :: UUID -> String
fromUUID (UUID u) = u
fromUUID NoUUID = ""

toUUID :: String -> UUID
toUUID [] = NoUUID
toUUID s = UUID s

isUUID :: String -> Bool
isUUID = isJust . U.fromString

type UUIDMap = M.Map UUID String


code:
{- types for metadata based branch views
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Types.View where

import Common.Annex
import Types.MetaData
import Utility.QuickCheck
import qualified Git

import qualified Data.Set as S

{- A view is a list of fields with filters on their allowed values,
 - which are applied to files in a parent git branch. -}
data View = View
	{ viewParentBranch :: Git.Branch
	, viewComponents :: [ViewComponent]
	}
	deriving (Eq, Read, Show)

instance Arbitrary View where
	arbitrary = View <$> pure (Git.Ref "master") <*> arbitrary

data ViewComponent = ViewComponent
	{ viewField :: MetaField
	, viewFilter :: ViewFilter
	, viewVisible :: Bool
	}
	deriving (Eq, Read, Show)

instance Arbitrary ViewComponent where
	arbitrary = ViewComponent <$> arbitrary <*> arbitrary <*> arbitrary

data ViewFilter
	= FilterValues (S.Set MetaValue)
	| FilterGlob String
	| ExcludeValues (S.Set MetaValue)
	deriving (Eq, Read, Show)

instance Arbitrary ViewFilter where
	arbitrary = do
		size <- arbitrarySizedBoundedIntegral `suchThat` (< 100)
		s <- S.fromList <$> vector size
		ifM arbitrary
			( return (FilterValues s)
			, return (ExcludeValues s)
			)

mkViewComponent :: MetaField -> ViewFilter -> ViewComponent
mkViewComponent f vf = ViewComponent f vf (multiValue vf)

{- Can a ViewFilter match multiple different MetaValues? -}
multiValue :: ViewFilter -> Bool
multiValue (FilterValues s) = S.size s > 1
multiValue (FilterGlob _) = True
multiValue (ExcludeValues _) = False


code:
{- git-annex upgrade support
 -
 - Copyright 2010, 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}

module Upgrade where

import Common.Annex
import Annex.Version
#ifndef mingw32_HOST_OS
import qualified Upgrade.V0
import qualified Upgrade.V1
#endif
import qualified Upgrade.V2
import qualified Upgrade.V3
import qualified Upgrade.V4

checkUpgrade :: Version -> Annex ()
checkUpgrade = maybe noop error <=< needsUpgrade

needsUpgrade :: Version -> Annex (Maybe String)
needsUpgrade v
	| v == supportedVersion = ok
	| v `elem` autoUpgradeableVersions = ifM (upgrade True)
		( ok
		, err "Automatic upgrade failed!"
		)
	| v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade"
	| otherwise = err "Upgrade git-annex."
  where
	err msg = return $ Just $ "Repository version " ++ v ++
		" is not supported. " ++ msg
	ok = return Nothing

upgrade :: Bool -> Annex Bool
upgrade automatic = do
	upgraded <- go =<< getVersion
	when upgraded $
		setVersion supportedVersion
	return upgraded
  where
#ifndef mingw32_HOST_OS
	go (Just "0") = Upgrade.V0.upgrade
	go (Just "1") = Upgrade.V1.upgrade
#else
	go (Just "0") = error "upgrade from v0 on Windows not supported"
	go (Just "1") = error "upgrade from v1 on Windows not supported"
#endif
	go (Just "2") = Upgrade.V2.upgrade
	go (Just "3") = Upgrade.V3.upgrade automatic
	go (Just "4") = Upgrade.V4.upgrade automatic
	go _ = return True


code:
{- git-annex v0 -> v1 upgrade support
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Upgrade.V0 where

import Common.Annex
import Annex.Content
import qualified Upgrade.V1

upgrade :: Annex Bool
upgrade = do
	showAction "v0 to v1"

	-- do the reorganisation of the key files
	olddir <- fromRepo gitAnnexDir
	keys <- getKeysPresent0 olddir
	forM_ keys $ \k -> moveAnnex k $ olddir </> keyFile0 k

	-- update the symlinks to the key files
	-- No longer needed here; V1.upgrade does the same thing

	-- Few people had v0 repos, so go the long way around from 0 -> 1 -> 2
	Upgrade.V1.upgrade

-- these stayed unchanged between v0 and v1
keyFile0 :: Key -> FilePath
keyFile0 = Upgrade.V1.keyFile1
fileKey0 :: FilePath -> Key
fileKey0 = Upgrade.V1.fileKey1
lookupFile0 :: FilePath -> Annex (Maybe (Key, Backend))
lookupFile0 = Upgrade.V1.lookupFile1

getKeysPresent0 :: FilePath -> Annex [Key]
getKeysPresent0 dir = ifM (liftIO $ doesDirectoryExist dir)
	( liftIO $ map fileKey0
		<$> (filterM present =<< getDirectoryContents dir)
	, return []
	)
  where
	present d = do
		result <- tryIO $
			getFileStatus $ dir ++ "/" ++ takeFileName d
		case result of
			Right s -> return $ isRegularFile s
			Left _ -> return False


code:
{- git-annex v1 -> v2 upgrade support
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Upgrade.V1 where

import System.Posix.Types
import Data.Char

import Common.Annex
import Types.Key
import Annex.Content
import Logs.Presence
import qualified Annex.Queue
import qualified Git
import qualified Git.LsFiles as LsFiles
import Backend
import Annex.Version
import Utility.FileMode
import Utility.Tmp
import qualified Upgrade.V2

-- v2 adds hashing of filenames of content and location log files.
-- Key information is encoded in filenames differently, so
-- both content and location log files move around, and symlinks
-- to content need to be changed.
--
-- When upgrading a v1 key to v2, file size metadata ought to be
-- added to the key (unless it is a WORM key, which encoded
-- mtime:size in v1). This can only be done when the file content
-- is present. Since upgrades need to happen consistently,
-- (so that two repos get changed the same way by the upgrade, and
-- will merge), that metadata cannot be added on upgrade.
--
-- Note that file size metadata
-- will only be used for detecting situations where git-annex
-- would run out of disk space, so if some keys don't have it,
-- the impact is minor. At least initially. It could be used in the
-- future by smart auto-repo balancing code, etc.
--
-- Anyway, since v2 plans ahead for other metadata being included
-- in keys, there should probably be a way to update a key.
-- Something similar to the migrate subcommand could be used,
-- and users could then run that at their leisure.

upgrade :: Annex Bool
upgrade = do
	showAction "v1 to v2"

	ifM (fromRepo Git.repoIsLocalBare)
		( do
			moveContent
			setVersion supportedVersion
		, do
			moveContent
			updateSymlinks
			moveLocationLogs

			Annex.Queue.flush
			setVersion supportedVersion
		)

	Upgrade.V2.upgrade

moveContent :: Annex ()
moveContent = do
	showAction "moving content"
	files <- getKeyFilesPresent1
	forM_ files move
  where
	move f = do
		let k = fileKey1 (takeFileName f)
		let d = parentDir f
		liftIO $ allowWrite d
		liftIO $ allowWrite f
		moveAnnex k f
		liftIO $ removeDirectory d

updateSymlinks :: Annex ()
updateSymlinks = do
	showAction "updating symlinks"
	top <- fromRepo Git.repoPath
	(files, cleanup) <- inRepo $ LsFiles.inRepo [top]
	forM_ files fixlink
	void $ liftIO cleanup
  where
	fixlink f = do
		r <- lookupFile1 f
		case r of
			Nothing -> noop
			Just (k, _) -> do
				link <- inRepo $ gitAnnexLink f k
				liftIO $ removeFile f
				liftIO $ createSymbolicLink link f
				Annex.Queue.addCommand "add" [Param "--"] [f]

moveLocationLogs :: Annex ()
moveLocationLogs = do
	showAction "moving location logs"
	logkeys <- oldlocationlogs
	forM_ logkeys move
  where
	oldlocationlogs = do
		dir <- fromRepo Upgrade.V2.gitStateDir
		ifM (liftIO $ doesDirectoryExist dir)
			( mapMaybe oldlog2key
				<$> liftIO (getDirectoryContents dir)
			, return []
			)
	move (l, k) = do
		dest <- fromRepo $ logFile2 k
		dir <- fromRepo Upgrade.V2.gitStateDir
		let f = dir </> l
		liftIO $ createDirectoryIfMissing True (parentDir dest)
		-- could just git mv, but this way deals with
		-- log files that are not checked into git,
		-- as well as merging with already upgraded
		-- logs that have been pulled from elsewhere
		old <- liftIO $ readLog1 f
		new <- liftIO $ readLog1 dest
		liftIO $ writeLog1 dest (old++new)
		Annex.Queue.addCommand "add" [Param "--"] [dest]
		Annex.Queue.addCommand "add" [Param "--"] [f]
		Annex.Queue.addCommand "rm" [Param "--quiet", Param "-f", Param "--"] [f]

oldlog2key :: FilePath -> Maybe (FilePath, Key)
oldlog2key l
	| drop len l == ".log" && sane = Just (l, k)
	| otherwise = Nothing
  where
	len = length l - 4
	k = readKey1 (take len l)
	sane = (not . null $ keyName k) && (not . null $ keyBackendName k)

-- WORM backend keys: "WORM:mtime:size:filename"
-- all the rest: "backend:key"
--
-- If the file looks like "WORM:XXX-...", then it was created by mixing
-- v2 and v1; that infelicity is worked around by treating the value
-- as the v2 key that it is.
readKey1 :: String -> Key
readKey1 v
	| mixup = fromJust $ file2key $ intercalate ":" $ Prelude.tail bits
	| otherwise = stubKey
		{ keyName = n
		, keyBackendName = b
		, keySize = s
		, keyMtime = t
		}
  where
	bits = split ":" v
	b = Prelude.head bits
	n = intercalate ":" $ drop (if wormy then 3 else 1) bits
	t = if wormy
		then Just (Prelude.read (bits !! 1) :: EpochTime)
		else Nothing
	s = if wormy
		then Just (Prelude.read (bits !! 2) :: Integer)
		else Nothing
	wormy = Prelude.head bits == "WORM"
	mixup = wormy && isUpper (Prelude.head $ bits !! 1)

showKey1 :: Key -> String
showKey1 Key { keyName = n , keyBackendName = b, keySize = s, keyMtime = t } =
	intercalate ":" $ filter (not . null) [b, showifhere t, showifhere s, n]
  where
	showifhere Nothing = ""
	showifhere (Just v) = show v

keyFile1 :: Key -> FilePath
keyFile1 key = replace "/" "%" $ replace "%" "&s" $ replace "&" "&a"  $ showKey1 key

fileKey1 :: FilePath -> Key
fileKey1 file = readKey1 $
	replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file

writeLog1 :: FilePath -> [LogLine] -> IO ()
writeLog1 file ls = viaTmp writeFile file (showLog ls)

readLog1 :: FilePath -> IO [LogLine]
readLog1 file = catchDefaultIO [] $
	parseLog <$> readFileStrict file

lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend))
lookupFile1 file = do
	tl <- liftIO $ tryIO getsymlink
	case tl of
		Left _ -> return Nothing
		Right l -> makekey l
  where
	getsymlink = takeFileName <$> readSymbolicLink file
	makekey l = case maybeLookupBackendName bname of
		Nothing -> do
			unless (null kname || null bname ||
			        not (isLinkToAnnex l)) $
				warning skip
			return Nothing
		Just backend -> return $ Just (k, backend)
	  where
		k = fileKey1 l
		bname = keyBackendName k
		kname = keyName k
		skip = "skipping " ++ file ++
			" (unknown backend " ++ bname ++ ")"

getKeyFilesPresent1 :: Annex [FilePath]
getKeyFilesPresent1  = getKeyFilesPresent1' =<< fromRepo gitAnnexObjectDir
getKeyFilesPresent1' :: FilePath -> Annex [FilePath]
getKeyFilesPresent1' dir =
	ifM (liftIO $ doesDirectoryExist dir)
		(  do
			dirs <- liftIO $ getDirectoryContents dir
			let files = map (\d -> dir ++ "/" ++ d ++ "/" ++ takeFileName d) dirs
			liftIO $ filterM present files
		, return []
		)
  where
	present f = do
		result <- tryIO $ getFileStatus f
		case result of
			Right s -> return $ isRegularFile s
			Left _ -> return False

logFile1 :: Git.Repo -> Key -> String
logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log"

logFile2 :: Key -> Git.Repo -> String
logFile2 = logFile' hashDirLower

logFile' :: (Key -> FilePath) -> Key -> Git.Repo -> String
logFile' hasher key repo =
	gitStateDir repo ++ hasher key ++ keyFile key ++ ".log"

stateDir :: FilePath
stateDir = addTrailingPathSeparator ".git-annex"

gitStateDir :: Git.Repo -> FilePath
gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo </> stateDir


code:
{- git-annex v2 -> v3 upgrade support
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Upgrade.V2 where

import Common.Annex
import qualified Git
import qualified Git.Command
import qualified Git.Ref
import qualified Annex.Branch
import Annex.Content
import Utility.Tmp
import Logs

olddir :: Git.Repo -> FilePath
olddir g
	| Git.repoIsLocalBare g = ""
	| otherwise = ".git-annex"

{- .git-annex/ moved to a git-annex branch.
 -
 - Strategy:
 -
 - * Create the git-annex branch.
 - * Find each location log file in .git-annex/, and inject its content
 -   into the git-annex branch, unioning with any content already in
 -   there. (in passing, this deals with the semi transition that left
 -   some location logs hashed two different ways; both are found and
 -   merged).
 - * Also inject remote.log, trust.log, and uuid.log.
 - * git rm -rf .git-annex
 - * Remove stuff that used to be needed in .gitattributes.
 - * Commit changes.
 -}
upgrade :: Annex Bool
upgrade = do
	showAction "v2 to v3"
	bare <- fromRepo Git.repoIsLocalBare
	old <- fromRepo olddir

	Annex.Branch.create
	showProgress

	e <- liftIO $ doesDirectoryExist old
	when e $ do
		mapM_ (\(k, f) -> inject f $ locationLogFile k) =<< locationLogs
		mapM_ (\f -> inject f f) =<< logFiles old

	saveState False
	showProgress

	when e $ do
		inRepo $ Git.Command.run [Param "rm", Param "-r", Param "-f", Param "-q", File old]
		unless bare $ inRepo gitAttributesUnWrite
	showProgress

	unless bare push

	return True

locationLogs :: Annex [(Key, FilePath)]
locationLogs = do
	dir <- fromRepo gitStateDir
	liftIO $ do
		levela <- dirContents dir
		levelb <- mapM tryDirContents levela
		files <- mapM tryDirContents (concat levelb)
		return $ mapMaybe islogfile (concat files)
  where
	tryDirContents d = catchDefaultIO [] $ dirContents d
	islogfile f = maybe Nothing (\k -> Just (k, f)) $
			locationLogFileKey f

inject :: FilePath -> FilePath -> Annex ()
inject source dest = do
	old <- fromRepo olddir
	new <- liftIO (readFile $ old </> source)
	Annex.Branch.change dest $ \prev ->
		unlines $ nub $ lines prev ++ lines new

logFiles :: FilePath -> Annex [FilePath]
logFiles dir = return . filter (".log" `isSuffixOf`)
		<=< liftIO $ getDirectoryContents dir

push :: Annex ()
push = do
	origin_master <- inRepo $ Git.Ref.exists $ Git.Ref "origin/master"
	origin_gitannex <- Annex.Branch.hasOrigin
	case (origin_master, origin_gitannex) of
		(_, True) -> do
			-- Merge in the origin's git-annex branch,
			-- so that pushing the git-annex branch
			-- will immediately work. Not pushed here,
			-- because it's less obnoxious to let the user
			-- push.
			Annex.Branch.update
		(True, False) -> do
			-- push git-annex to origin, so that
			-- "git push" will from then on
			-- automatically push it
			Annex.Branch.update -- just in case
			showAction "pushing new git-annex branch to origin"
			showOutput
			inRepo $ Git.Command.run
				[ Param "push"
				, Param "origin"
				, Param $ Git.fromRef Annex.Branch.name
				]
		_ -> do
			-- no origin exists, so just let the user
			-- know about the new branch
			Annex.Branch.update
			showLongNote $
				"git-annex branch created\n" ++
				"Be sure to push this branch when pushing to remotes.\n"

{- Old .gitattributes contents, not needed anymore. -}
attrLines :: [String]
attrLines =
	[ stateDir </> "*.log merge=union"
	, stateDir </> "*/*/*.log merge=union"
	]

gitAttributesUnWrite :: Git.Repo -> IO ()
gitAttributesUnWrite repo = do
	let attributes = Git.attributes repo
	whenM (doesFileExist attributes) $ do
		c <- readFileStrict attributes
		liftIO $ viaTmp writeFile attributes $ unlines $
			filter (`notElem` attrLines) $ lines c
		Git.Command.run [Param "add", File attributes] repo

stateDir :: FilePath
stateDir = addTrailingPathSeparator ".git-annex"
gitStateDir :: Git.Repo -> FilePath
gitStateDir repo = addTrailingPathSeparator $ Git.repoPath repo </> stateDir


code:
{- git-annex v3 -> v4 uppgrade support
 -
 - There was no explicit v3 to v4 upgrade, so run v5 upgrade code.
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Upgrade.V3 (upgrade) where

import Upgrade.V4 (upgrade)


code:
{- git-annex v4 -> v5 uppgrade support
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Upgrade.V4 where

import Common.Annex
import Config
import Annex.Direct

{- Direct mode only upgrade. v4 to v5 indirect update is a no-op -}
upgrade :: Bool -> Annex Bool
upgrade automatic = ifM isDirect
	( do
		unless automatic $
			showAction "v4 to v5"
		setDirect True
		return True
	, return True
	)


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

module Utility.Applicative where

{- Like <$> , but supports one level of currying.
 -
 - foo v = bar <$> action v  ==  foo = bar <$$> action
 -}
(<$$>) :: Functor f => (a -> b) -> (c -> f a) -> c -> f b
f <$$> v = fmap f . v
infixr 4 <$$>


code:
{- Simple Base64 access
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.Base64 (toB64, fromB64Maybe, fromB64) where

import "dataenc" Codec.Binary.Base64
import Data.Bits.Utils
import Control.Applicative
import Data.Maybe

toB64 :: String -> String
toB64 = encode . s2w8

fromB64Maybe :: String -> Maybe String
fromB64Maybe s = w82s <$> decode s

fromB64 :: String -> String
fromB64 = fromMaybe bad . fromB64Maybe
  where
	bad = error "bad base64 encoded data"


code:
{- Running a long or expensive batch operation niced.
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.Batch where

import Common

#if defined(linux_HOST_OS) || defined(__ANDROID__)
import Control.Concurrent.Async
import System.Posix.Process
#endif
import qualified Control.Exception as E

{- Runs an operation, at batch priority.
 -
 - This is done by running it in a bound thread, which on Linux can be set
 - to have a different nice level than the rest of the program. Note that
 - due to running in a bound thread, some operations may be more expensive
 - to perform. Also note that if the action calls forkIO or forkOS itself,
 - that will make a new thread that does not have the batch priority.
 -
 - POSIX threads do not support separate nice levels, so on other operating
 - systems, the action is simply ran.
 -}
batch :: IO a -> IO a
#if defined(linux_HOST_OS) || defined(__ANDROID__)
batch a = wait =<< batchthread
  where
  	batchthread = asyncBound $ do
		setProcessPriority 0 maxNice
		a
#else
batch a = a
#endif

maxNice :: Int
maxNice = 19

{- Makes a command be run by whichever of nice, ionice, and nocache
 - are available in the path. -}
type BatchCommandMaker = (String, [CommandParam]) -> (String, [CommandParam])

getBatchCommandMaker :: IO BatchCommandMaker
getBatchCommandMaker = do
#ifndef mingw32_HOST_OS
	nicers <- filterM (inPath . fst)
		[ ("nice", [])
#ifndef __ANDROID__
		-- Android's ionice does not allow specifying a command,
		-- so don't use it.
		, ("ionice", ["-c3"])
#endif
		, ("nocache", [])
		]
	return $ \(command, params) ->
		case nicers of
			[] -> (command, params)
			(first:rest) -> (fst first, map Param (snd first ++ concatMap (\p -> fst p : snd p) rest ++ [command]) ++ params)
#else
	return id
#endif

toBatchCommand :: (String, [CommandParam]) -> IO (String, [CommandParam])
toBatchCommand v = do
	batchmaker <- getBatchCommandMaker
	return $ batchmaker v

{- Runs a command in a way that's suitable for batch jobs that can be
 - interrupted.
 -
 - If the calling thread receives an async exception, it sends the
 - command a SIGTERM, and after the command finishes shuttting down,
 - it re-raises the async exception. -}
batchCommand :: String -> [CommandParam] -> IO Bool
batchCommand command params = batchCommandEnv command params Nothing

batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
batchCommandEnv command params environ = do
	batchmaker <- getBatchCommandMaker
	let (command', params') = batchmaker (command, params)
	let p = proc command' $ toCommand params'
	(_, _, _, pid) <- createProcess $ p { env = environ }
	r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode)
	case r of
		Right ExitSuccess -> return True
		Right _ -> return False
		Left asyncexception -> do
			terminateProcess pid
			void $ waitForProcess pid
			E.throwIO asyncexception


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

{-# LANGUAGE CPP #-}

module Utility.Bloom (
	Bloom,
	suggestSizing,
	Hashable,
	cheapHashes,
	notElemB,

	newMB,
	insertMB,
	unsafeFreezeMB,
) where

#if MIN_VERSION_bloomfilter(2,0,0)
import qualified Data.BloomFilter.Mutable as MBloom
import qualified Data.BloomFilter as Bloom
#else
import qualified Data.BloomFilter as Bloom
#endif
import Data.BloomFilter.Easy (suggestSizing, Bloom)
import Data.BloomFilter.Hash (Hashable, cheapHashes)
import Control.Monad.ST.Safe (ST)

#if MIN_VERSION_bloomfilter(2,0,0)

notElemB :: a -> Bloom a -> Bool
notElemB = Bloom.notElem

newMB :: (a -> [Bloom.Hash]) -> Int -> ST s (MBloom.MBloom s a)
newMB = MBloom.new

insertMB :: MBloom.MBloom s a -> a -> ST s ()
insertMB = MBloom.insert

unsafeFreezeMB :: MBloom.MBloom s a -> ST s (Bloom a)
unsafeFreezeMB = Bloom.unsafeFreeze

#else

notElemB :: a -> Bloom a -> Bool
notElemB = Bloom.notElemB

newMB :: (a -> [Bloom.Hash]) -> Int -> ST s (Bloom.MBloom s a)
newMB = Bloom.newMB

insertMB :: Bloom.MBloom s a -> a -> ST s ()
insertMB = Bloom.insertMB

unsafeFreezeMB :: Bloom.MBloom s a -> ST s (Bloom a)
unsafeFreezeMB = Bloom.unsafeFreezeMB

#endif


code:
{- Interface for running a shell command as a coprocess,
 - sending it queries and getting back results.
 -
 - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.CoProcess (
	CoProcessHandle,
	start,
	stop,
	query,
	rawMode
) where

import Common

import Control.Concurrent.MVar

type CoProcessHandle = MVar CoProcessState

data CoProcessState = CoProcessState
	{ coProcessPid :: ProcessHandle
	, coProcessTo :: Handle
	, coProcessFrom :: Handle
	, coProcessSpec :: CoProcessSpec
	}

data CoProcessSpec = CoProcessSpec
	{ coProcessNumRestarts :: Int
	, coProcessCmd :: FilePath
	, coProcessParams :: [String]
	, coProcessEnv :: Maybe [(String, String)]
	}

start :: Int -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle
start numrestarts cmd params environ = do
	s <- start' $ CoProcessSpec numrestarts cmd params environ
	newMVar s

start' :: CoProcessSpec -> IO CoProcessState
start' s = do
	(pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (coProcessEnv s)
	return $ CoProcessState pid to from s

stop :: CoProcessHandle -> IO ()
stop ch = do
	s <- readMVar ch
	hClose $ coProcessTo s
	hClose $ coProcessFrom s
	let p = proc (coProcessCmd $ coProcessSpec s) (coProcessParams $ coProcessSpec s)
	forceSuccessProcess p (coProcessPid s)

{- To handle a restartable process, any IO exception thrown by the send and
 - receive actions are assumed to mean communication with the process
 - failed, and the failed action is re-run with a new process. -}
query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b
query ch send receive = do
	s <- readMVar ch
	restartable s (send $ coProcessTo s) $ const $
		restartable s (hFlush $ coProcessTo s) $ const $
			restartable s (receive $ coProcessFrom s)
				return
  where
  	restartable s a cont
		| coProcessNumRestarts (coProcessSpec s) > 0 =
			maybe restart cont =<< catchMaybeIO a
		| otherwise = cont =<< a
	restart = do
		s <- takeMVar ch
		void $ catchMaybeIO $ do
			hClose $ coProcessTo s
			hClose $ coProcessFrom s
		void $ waitForProcess $ coProcessPid s
		s' <- start' $ (coProcessSpec s)
			{ coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 }
		putMVar ch s'
		query ch send receive

rawMode :: CoProcessHandle -> IO CoProcessHandle
rawMode ch = do
	s <- readMVar ch
	raw $ coProcessFrom s
	raw $ coProcessTo s
	return ch
  where
  	raw h = do
		fileEncoding h
#ifdef mingw32_HOST_OS
		hSetNewlineMode h noNewlineTranslation
#endif


code:
{- file copying
 -
 - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.CopyFile (
	copyFileExternal,
	createLinkOrCopy
) where

import Common
import qualified Build.SysConfig as SysConfig

{- The cp command is used, because I hate reinventing the wheel,
 - and because this allows easy access to features like cp --reflink. -}
copyFileExternal :: FilePath -> FilePath -> IO Bool
copyFileExternal src dest = do
	whenM (doesFileExist dest) $
		removeFile dest
	boolSystem "cp" $ params ++ [File src, File dest]
  where
#ifndef __ANDROID__
	params = map snd $ filter fst
		[ (SysConfig.cp_reflink_auto, Param "--reflink=auto")
		, (SysConfig.cp_a, Param "-a")
		, (SysConfig.cp_p && not SysConfig.cp_a, Param "-p")
		]
#else
	params = []
#endif

{- Create a hard link if the filesystem allows it, and fall back to copying
 - the file. -}
createLinkOrCopy :: FilePath -> FilePath -> IO Bool
#ifndef mingw32_HOST_OS
createLinkOrCopy src dest = go `catchIO` const fallback
  where
  	go = do
		createLink src dest
		return True
  	fallback = copyFileExternal src dest
#else
createLinkOrCopy = copyFileExternal
#endif


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

{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}

module Utility.DBus where

import Utility.PartialPrelude
import Utility.Exception

import DBus.Client
import DBus
import Data.Maybe
import Control.Concurrent
import Control.Exception as E

type ServiceName = String

listServiceNames :: Client -> IO [ServiceName]
listServiceNames client = do
	reply <- callDBus client "ListNames" []
	return $ fromMaybe [] $ fromVariant =<< headMaybe (methodReturnBody reply)

callDBus :: Client -> MemberName -> [Variant] -> IO MethodReturn
callDBus client name params = call_ client $
	(methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" name)
		{ methodCallDestination = Just "org.freedesktop.DBus"
		, methodCallBody = params
		}

{- Connects to the bus, and runs the client action.
 -
 - Throws a ClientError, and closes the connection if it fails to
 - process an incoming message, or if the connection is lost.
 - Unlike DBus's usual interface, this error is thrown at the top level,
 - rather than inside the clientThreadRunner, so it can be caught, and
 - runClient re-run as needed. -}
runClient :: IO (Maybe Address) -> (Client -> IO ()) -> IO ()
runClient getaddr clientaction = do
	env <- getaddr
	case env of
		Nothing -> throwIO (clientError "runClient: unable to determine DBUS address")
		Just addr -> do
			{- The clientaction will set up listeners, which
			 - run in a different thread. We block while
			 - they're running, until our threadrunner catches
			 - a ClientError, which it will put into the MVar
			 - to be rethrown here. -}
			mv <- newEmptyMVar
			let tr = threadrunner (putMVar mv)
			let opts = defaultClientOptions { clientThreadRunner = tr }
			client <- connectWith opts addr
			clientaction client
			e <- takeMVar mv
			disconnect client
			throw e
  where
	threadrunner storeerr io = loop
	  where
		loop = catchClientError (io >> loop) storeerr

{- Connects to the bus, and runs the client action.
 -
 - If the connection is lost, runs onretry, which can do something like
 - a delay, or printing a warning, and has a state value (useful for
 - exponential backoff). Once onretry returns, the connection is retried.
 -}
persistentClient :: IO (Maybe Address) -> v -> (SomeException -> v -> IO v) -> (Client -> IO ()) -> IO ()
persistentClient getaddr v onretry clientaction =
	{- runClient can fail with not just ClientError, but also other
	 - things, if dbus is not running. Let async exceptions through. -}
	runClient getaddr clientaction `catchNonAsync` retry
  where
	retry e = do
		v' <- onretry e v
		persistentClient getaddr v' onretry clientaction

{- Catches only ClientError -}
catchClientError :: IO () -> (ClientError -> IO ()) -> IO ()
catchClientError io handler =
	either handler return =<< (E.try io :: IO (Either ClientError ()))


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

{-# LANGUAGE CPP #-}

module Utility.Daemon where

import Common
import Utility.PID
#ifndef mingw32_HOST_OS
import Utility.LogFile
#else
import Utility.WinProcess
import Utility.WinLock
#endif

#ifndef mingw32_HOST_OS
import System.Posix
import Control.Concurrent.Async
#else
import System.Exit
#endif

#ifndef mingw32_HOST_OS
{- Run an action as a daemon, with all output sent to a file descriptor.
 -
 - Can write its pid to a file, to guard against multiple instances
 - running and allow easy termination.
 -
 - When successful, does not return. -}
daemonize :: Fd -> Maybe FilePath -> Bool -> IO () -> IO ()
daemonize logfd pidfile changedirectory a = do
	maybe noop checkalreadyrunning pidfile
	_ <- forkProcess child1
	out
  where
	checkalreadyrunning f = maybe noop (const alreadyRunning)
		=<< checkDaemon f
	child1 = do
		_ <- tryIO createSession
		_ <- forkProcess child2
		out
	child2 = do
		maybe noop lockPidFile pidfile
		when changedirectory $
			setCurrentDirectory "/"
		nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
		redir nullfd stdInput
		redirLog logfd
		{- In old versions of ghc, forkProcess masks async exceptions;
		 - unmask them inside the action. -}
		wait =<< asyncWithUnmask (\unmask -> unmask a)
		out
	out = exitImmediately ExitSuccess
#endif

{- To run an action that is normally daemonized in the forground. -}
#ifndef mingw32_HOST_OS
foreground :: Fd -> Maybe FilePath -> IO () -> IO ()
foreground logfd pidfile a = do
#else
foreground :: Maybe FilePath -> IO () -> IO ()
foreground pidfile a = do
#endif
	maybe noop lockPidFile pidfile
#ifndef mingw32_HOST_OS
	_ <- tryIO createSession
	redirLog logfd
#endif
	a
#ifndef mingw32_HOST_OS
	exitImmediately ExitSuccess
#else
	exitWith ExitSuccess
#endif

{- Locks the pid file, with an exclusive, non-blocking lock,
 - and leaves it locked on return.
 -
 - Writes the pid to the file, fully atomically.
 - Fails if the pid file is already locked by another process. -}
lockPidFile :: FilePath -> IO ()
lockPidFile pidfile = do
	createDirectoryIfMissing True (parentDir pidfile)
#ifndef mingw32_HOST_OS
	fd <- openFd pidfile ReadWrite (Just stdFileMode) defaultFileFlags
	locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
	fd' <- openFd newfile ReadWrite (Just stdFileMode) defaultFileFlags
		{ trunc = True }
	locked' <- catchMaybeIO $ setLock fd' (WriteLock, AbsoluteSeek, 0, 0)
	case (locked, locked') of
		(Nothing, _) -> alreadyRunning
		(_, Nothing) -> alreadyRunning
		_ -> do
			_ <- fdWrite fd' =<< show <$> getPID
			closeFd fd
	rename newfile pidfile
  where
	newfile = pidfile ++ ".new"
#else
	{- Not atomic on Windows, oh well. -}
	unlessM (isNothing <$> checkDaemon pidfile)
		alreadyRunning
	pid <- getPID
	writeFile pidfile (show pid)
	lckfile <- winLockFile pid pidfile
	writeFile lckfile ""
	void $ lockExclusive lckfile
#endif

alreadyRunning :: IO ()
alreadyRunning = error "Daemon is already running."

{- Checks if the daemon is running, by checking that the pid file
 - is locked by the same process that is listed in the pid file.
 -
 - If it's running, returns its pid. -}
checkDaemon :: FilePath -> IO (Maybe PID)
#ifndef mingw32_HOST_OS
checkDaemon pidfile = do
	v <- catchMaybeIO $
		openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags
	case v of
		Just fd -> do
			locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0)
			p <- readish <$> readFile pidfile
			closeFd fd `after` return (check locked p)
		Nothing -> return Nothing
  where
	check Nothing _ = Nothing
	check _ Nothing = Nothing
	check (Just (pid, _)) (Just pid')
		| pid == pid' = Just pid
		| otherwise = error $
			"stale pid in " ++ pidfile ++
			" (got " ++ show pid' ++
			"; expected " ++ show pid ++ " )"
#else
checkDaemon pidfile = maybe (return Nothing) (check . readish)
	=<< catchMaybeIO (readFile pidfile)
  where
	check Nothing = return Nothing
	check (Just pid) = do
		v <- lockShared =<< winLockFile pid pidfile
		case v of
			Just h -> do
				dropLock h
				return Nothing
			Nothing -> return (Just pid)
#endif

{- Stops the daemon, safely. -}
stopDaemon :: FilePath -> IO ()
stopDaemon pidfile = go =<< checkDaemon pidfile
  where
	go Nothing = noop
	go (Just pid) =
#ifndef mingw32_HOST_OS
		signalProcess sigTERM pid
#else
		terminatePID pid
#endif

{- Windows locks a lock file that corresponds with the pid of the process.
 - This allows changing the process in the pid file and taking a new lock
 - when eg, restarting the daemon.
 -}
#ifdef mingw32_HOST_OS
winLockFile :: PID -> FilePath -> IO FilePath
winLockFile pid pidfile = do
	cleanstale
	return $ prefix ++ show pid ++ suffix
  where
  	prefix = pidfile ++ "."
	suffix = ".lck"
	cleanstale = mapM_ (void . tryIO . removeFile) =<<
		(filter iswinlockfile <$> dirContents (parentDir pidfile))
	iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f
#endif


code:
{- utilities for simple data types
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.Data where

{- First item in the list that is not Nothing. -}
firstJust :: Eq a => [Maybe a] -> Maybe a
firstJust ms = case dropWhile (== Nothing) ms of
	[] -> Nothing
	(md:_) -> md

eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe = either (const Nothing) Just


code:
{- data size display and parsing
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -
 -
 - And now a rant:
 -
 - In the beginning, we had powers of two, and they were good.
 -
 - Disk drive manufacturers noticed that some powers of two were
 - sorta close to some powers of ten, and that rounding down to the nearest
 - power of ten allowed them to advertise their drives were bigger. This
 - was sorta annoying.
 -
 - Then drives got big. Really, really big. This was good.
 -
 - Except that the small rounding error perpretrated by the drive
 - manufacturers suffered the fate of a small error, and became a large
 - error. This was bad.
 -
 - So, a committee was formed. And it arrived at a committee-like decision,
 - which satisfied noone, confused everyone, and made the world an uglier
 - place. As with all committees, this was meh.
 -
 - And the drive manufacturers happily continued selling drives that are
 - increasingly smaller than you'd expect, if you don't count on your
 - fingers. But that are increasingly too big for anyone to much notice.
 - This caused me to need git-annex.
 -
 - Thus, I use units here that I loathe. Because if I didn't, people would
 - be confused that their drives seem the wrong size, and other people would
 - complain at me for not being standards compliant. And we call this
 - progress?
 -}

module Utility.DataUnits (
	dataUnits,
	storageUnits,
	memoryUnits,
	bandwidthUnits,
	oldSchoolUnits,

	roughSize,
	compareSizes,
	readSize
) where

import Data.List
import Data.Char

import Utility.HumanNumber

type ByteSize = Integer
type Name = String
type Abbrev = String
data Unit = Unit ByteSize Abbrev Name
	deriving (Ord, Show, Eq)

dataUnits :: [Unit]
dataUnits = storageUnits ++ memoryUnits

{- Storage units are (stupidly) powers of ten. -}
storageUnits :: [Unit]
storageUnits =
	[ Unit (p 8) "YB" "yottabyte"
	, Unit (p 7) "ZB" "zettabyte"
	, Unit (p 6) "EB" "exabyte"
	, Unit (p 5) "PB" "petabyte"
	, Unit (p 4) "TB" "terabyte"
	, Unit (p 3) "GB" "gigabyte"
	, Unit (p 2) "MB" "megabyte"
	, Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe
	, Unit (p 0) "B" "byte"
	]
  where
	p :: Integer -> Integer
	p n = 1000^n

{- Memory units are (stupidly named) powers of 2. -}
memoryUnits :: [Unit]
memoryUnits =
	[ Unit (p 8) "YiB" "yobibyte"
	, Unit (p 7) "ZiB" "zebibyte"
	, Unit (p 6) "EiB" "exbibyte"
	, Unit (p 5) "PiB" "pebibyte"
	, Unit (p 4) "TiB" "tebibyte"
	, Unit (p 3) "GiB" "gibibyte"
	, Unit (p 2) "MiB" "mebibyte"
	, Unit (p 1) "KiB" "kibibyte"
	, Unit (p 0) "B" "byte"
	]
  where
	p :: Integer -> Integer
	p n = 2^(n*10)

{- Bandwidth units are only measured in bits if you're some crazy telco. -}
bandwidthUnits :: [Unit]
bandwidthUnits = error "stop trying to rip people off"

{- Do you yearn for the days when men were men and megabytes were megabytes? -}
oldSchoolUnits :: [Unit]
oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits
  where
	mingle (Unit _ a n, Unit s' _ _) = Unit s' a n

{- approximate display of a particular number of bytes -}
roughSize :: [Unit] -> Bool -> ByteSize -> String
roughSize units short i
	| i < 0 = '-' : findUnit units' (negate i)
	| otherwise = findUnit units' i
  where
	units' = sortBy (flip compare) units -- largest first

	findUnit (u@(Unit s _ _):us) i'
		| i' >= s = showUnit i' u
		| otherwise = findUnit us i'
	findUnit [] i' = showUnit i' (last units') -- bytes

	showUnit x (Unit size abbrev name) = s ++ " " ++ unit
	  where
	  	v = (fromInteger x :: Double) / fromInteger size
		s = showImprecise 2 v
		unit
			| short = abbrev
			| s == "1" = name
			| otherwise = name ++ "s"

{- displays comparison of two sizes -}
compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String
compareSizes units abbrev old new
	| old > new = roughSize units abbrev (old - new) ++ " smaller"
	| old < new = roughSize units abbrev (new - old) ++ " larger"
	| otherwise = "same"

{- Parses strings like "10 kilobytes" or "0.5tb". -}
readSize :: [Unit] -> String -> Maybe ByteSize
readSize units input
	| null parsednum || null parsedunit = Nothing
	| otherwise = Just $ round $ number * fromIntegral multiplier
  where
	(number, rest) = head parsednum
	multiplier = head parsedunit
	unitname = takeWhile isAlpha $ dropWhile isSpace rest

	parsednum = reads input :: [(Double, String)]
	parsedunit = lookupUnit units unitname

	lookupUnit _ [] = [1] -- no unit given, assume bytes
	lookupUnit [] _ = []
	lookupUnit (Unit s a n:us) v
		| a ~~ v || n ~~ v = [s]
		| plural n ~~ v || a ~~ byteabbrev v = [s]
		| otherwise = lookupUnit us v

	a ~~ b = map toLower a == map toLower b

	plural n = n ++ "s"
	byteabbrev a = a ++ "b"


code:
{- generic directory watching interface
 -
 - Uses inotify, or kqueue, or fsevents, or win32-notify to watch a directory
 - (and subdirectories) for changes, and runs hooks for different
 - sorts of events as they occur.
 -
 - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.DirWatcher where

import Utility.DirWatcher.Types

#if WITH_INOTIFY
import qualified Utility.DirWatcher.INotify as INotify
import qualified System.INotify as INotify
#endif
#if WITH_KQUEUE
import qualified Utility.DirWatcher.Kqueue as Kqueue
import Control.Concurrent
#endif
#if WITH_FSEVENTS
import qualified Utility.DirWatcher.FSEvents as FSEvents
import qualified System.OSX.FSEvents as FSEvents
#endif
#if WITH_WIN32NOTIFY
import qualified Utility.DirWatcher.Win32Notify as Win32Notify
import qualified System.Win32.Notify as Win32Notify
#endif

type Pruner = FilePath -> Bool

canWatch :: Bool
#if (WITH_INOTIFY || WITH_KQUEUE || WITH_FSEVENTS || WITH_WIN32NOTIFY)
canWatch = True
#else
#if defined linux_HOST_OS
#warning "Building without inotify support"
#endif
canWatch = False
#endif

{- With inotify, discrete events will be received when making multiple changes
 - to the same filename. For example, adding it, deleting it, and adding it
 - again will be three events.
 -
 - OTOH, with kqueue, often only one event is received, indicating the most
 - recent state of the file. -}
eventsCoalesce :: Bool
#if (WITH_INOTIFY || WITH_WIN32NOTIFY)
eventsCoalesce = False
#else
#if (WITH_KQUEUE || WITH_FSEVENTS)
eventsCoalesce = True
#else
eventsCoalesce = undefined
#endif
#endif

{- With inotify, file closing is tracked to some extent, so an add event
 - will always be received for a file once its writer closes it, and
 - (typically) not before. This may mean multiple add events for the same file.
 -
 - fsevents behaves similarly, although different event types are used for
 - creating and modification of the file.
 -
 - OTOH, with kqueue, add events will often be received while a file is
 - still being written to, and then no add event will be received once the
 - writer closes it. -}
closingTracked :: Bool
#if (WITH_INOTIFY || WITH_FSEVENTS || WITH_WIN32NOTIFY)
closingTracked = True
#else
#if WITH_KQUEUE
closingTracked = False
#else
closingTracked = undefined
#endif
#endif

{- With inotify, modifications to existing files can be tracked.
 - Kqueue does not support this.
 - Fsevents generates events when an existing file is reopened and rewritten,
 - but not necessarily when it's opened once and modified repeatedly. -}
modifyTracked :: Bool
#if (WITH_INOTIFY || WITH_FSEVENTS || WITH_WIN32NOTIFY)
modifyTracked = True
#else
#if WITH_KQUEUE
modifyTracked = False
#else
modifyTracked = undefined
#endif
#endif

{- Starts a watcher thread. The runstartup action is passed a scanner action
 - to run, that will return once the initial directory scan is complete.
 - Once runstartup returns, the watcher thread continues running,
 - and processing events. Returns a DirWatcherHandle that can be used
 - to shutdown later. -}
#if WITH_INOTIFY
type DirWatcherHandle = INotify.INotify
watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle
watchDir dir prune scanevents hooks runstartup = do
	i <- INotify.initINotify
	runstartup $ INotify.watchDir i dir prune scanevents hooks
	return i
#else
#if WITH_KQUEUE
type DirWatcherHandle = ThreadId
watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO DirWatcherHandle
watchDir dir prune _scanevents hooks runstartup = do
	kq <- runstartup $ Kqueue.initKqueue dir prune
	forkIO $ Kqueue.runHooks kq hooks
#else
#if WITH_FSEVENTS
type DirWatcherHandle = FSEvents.EventStream
watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO FSEvents.EventStream -> IO FSEvents.EventStream) -> IO DirWatcherHandle
watchDir dir prune scanevents hooks runstartup =
	runstartup $ FSEvents.watchDir dir prune scanevents hooks
#else
#if WITH_WIN32NOTIFY
type DirWatcherHandle = Win32Notify.WatchManager
watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO Win32Notify.WatchManager -> IO Win32Notify.WatchManager) -> IO DirWatcherHandle
watchDir dir prune scanevents hooks runstartup =
	runstartup $ Win32Notify.watchDir dir prune scanevents hooks
#else
type DirWatcherHandle = ()
watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle
watchDir = undefined
#endif
#endif
#endif
#endif

stopWatchDir :: DirWatcherHandle -> IO ()
#if WITH_INOTIFY
stopWatchDir = INotify.killINotify
#else
#if WITH_KQUEUE
stopWatchDir = killThread
#else
#if WITH_FSEVENTS
stopWatchDir = FSEvents.eventStreamDestroy
#else
#if WITH_WIN32NOTIFY
stopWatchDir = Win32Notify.killWatchManager
#else
stopWatchDir = undefined
#endif
#endif
#endif
#endif


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

module Utility.DirWatcher.FSEvents where

import Common hiding (isDirectory)
import Utility.DirWatcher.Types

import System.OSX.FSEvents
import qualified System.Posix.Files as Files
import Data.Bits ((.&.))

watchDir :: FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO EventStream
watchDir dir ignored scanevents hooks = do
	unlessM fileLevelEventsSupported $
		error "Need at least OSX 10.7.0 for file-level FSEvents"
	scan dir
	eventStreamCreate [dir] 1.0 True True True handle
  where
	handle evt
		| ignoredPath ignored (eventPath evt) = noop
		| otherwise = do
			{- More than one flag may be set, if events occurred
			 - close together.
			 -
			 - Order is important..
			 - If a file is added and then deleted, we'll see it's
			 - not present, and addHook won't run.
			 - OTOH, if a file is deleted and then re-added,
			 - the delHook will run first, followed by the addHook.
			 -}

			when (hasflag eventFlagItemRemoved) $
				if hasflag eventFlagItemIsDir
					then runhook delDirHook Nothing
					else runhook delHook Nothing
			when (hasflag eventFlagItemCreated) $
				maybe noop handleadd =<< getstatus (eventPath evt)
			{- When a file or dir is renamed, a rename event is
			 - received for both its old and its new name. -}
			when (hasflag eventFlagItemRenamed) $
				if hasflag eventFlagItemIsDir
					then ifM (doesDirectoryExist $ eventPath evt)
						( scan $ eventPath evt
						, runhook delDirHook Nothing
						)
					else maybe (runhook delHook Nothing) handleadd
						=<< getstatus (eventPath evt)
			{- Add hooks are run when a file is modified for
			 - compatability with INotify, which calls the add
			 - hook when a file is closed, and so tends to call
			 - both add and modify for file modifications. -}
			when (hasflag eventFlagItemModified && not (hasflag eventFlagItemIsDir)) $ do
				ms <- getstatus $ eventPath evt
				maybe noop handleadd ms
				runhook modifyHook ms
	  where
		hasflag f = eventFlags evt .&. f /= 0
		runhook h s = maybe noop (\a -> a (eventPath evt) s) (h hooks)
		handleadd s
			| Files.isSymbolicLink s = runhook addSymlinkHook $ Just s
			| Files.isRegularFile s = runhook addHook $ Just s
			| otherwise = noop

	scan d = unless (ignoredPath ignored d) $
		-- Do not follow symlinks when scanning.
		-- This mirrors the inotify startup scan behavior.
		mapM_ go =<< dirContentsRecursiveSkipping (const False) False d
	  where
		go f
			| ignoredPath ignored f = noop
			| otherwise = do
				ms <- getstatus f
				case ms of
					Nothing -> noop
					Just s
						| Files.isSymbolicLink s ->
							when scanevents $
								runhook addSymlinkHook ms
						| Files.isRegularFile s ->
							when scanevents $
								runhook addHook ms
						| otherwise ->
							noop
		  where
			runhook h s = maybe noop (\a -> a f s) (h hooks)

	getstatus = catchMaybeIO . getSymbolicLinkStatus

{- Check each component of the path to see if it's ignored. -}
ignoredPath :: (FilePath -> Bool) -> FilePath -> Bool
ignoredPath ignored = any ignored . map dropTrailingPathSeparator . splitPath


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

module Utility.DirWatcher.INotify where

import Common hiding (isDirectory)
import Utility.ThreadLock
import Utility.DirWatcher.Types

import System.INotify
import qualified System.Posix.Files as Files
import System.IO.Error
import Control.Exception (throw)

{- Watches for changes to files in a directory, and all its subdirectories
 - that are not ignored, using inotify. This function returns after
 - its initial scan is complete, leaving a thread running. Callbacks are
 - made for different events.
 -
 - Inotify is weak at recursive directory watching; the whole directory
 - tree must be scanned and watches set explicitly for each subdirectory.
 -
 - To notice newly created subdirectories, inotify is used, and
 - watches are registered for those directories. There is a race there;
 - things can be added to a directory before the watch gets registered.
 -
 - To close the inotify race, each time a new directory is found, it also
 - recursively scans it, assuming all files in it were just added,
 - and registering each subdirectory.
 -
 - Note: Due to the race amelioration, multiple add events may occur
 - for the same file.
 -
 - Note: Moving a file will cause events deleting it from its old location
 - and adding it to the new location.
 -
 - Note: It's assumed that when a file that was open for write is closed,
 - it's finished being written to, and can be added.
 -
 - Note: inotify has a limit to the number of watches allowed,
 - /proc/sys/fs/inotify/max_user_watches (default 8192).
 - So this will fail if there are too many subdirectories. The
 - errHook is called when this happens.
 -}
watchDir :: INotify -> FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO ()
watchDir i dir ignored scanevents hooks
	| ignored dir = noop
	| otherwise = do
		-- Use a lock to make sure events generated during initial
		-- scan come before real inotify events.
		lock <- newLock
		let handler event = withLock lock (void $ go event)
		flip catchNonAsync failedwatch $ do
			void (addWatch i watchevents dir handler)
				`catchIO` failedaddwatch
			withLock lock $
				mapM_ scan =<< filter (not . dirCruft) <$>
					getDirectoryContents dir
  where
	recurse d = watchDir i d ignored scanevents hooks

	-- Select only inotify events required by the enabled
	-- hooks, but always include Create so new directories can
	-- be scanned.
	watchevents = Create : addevents ++ delevents ++ modifyevents
	addevents
		| hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite]
		| otherwise = []
	delevents
		| hashook delHook || hashook delDirHook = [MoveOut, Delete]
		| otherwise = []
	modifyevents
		| hashook modifyHook = [Modify]
		| otherwise = []

	scan f = unless (ignored f) $ do
		ms <- getstatus f
		case ms of
			Nothing -> return ()
			Just s
				| Files.isDirectory s ->
					recurse $ indir f
				| Files.isSymbolicLink s ->
					when scanevents $
						runhook addSymlinkHook f ms
				| Files.isRegularFile s ->
					when scanevents $
						runhook addHook f ms
				| otherwise ->
					noop

	go (Created { isDirectory = isd, filePath = f })
		| isd = recurse $ indir f
		| otherwise = do
			ms <- getstatus f
			case ms of
				Just s
					| Files.isSymbolicLink s ->
						when (hashook addSymlinkHook) $
							runhook addSymlinkHook f ms
					| Files.isRegularFile s ->
						when (hashook addHook) $
							runhook addHook f ms
				_ -> noop
	-- Closing a file is assumed to mean it's done being written,
	-- so a new add event is sent.
	go (Closed { isDirectory = False, maybeFilePath = Just f }) =
			checkfiletype Files.isRegularFile addHook f
	-- When a file or directory is moved in, scan it to add new
	-- stuff.
	go (MovedIn { filePath = f }) = scan f
	go (MovedOut { isDirectory = isd, filePath = f })
		| isd = runhook delDirHook f Nothing
		| otherwise = runhook delHook f Nothing
	-- Verify that the deleted item really doesn't exist,
	-- since there can be spurious deletion events for items
	-- in a directory that has been moved out, but is still
	-- being watched.
	go (Deleted { isDirectory = isd, filePath = f })
		| isd = guarded $ runhook delDirHook f Nothing
		| otherwise = guarded $ runhook delHook f Nothing
	  where
		guarded = unlessM (filetype (const True) f)
	go (Modified { isDirectory = isd, maybeFilePath = Just f })
		| isd = noop
		| otherwise = runhook modifyHook f Nothing
	go _ = noop

	hashook h = isJust $ h hooks

	runhook h f s
		| ignored f = noop
		| otherwise = maybe noop (\a -> a (indir f) s) (h hooks)

	indir f = dir </> f

	getstatus f = catchMaybeIO $ getSymbolicLinkStatus $ indir f
	checkfiletype check h f = do
		ms <- getstatus f
		case ms of
			Just s
				| check s -> runhook h f ms
			_ -> noop
	filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f)

	failedaddwatch e
		-- Inotify fails when there are too many watches with a
		-- disk full error.
		| isFullError e =
			case errHook hooks of
				Nothing -> error $ "failed to add inotify watch on directory " ++ dir ++ " (" ++ show e ++ ")"
				Just hook -> tooManyWatches hook dir
		-- The directory could have been deleted.
		| isDoesNotExistError e = return ()
		| otherwise = throw e

	failedwatch e = hPutStrLn stderr $ "failed to add watch on directory " ++ dir ++ " (" ++ show e ++ ")"

tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO ()
tooManyWatches hook dir = do
	sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer)
	hook (unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval) Nothing
  where
	maxwatches = "fs.inotify.max_user_watches"
	basewarning = "Too many directories to watch! (Not watching " ++ dir ++")"
	withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"]
	withsysctl n = let new = n * 10 in
		[ "Increase the limit permanently by running:"
		, "  echo " ++ maxwatches ++ "=" ++ show new ++
		  " | sudo tee -a /etc/sysctl.conf; sudo sysctl -p"
		, "Or temporarily by running:"
		, "  sudo sysctl -w " ++ maxwatches ++ "=" ++ show new
		]

querySysctl :: Read a => [CommandParam] -> IO (Maybe a)
querySysctl ps = getM go ["sysctl", "/sbin/sysctl", "/usr/sbin/sysctl"]
  where
	go p = do
		v <- catchMaybeIO $ readProcess p (toCommand ps)
		case v of
			Nothing -> return Nothing
			Just s -> return $ parsesysctl s
	parsesysctl s = readish =<< lastMaybe (words s)


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

{-# LANGUAGE ForeignFunctionInterface #-}

module Utility.DirWatcher.Kqueue (
	Kqueue,
	initKqueue,
	stopKqueue,
	waitChange,
	Change(..),
	changedFile,
	runHooks,
) where

import Common
import Utility.DirWatcher.Types

import System.Posix.Types
import Foreign.C.Types
import Foreign.C.Error
import Foreign.Ptr
import Foreign.Marshal
import qualified Data.Map as M
import qualified Data.Set as S
import qualified System.Posix.Files as Files
import Control.Concurrent

data Change
	= Deleted FilePath
	| DeletedDir FilePath
	| Added FilePath
	deriving (Show)

isAdd :: Change -> Bool
isAdd (Added _) = True
isAdd (Deleted _) = False
isAdd (DeletedDir _) = False

changedFile :: Change -> FilePath
changedFile (Added f) = f
changedFile (Deleted f) = f
changedFile (DeletedDir f) = f

data Kqueue = Kqueue
	{ kqueueFd :: Fd
	, kqueueTop :: FilePath
	, kqueueMap :: DirMap
	, _kqueuePruner :: Pruner
	}

type Pruner = FilePath -> Bool

type DirMap = M.Map Fd DirInfo

{- Enough information to uniquely identify a file in a directory,
 - but not too much. -}
data DirEnt = DirEnt
	{ dirEnt :: FilePath -- relative to the parent directory
	, _dirInode :: FileID -- included to notice file replacements
	, isSubDir :: Bool
	}
	deriving (Eq, Ord, Show)

{- A directory, and its last known contents. -}
data DirInfo = DirInfo
	{ dirName :: FilePath
	, dirCache :: S.Set DirEnt
	}
	deriving (Show)

getDirInfo :: FilePath -> IO DirInfo
getDirInfo dir = do
	l <- filter (not . dirCruft) <$> getDirectoryContents dir
	contents <- S.fromList . catMaybes <$> mapM getDirEnt l
	return $ DirInfo dir contents
  where
	getDirEnt f = catchMaybeIO $ do
		s <- getSymbolicLinkStatus (dir </> f)
		return $ DirEnt f (fileID s) (isDirectory s)

{- Difference between the dirCaches of two DirInfos. -}
(//) :: DirInfo -> DirInfo -> [Change]
oldc // newc = deleted ++ added
  where
	deleted = calc gendel oldc newc
	added   = calc genadd newc oldc
	gendel x = (if isSubDir x then DeletedDir else Deleted) $
		dirName oldc </> dirEnt x
	genadd x = Added $ dirName newc </> dirEnt x
	calc a x y = map a $ S.toList $
		S.difference (dirCache x) (dirCache y)

{- Builds a map of directories in a tree, possibly pruning some.
 - Opens each directory in the tree, and records its current contents. -}
scanRecursive :: FilePath -> Pruner -> IO DirMap
scanRecursive topdir prune = M.fromList <$> walk [] [topdir]
  where
	walk c [] = return c
	walk c (dir:rest)
		| prune dir = walk c rest
		| otherwise = do
			minfo <- catchMaybeIO $ getDirInfo dir
			case minfo of
				Nothing -> walk c rest
				Just info -> do
					mfd <- catchMaybeIO $
						openFd dir ReadOnly Nothing defaultFileFlags
					case mfd of
						Nothing -> walk c rest
						Just fd -> do
							let subdirs = map (dir </>) . map dirEnt $
								S.toList $ dirCache info
							walk ((fd, info):c) (subdirs ++ rest)

{- Adds a list of subdirectories (and all their children), unless pruned to a
 - directory map. Adding a subdirectory that's already in the map will
 - cause its contents to be refreshed. -}
addSubDirs :: DirMap -> Pruner -> [FilePath] -> IO DirMap
addSubDirs dirmap prune dirs = do
	newmap <- foldr M.union M.empty <$>
		mapM (\d -> scanRecursive d prune) dirs
	return $ M.union newmap dirmap -- prefer newmap

{- Removes a subdirectory (and all its children) from a directory map. -}
removeSubDir :: DirMap -> FilePath -> IO DirMap
removeSubDir dirmap dir = do
	mapM_ closeFd $ M.keys toremove
	return rest
  where
	(toremove, rest) = M.partition (dirContains dir . dirName) dirmap

findDirContents :: DirMap -> FilePath -> [FilePath]
findDirContents dirmap dir = concatMap absolutecontents $ search
  where
	absolutecontents i = map (dirName i </>)
		(map dirEnt $ S.toList $ dirCache i)
	search = map snd $ M.toList $
		M.filter (\i -> dirName i == dir) dirmap

foreign import ccall safe "libkqueue.h init_kqueue" c_init_kqueue
	:: IO Fd
foreign import ccall safe "libkqueue.h addfds_kqueue" c_addfds_kqueue
	:: Fd -> CInt -> Ptr Fd -> IO ()
foreign import ccall safe "libkqueue.h waitchange_kqueue" c_waitchange_kqueue
	:: Fd -> IO Fd

{- Initializes a Kqueue to watch a directory, and all its subdirectories. -}
initKqueue :: FilePath -> Pruner -> IO Kqueue
initKqueue dir pruned = do
	dirmap <- scanRecursive dir pruned
	h <- c_init_kqueue
	let kq = Kqueue h dir dirmap pruned
	updateKqueue kq
	return kq

{- Updates a Kqueue, adding watches for its map. -}
updateKqueue :: Kqueue -> IO ()
updateKqueue (Kqueue h _ dirmap _) =
	withArrayLen (M.keys dirmap) $ \fdcnt c_fds -> do
		c_addfds_kqueue h (fromIntegral fdcnt) c_fds

{- Stops a Kqueue. Note: Does not directly close the Fds in the dirmap,
 - so it can be reused.  -}
stopKqueue :: Kqueue -> IO ()
stopKqueue = closeFd . kqueueFd

{- Waits for a change on a Kqueue.
 - May update the Kqueue.
 -}
waitChange :: Kqueue -> IO (Kqueue, [Change])
waitChange kq@(Kqueue h _ dirmap _) = do
	changedfd <- c_waitchange_kqueue h
	if changedfd == -1
		then ifM ((==) eINTR <$> getErrno)
			(yield >> waitChange kq, nochange)
		else case M.lookup changedfd dirmap of
			Nothing -> nochange
			Just info -> handleChange kq changedfd info
  where
	nochange = return (kq, [])

{- The kqueue interface does not tell what type of change took place in
 - the directory; it could be an added file, a deleted file, a renamed
 - file, a new subdirectory, or a deleted subdirectory, or a moved
 - subdirectory.
 -
 - So to determine this, the contents of the directory are compared
 - with its last cached contents. The Kqueue is updated to watch new
 - directories as necessary.
 -}
handleChange :: Kqueue -> Fd -> DirInfo -> IO (Kqueue, [Change])
handleChange kq@(Kqueue _ _ dirmap pruner) fd olddirinfo =
	go =<< catchMaybeIO (getDirInfo $ dirName olddirinfo)
  where
	go (Just newdirinfo) = do
		let changes = filter (not . pruner . changedFile) $
			 olddirinfo // newdirinfo
		let (added, deleted) = partition isAdd changes

		-- Scan newly added directories to add to the map.
		-- (Newly added files will fail getDirInfo.)
		newdirinfos <- catMaybes <$>
			mapM (catchMaybeIO . getDirInfo . changedFile) added
		newmap <- addSubDirs dirmap pruner $ map dirName newdirinfos

		-- Remove deleted directories from the map.
		newmap' <- foldM removeSubDir newmap (map changedFile deleted)

		-- Update the cached dirinfo just looked up.
		let newmap'' = M.insertWith' const fd newdirinfo newmap'

		-- When new directories were added, need to update
		-- the kqueue to watch them.
		let kq' = kq { kqueueMap = newmap'' }
		unless (null newdirinfos) $
			updateKqueue kq'

		return (kq', changes)
	go Nothing = do
		-- The directory has been moved or deleted, so
		-- remove it from our map.
		newmap <- removeSubDir dirmap (dirName olddirinfo)
		return (kq { kqueueMap = newmap }, [])

{- Processes changes on the Kqueue, calling the hooks as appropriate.
 - Never returns. -}
runHooks :: Kqueue -> WatchHooks -> IO ()
runHooks kq hooks = do
	-- First, synthetic add events for the whole directory tree contents,
	-- to catch any files created beforehand.
	recursiveadd (kqueueMap kq) (Added $ kqueueTop kq)
	loop kq
  where
	loop q = do
		(q', changes) <- waitChange q
		forM_ changes $ dispatch (kqueueMap q')
		loop q'

	dispatch _ change@(Deleted _) =
		callhook delHook Nothing change
	dispatch _ change@(DeletedDir _) =
		callhook delDirHook Nothing change
	dispatch dirmap change@(Added _) =
		withstatus change $ dispatchadd dirmap

	dispatchadd dirmap change s
		| Files.isSymbolicLink s = callhook addSymlinkHook (Just s) change
		| Files.isDirectory s = recursiveadd dirmap change
		| Files.isRegularFile s = callhook addHook (Just s) change
		| otherwise = noop

	recursiveadd dirmap change = do
		let contents = findDirContents dirmap $ changedFile change
		forM_ contents $ \f ->
			withstatus (Added f) $ dispatchadd dirmap

	callhook h s change = case h hooks of
		Nothing -> noop
		Just a -> a (changedFile change) s

	withstatus change a = maybe noop (a change) =<<
		(catchMaybeIO (getSymbolicLinkStatus (changedFile change)))


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

module Utility.DirWatcher.Types where

import Common

type Hook a = Maybe (a -> Maybe FileStatus -> IO ())

data WatchHooks = WatchHooks
	{ addHook :: Hook FilePath
	, addSymlinkHook :: Hook FilePath
	, delHook :: Hook FilePath
	, delDirHook :: Hook FilePath
	, errHook :: Hook String -- error message
	, modifyHook :: Hook FilePath
	}

mkWatchHooks :: WatchHooks
mkWatchHooks = WatchHooks Nothing Nothing Nothing Nothing Nothing Nothing


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

module Utility.DirWatcher.Win32Notify where

import Common hiding (isDirectory)
import Utility.DirWatcher.Types

import System.Win32.Notify
import qualified Utility.PosixFiles as Files

watchDir :: FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO WatchManager
watchDir dir ignored scanevents hooks = do
	scan dir
	wm <- initWatchManager
	void $ watchDirectory wm dir True [Create, Delete, Modify, Move] handle
	return wm
  where
	handle evt
		| ignoredPath ignored (filePath evt) = noop
		| otherwise = case evt of
			(Deleted _ _)
				| isDirectory evt -> runhook delDirHook Nothing
				| otherwise -> runhook delHook Nothing
			(Created _ _)
				| isDirectory evt -> noop
				| otherwise -> runhook addHook Nothing
			(Modified _ _)
				| isDirectory evt -> noop
				{- Add hooks are run when a file is modified for
				 - compatability with INotify, which calls the add
				 - hook when a file is closed, and so tends to call
				 - both add and modify for file modifications. -}
				| otherwise -> do
					runhook addHook Nothing
					runhook modifyHook Nothing
	  where
		runhook h s = maybe noop (\a -> a (filePath evt) s) (h hooks)

	scan d = unless (ignoredPath ignored d) $
		mapM_ go =<< dirContentsRecursiveSkipping (const False) False d
	  where
		go f
			| ignoredPath ignored f = noop
			| otherwise = do
				ms <- getstatus f
				case ms of
					Nothing -> noop
					Just s
						| Files.isRegularFile s ->
							when scanevents $
								runhook addHook ms
						| otherwise ->
							noop
		  where
			runhook h s = maybe noop (\a -> a f s) (h hooks)

	getstatus = catchMaybeIO . getFileStatus

{- Check each component of the path to see if it's ignored. -}
ignoredPath :: (FilePath -> Bool) -> FilePath -> Bool
ignoredPath ignored = any ignored . map dropTrailingPathSeparator . splitPath


code:
{- directory traversal and manipulation
 -
 - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.Directory where

import System.IO.Error
import System.Directory
import Control.Exception (throw, bracket)
import Control.Monad
import Control.Monad.IfElse
import System.FilePath
import Control.Applicative
import Control.Concurrent
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.Maybe

#ifdef mingw32_HOST_OS
import qualified System.Win32 as Win32
#else
import qualified System.Posix as Posix
#endif

import Utility.PosixFiles
import Utility.SafeCommand
import Utility.Tmp
import Utility.Exception
import Utility.Monad
import Utility.Applicative

dirCruft :: FilePath -> Bool
dirCruft "." = True
dirCruft ".." = True
dirCruft _ = False

{- Lists the contents of a directory.
 - Unlike getDirectoryContents, paths are not relative to the directory. -}
dirContents :: FilePath -> IO [FilePath]
dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d

{- Gets files in a directory, and then its subdirectories, recursively,
 - and lazily.
 -
 - Does not follow symlinks to other subdirectories.
 -
 - When the directory does not exist, no exception is thrown,
 - instead, [] is returned. -}
dirContentsRecursive :: FilePath -> IO [FilePath]
dirContentsRecursive = dirContentsRecursiveSkipping (const False) True

{- Skips directories whose basenames match the skipdir. -}
dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
  where
  	go [] = return []
	go (dir:dirs)
		| skipdir (takeFileName dir) = go dirs
		| otherwise = unsafeInterleaveIO $ do
			(files, dirs') <- collect [] []
				=<< catchDefaultIO [] (dirContents dir)
			files' <- go (dirs' ++ dirs)
			return (files ++ files')
	collect files dirs' [] = return (reverse files, reverse dirs')
	collect files dirs' (entry:entries)
		| dirCruft entry = collect files dirs' entries
		| otherwise = do
			let skip = collect (entry:files) dirs' entries
			let recurse = collect files (entry:dirs') entries
			ms <- catchMaybeIO $ getSymbolicLinkStatus entry
			case ms of
				(Just s)
					| isDirectory s -> recurse
					| isSymbolicLink s && followsubdirsymlinks ->
						ifM (doesDirectoryExist entry)
							( recurse
							, skip
							)
				_ -> skip

{- Gets the directory tree from a point, recursively and lazily,
 - with leaf directories **first**, skipping any whose basenames
 - match the skipdir. Does not follow symlinks. -}
dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]
  where
  	go c [] = return c
	go c (dir:dirs)
		| skipdir (takeFileName dir) = go c dirs
		| otherwise = unsafeInterleaveIO $ do
			subdirs <- go c
				=<< filterM (isDirectory <$$> getSymbolicLinkStatus)
				=<< catchDefaultIO [] (dirContents dir)
			go (subdirs++[dir]) dirs

{- Moves one filename to another.
 - First tries a rename, but falls back to moving across devices if needed. -}
moveFile :: FilePath -> FilePath -> IO ()
moveFile src dest = tryIO (rename src dest) >>= onrename
  where
	onrename (Right _) = noop
	onrename (Left e)
		| isPermissionError e = rethrow
		| isDoesNotExistError e = rethrow
		| otherwise = do
			-- copyFile is likely not as optimised as
			-- the mv command, so we'll use the latter.
			-- But, mv will move into a directory if
			-- dest is one, which is not desired.
			whenM (isdir dest) rethrow
			viaTmp mv dest undefined
	  where
		rethrow = throw e
		mv tmp _ = do
			ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]
			unless ok $ do
				-- delete any partial
				_ <- tryIO $ removeFile tmp
				rethrow

	isdir f = do
		r <- tryIO $ getFileStatus f
		case r of
			(Left _) -> return False
			(Right s) -> return $ isDirectory s

{- Removes a file, which may or may not exist, and does not have to
 - be a regular file.
 -
 - Note that an exception is thrown if the file exists but
 - cannot be removed. -}
nukeFile :: FilePath -> IO ()
nukeFile file = void $ tryWhenExists go
  where
#ifndef mingw32_HOST_OS
	go = removeLink file
#else
	go = removeFile file
#endif

#ifndef mingw32_HOST_OS
data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream
#else
data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ())
#endif

type IsOpen = MVar () -- full when the handle is open

openDirectory :: FilePath -> IO DirectoryHandle
openDirectory path = do
#ifndef mingw32_HOST_OS
	dirp <- Posix.openDirStream path
	isopen <- newMVar ()
	return (DirectoryHandle isopen dirp)
#else
	(h, fdat) <- Win32.findFirstFile (path </> "*")
	-- Indicate that the fdat contains a filename that readDirectory
	-- has not yet returned, by making the MVar be full.
	-- (There's always at least a "." entry.)
	alreadyhave <- newMVar ()
	isopen <- newMVar ()
	return (DirectoryHandle isopen h fdat alreadyhave)
#endif

closeDirectory :: DirectoryHandle -> IO ()
#ifndef mingw32_HOST_OS
closeDirectory (DirectoryHandle isopen dirp) =
	whenOpen isopen $
		Posix.closeDirStream dirp
#else
closeDirectory (DirectoryHandle isopen h _ alreadyhave) =
	whenOpen isopen $ do
		_ <- tryTakeMVar alreadyhave
		Win32.findClose h
#endif
  where
	whenOpen :: IsOpen -> IO () -> IO ()
	whenOpen mv f = do
		v <- tryTakeMVar mv
		when (isJust v) f

{- |Reads the next entry from the handle. Once the end of the directory
is reached, returns Nothing and automatically closes the handle.
-}
readDirectory :: DirectoryHandle -> IO (Maybe FilePath)
#ifndef mingw32_HOST_OS
readDirectory hdl@(DirectoryHandle _ dirp) = do
	e <- Posix.readDirStream dirp
	if null e
		then do
			closeDirectory hdl
			return Nothing
		else return (Just e)
#else
readDirectory hdl@(DirectoryHandle _ h fdat mv) = do
	-- If the MVar is full, then the filename in fdat has
	-- not yet been returned. Otherwise, need to find the next
	-- file.
	r <- tryTakeMVar mv
	case r of
		Just () -> getfn
		Nothing -> do
			more <- Win32.findNextFile h fdat
			if more
				then getfn
				else do
					closeDirectory hdl
					return Nothing
  where
	getfn = do
		filename <- Win32.getFindDataFileName fdat
		return (Just filename)
#endif

-- True only when directory exists and contains nothing.
-- Throws exception if directory does not exist.
isDirectoryEmpty :: FilePath -> IO Bool
isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check
  where
	check h = do
		v <- readDirectory h
		case v of
			Nothing -> return True
			Just f
				| not (dirCruft f) -> return False
				| otherwise -> check h


code:
{- disk free space checking
 -
 - Copyright 2012, 2014 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE ForeignFunctionInterface, CPP #-}

module Utility.DiskFree (
	getDiskFree,
	getDiskSize
) where

#ifdef WITH_CLIBS

import Common

import Foreign.C.Types
import Foreign.C.String
import Foreign.C.Error

foreign import ccall safe "libdiskfree.h diskfree" c_diskfree
	:: CString -> IO CULLong

foreign import ccall safe "libdiskfree.h disksize" c_disksize
	:: CString -> IO CULLong

getVal :: (CString -> IO CULLong) -> FilePath -> IO (Maybe Integer)
getVal getter path = withFilePath path $ \c_path -> do
	free <- getter c_path
	ifM (safeErrno <$> getErrno)
		( return $ Just $ toInteger free
		, return Nothing
		)
  where
	safeErrno (Errno v) = v == 0

getDiskFree :: FilePath -> IO (Maybe Integer)
getDiskFree = getVal c_diskfree

getDiskSize :: FilePath -> IO (Maybe Integer)
getDiskSize = getVal c_disksize

#else
#ifdef mingw32_HOST_OS

import Common

import System.Win32.File

getDiskFree :: FilePath -> IO (Maybe Integer)
getDiskFree path = catchMaybeIO $ do
	(sectors, bytes, nfree, _ntotal) <- getDiskFreeSpace (Just path)
	return $ toInteger sectors * toInteger bytes * toInteger nfree

getDiskSize :: FilePath -> IO (Maybe Integer)
getDiskSize _ = return Nothing
#else

#warning Building without disk free space checking support

getDiskFree :: FilePath -> IO (Maybe Integer)
getDiskFree _ = return Nothing

getDiskSize :: FilePath -> IO (Maybe Integer)
getDiskSize _ = return Nothing

#endif
#endif


code:
{- a simple graphviz / dot(1) digraph description generator library
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.Dot where -- import qualified

{- generates a graph description from a list of lines -}
graph :: [String] -> String
graph s = unlines $ [header] ++ map indent s ++ [footer]
  where
	header = "digraph map {"
	footer= "}"

{- a node in the graph -}
graphNode :: String -> String -> String
graphNode nodeid desc = label desc $ quote nodeid

{- an edge between two nodes -}
graphEdge :: String -> String -> Maybe String -> String
graphEdge fromid toid desc = indent $ maybe edge (`label` edge) desc
  where
	edge = quote fromid ++ " -> " ++ quote toid

{- adds a label to a node or edge -}
label :: String -> String -> String
label = attr "label"

{- adds an attribute to a node or edge
 - (can be called multiple times for multiple attributes) -}
attr :: String -> String -> String -> String
attr a v s = s ++ " [ " ++ a ++ "=" ++ quote v ++ " ]"

{- fills a node with a color -}
fillColor :: String -> String -> String
fillColor color s = attr "fillcolor" color $ attr "style" "filled" s

{- apply to graphNode to put the node in a labeled box -}
subGraph :: String -> String -> String -> String -> String
subGraph subid l color s =
	"subgraph " ++ name ++ " {\n" ++
		ii setlabel ++
		ii setfilled ++
		ii setcolor ++
		ii s ++
		indent "}"
  where
	-- the "cluster_" makes dot draw a box
	name = quote ("cluster_" ++ subid)
	setlabel = "label=" ++ quote l
	setfilled = "style=" ++ quote "filled"
	setcolor = "fillcolor=" ++ quote color
	ii x = indent (indent x) ++ "\n"

indent ::String -> String
indent s = '\t' : s

quote :: String -> String
quote s = "\"" ++ s' ++ "\""
  where
	s' = filter (/= '"') s


code:
{- portable environment variables
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.Env where

#ifdef mingw32_HOST_OS
import Utility.Exception
import Control.Applicative
import Data.Maybe
import qualified System.Environment as E
#else
import qualified System.Posix.Env as PE
#endif

getEnv :: String -> IO (Maybe String)
#ifndef mingw32_HOST_OS
getEnv = PE.getEnv
#else
getEnv = catchMaybeIO . E.getEnv
#endif

getEnvDefault :: String -> String -> IO String
#ifndef mingw32_HOST_OS
getEnvDefault = PE.getEnvDefault
#else
getEnvDefault var fallback = fromMaybe fallback <$> getEnv var
#endif

getEnvironment :: IO [(String, String)]
#ifndef mingw32_HOST_OS
getEnvironment = PE.getEnvironment
#else
getEnvironment = E.getEnvironment
#endif

{- Returns True if it could successfully set the environment variable.
 -
 - There is, apparently, no way to do this in Windows. Instead,
 - environment varuables must be provided when running a new process. -}
setEnv :: String -> String -> Bool -> IO Bool
#ifndef mingw32_HOST_OS
setEnv var val overwrite = do
	PE.setEnv var val overwrite
	return True
#else
setEnv _ _ _ = return False
#endif

{- Returns True if it could successfully unset the environment variable. -}
unsetEnv :: String -> IO Bool
#ifndef mingw32_HOST_OS
unsetEnv var = do
	PE.unsetEnv var
	return True
#else
unsetEnv _ = return False
#endif

{- Adds the environment variable to the input environment. If already
 - present in the list, removes the old value.
 -
 - This does not really belong here, but Data.AssocList is for some reason
 - buried inside hxt.
 -}
addEntry :: Eq k => k -> v -> [(k, v)] -> [(k, v)]
addEntry k v l = ( (k,v) : ) $! delEntry k l

addEntries :: Eq k => [(k, v)] -> [(k, v)] -> [(k, v)]
addEntries = foldr (.) id . map (uncurry addEntry) . reverse

delEntry :: Eq k => k -> [(k, v)] -> [(k, v)]
delEntry _ []   = []
delEntry k (x@(k1,_) : rest)
	| k == k1 = rest
	| otherwise = ( x : ) $! delEntry k rest