code:
{- System.Process enhancements, including additional ways of running
 - processes, and logging.
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP, Rank2Types #-}

module Utility.Process (
	module X,
	CreateProcess(..),
	StdHandle(..),
	readProcess,
	readProcessEnv,
	writeReadProcessEnv,
	forceSuccessProcess,
	checkSuccessProcess,
	ignoreFailureProcess,
	createProcessSuccess,
	createProcessChecked,
	createBackgroundProcess,
	processTranscript,
	processTranscript',
	withHandle,
	withBothHandles,
	withQuietOutput,
	createProcess,
	startInteractiveProcess,
	stdinHandle,
	stdoutHandle,
	stderrHandle,
	bothHandles,
	processHandle,
	devNull,
) where

import qualified System.Process
import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)
import System.Process hiding (createProcess, readProcess)
import System.Exit
import System.IO
import System.Log.Logger
import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad
#ifndef mingw32_HOST_OS
import System.Posix.IO
#else
import Control.Applicative
#endif
import Data.Maybe

import Utility.Misc
import Utility.Exception

type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a

data StdHandle = StdinHandle | StdoutHandle | StderrHandle
	deriving (Eq)

{- Normally, when reading from a process, it does not need to be fed any
 - standard input. -}
readProcess :: FilePath	-> [String] -> IO String
readProcess cmd args = readProcessEnv cmd args Nothing

readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String
readProcessEnv cmd args environ =
	withHandle StdoutHandle createProcessSuccess p $ \h -> do
		output  <- hGetContentsStrict h
		hClose h
		return output
  where
	p = (proc cmd args)
		{ std_out = CreatePipe
		, env = environ
		}

{- Runs an action to write to a process on its stdin,
 - returns its output, and also allows specifying the environment.
 -}
writeReadProcessEnv
	:: FilePath
	-> [String]
	-> Maybe [(String, String)]
	-> (Maybe (Handle -> IO ()))
	-> (Maybe (Handle -> IO ()))
	-> IO String
writeReadProcessEnv cmd args environ writestdin adjusthandle = do
	(Just inh, Just outh, _, pid) <- createProcess p

	maybe (return ()) (\a -> a inh) adjusthandle
	maybe (return ()) (\a -> a outh) adjusthandle

	-- fork off a thread to start consuming the output
	output  <- hGetContents outh
	outMVar <- newEmptyMVar
	_ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()

	-- now write and flush any input
	maybe (return ()) (\a -> a inh >> hFlush inh) writestdin
	hClose inh -- done with stdin

	-- wait on the output
	takeMVar outMVar
	hClose outh

	-- wait on the process
	forceSuccessProcess p pid

	return output

  where
	p = (proc cmd args)
		{ std_in = CreatePipe
		, std_out = CreatePipe
		, std_err = Inherit
		, env = environ
		}

{- Waits for a ProcessHandle, and throws an IOError if the process
 - did not exit successfully. -}
forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()
forceSuccessProcess p pid = do
	code <- waitForProcess pid
	case code of
		ExitSuccess -> return ()
		ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n

{- Waits for a ProcessHandle and returns True if it exited successfully.
 - Note that using this with createProcessChecked will throw away
 - the Bool, and is only useful to ignore the exit code of a process,
 - while still waiting for it. -}
checkSuccessProcess :: ProcessHandle -> IO Bool
checkSuccessProcess pid = do
	code <- waitForProcess pid
	return $ code == ExitSuccess

ignoreFailureProcess :: ProcessHandle -> IO Bool
ignoreFailureProcess pid = do
	void $ waitForProcess pid
	return True

{- Runs createProcess, then an action on its handles, and then
 - forceSuccessProcess. -}
createProcessSuccess :: CreateProcessRunner
createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a

{- Runs createProcess, then an action on its handles, and then
 - a checker action on its exit code, which must wait for the process. -}
createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner
createProcessChecked checker p a = do
	t@(_, _, _, pid) <- createProcess p
	r <- tryNonAsync $ a t
	_ <- checker pid
	either E.throw return r

{- Leaves the process running, suitable for lazy streaming.
 - Note: Zombies will result, and must be waited on. -}
createBackgroundProcess :: CreateProcessRunner
createBackgroundProcess p a = a =<< createProcess p

{- Runs a process, optionally feeding it some input, and
 - returns a transcript combining its stdout and stderr, and
 - whether it succeeded or failed. -}
processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
processTranscript cmd opts input = processTranscript' cmd opts Nothing input

processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)
processTranscript' cmd opts environ input = do
#ifndef mingw32_HOST_OS
{- This implementation interleves stdout and stderr in exactly the order
 - the process writes them. -}
	(readf, writef) <- createPipe
	readh <- fdToHandle readf
	writeh <- fdToHandle writef
	p@(_, _, _, pid) <- createProcess $
		(proc cmd opts)
			{ std_in = if isJust input then CreatePipe else Inherit
			, std_out = UseHandle writeh
			, std_err = UseHandle writeh
			, env = environ
			}
	hClose writeh

	get <- mkreader readh
	writeinput input p
	transcript <- get

	ok <- checkSuccessProcess pid
	return (transcript, ok)
#else
{- This implementation for Windows puts stderr after stdout. -}
	p@(_, _, _, pid) <- createProcess $
		(proc cmd opts)
			{ std_in = if isJust input then CreatePipe else Inherit
			, std_out = CreatePipe
			, std_err = CreatePipe
			, env = environ
			}

	getout <- mkreader (stdoutHandle p)
	geterr <- mkreader (stderrHandle p)
	writeinput input p
	transcript <- (++) <$> getout <*> geterr

	ok <- checkSuccessProcess pid
	return (transcript, ok)
#endif
  where
	mkreader h = do
		s <- hGetContents h
		v <- newEmptyMVar
		void $ forkIO $ do
			void $ E.evaluate (length s)
			putMVar v ()
		return $ do
			takeMVar v
			return s

	writeinput (Just s) p = do
		let inh = stdinHandle p
		unless (null s) $ do
			hPutStr inh s
			hFlush inh
		hClose inh
	writeinput Nothing _ = return ()

{- Runs a CreateProcessRunner, on a CreateProcess structure, that
 - is adjusted to pipe only from/to a single StdHandle, and passes
 - the resulting Handle to an action. -}
withHandle
	:: StdHandle
	-> CreateProcessRunner
	-> CreateProcess
	-> (Handle -> IO a)
	-> IO a
withHandle h creator p a = creator p' $ a . select
  where
	base = p
		{ std_in = Inherit
		, std_out = Inherit
		, std_err = Inherit
		}
	(select, p')
		| h == StdinHandle  =
			(stdinHandle, base { std_in = CreatePipe })
		| h == StdoutHandle =
			(stdoutHandle, base { std_out = CreatePipe })
		| h == StderrHandle =
			(stderrHandle, base { std_err = CreatePipe })

{- Like withHandle, but passes (stdin, stdout) handles to the action. -}
withBothHandles
	:: CreateProcessRunner
	-> CreateProcess
	-> ((Handle, Handle) -> IO a)
	-> IO a
withBothHandles creator p a = creator p' $ a . bothHandles
  where
	p' = p
		{ std_in = CreatePipe
		, std_out = CreatePipe
		, std_err = Inherit
		}

{- Forces the CreateProcessRunner to run quietly;
 - both stdout and stderr are discarded. -}
withQuietOutput
	:: CreateProcessRunner
	-> CreateProcess
	-> IO ()
withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
	let p' = p
		{ std_out = UseHandle nullh
		, std_err = UseHandle nullh
		}
	creator p' $ const $ return ()

devNull :: FilePath
#ifndef mingw32_HOST_OS
devNull = "/dev/null"
#else
devNull = "NUL"
#endif

{- Extract a desired handle from createProcess's tuple.
 - These partial functions are safe as long as createProcess is run
 - with appropriate parameters to set up the desired handle.
 - Get it wrong and the runtime crash will always happen, so should be
 - easily noticed. -}
type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle
stdinHandle :: HandleExtractor
stdinHandle (Just h, _, _, _) = h
stdinHandle _ = error "expected stdinHandle"
stdoutHandle :: HandleExtractor
stdoutHandle (_, Just h, _, _) = h
stdoutHandle _ = error "expected stdoutHandle"
stderrHandle :: HandleExtractor
stderrHandle (_, _, Just h, _) = h
stderrHandle _ = error "expected stderrHandle"
bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
bothHandles (Just hin, Just hout, _, _) = (hin, hout)
bothHandles _ = error "expected bothHandles"

processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
processHandle (_, _, _, pid) = pid

{- Debugging trace for a CreateProcess. -}
debugProcess :: CreateProcess -> IO ()
debugProcess p = do
	debugM "Utility.Process" $ unwords
		[ action ++ ":"
		, showCmd p
		]
  where
	action
		| piped (std_in p) && piped (std_out p) = "chat"
		| piped (std_in p)                      = "feed"
		| piped (std_out p)                     = "read"
		| otherwise                             = "call"
	piped Inherit = False
	piped _ = True

{- Shows the command that a CreateProcess will run. -}
showCmd :: CreateProcess -> String
showCmd = go . cmdspec
  where
	go (ShellCommand s) = s
	go (RawCommand c ps) = c ++ " " ++ show ps

{- Starts an interactive process. Unlike runInteractiveProcess in
 - System.Process, stderr is inherited. -}
startInteractiveProcess
	:: FilePath
	-> [String]
	-> Maybe [(String, String)]
	-> IO (ProcessHandle, Handle, Handle)
startInteractiveProcess cmd args environ = do
	let p = (proc cmd args)
		{ std_in = CreatePipe
		, std_out = CreatePipe
		, std_err = Inherit
		, env = environ
		}
	(Just from, Just to, _, pid) <- createProcess p
	return (pid, to, from)

{- Wrapper around System.Process function that does debug logging. -}
createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess p = do
	debugProcess p
	System.Process.createProcess p


code:
{- QuickCheck with additional instances
 -
 - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Utility.QuickCheck
	( module X
	, module Utility.QuickCheck
	) where

import Test.QuickCheck as X
import Data.Time.Clock.POSIX
import System.Posix.Types
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Applicative

instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where
	arbitrary = M.fromList <$> arbitrary

instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where
	arbitrary = S.fromList <$> arbitrary

{- Times before the epoch are excluded. -}
instance Arbitrary POSIXTime where
	arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral

instance Arbitrary EpochTime where
	arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral

{- Pids are never negative, or 0. -}
instance Arbitrary ProcessID where
	arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)

{- Inodes are never negative. -}
instance Arbitrary FileID where
	arbitrary = nonNegative arbitrarySizedIntegral

{- File sizes are never negative. -}
instance Arbitrary FileOffset where
	arbitrary = nonNegative arbitrarySizedIntegral

nonNegative :: (Num a, Ord a) => Gen a -> Gen a
nonNegative g = g `suchThat` (>= 0)

positive :: (Num a, Ord a) => Gen a -> Gen a
positive g = g `suchThat` (> 0)

repo_name: kakafarm/git

license: unknown


code:
{- querying quvi (import qualified)
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE OverloadedStrings #-}

module Utility.Quvi where

import Common
import Utility.Url

import Data.Aeson
import Data.ByteString.Lazy.UTF8 (fromString)
import qualified Data.Map as M
import Network.URI (uriAuthority, uriRegName)
import Data.Char

data QuviVersion
	= Quvi04
	| Quvi09
	| NoQuvi

data Page = Page
	{ pageTitle :: String
	, pageLinks :: [Link]
	} deriving (Show)

data Link = Link
	{ linkSuffix :: String
	, linkUrl :: URLString
	} deriving (Show)

{- JSON instances for quvi 0.4. -}
instance FromJSON Page where
	parseJSON (Object v) = Page
		<$> v .: "page_title"
		<*> v .: "link"
	parseJSON _ = mzero

instance FromJSON Link where
	parseJSON (Object v) = Link
		<$> v .: "file_suffix"
		<*> v .: "url"
	parseJSON _ = mzero

{- "enum" format used by quvi 0.9 -}
parseEnum :: String -> Maybe Page
parseEnum s = Page
	<$> get "QUVI_MEDIA_PROPERTY_TITLE"
	<*> ((:[]) <$>
		( Link
			<$> get "QUVI_MEDIA_STREAM_PROPERTY_CONTAINER"
			<*> get "QUVI_MEDIA_STREAM_PROPERTY_URL"
		)
	    )
  where
	get = flip M.lookup m
	m = M.fromList $ map (separate (== '=')) $ lines s

probeVersion :: IO QuviVersion
probeVersion = examine <$> processTranscript "quvi" ["--version"] Nothing
  where
	examine (s, True)
		| "quvi v0.4" `isInfixOf` s = Quvi04
		| otherwise = Quvi09
	examine _ = NoQuvi

type Query a = QuviVersion -> [CommandParam] -> URLString -> IO a

{- Throws an error when quvi is not installed. -}
forceQuery :: Query (Maybe Page)
forceQuery v ps url = query' v ps url `catchNonAsync` onerr
  where
	onerr _ = ifM (inPath "quvi")
		( error "quvi failed"
		, error "quvi is not installed"
		)

{- Returns Nothing if the page is not a video page, or quvi is not
 - installed. -}
query :: Query (Maybe Page)
query v ps url = flip catchNonAsync (const $ return Nothing) (query' v ps url)

query' :: Query (Maybe Page)
query' Quvi09 ps url = parseEnum
	<$> readProcess "quvi" (toCommand $ [Param "dump", Param "-p", Param "enum"] ++ ps ++ [Param url])
query' Quvi04 ps url = decode . fromString
	<$> readProcess "quvi" (toCommand $ ps ++ [Param url])
query' NoQuvi _ _ = return Nothing

queryLinks :: Query [URLString]
queryLinks v ps url = maybe [] (map linkUrl . pageLinks) <$> query v ps url

{- Checks if quvi can still find a download link for an url.
 - If quvi is not installed, returns False. -}
check :: Query Bool
check v ps url = maybe False (not . null . pageLinks) <$> query v ps url

{- Checks if an url is supported by quvi, as quickly as possible
 - (without hitting it if possible), and without outputting
 - anything. Also returns False if quvi is not installed. -}
supported :: QuviVersion -> URLString -> IO Bool
supported NoQuvi _ = return False
supported Quvi04 url = boolSystem "quvi"
		[ Params "--verbosity mute --support"
		, Param url
		]
{- Use quvi-info to see if the url's domain is supported.
 - If so, have to do a online verification of the url. -}
supported Quvi09 url = (firstlevel <&&> secondlevel)
		`catchNonAsync` (\_ -> return False)
  where
  	firstlevel = case uriAuthority =<< parseURIRelaxed url of
		Nothing -> return False
		Just auth -> do
			let domain = map toLower $ uriRegName auth
			let basedomain = intercalate "." $ reverse $ take 2 $ reverse $ split "." domain
			any (\h -> domain `isSuffixOf` h || basedomain `isSuffixOf` h)
				. map (map toLower) <$> listdomains Quvi09
	secondlevel = snd <$> processTranscript "quvi"
		(toCommand [Param "dump", Param "-o", Param url]) Nothing

listdomains :: QuviVersion -> IO [String]
listdomains Quvi09 = concatMap (split ",")
	. concatMap (drop 1 . words)
	. filter ("domains: " `isPrefixOf`) . lines
	<$> readProcess "quvi"
		(toCommand [Param "info", Param "-p", Param "domains"])
listdomains _ = return []

type QuviParam = QuviVersion -> CommandParam

{- Disables progress, but not information output. -}
quiet :: QuviParam
-- Cannot use quiet as it now disables informational output.
-- No way to disable progress.
quiet Quvi09 = Params "--verbosity verbose"
quiet Quvi04 = Params "--verbosity quiet"
quiet NoQuvi = Params ""

{- Only return http results, not streaming protocols. -}
httponly :: QuviParam
-- No way to do it with 0.9?
httponly Quvi04 = Params "-c http"
httponly _ = Params "" -- No way to do it with 0.9?


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

module Utility.Rsync where

import Common
import Utility.Metered

import Data.Char
import System.Console.GetOpt
import Data.Tuple.Utils

{- Generates parameters to make rsync use a specified command as its remote
 - shell. -}
rsyncShell :: [CommandParam] -> [CommandParam]
rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand command)]
  where
	{- rsync requires some weird, non-shell like quoting in
	- here. A doubled single quote inside the single quoted
	- string is a single quote. -}
	escape s = "'" ++  intercalate "''" (split "'" s) ++ "'"

{- Runs rsync in server mode to send a file. -}
rsyncServerSend :: [CommandParam] -> FilePath -> IO Bool
rsyncServerSend options file = rsync $
	rsyncServerParams ++ Param "--sender" : options ++ [File file]

{- Runs rsync in server mode to receive a file. -}
rsyncServerReceive :: [CommandParam] -> FilePath -> IO Bool
rsyncServerReceive options file = rsync $
	rsyncServerParams ++ options ++ [File file]

rsyncServerParams :: [CommandParam]
rsyncServerParams =
	[ Param "--server"
	-- preserve timestamps
	, Param "-t"
	-- allow resuming of transfers of big files
	, Param "--inplace"
	-- other options rsync normally uses in server mode
	, Params "-e.Lsf ."
	]

rsyncUseDestinationPermissions :: CommandParam
rsyncUseDestinationPermissions = Param "--chmod=ugo=rwX"

rsync :: [CommandParam] -> IO Bool
rsync = boolSystem "rsync" . rsyncParamsFixup

{- On Windows, rsync is from Cygwin, and expects to get Cygwin formatted
 - paths to files. (It thinks that C:foo refers to a host named "C").
 - Fix up all Files in the Params appropriately. -}
rsyncParamsFixup :: [CommandParam] -> [CommandParam]
rsyncParamsFixup = map fixup
  where
  	fixup (File f) = File (toCygPath f)
	fixup p = p

{- Runs rsync, but intercepts its progress output and updates a meter.
 - The progress output is also output to stdout.
 -
 - The params must enable rsync's --progress mode for this to work.
 -}
rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool
rsyncProgress meterupdate params = do
	r <- catchBoolIO $
		withHandle StdoutHandle createProcessSuccess p (feedprogress 0 [])
	{- For an unknown reason, piping rsync's output like this does
	 - causes it to run a second ssh process, which it neglects to wait
	 - on. Reap the resulting zombie. -}
	reapZombies
	return r
  where
	p = proc "rsync" (toCommand $ rsyncParamsFixup params)
	feedprogress prev buf h = do
		s <- hGetSomeString h 80
		if null s
			then return True
			else do
				putStr s
				hFlush stdout
				let (mbytes, buf') = parseRsyncProgress (buf++s)
				case mbytes of
					Nothing -> feedprogress prev buf' h
					(Just bytes) -> do
						when (bytes /= prev) $
							meterupdate $ toBytesProcessed bytes
						feedprogress bytes buf' h

{- Checks if an rsync url involves the remote shell (ssh or rsh).
 - Use of such urls with rsync requires additional shell
 - escaping. -}
rsyncUrlIsShell :: String -> Bool
rsyncUrlIsShell s
	| "rsync://" `isPrefixOf` s = False
	| otherwise = go s
  where
	-- host::dir is rsync protocol, while host:dir is ssh/rsh
	go [] = False
	go (c:cs)
		| c == '/' = False -- got to directory with no colon
		| c == ':' = not $ ":" `isPrefixOf` cs
		| otherwise = go cs

{- Checks if a rsync url is really just a local path. -}
rsyncUrlIsPath :: String -> Bool
rsyncUrlIsPath s
	| rsyncUrlIsShell s = False
	| otherwise = ':' `notElem` s

{- Parses the String looking for rsync progress output, and returns
 - Maybe the number of bytes rsynced so far, and any any remainder of the
 - string that could be an incomplete progress output. That remainder
 - should be prepended to future output, and fed back in. This interface
 - allows the output to be read in any desired size chunk, or even one
 - character at a time.
 -
 - Strategy: Look for chunks prefixed with \r (rsync writes a \r before
 - the first progress output, and each thereafter). The first number
 - after the \r is the number of bytes processed. After the number,
 - there must appear some whitespace, or we didn't get the whole number,
 - and return the \r and part we did get, for later processing.
 -
 - In some locales, the number will have one or more commas in the middle
 - of it.
 -}
parseRsyncProgress :: String -> (Maybe Integer, String)
parseRsyncProgress = go [] . reverse . progresschunks
  where
	go remainder [] = (Nothing, remainder)
	go remainder (x:xs) = case parsebytes (findbytesstart x) of
		Nothing -> go (delim:x++remainder) xs
		Just b -> (Just b, remainder)

	delim = '\r'
	{- Find chunks that each start with delim.
	 - The first chunk doesn't start with it
	 - (it's empty when delim is at the start of the string). -}
	progresschunks = drop 1 . split [delim]
	findbytesstart s = dropWhile isSpace s
	parsebytes s = case break isSpace s of
		([], _) -> Nothing
		(_, []) -> Nothing
		(b, _) -> readish $ filter (/= ',') b

{- Filters options to those that are safe to pass to rsync in server mode,
 - without causing it to eg, expose files. -}
filterRsyncSafeOptions :: [String] -> [String]
filterRsyncSafeOptions = fst3 . getOpt Permute
	[ Option [] ["bwlimit"] (reqArgLong "bwlimit") "" ]
  where
	reqArgLong x = ReqArg (\v -> "--" ++ x ++ "=" ++ v) ""


code:
{- SRV record lookup
 -
 - Uses either the ADNS Haskell library, or the standalone Haskell DNS
 - package, or the host command.
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.SRV (
	mkSRVTcp,
	mkSRV,
	lookupSRV,
	lookupSRVHost,
	HostPort,
) where

import Utility.Process
import Utility.Exception
import Utility.PartialPrelude

import Network
import Data.Function
import Data.List
import Control.Applicative
import Data.Maybe

#ifdef WITH_ADNS
import ADNS.Resolver
import Data.Either
#else
#ifdef WITH_DNS
import qualified Network.DNS.Lookup as DNS
import Network.DNS.Resolver
import qualified Data.ByteString.UTF8 as B8
#endif
#endif

newtype SRV = SRV String
	deriving (Show, Eq)

type HostPort = (HostName, PortID)

type PriorityWeight = (Int, Int) -- sort by priority first, then weight

mkSRV :: String -> String -> HostName -> SRV
mkSRV transport protocol host = SRV $ concat
	["_", protocol, "._", transport, ".", host]

mkSRVTcp :: String -> HostName -> SRV
mkSRVTcp = mkSRV "tcp"

{- Returns an ordered list, with highest priority hosts first.
 -
 - On error, returns an empty list. -}
lookupSRV :: SRV -> IO [HostPort]
#ifdef WITH_ADNS
lookupSRV (SRV srv) = initResolver [] $ \resolver -> do
	r <- catchDefaultIO (Right []) $
		resolveSRV resolver srv
	return $ either (\_ -> []) id r
#else
#ifdef WITH_DNS
lookupSRV (SRV srv) = do
	seed <- makeResolvSeed defaultResolvConf
	r <- withResolver seed $ flip DNS.lookupSRV $ B8.fromString srv
	return $
#if MIN_VERSION_dns(1,0,0)
		either (const []) use r
#else
		maybe [] use r
#endif
  where
  	use = orderHosts . map tohosts
	tohosts (priority, weight, port, hostname) =
		( (priority, weight)
		, (B8.toString hostname, PortNumber $ fromIntegral port)
		)
#else
lookupSRV = lookupSRVHost
#endif
#endif

lookupSRVHost :: SRV -> IO [HostPort]
lookupSRVHost (SRV srv) = catchDefaultIO [] $
	parseSrvHost <$> readProcessEnv "host" ["-t", "SRV", "--", srv]
		-- clear environment, to avoid LANG affecting output
		(Just [])

parseSrvHost :: String -> [HostPort]
parseSrvHost = orderHosts . catMaybes . map parse . lines
  where
	parse l = case words l of
		[_, _, _, _, spriority, sweight, sport, hostname] -> do
			let v =
				( readish sport :: Maybe Int
				, readish spriority :: Maybe Int
				, readish sweight :: Maybe Int
				)
			case v of
				(Just port, Just priority, Just weight) -> Just
					( (priority, weight)
					, (hostname, PortNumber $ fromIntegral port)
					)
				_ -> Nothing
		_ -> Nothing

orderHosts :: [(PriorityWeight, HostPort)] -> [HostPort]
orderHosts = map snd . sortBy (compare `on` fst)


code:
{- safely running shell commands
 -
 - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.SafeCommand where

import System.Exit
import Utility.Process
import Data.String.Utils
import Control.Applicative
import System.FilePath
import Data.Char

{- A type for parameters passed to a shell command. A command can
 - be passed either some Params (multiple parameters can be included,
 - whitespace-separated, or a single Param (for when parameters contain
 - whitespace), or a File.
 -}
data CommandParam = Params String | Param String | File FilePath
	deriving (Eq, Show, Ord)

{- Used to pass a list of CommandParams to a function that runs
 - a command and expects Strings. -}
toCommand :: [CommandParam] -> [String]
toCommand = concatMap unwrap
  where
	unwrap (Param s) = [s]
	unwrap (Params s) = filter (not . null) (split " " s)
	-- Files that start with a non-alphanumeric that is not a path
	-- separator are modified to avoid the command interpreting them as
	-- options or other special constructs.
	unwrap (File s@(h:_))
		| isAlphaNum h || h `elem` pathseps = [s]
		| otherwise = ["./" ++ s]
	unwrap (File s) = [s]
	-- '/' is explicitly included because it's an alternative
	-- path separator on Windows.
	pathseps = pathSeparator:"./"

{- Run a system command, and returns True or False
 - if it succeeded or failed.
 -}
boolSystem :: FilePath -> [CommandParam] -> IO Bool
boolSystem command params = boolSystemEnv command params Nothing

boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ
  where
	dispatch ExitSuccess = True
	dispatch _ = False

{- Runs a system command, returning the exit status. -}
safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
safeSystem command params = safeSystemEnv command params Nothing

safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode
safeSystemEnv command params environ = do
	(_, _, _, pid) <- createProcess (proc command $ toCommand params)
		{ env = environ }
	waitForProcess pid

{- Wraps a shell command line inside sh -c, allowing it to be run in a
 - login shell that may not support POSIX shell, eg csh. -}
shellWrap :: String -> String
shellWrap cmdline = "sh -c " ++ shellEscape cmdline

{- Escapes a filename or other parameter to be safely able to be exposed to
 - the shell.
 -
 - This method works for POSIX shells, as well as other shells like csh.
 -}
shellEscape :: String -> String
shellEscape f = "'" ++ escaped ++ "'"
  where
	-- replace ' with '"'"'
	escaped = join "'\"'\"'" $ split "'" f

{- Unescapes a set of shellEscaped words or filenames. -}
shellUnEscape :: String -> [String]
shellUnEscape [] = []
shellUnEscape s = word : shellUnEscape rest
  where
	(word, rest) = findword "" s
	findword w [] = (w, "")
	findword w (c:cs)
		| c == ' ' = (w, cs)
		| c == '\'' = inquote c w cs
		| c == '"' = inquote c w cs
		| otherwise = findword (w++[c]) cs
	inquote _ w [] = (w, "")
	inquote q w (c:cs)
		| c == q = findword w cs
		| otherwise = inquote q (w++[c]) cs

{- For quickcheck. -}
prop_idempotent_shellEscape :: String -> Bool
prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s
prop_idempotent_shellEscape_multiword :: [String] -> Bool
prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s

{- Segements a list of filenames into groups that are all below the manximum
 - command-line length limit. Does not preserve order. -}
segmentXargs :: [FilePath] -> [[FilePath]]
segmentXargs l = go l [] 0 []
  where
	go [] c _ r = c:r
	go (f:fs) c accumlen r
		| len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r)
		| otherwise = go fs (f:c) newlen r
	  where
		len = length f
		newlen = accumlen + len

	{- 10k of filenames per command, well under Linux's 20k limit;
	 - allows room for other parameters etc. -}
	maxlen = 10240


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

module Utility.Scheduled (
	Schedule(..),
	Recurrance(..),
	ScheduledTime(..),
	NextTime(..),
	WeekDay,
	MonthDay,
	YearDay,
	nextTime,
	calcNextTime,
	startTime,
	fromSchedule,
	fromScheduledTime,
	toScheduledTime,
	fromRecurrance,
	toRecurrance,
	toSchedule,
	parseSchedule,
	prop_schedule_roundtrips,
	prop_past_sane,
) where

import Utility.Data
import Utility.QuickCheck
import Utility.PartialPrelude
import Utility.Misc

import Control.Applicative
import Data.List
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Time.Calendar
import Data.Time.Calendar.WeekDate
import Data.Time.Calendar.OrdinalDate
import Data.Tuple.Utils
import Data.Char

{- Some sort of scheduled event. -}
data Schedule = Schedule Recurrance ScheduledTime
  deriving (Eq, Read, Show, Ord)

data Recurrance
	= Daily
	| Weekly (Maybe WeekDay)
	| Monthly (Maybe MonthDay)
	| Yearly (Maybe YearDay)
	| Divisible Int Recurrance
	-- ^ Days, Weeks, or Months of the year evenly divisible by a number.
	-- (Divisible Year is years evenly divisible by a number.)
  deriving (Eq, Read, Show, Ord)

type WeekDay = Int
type MonthDay = Int
type YearDay = Int

data ScheduledTime
	= AnyTime
	| SpecificTime Hour Minute
  deriving (Eq, Read, Show, Ord)

type Hour = Int
type Minute = Int

-- | Next time a Schedule should take effect. The NextTimeWindow is used
-- when a Schedule is allowed to start at some point within the window.
data NextTime
	= NextTimeExactly LocalTime
	| NextTimeWindow LocalTime LocalTime
  deriving (Eq, Read, Show)

startTime :: NextTime -> LocalTime
startTime (NextTimeExactly t) = t
startTime (NextTimeWindow t _) = t

nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime)
nextTime schedule lasttime = do
	now <- getCurrentTime
	tz <- getTimeZone now
	return $ calcNextTime schedule lasttime $ utcToLocalTime tz now

-- | Calculate the next time that fits a Schedule, based on the
-- last time it occurred, and the current time.
calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime
calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime
	| scheduledtime == AnyTime = do
		next <- findfromtoday True
		return $ case next of
			NextTimeWindow _ _ -> next
			NextTimeExactly t -> window (localDay t) (localDay t)
	| otherwise = NextTimeExactly . startTime <$> findfromtoday False
  where
  	findfromtoday anytime = findfrom recurrance afterday today
	  where
	  	today = localDay currenttime
		afterday = sameaslastrun || toolatetoday
		toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime
		sameaslastrun = lastrun == Just today
	lastrun = localDay <$> lasttime
	nexttime = case scheduledtime of
		AnyTime -> TimeOfDay 0 0 0
		SpecificTime h m -> TimeOfDay h m 0
	exactly d = NextTimeExactly $ LocalTime d nexttime
	window startd endd = NextTimeWindow
		(LocalTime startd nexttime)
		(LocalTime endd (TimeOfDay 23 59 0))
	findfrom r afterday candidate
		| ynum candidate > (ynum (localDay currenttime)) + 100 =
			-- avoid possible infinite recusion
			error $ "bug: calcNextTime did not find a time within 100 years to run " ++
			show (schedule, lasttime, currenttime)
		| otherwise = findfromChecked r afterday candidate
	findfromChecked r afterday candidate = case r of
		Daily
			| afterday -> Just $ exactly $ addDays 1 candidate
			| otherwise -> Just $ exactly candidate
		Weekly Nothing
			| afterday -> skip 1
			| otherwise -> case (wday <$> lastrun, wday candidate) of
				(Nothing, _) -> Just $ window candidate (addDays 6 candidate)
				(Just old, curr)
					| old == curr -> Just $ window candidate (addDays 6 candidate)
					| otherwise -> skip 1
		Monthly Nothing
			| afterday -> skip 1
			| maybe True (candidate `oneMonthPast`) lastrun ->
				Just $ window candidate (endOfMonth candidate)
			| otherwise -> skip 1
		Yearly Nothing
			| afterday -> skip 1
			| maybe True (candidate `oneYearPast`) lastrun ->
				Just $ window candidate (endOfYear candidate)
			| otherwise -> skip 1
		Weekly (Just w)
			| w < 0 || w > maxwday -> Nothing
			| w == wday candidate -> if afterday
				then Just $ exactly $ addDays 7 candidate
				else Just $ exactly candidate
			| otherwise -> Just $ exactly $
				addDays (fromIntegral $ (w - wday candidate) `mod` 7) candidate
		Monthly (Just m)
			| m < 0 || m > maxmday -> Nothing
			-- TODO can be done more efficiently than recursing
			| m == mday candidate -> if afterday
				then skip 1
				else Just $ exactly candidate
			| otherwise -> skip 1
		Yearly (Just y)
			| y < 0 || y > maxyday -> Nothing
			| y == yday candidate -> if afterday
				then skip 365
				else Just $ exactly candidate
			| otherwise -> skip 1
		Divisible n r'@Daily -> handlediv n r' yday (Just maxyday)
		Divisible n r'@(Weekly _) -> handlediv n r' wnum (Just maxwnum)
		Divisible n r'@(Monthly _) -> handlediv n r' mnum (Just maxmnum)
		Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing
		Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate
	  where
	  	skip n = findfrom r False (addDays n candidate)
	  	handlediv n r' getval mmax
			| n > 0 && maybe True (n <=) mmax =
				findfromwhere r' (divisible n . getval) afterday candidate
			| otherwise = Nothing
	findfromwhere r p afterday candidate
		| maybe True (p . getday) next = next
		| otherwise = maybe Nothing (findfromwhere r p True . getday) next
	  where
		next = findfrom r afterday candidate
		getday = localDay . startTime
	divisible n v = v `rem` n == 0

-- Check if the new Day occurs one month or more past the old Day.
oneMonthPast :: Day -> Day -> Bool
new `oneMonthPast` old = fromGregorian y (m+1) d <= new
  where
	(y,m,d) = toGregorian old

-- Check if the new Day occurs one year or more past the old Day.
oneYearPast :: Day -> Day -> Bool
new `oneYearPast` old = fromGregorian (y+1) m d <= new
  where
	(y,m,d) = toGregorian old

endOfMonth :: Day -> Day
endOfMonth day =
	let (y,m,_d) = toGregorian day
	in fromGregorian y m (gregorianMonthLength y m)

endOfYear :: Day -> Day
endOfYear day =
	let (y,_m,_d) = toGregorian day
	in endOfMonth (fromGregorian y maxmnum 1)

-- extracting various quantities from a Day
wday :: Day -> Int
wday = thd3 . toWeekDate
wnum :: Day -> Int
wnum = snd3 . toWeekDate
mday :: Day -> Int
mday = thd3 . toGregorian
mnum :: Day -> Int
mnum = snd3 . toGregorian
yday :: Day -> Int
yday = snd . toOrdinalDate
ynum :: Day -> Int
ynum = fromIntegral . fst . toOrdinalDate

-- Calendar max values.
maxyday :: Int
maxyday = 366 -- with leap days
maxwnum :: Int
maxwnum = 53 -- some years have more than 52
maxmday :: Int
maxmday = 31
maxmnum :: Int
maxmnum = 12
maxwday :: Int
maxwday = 7

fromRecurrance :: Recurrance -> String
fromRecurrance (Divisible n r) =
	fromRecurrance' (++ "s divisible by " ++ show n) r
fromRecurrance r = fromRecurrance' ("every " ++) r

fromRecurrance' :: (String -> String) -> Recurrance -> String
fromRecurrance' a Daily = a "day"
fromRecurrance' a (Weekly n) = onday n (a "week")
fromRecurrance' a (Monthly n) = onday n (a "month")
fromRecurrance' a (Yearly n) = onday n (a "year")
fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used

onday :: Maybe Int -> String -> String
onday (Just n) s = "on day " ++ show n ++ " of " ++ s
onday Nothing s = s

toRecurrance :: String -> Maybe Recurrance
toRecurrance s = case words s of
	("every":"day":[]) -> Just Daily
	("on":"day":sd:"of":"every":something:[]) -> withday sd something
	("every":something:[]) -> noday something
	("days":"divisible":"by":sn:[]) ->
		Divisible <$> getdivisor sn <*> pure Daily
	("on":"day":sd:"of":something:"divisible":"by":sn:[]) ->
		Divisible
			<$> getdivisor sn
			<*> withday sd something
	("every":something:"divisible":"by":sn:[]) ->
		Divisible
			<$> getdivisor sn
			<*> noday something
	(something:"divisible":"by":sn:[]) ->
		Divisible
			<$> getdivisor sn
			<*> noday something
	_ -> Nothing
  where
	constructor "week" = Just Weekly
	constructor "month" = Just Monthly
	constructor "year" = Just Yearly
	constructor u
		| "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u
		| otherwise = Nothing
  	withday sd u = do
		c <- constructor u
		d <- readish sd
		Just $ c (Just d)
	noday u = do
		c <- constructor u
		Just $ c Nothing
	getdivisor sn = do
		n <- readish sn
		if n > 0
			then Just n
			else Nothing

fromScheduledTime :: ScheduledTime -> String
fromScheduledTime AnyTime = "any time"
fromScheduledTime (SpecificTime h m) =
	show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm
  where
  	pad n s = take (n - length s) (repeat '0') ++ s
	(h', ampm)
		| h == 0 = (12, "AM")
		| h < 12 = (h, "AM")
		| h == 12 = (h, "PM")
		| otherwise = (h - 12, "PM")

toScheduledTime :: String -> Maybe ScheduledTime
toScheduledTime "any time" = Just AnyTime
toScheduledTime v = case words v of
	(s:ampm:[])
		| map toUpper ampm == "AM" ->
			go s h0
		| map toUpper ampm == "PM" ->
			go s (\h -> (h0 h) + 12)
		| otherwise -> Nothing
	(s:[]) -> go s id
	_ -> Nothing
  where
  	h0 h
		| h == 12 = 0
		| otherwise = h
  	go :: String -> (Int -> Int) -> Maybe ScheduledTime
	go s adjust =
		let (h, m) = separate (== ':') s
		in SpecificTime
			<$> (adjust <$> readish h)
			<*> if null m then Just 0 else readish m

fromSchedule :: Schedule -> String
fromSchedule (Schedule recurrance scheduledtime) = unwords
	[ fromRecurrance recurrance
	, "at"
	, fromScheduledTime scheduledtime
	]

toSchedule :: String -> Maybe Schedule
toSchedule = eitherToMaybe . parseSchedule

parseSchedule :: String -> Either String Schedule
parseSchedule s = do
	r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right
		(toRecurrance recurrance)
	t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right
		(toScheduledTime scheduledtime)
	Right $ Schedule r t
  where
	(rws, tws) = separate (== "at") (words s)
	recurrance = unwords rws
	scheduledtime = unwords tws

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

instance Arbitrary ScheduledTime where
	arbitrary = oneof
		[ pure AnyTime
		, SpecificTime
			<$> choose (0, 23)
			<*> choose (1, 59)
		]

instance Arbitrary Recurrance where
	arbitrary = oneof
		[ pure Daily
		, Weekly <$> arbday
		, Monthly <$> arbday
		, Yearly <$> arbday
		, Divisible
			<$> positive arbitrary
			<*> oneof -- no nested Divisibles
				[ pure Daily
				, Weekly <$> arbday
				, Monthly <$> arbday
				, Yearly <$> arbday
				]
		]
	  where
	  	arbday = oneof
			[ Just <$> nonNegative arbitrary
			, pure Nothing
			]

prop_schedule_roundtrips :: Schedule -> Bool
prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s

prop_past_sane :: Bool
prop_past_sane = and
	[ all (checksout oneMonthPast) (mplus1 ++ yplus1)
	, all (not . (checksout oneMonthPast)) (map swap (mplus1 ++ yplus1))
	, all (checksout oneYearPast) yplus1
	, all (not . (checksout oneYearPast)) (map swap yplus1)
	]
  where
	mplus1 =   -- new date               old date, 1+ months before it
		[ (fromGregorian 2014 01 15, fromGregorian 2013 12 15)
		, (fromGregorian 2014 01 15, fromGregorian 2013 02 15)
		, (fromGregorian 2014 02 15, fromGregorian 2013 01 15)
		, (fromGregorian 2014 03 01, fromGregorian 2013 01 15)
		, (fromGregorian 2014 03 01, fromGregorian 2013 12 15)
		, (fromGregorian 2015 01 01, fromGregorian 2010 01 01)
		]
	yplus1 =   -- new date               old date, 1+ years before it
		[ (fromGregorian 2014 01 15, fromGregorian 2012 01 16)
		, (fromGregorian 2014 01 15, fromGregorian 2013 01 14)
		, (fromGregorian 2022 12 31, fromGregorian 2000 01 01)
		]
	checksout cmp (new, old) = new `cmp` old
	swap (a,b) = (b,a)


code:
{- /bin/sh handling
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.Shell where

shellPath_portable :: FilePath
shellPath_portable = "/bin/sh"

shellPath_local :: FilePath
#ifndef __ANDROID__
shellPath_local = shellPath_portable
#else
shellPath_local = "/system/bin/sh"
#endif

shebang_portable :: String
shebang_portable = "#!" ++ shellPath_portable

shebang_local :: String
shebang_local = "#!" ++ shellPath_local


code:
{- Simple line-based protocols.
 -
 - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.SimpleProtocol (
	Sendable(..),
	Receivable(..),
	parseMessage,
	Serializable(..),
	Parser,
	parseFail,
	parse0,
	parse1,
	parse2,
	parse3,
	ioHandles,
) where

import Data.Char
import GHC.IO.Handle

import Common

-- Messages that can be sent.
class Sendable m where
	formatMessage :: m -> [String]

-- Messages that can be received.
class Receivable m where
	-- Passed the first word of the message, returns
	-- a Parser that can be be fed the rest of the message to generate
	-- the value.
	parseCommand :: String -> Parser m

parseMessage :: (Receivable m) => String -> Maybe m
parseMessage s = parseCommand command rest
  where
	(command, rest) = splitWord s

class Serializable a where
	serialize :: a -> String
	deserialize :: String -> Maybe a

{- Parsing the parameters of messages. Using the right parseN ensures
 - that the string is split into exactly the requested number of words,
 - which allows the last parameter of a message to contain arbitrary
 - whitespace, etc, without needing any special quoting.
 -}
type Parser a = String -> Maybe a

parseFail :: Parser a
parseFail _ = Nothing

parse0 :: a -> Parser a
parse0 mk "" = Just mk
parse0 _ _ = Nothing

parse1 :: Serializable p1 => (p1 -> a) -> Parser a
parse1 mk p1 = mk <$> deserialize p1

parse2 :: (Serializable p1, Serializable p2) => (p1 -> p2 -> a) -> Parser a
parse2 mk s = mk <$> deserialize p1 <*> deserialize p2
  where
	(p1, p2) = splitWord s

parse3 :: (Serializable p1, Serializable p2, Serializable p3) => (p1 -> p2 -> p3 -> a) -> Parser a
parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3
  where
	(p1, rest) = splitWord s
	(p2, p3) = splitWord rest

splitWord :: String -> (String, String)
splitWord = separate isSpace

{- When a program speaks a simple protocol over stdio, any other output
 - to stdout (or anything that attempts to read from stdin)
 - will mess up the protocol. To avoid that, close stdin, and
 - and duplicate stderr to stdout. Return two new handles
 - that are duplicates of the original (stdin, stdout). -}
ioHandles :: IO (Handle, Handle)
ioHandles = do
	readh <- hDuplicate stdin
	writeh <- hDuplicate stdout
	nullh <- openFile devNull ReadMode
	nullh `hDuplicateTo` stdin
	stderr `hDuplicateTo` stdout
	return (readh, writeh)


code:
{- ssh config file parsing and modification
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.SshConfig where

import Common
import Utility.UserInfo
import Utility.Tmp
import Utility.FileMode

import Data.Char
import Data.Ord
import Data.Either

data SshConfig
	= GlobalConfig SshSetting
	| HostConfig Host [Either Comment SshSetting]
	| CommentLine Comment
	deriving (Show)

data Comment = Comment Indent String
	deriving (Show)

data SshSetting = SshSetting Indent Key Value
	deriving (Show)

type Indent = String
type Host = String
type Key = String
type Value = String

{- Parses ~/.ssh/config. Comments and indentation are preserved.
 -
 - Note that there is no parse failure. If a line cannot be parsed, it will
 - be taken to be a SshSetting that contains the whole line as the key,
 - and has no value. -}
parseSshConfig :: String -> [SshConfig]
parseSshConfig = go [] . lines
  where
	go c [] = reverse c
	go c (l:ls)
		| iscomment l = collect $ CommentLine $ mkcomment l
		| otherwise = case splitline l of
			(indent, k, v)
				| isHost k -> hoststanza v c [] ls
				| otherwise -> collect $ GlobalConfig $ SshSetting indent k v
	  where
		collect v = go (v:c) ls

	hoststanza host c hc [] = go (HostConfig host (reverse hc):c) []
	hoststanza host c hc (l:ls)
		| iscomment l = hoststanza host c ((Left $ mkcomment l):hc) ls
		| otherwise = case splitline l of
			(indent, k, v)
			 	| isHost k -> hoststanza v
					(HostConfig host (reverse hc):c) [] ls
				| otherwise -> hoststanza host c
					((Right $ SshSetting indent k v):hc) ls

	iscomment l = all isSpace l || "#" `isPrefixOf` (dropWhile isSpace l)

	splitline l = (indent, k, v)
	  where
		(indent, rest) = span isSpace l
		(k, v) = separate isSpace rest

	mkcomment l = Comment indent c
	  where
		(indent, c) = span isSpace l

	isHost v = map toLower v == "host"

genSshConfig :: [SshConfig] -> String
genSshConfig = unlines . concatMap gen
  where
	gen (CommentLine c) = [comment c]
	gen (GlobalConfig s) = [setting s]
	gen (HostConfig h cs) = ("Host " ++ h) : map (either comment setting) cs

	setting (SshSetting indent k v) = indent ++ k ++ " " ++ v
	comment (Comment indent c) = indent ++ c

findHostConfigKey :: SshConfig -> Key -> Maybe Value
findHostConfigKey (HostConfig _ cs) wantk = go (rights cs) (map toLower wantk)
  where
  	go [] _ = Nothing
	go ((SshSetting _ k v):rest) wantk'
		| map toLower k == wantk' = Just v
		| otherwise = go rest wantk'
findHostConfigKey _ _ = Nothing

{- Adds a particular Key and Value to a HostConfig. -}
addToHostConfig :: SshConfig -> Key -> Value -> SshConfig
addToHostConfig (HostConfig host cs) k v =
	HostConfig host $ Right (SshSetting indent k v) : cs
  where
 	{- The indent is taken from any existing SshSetting
	 - in the HostConfig (largest indent wins). -}
	indent = fromMaybe "\t" $ headMaybe $ reverse $
		sortBy (comparing length) $ map getindent cs
	getindent (Right (SshSetting i _ _)) = i
	getindent (Left (Comment i _)) = i
addToHostConfig other _ _ = other

modifyUserSshConfig :: ([SshConfig] -> [SshConfig]) -> IO ()
modifyUserSshConfig modifier = changeUserSshConfig $
	genSshConfig . modifier . parseSshConfig

changeUserSshConfig :: (String -> String) -> IO ()
changeUserSshConfig modifier = do
	sshdir <- sshDir
	let configfile = sshdir </> "config"
	whenM (doesFileExist configfile) $ do
		c <- readFileStrict configfile
		let c' = modifier c
		when (c /= c') $
			viaTmp writeSshConfig configfile c'

writeSshConfig :: FilePath -> String -> IO ()
writeSshConfig f s = do
	writeFile f s
	setSshConfigMode f

{- Ensure that the ssh config file lacks any group or other write bits,
 - since ssh is paranoid about not working if other users can write
 - to one of its config files (.ssh/config and .ssh/authorized_keys).
 -
 - If the chmod fails, ignore the failure, as it might be a filesystem like
 - Android's that does not support file modes.
 -}
setSshConfigMode :: FilePath -> IO ()
setSshConfigMode f = void $ tryIO $ modifyFileMode f $
	removeModes [groupWriteMode, otherWriteMode]

sshDir :: IO FilePath
sshDir = do
	home <- myHomeDir
	return $ home </> ".ssh"


code:
{- Transactional lists
 -
 - Based on DLists, a transactional list can quickly and efficiently
 - have items inserted at either end, or a whole list appended to it.
 -
 - Unlike a TQueue, the entire contents of a TList can be efficiently
 - read without modifying it.
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -}

{-# LANGUAGE BangPatterns #-}

module Utility.TList where

import Common

import Control.Concurrent.STM
import qualified Data.DList as D

type TList a = TMVar (D.DList a)

newTList :: STM (TList a)
newTList = newEmptyTMVar

{- Gets the contents of the TList. Blocks when empty.
 - TList is left empty. -}
getTList :: TList a -> STM [a]
getTList tlist = D.toList <$> getTDList tlist

getTDList :: TList a -> STM (D.DList a)
getTDList = takeTMVar

{- Replaces the contents of the TList. -}
setTList :: TList a -> [a] -> STM ()
setTList tlist = setTDList tlist . D.fromList

setTDList :: TList a -> D.DList a -> STM ()
setTDList tlist = modifyTList tlist . const

{- Takes anything currently in the TList, without blocking.
 - TList is left empty. -}
takeTList :: TList a -> STM [a]
takeTList tlist = maybe [] D.toList <$> tryTakeTMVar tlist

{- Reads anything in the list, without modifying it, or blocking. -}
readTList :: TList a -> STM [a]
readTList tlist = maybe [] D.toList <$> tryReadTMVar tlist

{- Mutates a TList. -}
modifyTList :: TList a -> (D.DList a -> D.DList a) -> STM ()
modifyTList tlist a = do
	dl <- fromMaybe D.empty <$> tryTakeTMVar tlist
	let !dl' = a dl
	{- The TMVar is left empty when the list is empty.
	 - Thus attempts to read it automatically block. -}
	unless (emptyDList dl') $
		putTMVar tlist dl'
  where
  	emptyDList = D.list True (\_ _ -> False)

consTList :: TList a -> a -> STM ()
consTList tlist v = modifyTList tlist $ \dl -> D.cons v dl

snocTList :: TList a -> a -> STM ()
snocTList tlist v = modifyTList tlist $ \dl -> D.snoc dl v

appendTList :: TList a -> [a] -> STM ()
appendTList tlist l = modifyTList tlist $ \dl -> D.append dl (D.fromList l)


code:
{- Past and present tense text.
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE OverloadedStrings #-}

module Utility.Tense where

import qualified Data.Text as T
import Data.Text (Text)
import GHC.Exts( IsString(..) )

data Tense = Present | Past
	deriving (Eq)

data TenseChunk = Tensed Text Text | UnTensed Text
	deriving (Eq, Ord, Show)

newtype TenseText = TenseText [TenseChunk]
	deriving (Eq, Ord)

{- Allows OverloadedStrings to be used, to build UnTensed chunks. -}
instance IsString TenseChunk where
	fromString = UnTensed . T.pack

{- Allows OverloadedStrings to be used, to provide UnTensed TenseText. -}
instance IsString TenseText where
	fromString s = TenseText [fromString s]

renderTense :: Tense -> TenseText -> Text
renderTense tense (TenseText chunks) = T.concat $ map render chunks
  where
	render (Tensed present past)
		| tense == Present = present
		| otherwise = past
	render (UnTensed s) = s

{- Builds up a TenseText, separating chunks with spaces.
 -
 - However, rather than just intersperse new chunks for the spaces,
 - the spaces are appended to the end of the chunks.
 -}
tenseWords :: [TenseChunk] -> TenseText
tenseWords = TenseText . go []
  where
	go c [] = reverse c
	go c (w:[]) = reverse (w:c)
	go c ((UnTensed w):ws) = go (UnTensed (addspace w) : c) ws
	go c ((Tensed w1 w2):ws) =
		go (Tensed (addspace w1) (addspace w2) : c) ws
	addspace w = T.append w " "

unTensed :: Text -> TenseText
unTensed t = TenseText [UnTensed t]


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

module Utility.ThreadLock where

import Control.Concurrent.MVar

type Lock = MVar ()

newLock :: IO Lock
newLock = newMVar ()

{- Runs an action with a lock held, so only one thread at a time can run it. -}
withLock :: Lock -> IO a -> IO a
withLock lock = withMVar lock . const


code:
{- thread scheduling
 -
 - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
 - Copyright 2011 Bas van Dijk & Roel van Dijk
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.ThreadScheduler where

import Control.Monad
import Control.Concurrent
#ifndef mingw32_HOST_OS
import Control.Monad.IfElse
import System.Posix.IO
#endif
#ifndef mingw32_HOST_OS
import System.Posix.Signals
#ifndef __ANDROID__
import System.Posix.Terminal
#endif
#endif

newtype Seconds = Seconds { fromSeconds :: Int }
	deriving (Eq, Ord, Show)

type Microseconds = Integer

{- Runs an action repeatedly forever, sleeping at least the specified number
 - of seconds in between. -}
runEvery :: Seconds -> IO a -> IO a
runEvery n a = forever $ do
	threadDelaySeconds n
	a

threadDelaySeconds :: Seconds -> IO ()
threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)

{- Like threadDelay, but not bounded by an Int.
 -
 - There is no guarantee that the thread will be rescheduled promptly when the
 - delay has expired, but the thread will never continue to run earlier than
 - specified.
 -
 - Taken from the unbounded-delay package to avoid a dependency for 4 lines
 - of code.
 -}
unboundDelay :: Microseconds -> IO ()
unboundDelay time = do
	let maxWait = min time $ toInteger (maxBound :: Int)
	threadDelay $ fromInteger maxWait
	when (maxWait /= time) $ unboundDelay (time - maxWait)

{- Pauses the main thread, letting children run until program termination. -}
waitForTermination :: IO ()
waitForTermination = do
#ifdef mingw32_HOST_OS
	forever $ threadDelaySeconds (Seconds 6000)
#else
	lock <- newEmptyMVar
	let check sig = void $
		installHandler sig (CatchOnce $ putMVar lock ()) Nothing
	check softwareTermination
#ifndef __ANDROID__
	whenM (queryTerminal stdInput) $
		check keyboardSignal
#endif
	takeMVar lock
#endif

oneSecond :: Microseconds
oneSecond = 1000000


code:
{- Temporary files and directories.
 -
 - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.Tmp where

import System.IO
import System.Directory
import Control.Monad.IfElse
import System.FilePath
import Control.Monad.IO.Class
import Control.Monad.Catch (bracket, MonadMask)

import Utility.Exception
import Utility.FileSystemEncoding
import Utility.PosixFiles

type Template = String

{- Runs an action like writeFile, writing to a temp file first and
 - then moving it into place. The temp file is stored in the same
 - directory as the final file to avoid cross-device renames. -}
viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO ()
viaTmp a file content = bracket setup cleanup use
  where
	(dir, base) = splitFileName file
	template = base ++ ".tmp"
	setup = do
		createDirectoryIfMissing True dir
		openTempFile dir template
	cleanup (tmpfile, handle) = do
		_ <- tryIO $ hClose handle
		tryIO $ removeFile tmpfile
	use (tmpfile, handle) = do
		hClose handle
		a tmpfile content
		rename tmpfile file

{- Runs an action with a tmp file located in the system's tmp directory
 - (or in "." if there is none) then removes the file. -}
withTmpFile :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a
withTmpFile template a = do
	tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
	withTmpFileIn tmpdir template a

{- Runs an action with a tmp file located in the specified directory,
 - then removes the file. -}
withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a
withTmpFileIn tmpdir template a = bracket create remove use
  where
	create = liftIO $ openTempFile tmpdir template
	remove (name, handle) = liftIO $ do
		hClose handle
		catchBoolIO (removeFile name >> return True)
	use (name, handle) = a name handle

{- Runs an action with a tmp directory located within the system's tmp
 - directory (or within "." if there is none), then removes the tmp
 - directory and all its contents. -}
withTmpDir :: Template -> (FilePath -> IO a) -> IO a
withTmpDir template a = do
	tmpdir <- catchDefaultIO "." getTemporaryDirectory
	withTmpDirIn tmpdir template a

{- Runs an action with a tmp directory located within a specified directory,
 - then removes the tmp directory and all its contents. -}
withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a
withTmpDirIn tmpdir template = bracket create remove
  where
	remove d = whenM (doesDirectoryExist d) $ do
#if mingw32_HOST_OS
		-- Windows will often refuse to delete a file
		-- after a process has just written to it and exited.
		-- Because it's crap, presumably. So, ignore failure
		-- to delete the temp directory.
		_ <- tryIO $ removeDirectoryRecursive d
		return ()
#else
		removeDirectoryRecursive d
#endif
	create = do
		createDirectoryIfMissing True tmpdir
		makenewdir (tmpdir </> template) (0 :: Int)
	makenewdir t n = do
		let dir = t ++ "." ++ show n
		either (const $ makenewdir t $ n + 1) (const $ return dir)
			=<< tryIO (createDirectory dir)

{- It's not safe to use a FilePath of an existing file as the template
 - for openTempFile, because if the FilePath is really long, the tmpfile
 - will be longer, and may exceed the maximum filename length.
 -
 - This generates a template that is never too long.
 - (Well, it allocates 20 characters for use in making a unique temp file,
 - anyway, which is enough for the current implementation and any
 - likely implementation.)
 -}
relatedTemplate :: FilePath -> FilePath
relatedTemplate f
	| len > 20 = truncateFilePath (len - 20) f
	| otherwise = f
  where
	len = length f


code:
{- More control over touching a file.
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE ForeignFunctionInterface #-}

module Utility.Touch (
	TimeSpec(..),
	touchBoth,
	touch
) where

import Utility.FileSystemEncoding

import Foreign
import Foreign.C
import Control.Monad (when)

newtype TimeSpec = TimeSpec CTime

{- Changes the access and modification times of an existing file.
   Can follow symlinks, or not. Throws IO error on failure. -}
touchBoth :: FilePath -> TimeSpec -> TimeSpec -> Bool -> IO ()

touch :: FilePath -> TimeSpec -> Bool -> IO ()
touch file mtime = touchBoth file mtime mtime

#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <sys/time.h>

#ifndef _BSD_SOURCE
#define _BSD_SOURCE
#endif

#if (defined UTIME_OMIT && defined UTIME_NOW && defined AT_FDCWD && defined AT_SYMLINK_NOFOLLOW)

at_fdcwd :: CInt
at_fdcwd = #const AT_FDCWD

at_symlink_nofollow :: CInt
at_symlink_nofollow = #const AT_SYMLINK_NOFOLLOW

instance Storable TimeSpec where
	-- use the larger alignment of the two types in the struct
	alignment _ = max sec_alignment nsec_alignment
	  where
		sec_alignment = alignment (undefined::CTime)
		nsec_alignment = alignment (undefined::CLong)
	sizeOf _ = #{size struct timespec}
	peek ptr = do
		sec <- #{peek struct timespec, tv_sec} ptr
		return $ TimeSpec sec
	poke ptr (TimeSpec sec) = do
		#{poke struct timespec, tv_sec} ptr sec
		#{poke struct timespec, tv_nsec} ptr (0 :: CLong)

{- While its interface is beastly, utimensat is in recent
   POSIX standards, unlike lutimes. -}
foreign import ccall "utimensat"
	c_utimensat :: CInt -> CString -> Ptr TimeSpec -> CInt -> IO CInt

touchBoth file atime mtime follow =
	allocaArray 2 $ \ptr ->
	withFilePath file $ \f -> do
		pokeArray ptr [atime, mtime]
		r <- c_utimensat at_fdcwd f ptr flags
		when (r /= 0) $ throwErrno "touchBoth"
  where
	flags
       		| follow = 0
		| otherwise = at_symlink_nofollow

#else
#if 0
{- Using lutimes is needed for BSD.
 -
 - TODO: test if lutimes is available. May have to do it in configure.
 - TODO: TimeSpec uses a CTime, while tv_sec is a CLong. It is implementation
 - dependent whether these are the same; need to find a cast that works.
 - (Without the cast it works on linux i386, but
 - maybe not elsewhere.)
 -}

instance Storable TimeSpec where
	alignment _ = alignment (undefined::CLong)
	sizeOf _ = #{size struct timeval}
	peek ptr = do
		sec <- #{peek struct timeval, tv_sec} ptr
		return $ TimeSpec sec
	poke ptr (TimeSpec sec) = do
		#{poke struct timeval, tv_sec} ptr sec
		#{poke struct timeval, tv_usec} ptr (0 :: CLong)

foreign import ccall "utimes"
	c_utimes :: CString -> Ptr TimeSpec -> IO CInt
foreign import ccall "lutimes"
	c_lutimes :: CString -> Ptr TimeSpec -> IO CInt

touchBoth file atime mtime follow =
	allocaArray 2 $ \ptr ->
	withFilePath file $ \f -> do
		pokeArray ptr [atime, mtime]
		r <- syscall f ptr
		when (r /= 0) $
			throwErrno "touchBoth"
  where
	syscall
       		| follow = c_lutimes
		| otherwise = c_utimes

#else
#warning "utimensat and lutimes not available; building without symlink timestamp preservation support"
touchBoth _ _ _ _ = return ()
#endif
#endif


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

{-# LANGUAGE CPP #-}

module Utility.URI where

-- Old versions of network lacked an Ord for URI
#if ! MIN_VERSION_network(2,4,0)
import Network.URI

instance Ord URI where
	a `compare` b = show a `compare` show b
#endif


code:
{- Url downloading.
 -
 - Copyright 2011,2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}

module Utility.Url (
	URLString,
	UserAgent,
	UrlOptions(..),
	check,
	checkBoth,
	exists,
	download,
	downloadQuiet,
	parseURIRelaxed
) where

import Common
import Network.URI
import qualified Network.Browser as Browser
import Network.HTTP
import Data.Either
import Data.Default

import qualified Build.SysConfig

type URLString = String

type Headers = [String]

type UserAgent = String

data UrlOptions = UrlOptions
	{ userAgent :: Maybe UserAgent
	, reqHeaders :: Headers
	, reqParams :: [CommandParam]
	}

instance Default UrlOptions
  where
	def = UrlOptions Nothing [] []

{- Checks that an url exists and could be successfully downloaded,
 - also checking that its size, if available, matches a specified size. -}
checkBoth :: URLString -> Maybe Integer -> UrlOptions -> IO Bool
checkBoth url expected_size uo = do
	v <- check url expected_size uo
	return (fst v && snd v)
check :: URLString -> Maybe Integer -> UrlOptions -> IO (Bool, Bool)
check url expected_size = handle <$$> exists url
  where
	handle (False, _) = (False, False)
	handle (True, Nothing) = (True, True)
	handle (True, s) = case expected_size of
		Just _ -> (True, expected_size == s)
		Nothing -> (True, True)

{- Checks that an url exists and could be successfully downloaded,
 - also returning its size if available.
 -
 - For a file: url, check it directly.
 -
 - Uses curl otherwise, when available, since curl handles https better
 - than does Haskell's Network.Browser.
 -}
exists :: URLString -> UrlOptions -> IO (Bool, Maybe Integer)
exists url uo = case parseURIRelaxed url of
	Just u
		| uriScheme u == "file:" -> do
			s <- catchMaybeIO $ getFileStatus (unEscapeString $ uriPath u)
			case s of
				Just stat -> return (True, Just $ fromIntegral $ fileSize stat)
				Nothing -> dne
		| otherwise -> if Build.SysConfig.curl
			then do
				output <- catchDefaultIO "" $
					readProcess "curl" $ toCommand curlparams
				case lastMaybe (lines output) of
					Just ('2':_:_) -> return (True, extractsize output)
					_ -> dne
			else do
				r <- request u HEAD uo
				case rspCode r of
					(2,_,_) -> return (True, size r)
					_ -> return (False, Nothing)
	Nothing -> dne
  where
	dne = return (False, Nothing)

	curlparams = addUserAgent uo $
		[ Param "-s"
		, Param "--head"
		, Param "-L", Param url
		, Param "-w", Param "%{http_code}"
		] ++ concatMap (\h -> [Param "-H", Param h]) (reqHeaders uo) ++ (reqParams uo)

	extractsize s = case lastMaybe $ filter ("Content-Length:" `isPrefixOf`) (lines s) of
		Just l -> case lastMaybe $ words l of
			Just sz -> readish sz
			_ -> Nothing
		_ -> Nothing

	size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders

-- works for both wget and curl commands
addUserAgent :: UrlOptions -> [CommandParam] -> [CommandParam]
addUserAgent uo ps = case userAgent uo of
	Nothing -> ps
	Just ua -> ps ++ [Param "--user-agent", Param ua]

{- Used to download large files, such as the contents of keys.
 -
 - Uses wget or curl program for its progress bar. (Wget has a better one,
 - so is preferred.) Which program to use is determined at run time; it
 - would not be appropriate to test at configure time and build support
 - for only one in.
 -}
download :: URLString -> FilePath -> UrlOptions -> IO Bool
download = download' False

{- No output, even on error. -}
downloadQuiet :: URLString -> FilePath -> UrlOptions -> IO Bool
downloadQuiet = download' True

download' :: Bool -> URLString -> FilePath -> UrlOptions -> IO Bool
download' quiet url file uo =
	case parseURIRelaxed url of
		Just u
			| uriScheme u == "file:" -> do
				-- curl does not create destination file
				-- for an empty file:// url, so pre-create
				writeFile file ""
				curl
			| otherwise -> ifM (inPath "wget") (wget , curl)
		_ -> return False
  where
	headerparams = map (\h -> Param $ "--header=" ++ h) (reqHeaders uo)
	wget = go "wget" $ headerparams ++ quietopt "-q" ++ wgetparams
	{- Regular wget needs --clobber to continue downloading an existing
	 - file. On Android, busybox wget is used, which does not
	 - support, or need that option. -}
#ifndef __ANDROID__
	wgetparams = [Params "--clobber -c -O"]
#else
	wgetparams = [Params "-c -O"]
#endif
	{- Uses the -# progress display, because the normal
	 - one is very confusing when resuming, showing
	 - the remainder to download as the whole file,
	 - and not indicating how much percent was
	 - downloaded before the resume. -}
	curl = go "curl" $ headerparams ++ quietopt "-s" ++
		[Params "-f -L -C - -# -o"]
	go cmd opts = boolSystem cmd $
		addUserAgent uo $ reqParams uo++opts++[File file, File url]
	quietopt s
		| quiet = [Param s]
		| otherwise = []

{- Uses Network.Browser to make a http request of an url.
 - For example, HEAD can be used to check if the url exists,
 - or GET used to get the url content (best for small urls).
 -
 - This does its own redirect following because Browser's is buggy for HEAD
 - requests.
 -
 - Unfortunately, does not handle https, so should only be used
 - when curl is not available.
 -}
request :: URI -> RequestMethod -> UrlOptions -> IO (Response String)
request url requesttype uo = go 5 url
  where
	go :: Int -> URI -> IO (Response String)
	go 0 _ = error "Too many redirects "
	go n u = do
		rsp <- Browser.browse $ do
			maybe noop Browser.setUserAgent (userAgent uo)
			Browser.setErrHandler ignore
			Browser.setOutHandler ignore
			Browser.setAllowRedirects False
			let req = mkRequest requesttype u :: Request_String
			snd <$> Browser.request (addheaders req)
		case rspCode rsp of
			(3,0,x) | x /= 5 -> redir (n - 1) u rsp
			_ -> return rsp
	addheaders req = setHeaders req (rqHeaders req ++ userheaders)
	userheaders = rights $ map parseHeader (reqHeaders uo)
	ignore = const noop
	redir n u rsp = case retrieveHeaders HdrLocation rsp of
		[] -> return rsp
		(Header _ newu:_) ->
			case parseURIReference newu of
				Nothing -> return rsp
				Just newURI -> go n $
#if defined VERSION_network
#if ! MIN_VERSION_network(2,4,0)
#define WITH_OLD_URI
#endif
#endif
#ifdef WITH_OLD_URI
					fromMaybe newURI (newURI `relativeTo` u)
#else
					newURI `relativeTo` u
#endif

{- Allows for spaces and other stuff in urls, properly escaping them. -}
parseURIRelaxed :: URLString -> Maybe URI
parseURIRelaxed = parseURI . escapeURIString isAllowedInURI


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

{-# LANGUAGE CPP #-}

module Utility.UserInfo (
	myHomeDir,
	myUserName,
	myUserGecos,
) where

import Control.Applicative
import System.PosixCompat

import Utility.Env

{- Current user's home directory.
 -
 - getpwent will fail on LDAP or NIS, so use HOME if set. -}
myHomeDir :: IO FilePath
myHomeDir = myVal env homeDirectory
  where
#ifndef mingw32_HOST_OS
	env = ["HOME"]
#else
	env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin
#endif

{- Current user's user name. -}
myUserName :: IO String
myUserName = myVal env userName
  where
#ifndef mingw32_HOST_OS
	env = ["USER", "LOGNAME"]
#else
	env = ["USERNAME", "USER", "LOGNAME"]
#endif

myUserGecos :: IO String
#ifdef __ANDROID__
myUserGecos = return "" -- userGecos crashes on Android
#else
myUserGecos = myVal [] userGecos
#endif

myVal :: [String] -> (UserEntry -> String) -> IO String
myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars
  where
	check [] = return Nothing
	check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v
	getpwent = getUserEntryForID =<< getEffectiveUserID


code:
{- values verified using a shared secret
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.Verifiable where

import Data.Digest.Pure.SHA
import Data.ByteString.Lazy.UTF8 (fromString)
import qualified Data.ByteString.Lazy as L

type Secret = L.ByteString
type HMACDigest = String

{- A value, verifiable using a HMAC digest and a secret. -}
data Verifiable a = Verifiable
	{ verifiableVal :: a
	, verifiableDigest :: HMACDigest
	}
	deriving (Eq, Read, Show)

mkVerifiable :: Show a => a -> Secret -> Verifiable a
mkVerifiable a secret = Verifiable a (calcDigest (show a) secret)

verify :: (Eq a, Show a) => Verifiable a -> Secret -> Bool
verify v secret = v == mkVerifiable (verifiableVal v) secret

calcDigest :: String -> Secret -> HMACDigest
calcDigest v secret = showDigest $ hmacSha1 secret $ fromString v

{- for quickcheck -}
prop_verifiable_sane :: String -> String -> Bool
prop_verifiable_sane a s = verify (mkVerifiable a secret) secret
  where
	secret = fromString s


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

{-# LANGUAGE OverloadedStrings, CPP, RankNTypes #-}

module Utility.WebApp where

import Common
import Utility.Tmp
import Utility.FileMode
import Utility.Hash

import qualified Yesod
import qualified Network.Wai as Wai
import Network.Wai.Handler.Warp
import Network.Wai.Handler.WarpTLS
import Network.HTTP.Types
import qualified Data.CaseInsensitive as CI
import Network.Socket
import "crypto-api" Crypto.Random
import qualified Web.ClientSession as CS
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import Blaze.ByteString.Builder (Builder)
import Control.Arrow ((***))
import Control.Concurrent
#ifdef WITH_WEBAPP_SECURE
import Data.SecureMem
import Data.Byteable
#endif
#ifdef __ANDROID__
import Data.Endian
#endif
#if defined(__ANDROID__) || defined (mingw32_HOST_OS)
#else
import Control.Exception (bracketOnError)
#endif

localhost :: HostName
localhost = "localhost"

{- Builds a command to use to start or open a web browser showing an url. -}
browserProc :: String -> CreateProcess
#ifdef darwin_HOST_OS
browserProc url = proc "open" [url]
#else
#ifdef __ANDROID__
-- Warning: The `am` command does not work very reliably on Android.
browserProc url = proc "am"
	["start", "-a", "android.intent.action.VIEW", "-d", url]
#else
#ifdef mingw32_HOST_OS
-- Warning: On Windows, no quoting or escaping of the url seems possible,
-- so spaces in it will cause problems. One approach is to make the url
-- be a relative filename, and adjust the returned CreateProcess to change
-- to the directory it's in.
browserProc url = proc "cmd" ["/c start " ++ url]
#else
browserProc url = proc "xdg-open" [url]
#endif
#endif
#endif

{- Binds to a socket on localhost, or possibly a different specified
 - hostname or address, and runs a webapp on it.
 -
 - An IO action can also be run, to do something with the address,
 - such as start a web browser to view the webapp.
 -}
runWebApp :: Maybe TLSSettings -> Maybe HostName -> Wai.Application -> (SockAddr -> IO ()) -> IO ()
runWebApp tlssettings h app observer = withSocketsDo $ do
	sock <- getSocket h
	void $ forkIO $ go webAppSettings sock app
	sockaddr <- fixSockAddr <$> getSocketName sock
	observer sockaddr
  where
#ifdef WITH_WEBAPP_SECURE
	go = (maybe runSettingsSocket (\ts -> runTLSSocket ts) tlssettings)
#else
	go = runSettingsSocket
#endif

fixSockAddr :: SockAddr -> SockAddr
#ifdef __ANDROID__
{- On Android, the port is currently incorrectly returned in network
 - byte order, which is wrong on little endian systems. -}
fixSockAddr (SockAddrInet (PortNum port) addr) = SockAddrInet (PortNum $ swapEndian port) addr
#endif
fixSockAddr addr = addr

-- disable buggy sloworis attack prevention code
webAppSettings :: Settings

#if MIN_VERSION_warp(2,1,0)
webAppSettings = setTimeout halfhour defaultSettings
#else
webAppSettings = defaultSettings { settingsTimeout = halfhour }
#endif
  where
	halfhour = 30 * 60

{- Binds to a local socket, or if specified, to a socket on the specified
 - hostname or address. Selects any free port, unless the hostname ends with
 - ":port"
 -
 - Prefers to bind to the ipv4 address rather than the ipv6 address
 - of localhost, if it's available.
 -}
getSocket :: Maybe HostName -> IO Socket
getSocket h = do
#if defined(__ANDROID__) || defined (mingw32_HOST_OS)
	-- getAddrInfo currently segfaults on Android.
	-- The HostName is ignored by this code.
	when (isJust h) $
		error "getSocket with HostName not supported on this OS"
	addr <- inet_addr "127.0.0.1"
 	sock <- socket AF_INET Stream defaultProtocol
	preparesocket sock
	bindSocket sock (SockAddrInet aNY_PORT addr)
	use sock
  where
#else
	addrs <- getAddrInfo (Just hints) (Just hostname) Nothing
	case (partition (\a -> addrFamily a == AF_INET) addrs) of
		(v4addr:_, _) -> go v4addr
		(_, v6addr:_) -> go v6addr
		_ -> error "unable to bind to a local socket"
  where
	hostname = fromMaybe localhost h
	hints = defaultHints { addrSocketType = Stream }
	{- Repeated attempts because bind sometimes fails for an
	 - unknown reason on OSX. -}
	go addr = go' 100 addr
	go' :: Int -> AddrInfo -> IO Socket
	go' 0 _ = error "unable to bind to local socket"
	go' n addr = do
		r <- tryIO $ bracketOnError (open addr) sClose (useaddr addr)
		either (const $ go' (pred n) addr) return r
	open addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
	useaddr addr sock = do
		preparesocket sock
		bindSocket sock (addrAddress addr)
		use sock
#endif
	preparesocket sock = setSocketOption sock ReuseAddr 1
	use sock = do
		listen sock maxListenQueue
		return sock

lookupRequestField :: CI.CI B.ByteString -> Wai.Request -> B.ByteString
lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req

{- Rather than storing a session key on disk, use a random key
 - that will only be valid for this run of the webapp. -}
#if MIN_VERSION_yesod(1,2,0)
webAppSessionBackend :: Yesod.Yesod y => y -> IO (Maybe Yesod.SessionBackend)
#else
webAppSessionBackend :: Yesod.Yesod y => y -> IO (Maybe (Yesod.SessionBackend y))
#endif
webAppSessionBackend _ = do
	g <- newGenIO :: IO SystemRandom
	case genBytes 96 g of
		Left e -> error $ "failed to generate random key: " ++ show e
		Right (s, _) -> case CS.initKey s of
			Left e -> error $ "failed to initialize key: " ++ show e
			Right key -> use key
  where
	timeout = 120 * 60 -- 120 minutes
	use key =
#if MIN_VERSION_yesod(1,2,0)
		Just . Yesod.clientSessionBackend key . fst
			<$> Yesod.clientSessionDateCacher timeout
#else
#if MIN_VERSION_yesod(1,1,7)
		Just . Yesod.clientSessionBackend2 key . fst
			<$> Yesod.clientSessionDateCacher timeout
#else
		return $ Just $
			Yesod.clientSessionBackend key timeout
#endif
#endif

#ifdef WITH_WEBAPP_SECURE
type AuthToken = SecureMem
#else
type AuthToken = T.Text
#endif

toAuthToken :: T.Text -> AuthToken
#ifdef WITH_WEBAPP_SECURE
toAuthToken = secureMemFromByteString . TE.encodeUtf8
#else
toAuthToken = id
#endif

fromAuthToken :: AuthToken -> T.Text
#ifdef WITH_WEBAPP_SECURE
fromAuthToken = TE.decodeLatin1 . toBytes
#else
fromAuthToken = id
#endif

{- Generates a random sha512 string, encapsulated in a SecureMem,
 - suitable to be used for an authentication secret. -}
genAuthToken :: IO AuthToken
genAuthToken = do
	g <- newGenIO :: IO SystemRandom
	return $
		case genBytes 512 g of
			Left e -> error $ "failed to generate auth token: " ++ show e
			Right (s, _) -> toAuthToken $ T.pack $ show $ sha512 $ L.fromChunks [s]

{- A Yesod isAuthorized method, which checks the auth cgi parameter
 - against a token extracted from the Yesod application.
 -
 - Note that the usual Yesod error page is bypassed on error, to avoid
 - possibly leaking the auth token in urls on that page!
 -}
#if MIN_VERSION_yesod(1,2,0)
checkAuthToken :: (Monad m, Yesod.MonadHandler m) => (Yesod.HandlerSite m -> AuthToken) -> m Yesod.AuthResult
#else
checkAuthToken :: forall t sub. (t -> AuthToken) -> Yesod.GHandler sub t Yesod.AuthResult
#endif
checkAuthToken extractAuthToken = do
	webapp <- Yesod.getYesod
	req <- Yesod.getRequest
	let params = Yesod.reqGetParams req
	if (toAuthToken <$> lookup "auth" params) == Just (extractAuthToken webapp)
		then return Yesod.Authorized
		else Yesod.sendResponseStatus unauthorized401 ()

{- A Yesod joinPath method, which adds an auth cgi parameter to every
 - url matching a predicate, containing a token extracted from the
 - Yesod application.
 -
 - A typical predicate would exclude files under /static.
 -}
insertAuthToken :: forall y. (y -> AuthToken)
	-> ([T.Text] -> Bool)
	-> y
	-> T.Text
	-> [T.Text]
	-> [(T.Text, T.Text)]
	-> Builder
insertAuthToken extractAuthToken predicate webapp root pathbits params =
	fromText root `mappend` encodePath pathbits' encodedparams
  where
	pathbits' = if null pathbits then [T.empty] else pathbits
	encodedparams = map (TE.encodeUtf8 *** go) params'
	go "" = Nothing
	go x = Just $ TE.encodeUtf8 x
	authparam = (T.pack "auth", fromAuthToken (extractAuthToken webapp))
	params'
		| predicate pathbits = authparam:params
		| otherwise = params

{- Creates a html shim file that's used to redirect into the webapp,
 - to avoid exposing the secret token when launching the web browser. -}
writeHtmlShim :: String -> String -> FilePath -> IO ()
writeHtmlShim title url file = viaTmp writeFileProtected file $ genHtmlShim title url

{- TODO: generate this static file using Yesod. -}
genHtmlShim :: String -> String -> String
genHtmlShim title url = unlines
	[ ""
	, ""
	, "<title>"++ title ++ "</title>"
	, "<meta http-equiv=\"refresh\" content=\"1; URL="++url++"\">"
	, ""
	, "
"
	, "" ++ title ++ ""
	, "
"
	, ""
	, ""
	]


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

module Utility.WinLock (
	lockShared,
	lockExclusive,
	dropLock,
	waitToLock,
	LockHandle
) where

import System.Win32.Types
import System.Win32.File
import Control.Concurrent

{- Locking is exclusive, and prevents the file from being opened for read
 - or write by any other process. So for advisory locking of a file, a
 - different LockFile should be used. -}
type LockFile = FilePath

type LockHandle = HANDLE

{- Tries to lock a file with a shared lock, which allows other processes to
 - also lock it shared. Fails is the file is exclusively locked. -}
lockShared :: LockFile -> IO (Maybe LockHandle)
lockShared = openLock fILE_SHARE_READ

{- Tries to take an exclusive lock on a file. Fails if another process has
 - a shared or exclusive lock. -}
lockExclusive :: LockFile -> IO (Maybe LockHandle)
lockExclusive = openLock fILE_SHARE_NONE

{- Windows considers just opening a file enough to lock it. This will
 - create the LockFile if it does not already exist.
 -
 - Will fail if the file is already open with an incompatable ShareMode.
 - Note that this may happen if an unrelated process, such as a virus
 - scanner, even looks at the file. See http://support.microsoft.com/kb/316609
 -
 - Note that createFile busy-waits to try to avoid failing when some other
 - process briefly has a file open. But that would make checking locks
 - much more expensive, so is not done here. Thus, the use of c_CreateFile.
 -}
openLock :: ShareMode -> LockFile -> IO (Maybe LockHandle)
openLock sharemode f = do
	h <- withTString f $ \c_f ->
		c_CreateFile c_f gENERIC_READ sharemode (maybePtr Nothing)
			oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing)
	return $ if h == iNVALID_HANDLE_VALUE
		then Nothing
		else Just h

dropLock :: LockHandle -> IO ()
dropLock = closeHandle

{- If the initial lock fails, this is a BUSY wait, and does not
 - guarentee FIFO order of waiters. In other news, Windows is a POS. -}
waitToLock :: IO (Maybe LockHandle) -> IO LockHandle
waitToLock locker = takelock
  where
	takelock = go =<< locker
	go (Just lck) = return lck
	go Nothing = do
		threadDelay (500000) -- half a second
		takelock


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

{-# LANGUAGE ForeignFunctionInterface #-}

module Utility.WinProcess where

import Utility.PID

foreign import ccall unsafe "terminatepid"
	terminatePID :: PID -> IO ()


code:
{- Yesod stuff, that's typically found in the scaffolded site.
 -
 - Also a bit of a compatability layer to make it easier to support yesod
 - 1.1 and 1.2 in the same code base.
 -
 - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-}

module Utility.Yesod
	( module Y
	, liftH
#ifndef __NO_TH__
	, widgetFile
	, hamletTemplate
#endif
#if ! MIN_VERSION_yesod(1,2,0)
	, giveUrlRenderer
	, Html
#endif
	) where

#if MIN_VERSION_yesod(1,2,0)
import Yesod as Y
#else
import Yesod as Y hiding (Html)
#endif
import Assistant.WebApp.Bootstrap3 as Y hiding (bfs)
#ifndef __NO_TH__
import Yesod.Default.Util
import Language.Haskell.TH.Syntax (Q, Exp)
#if MIN_VERSION_yesod_default(1,1,0)
import Data.Default (def)
import Text.Hamlet hiding (Html)
#endif
#endif

#ifndef __NO_TH__
widgetFile :: String -> Q Exp
#if ! MIN_VERSION_yesod_default(1,1,0)
widgetFile = widgetFileNoReload
#else
widgetFile = widgetFileNoReload $ def
	{ wfsHamletSettings = defaultHamletSettings
		{ hamletNewlines = AlwaysNewlines
		}
	}
#endif

hamletTemplate :: FilePath -> FilePath
hamletTemplate f = globFile "hamlet" f
#endif

{- Lift Handler to Widget -}
#if MIN_VERSION_yesod(1,2,0)
liftH :: Monad m => HandlerT site m a -> WidgetT site m a
liftH = handlerToWidget
#else
liftH :: MonadLift base m => base a -> m a
liftH = lift
#endif

{- Misc new names for stuff. -}
#if ! MIN_VERSION_yesod(1,2,0)
giveUrlRenderer :: forall master sub. HtmlUrl (Route master) -> GHandler sub master RepHtml
giveUrlRenderer = hamletToRepHtml

type Html = RepHtml
#endif


code:
/* disk free space checking, C mini-library
 *
 * Copyright 2012, 2014 Joey Hess <joey@kitenet.net>
 *
 * License: BSD-2-clause
 */

/* Include appropriate headers for the OS, and define what will be used to
 * check the free space. */
#if defined(__APPLE__)
# include <sys/param.h>
# include <sys/mount.h>
/* In newer OSX versions, statfs64 is deprecated, in favor of statfs,
 * which is 64 bit only with a build option -- but statfs64 still works,
 * and this keeps older OSX also supported. */
# define STATCALL statfs64
# define STATSTRUCT statfs64
#else
#if defined (__FreeBSD__)
# include <sys/param.h>
# include <sys/mount.h>
# define STATCALL statfs /* statfs64 not yet tested on a real FreeBSD machine */
# define STATSTRUCT statfs
#else
#if defined __ANDROID__
# warning free space checking code not available for Android
# define UNKNOWN
#else
#if defined (__linux__) || defined (__FreeBSD_kernel__)
/* Linux or Debian kFreeBSD */
/* This is a POSIX standard, so might also work elsewhere too. */
# include <sys/statvfs.h>
# define STATCALL statvfs
# define STATSTRUCT statvfs
#else
# warning free space checking code not available for this OS
# define UNKNOWN
#endif
#endif
#endif
#endif

#include <errno.h>
#include <stdio.h>

unsigned long long int get(const char *path, int req) {
#ifdef UNKNOWN
	errno = 1;
	return 0;
#else
	unsigned long long int v, blocksize;
	struct STATSTRUCT buf;

	if (STATCALL(path, &buf) != 0)
		return 0; /* errno is set */
	else
		errno = 0;

	switch (req) {
		case 0:
			v = buf.f_blocks;
			break;
		case 1:
			v = buf.f_bavail;
			break;
		default:
			v = 0;
	}

	blocksize = buf.f_bsize;
	return v * blocksize;
#endif
}

/* Checks the amount of disk that is available to regular (non-root) users.
 * (If there's an error, or this is not supported,
 * returns 0 and sets errno to nonzero.)
 */
unsigned long long int diskfree(const char *path) {
	return get(path, 1);
}

/* Gets the total size of the disk. */
unsigned long long int disksize(const char *path) {
	return get(path, 0);
}

/*
main () {
	printf("%lli\n", diskfree("."));
}
*/


code: unsigned long long int diskfree(const char *path);


code:
/* kqueue interface, C mini-library
 *
 * Copyright 2012 Joey Hess <joey@kitenet.net>
 *
 * License: BSD-2-clause
 */

#include <stdio.h>
#include <dirent.h>
#include <fcntl.h>
#include <stdlib.h>
#include <unistd.h>
#include <sys/types.h>
#include <sys/event.h>
#include <sys/time.h>
#include <errno.h>

/* The specified fds are added to the set of fds being watched for changes.
 * Fds passed to prior calls still take effect, so it's most efficient to
 * not pass the same fds repeatedly.
 *
 * Returns the fd that changed, or -1 on error.
 */
signed int helper(const int kq, const int fdcnt, const int *fdlist, int nodelay) {
	int i, nev;
	struct kevent evlist[1];
	struct kevent chlist[fdcnt];
	struct timespec avoiddelay = {0, 0};
	struct timespec *timeout = nodelay ? &avoiddelay : NULL;

	for (i = 0; i < fdcnt; i++) {
		EV_SET(&chlist[i], fdlist[i], EVFILT_VNODE,
			EV_ADD | EV_ENABLE | EV_CLEAR,
			NOTE_WRITE,
			0, 0);
	}

	nev = kevent(kq, chlist, fdcnt, evlist, 1, timeout);
	if (nev == 1)
		return evlist[0].ident;
	else
		return -1;
}

/* Initializes a new, empty kqueue. */
int init_kqueue() {
	int kq;
	if ((kq = kqueue()) == -1) {
		perror("kqueue");
		exit(1);
	}
	return kq;
}

/* Adds fds to the set that should be watched. */
void addfds_kqueue(const int kq, const int fdcnt, const int *fdlist) {
	helper(kq, fdcnt, fdlist, 1);
}

/* Waits for a change event on a kqueue. */
signed int waitchange_kqueue(const int kq) {
	return helper(kq, 0, NULL, 0);
}

/*
main () {
	int list[1];
	int kq;
	list[0]=open(".", O_RDONLY);
	kq = init_kqueue();
	addfds_kqueue(kq, 1, list)
	printf("change: %i\n", waitchange_kqueue(kq));
}
*/


code:
int init_kqueue();
void addfds_kqueue(const int kq, const int fdcnt, const int *fdlist);
signed int waitchange_kqueue(const int kq);


code:
/* mounted filesystems, C mini-library
 *
 * Copyright (c) 1980, 1989, 1993, 1994
 *      The Regents of the University of California.  All rights reserved.
 * Copyright (c) 2001
 *      David Rufino <daverufino@btinternet.com>
 * Copyright 2012
 *      Joey Hess <joey@kitenet.net>
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. Neither the name of the University nor the names of its contributors
 *    may be used to endorse or promote products derived from this software
 *    without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 */

#include "libmounts.h"

#ifdef GETMNTENT
/* direct passthrough the getmntent */
FILE *mounts_start (void) {
	return setmntent("/etc/mtab", "r");
}
int mounts_end (FILE *fp) {
	return endmntent(fp);
}
struct mntent *mounts_next (FILE *fp) {
	return getmntent(fp);
}
#endif

#ifdef GETMNTINFO
/* getmntent emulation using getmntinfo */
FILE *mounts_start (void) {
	return ((FILE *)0x1); /* dummy non-NULL FILE pointer, not used */
}
int mounts_end (FILE *fp) {
	return 1;
}

static struct mntent _mntent;

static struct mntent *statfs_to_mntent (struct statfs *mntbuf) {
	_mntent.mnt_fsname = mntbuf->f_mntfromname;
	_mntent.mnt_dir = mntbuf->f_mntonname;
	_mntent.mnt_type = mntbuf->f_fstypename;

	_mntent.mnt_opts = '\0';
	_mntent.mnt_freq = 0;
	_mntent.mnt_passno = 0;

	return (&_mntent);
}

static int pos = -1;
static int mntsize = -1;
struct statfs *mntbuf = NULL;

struct mntent *mounts_next (FILE *fp) {

	if (pos == -1 || mntsize == -1)
		mntsize = getmntinfo(&mntbuf, MNT_NOWAIT);
	++pos;
	if (pos == mntsize) {
		pos = mntsize = -1;
		mntbuf = NULL;
		return NULL;
	}

	return (statfs_to_mntent(&mntbuf[pos]));
}
#endif

#ifdef UNKNOWN
/* dummy, do-nothing version */
FILE *mounts_start (void) {
	return ((FILE *)0x1);
}
int mounts_end (FILE *fp) {
	return 1;
}
struct mntent *mounts_next (FILE *fp) {
	return NULL;
}
#endif


code:
/* Include appropriate headers for the OS, and define what will be used. */
#if defined (__FreeBSD__) || defined (__APPLE__)
# include <sys/param.h>
# include <sys/ucred.h>
# include <sys/mount.h>
# define GETMNTINFO
#else
#if defined __ANDROID__
/* Android is handled by the Haskell code, not here. */
# define UNKNOWN
#else
#if defined (__linux__) || defined (__FreeBSD_kernel__)
/* Linux or Debian kFreeBSD */
#include <mntent.h>
# define GETMNTENT
#else
# warning mounts listing code not available for this OS
# define UNKNOWN
#endif
#endif
#endif

#include <stdio.h>

#ifndef GETMNTENT
struct mntent {
	char *mnt_fsname;
	char *mnt_dir;
	char *mnt_type;
	char *mnt_opts; /* not filled in */
	int mnt_freq; /* not filled in */
	int mnt_passno; /* not filled in */
};
#endif

FILE *mounts_start (void);
int mounts_end (FILE *fp);
struct mntent *mounts_next (FILE *fp);


code:
#include <windows.h>

void terminatepid (DWORD pid) {
	HANDLE h;
	h = OpenProcess(PROCESS_TERMINATE, 0, pid);
	if (h != NULL) {
		TerminateProcess(h, 1);
	}
	CloseHandle(h);
}


code:
{- configure program -}

import Build.Configure

main :: IO ()
main = run tests


code:
git-annex (4.20131002) unstable; urgency=low

   The layout of gcrypt repositories has changed, and
   if you created one you must manually upgrade it.
   See /usr/share/doc/git-annex/html/upgrades/gcrypt.html

 -- Joey Hess <joeyh@debian.org>  Tue, 24 Sep 2013 13:55:23 -0400

git-annex (3.20120123) unstable; urgency=low

  There was a bug in the handling of directory special remotes that
  could cause partial file contents to be stored in them. If you use
  a directory special remote, you should fsck it, to avoid potential
  data loss.

  Example: git annex fsck --from mydirectory

 -- Joey Hess <joeyh@debian.org>  Thu, 19 Jan 2012 15:24:23 -0400

git-annex (3.20110624) experimental; urgency=low

  There has been another change to the git-annex data store.
  Use `git annex upgrade` to migrate your repositories to the new
  layout. See <http://git-annex.branchable.com/upgrades/> or
  /usr/share/doc/git-annex/html/upgrades.html

  The significant change this time is that the .git-annex/ directory
  is gone; instead there is a git-annex branch that is automatically
  maintained by git-annex, and encapsulates all its state nicely out
  of your way.

  You should make sure you include the git-annex branch when
  git pushing and pulling.

 -- Joey Hess <joeyh@debian.org>  Tue, 21 Jun 2011 20:18:00 -0400

git-annex (0.20110316) experimental; urgency=low

  This version reorganises the layout of git-annex's files in your repository.
  There is an upgrade process to convert a repository from the old git-annex
  to this version. See <http://git-annex.branchable.com/upgrades/> or
  /usr/share/doc/git-annex/html/upgrades.html

 -- Joey Hess <joeyh@debian.org>  Wed, 16 Mar 2011 15:49:15 -0400

path: debian/NEWS