code:
mans=git-annex.1 git-annex-shell.1
all=git-annex $(mans) docs

CABAL?=cabal # set to "./Setup" if you lack a cabal program
GHC?=ghc

PREFIX?=/usr
SHAREDIR?=share

# Am I typing :make in vim? Do a fast build.
ifdef VIM
all=fast
endif

build: build-stamp
build-stamp: $(all)
	touch $@

Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs
	if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi
	$(CABAL) configure

git-annex: Build/SysConfig.hs
	$(CABAL) build
	ln -sf dist/build/git-annex/git-annex git-annex

git-annex.1: doc/git-annex.mdwn
	./Build/mdwn2man git-annex 1 doc/git-annex.mdwn > git-annex.1
git-annex-shell.1: doc/git-annex-shell.mdwn
	./Build/mdwn2man git-annex-shell 1 doc/git-annex-shell.mdwn > git-annex-shell.1

# These are not built normally.
git-union-merge.1: doc/git-union-merge.mdwn
	./Build/mdwn2man git-union-merge 1 doc/git-union-merge.mdwn > git-union-merge.1
git-union-merge:
	$(GHC) --make -threaded $@

install-mans: $(mans)
	install -d $(DESTDIR)$(PREFIX)/$(SHAREDIR)/man/man1
	install -m 0644 $(mans) $(DESTDIR)$(PREFIX)/$(SHAREDIR)/man/man1

install-docs: docs install-mans
	install -d $(DESTDIR)$(PREFIX)/$(SHAREDIR)/doc/git-annex
	if [ -d html ]; then \
		rsync -a --delete html/ $(DESTDIR)$(PREFIX)/$(SHAREDIR)/doc/git-annex/html/; \
	fi

install: build install-docs Build/InstallDesktopFile
	install -d $(DESTDIR)$(PREFIX)/bin
	install git-annex $(DESTDIR)$(PREFIX)/bin
	ln -sf git-annex $(DESTDIR)$(PREFIX)/bin/git-annex-shell
	./Build/InstallDesktopFile $(PREFIX)/bin/git-annex || true

test: git-annex
	./git-annex test

retest: git-annex
	./git-annex test --rerun-update --rerun-filter failures

# hothasktags chokes on some template haskell etc, so ignore errors
tags:
	(for f in $$(find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$'); do hothasktags -c --cpp -c -traditional -c --include=dist/build/autogen/cabal_macros.h $$f; done) 2>/dev/null | sort > tags

# If ikiwiki is available, build static html docs suitable for being
# shipped in the software package.
ifeq ($(shell which ikiwiki),)
IKIWIKI=@echo "** ikiwiki not found, skipping building docs" >&2; true
else
IKIWIKI=ikiwiki
endif

docs: $(mans)
	$(IKIWIKI) doc html -v --wikiname git-annex --plugin=goodstuff \
		--no-usedirs --disable-plugin=openid --plugin=sidebar \
		--underlaydir=/dev/null --disable-plugin=shortcut \
		--disable-plugin=smiley \
		--plugin=comments --set comments_pagespec="*" \
		--exclude='news/.*' --exclude='design/assistant/blog/*' \
		--exclude='bugs/*' --exclude='todo/*' --exclude='forum/*' \
		--exclude='users/*' --exclude='devblog/*'

clean:
	rm -rf tmp dist git-annex $(mans) configure  *.tix .hpc \
		doc/.ikiwiki html dist tags Build/SysConfig.hs build-stamp \
		Setup Build/InstallDesktopFile Build/EvilSplicer \
		Build/Standalone Build/OSXMkLibs Build/LinuxMkLibs \
		Build/DistributionUpdate Build/BuildVersion \
		git-union-merge .tasty-rerun-log
	find . -name \*.o -exec rm {} \;
	find . -name \*.hi -exec rm {} \;

Build/InstallDesktopFile: Build/InstallDesktopFile.hs
	$(GHC) --make $@ -Wall
Build/EvilSplicer: Build/EvilSplicer.hs
	$(GHC) --make $@ -Wall
Build/Standalone: Build/Standalone.hs Build/SysConfig.hs
	$(GHC) --make $@ -Wall
Build/OSXMkLibs: Build/OSXMkLibs.hs
	$(GHC) --make $@ -Wall
Build/LinuxMkLibs: Build/LinuxMkLibs.hs
	$(GHC) --make $@ -Wall

sdist: clean $(mans)
	./Build/make-sdist.sh

# Upload to hackage.
hackage: sdist
	@cabal upload dist/*.tar.gz

LINUXSTANDALONE_DEST=tmp/git-annex.linux
linuxstandalone:
	$(MAKE) git-annex linuxstandalone-nobuild
linuxstandalone-nobuild: Build/Standalone Build/LinuxMkLibs
	rm -rf "$(LINUXSTANDALONE_DEST)"
	mkdir -p tmp
	cp -R standalone/linux/skel "$(LINUXSTANDALONE_DEST)"

	install -d "$(LINUXSTANDALONE_DEST)/bin"
	cp dist/build/git-annex/git-annex "$(LINUXSTANDALONE_DEST)/bin/"
	strip "$(LINUXSTANDALONE_DEST)/bin/git-annex"
	ln -sf git-annex "$(LINUXSTANDALONE_DEST)/bin/git-annex-shell"
	zcat standalone/licences.gz > $(LINUXSTANDALONE_DEST)/LICENSE
	cp doc/logo_16x16.png doc/logo.svg $(LINUXSTANDALONE_DEST)
	cp standalone/trustedkeys.gpg $(LINUXSTANDALONE_DEST)

	./Build/Standalone "$(LINUXSTANDALONE_DEST)"

	install -d "$(LINUXSTANDALONE_DEST)/git-core"
	(cd "$(shell git --exec-path)" && tar c .) | (cd "$(LINUXSTANDALONE_DEST)"/git-core && tar x)
	install -d "$(LINUXSTANDALONE_DEST)/templates"

	./Build/LinuxMkLibs "$(LINUXSTANDALONE_DEST)"

	$(MAKE) install-mans DESTDIR="$(LINUXSTANDALONE_DEST)"

	cd tmp/git-annex.linux && find . -type f > git-annex.MANIFEST
	cd tmp/git-annex.linux && find . -type l >> git-annex.MANIFEST
	cd tmp && tar czf git-annex-standalone-$(shell dpkg --print-architecture).tar.gz git-annex.linux

OSXAPP_DEST=tmp/build-dmg/git-annex.app
OSXAPP_BASE=$(OSXAPP_DEST)/Contents/MacOS/bundle
osxapp: Build/Standalone Build/OSXMkLibs
	$(MAKE) git-annex

	rm -rf "$(OSXAPP_DEST)" "$(OSXAPP_BASE)"
	install -d tmp/build-dmg
	cp -R standalone/osx/git-annex.app "$(OSXAPP_DEST)"

	install -d "$(OSXAPP_BASE)"
	cp git-annex "$(OSXAPP_BASE)"
	strip "$(OSXAPP_BASE)/git-annex"
	ln -sf git-annex "$(OSXAPP_BASE)/git-annex-shell"
	gzcat standalone/licences.gz > $(OSXAPP_BASE)/LICENSE
	cp $(OSXAPP_BASE)/LICENSE tmp/build-dmg/LICENSE.txt
	cp standalone/trustedkeys.gpg $(OSXAPP_BASE)

	./Build/Standalone $(OSXAPP_BASE)

	(cd "$(shell git --exec-path)" && tar c .) | (cd "$(OSXAPP_BASE)" && tar x)
	install -d "$(OSXAPP_BASE)/templates"

	# OSX looks in man dir nearby the bin
	$(MAKE) install-mans DESTDIR="$(OSXAPP_BASE)/.." SHAREDIR="" PREFIX=""

	./Build/OSXMkLibs $(OSXAPP_BASE)
	cd $(OSXAPP_DEST) && find . -type f > Contents/MacOS/git-annex.MANIFEST
	cd $(OSXAPP_DEST) && find . -type l >> Contents/MacOS/git-annex.MANIFEST
	rm -f tmp/git-annex.dmg
	hdiutil create -format UDBZ -size 640m -srcfolder tmp/build-dmg \
		-volname git-annex -o tmp/git-annex.dmg

# Must be run on a system with TH supported, and the same
# versions of TH splice generating packages as the arm system installed.
no-th-webapp-stage1: Build/EvilSplicer
	echo "Running throwaway build, to get TH splices.."
	if [ ! -e dist/setup/setup ]; then $(CABAL) configure -f-Production -O0;  fi
	mkdir -p tmp
	if ! $(CABAL) build --ghc-options=-ddump-splices 2> tmp/dump-splices; then tail tmp/dump-splices >&2; exit 1; fi
	echo "Setting up no-th build tree.."
	./Build/EvilSplicer tmp/splices tmp/dump-splices standalone/no-th/evilsplicer-headers.hs
	rsync -az --exclude tmp --exclude dist . tmp/no-th-tree
# Copy the files with expanded splices to the source tree, but
# only if the existing source file is not newer. (So, if a file
# used to have TH splices but they were removed, it will be newer,
# and not overwritten.)
	cp -uR tmp/splices/* tmp/no-th-tree || true
# Some additional dependencies needed by the expanded splices.
	sed -i 's/^  Build-Depends: /  Build-Depends: yesod-routes, yesod-core, shakespeare-css, shakespeare-js, shakespeare, blaze-markup, file-embed, wai-app-static, /' tmp/no-th-tree/git-annex.cabal
# Avoid warnings due to sometimes unused imports added for the splices.
	sed -i 's/GHC-Options: \(.*\)-Wall/GHC-Options: \1-Wall -fno-warn-unused-imports -XMagicHash /i' tmp/no-th-tree/git-annex.cabal

# Run on the arm system, after stage1
no-th-webapp-stage2:
	if [ ! -e tmp/no-th-tree/dist/setup-config ]; then \
		cd tmp/no-th-tree && cabal configure; \
	fi
	cd tmp/no-th-tree && cabal build --ghc-option=-D__NO_TH__
	cd tmp/no-th-tree && $(MAKE) linuxstandalone-nobuild

ANDROID_FLAGS?=
# Cross compile for Android.
# Uses https://github.com/neurocyte/ghc-android
android: Build/EvilSplicer
	echo "Running native build, to get TH splices.."
	if [ ! -e dist/setup/setup ]; then $(CABAL) configure -f-Production -O0 $(ANDROID_FLAGS) -fAndroidSplice;  fi
	mkdir -p tmp
	if ! $(CABAL) build --ghc-options=-ddump-splices 2> tmp/dump-splices; then tail tmp/dump-splices >&2; exit 1; fi
	echo "Setting up Android build tree.."
	./Build/EvilSplicer tmp/splices tmp/dump-splices standalone/no-th/evilsplicer-headers.hs
	rsync -az --exclude tmp --exclude dist . tmp/androidtree
# Copy the files with expanded splices to the source tree, but
# only if the existing source file is not newer. (So, if a file
# used to have TH splices but they were removed, it will be newer,
# and not overwritten.)
	cp -uR tmp/splices/* tmp/androidtree || true
# Some additional dependencies needed by the expanded splices.
	sed -i 's/^  Build-Depends: /  Build-Depends: yesod-routes, yesod-core, shakespeare-css, shakespeare-js, shakespeare, blaze-markup, file-embed, wai-app-static, /' tmp/androidtree/git-annex.cabal
# Avoid warnings due to sometimes unused imports added for the splices.
	sed -i 's/GHC-Options: \(.*\)-Wall/GHC-Options: \1-Wall -fno-warn-unused-imports -XMagicHash /i' tmp/androidtree/git-annex.cabal
# Cabal cannot cross compile with custom build type, so workaround.
	sed -i 's/Build-type: Custom/Build-type: Simple/' tmp/androidtree/git-annex.cabal
# Build just once, but link twice, for 2 different versions of Android.
	mkdir -p tmp/androidtree/dist/build/git-annex/4.0 tmp/androidtree/dist/build/git-annex/4.3
	if [ ! -e tmp/androidtree/dist/setup-config ]; then \
		cd tmp/androidtree && $$HOME/.ghc/$(shell cat standalone/android/abiversion)/arm-linux-androideabi/bin/cabal configure -fAndroid $(ANDROID_FLAGS); \
	fi
	cd tmp/androidtree && $$HOME/.ghc/$(shell cat standalone/android/abiversion)/arm-linux-androideabi/bin/cabal build \
		&& mv dist/build/git-annex/git-annex dist/build/git-annex/4.0/git-annex
	cd tmp/androidtree && $$HOME/.ghc/$(shell cat standalone/android/abiversion)/arm-linux-androideabi/bin/cabal build \
		--ghc-options=-optl-z --ghc-options=-optlnocopyreloc \
		&& mv dist/build/git-annex/git-annex dist/build/git-annex/4.3/git-annex

androidapp:
	$(MAKE) android
	$(MAKE) -C standalone/android

# We bypass cabal, and only run the main ghc --make command for a
# fast development built. Note: Does not rebuild C libraries.
fast: dist/caballog
	@$$(grep 'ghc --make' dist/caballog | head -n 1 | sed -e 's/-package-id [^ ]*//g' -e 's/-hide-all-packages//') -O0
	@ln -sf dist/build/git-annex/git-annex git-annex
	@$(MAKE) tags >/dev/null 2>&1 &

dist/caballog: git-annex.cabal
	$(CABAL) configure -f"-Production" -O0
	$(CABAL) build -v2 | tee $@

# Hardcoded command line to make hdevtools start up and work.
# You will need some memory. It's worth it.
# Note: Don't include WebDAV or Webapp. TH use bloats memory > 500 mb!
# TODO should be possible to derive this from caballog.
hdevtools:
	hdevtools --stop-server || true
	hdevtools check git-annex.hs -g -cpp -g -i -g -idist/build/git-annex/git-annex-tmp -g -i. -g -idist/build/autogen -g -Idist/build/autogen -g -Idist/build/git-annex/git-annex-tmp -g -IUtility -g -DWITH_TESTSUITE -g -DWITH_S3 -g -DWITH_ASSISTANT -g -DWITH_INOTIFY -g -DWITH_DBUS -g -DWITH_PAIRING -g -DWITH_XMPP -g -optP-include -g -optPdist/build/autogen/cabal_macros.h -g -odir -g dist/build/git-annex/git-annex-tmp -g -hidir -g dist/build/git-annex/git-annex-tmp -g -stubdir -g dist/build/git-annex/git-annex-tmp -g -threaded -g -Wall -g -XHaskell98 -g -XPackageImports

distributionupdate:
	git pull
	cabal configure
	ghc -Wall --make Build/DistributionUpdate -XPackageImports -optP-include -optPdist/build/autogen/cabal_macros.h
	./Build/DistributionUpdate

.PHONY: git-annex git-union-merge git-recover-repository tags build-stamp

path: Makefile


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

module Messages (
	showStart,
	showStart',
	showNote,
	showAction,
	showProgress,
	metered,
	meteredBytes,
	showSideAction,
	doSideAction,
	doQuietSideAction,
	showStoringStateAction,
	showOutput,
	showLongNote,
	showEndOk,
	showEndFail,
	showEndResult,
	showErr,
	warning,
	warningIO,
	fileNotFound,
	indent,
	maybeShowJSON,
	showFullJSON,
	showCustom,
	showHeader,
	showRaw,
	setupConsole,
	enableDebugOutput,
	disableDebugOutput
) where

import Text.JSON
import Data.Progress.Meter
import Data.Progress.Tracker
import Data.Quantity
import System.Log.Logger
import System.Log.Formatter
import System.Log.Handler (setFormatter, LogHandler)
import System.Log.Handler.Simple
import qualified Data.Set as S

import Common
import Types
import Types.Messages
import qualified Messages.JSON as JSON
import Types.Key
import qualified Annex
import Utility.Metered

showStart :: String -> FilePath -> Annex ()
showStart command file = handle (JSON.start command $ Just file) $
	flushed $ putStr $ command ++ " " ++ file ++ " "

showStart' :: String -> Key -> Maybe FilePath -> Annex ()
showStart' command key afile = showStart command $
	fromMaybe (key2file key) afile

showNote :: String -> Annex ()
showNote s = handle (JSON.note s) $
	flushed $ putStr $ "(" ++ s ++ ") "

showAction :: String -> Annex ()
showAction s = showNote $ s ++ "..."

{- Progress dots. -}
showProgress :: Annex ()
showProgress = handle q $
	flushed $ putStr "."

{- Shows a progress meter while performing a transfer of a key.
 - The action is passed a callback to use to update the meter. -}
metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a
metered combinemeterupdate key a = go (keySize key)
  where
	go (Just size) = meteredBytes combinemeterupdate size a
	go _ = a (const noop)

{- Shows a progress meter while performing an action on a given number
 - of bytes. -}
meteredBytes :: Maybe MeterUpdate -> Integer -> (MeterUpdate -> Annex a) -> Annex a
meteredBytes combinemeterupdate size a = withOutputType go
  where
	go NormalOutput = do
		progress <- liftIO $ newProgress "" size
		meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1)
		showOutput
		r <- a $ \n -> liftIO $ do
			setP progress $ fromBytesProcessed n
			displayMeter stdout meter
			maybe noop (\m -> m n) combinemeterupdate
		liftIO $ clearMeter stdout meter
		return r
	go _ = a (const noop)

showSideAction :: String -> Annex ()
showSideAction m = Annex.getState Annex.output >>= go
  where
	go st
		| sideActionBlock st == StartBlock = do
			p
			let st' = st { sideActionBlock = InBlock }
			Annex.changeState $ \s -> s { Annex.output = st' }
		| sideActionBlock st == InBlock = return ()
		| otherwise = p
	p = handle q $ putStrLn $ "(" ++ m ++ "...)"

showStoringStateAction :: Annex ()
showStoringStateAction = showSideAction "Recording state in git"

{- Performs an action, supressing showSideAction messages. -}
doQuietSideAction :: Annex a -> Annex a
doQuietSideAction = doSideAction' InBlock

{- Performs an action, that may call showSideAction multiple times.
 - Only the first will be displayed. -}
doSideAction :: Annex a -> Annex a
doSideAction = doSideAction' StartBlock

doSideAction' :: SideActionBlock -> Annex a -> Annex a
doSideAction' b a = do
	o <- Annex.getState Annex.output
	set $ o { sideActionBlock = b }
	set o `after` a
  where
	set o = Annex.changeState $ \s -> s {  Annex.output = o }

showOutput :: Annex ()
showOutput = handle q $
	putStr "\n"

showLongNote :: String -> Annex ()
showLongNote s = handle (JSON.note s) $
	putStrLn $ '\n' : indent s

showEndOk :: Annex ()
showEndOk = showEndResult True

showEndFail :: Annex ()
showEndFail = showEndResult False

showEndResult :: Bool -> Annex ()
showEndResult ok = handle (JSON.end ok) $ putStrLn msg
  where
	msg
		| ok = "ok"
		| otherwise = "failed"

showErr :: (Show a) => a -> Annex ()
showErr e = warning' $ "git-annex: " ++ show e

warning :: String -> Annex ()
warning = warning' . indent

warning' :: String -> Annex ()
warning' w = do
	handle q $ putStr "\n"
	liftIO $ do
		hFlush stdout
		hPutStrLn stderr w

warningIO :: String -> IO ()
warningIO w = do
	putStr "\n"
	hFlush stdout
	hPutStrLn stderr w

{- Displays a warning one time about a file the user specified not existing. -}
fileNotFound :: FilePath -> Annex ()
fileNotFound file = do
	st <- Annex.getState Annex.output
	let shown = fileNotFoundShown st
	when (S.notMember file shown) $ do
		let shown' = S.insert file shown
		let st' = st { fileNotFoundShown = shown' }
		Annex.changeState $ \s -> s { Annex.output = st' }
		liftIO $ hPutStrLn stderr $ unwords
			[ "git-annex:", file, "not found" ]

indent :: String -> String
indent = intercalate "\n" . map (\l -> "  " ++ l) . lines

{- Shows a JSON fragment only when in json mode. -}
maybeShowJSON :: JSON a => [(String, a)] -> Annex ()
maybeShowJSON v = handle (JSON.add v) q

{- Shows a complete JSON value, only when in json mode. -}
showFullJSON :: JSON a => [(String, a)] -> Annex Bool
showFullJSON v = withOutputType $ liftIO . go
  where
	go JSONOutput = JSON.complete v >> return True
	go _ = return False

{- Performs an action that outputs nonstandard/customized output, and
 - in JSON mode wraps its output in JSON.start and JSON.end, so it's
 - a complete JSON document.
 - This is only needed when showStart and showEndOk is not used. -}
showCustom :: String -> Annex Bool -> Annex ()
showCustom command a = do
	handle (JSON.start command Nothing) q
	r <- a
	handle (JSON.end r) q

showHeader :: String -> Annex ()
showHeader h = handle q $
	flushed $ putStr $ h ++ ": "

showRaw :: String -> Annex ()
showRaw s = handle q $ putStrLn s

setupConsole :: IO ()
setupConsole = do
	s <- setFormatter
		<$> streamHandler stderr DEBUG
		<*> pure (simpleLogFormatter "[$time] $msg")
	updateGlobalLogger rootLoggerName (setLevel NOTICE . setHandlers [s])
	{- This avoids ghc's output layer crashing on
	 - invalid encoded characters in
	 - filenames when printing them out. -}
	fileEncoding stdout
	fileEncoding stderr

enableDebugOutput :: IO ()
enableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel DEBUG

disableDebugOutput :: IO ()
disableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel NOTICE

handle :: IO () -> IO () -> Annex ()
handle json normal = withOutputType go
  where
	go NormalOutput = liftIO normal
	go QuietOutput = q
	go JSONOutput = liftIO $ flushed json

q :: Monad m => m ()
q = noop

flushed :: IO () -> IO ()
flushed a = a >> hFlush stdout

withOutputType :: (OutputType -> Annex a) -> Annex a
withOutputType a = outputType <$> Annex.getState Annex.output >>= a

repo_name: kakafarm/git

license: unknown


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

module Messages.JSON (
	start,
	end,
	note,
	add,
	complete
) where

import Text.JSON

import qualified Utility.JSONStream as Stream

start :: String -> Maybe String -> IO ()
start command file =
	putStr $ Stream.start $ ("command", command) : filepart file
  where
	filepart Nothing = []
	filepart (Just f) = [("file", f)]

end :: Bool -> IO ()
end b = putStr $ Stream.add [("success", b)] ++ Stream.end

note :: String -> IO ()
note s = add [("note", s)]

add :: JSON a => [(String, a)] -> IO ()
add v = putStr $ Stream.add v

complete :: JSON a => [(String, a)] -> IO ()
complete v = putStr $ Stream.start v ++ Stream.end


code:
git-annex allows managing files with git, without checking the file
contents into git. While that may seem paradoxical, it is useful when
dealing with files larger than git can currently easily handle, whether due
to limitations in memory, checksumming time, or disk space.

For documentation, see doc/ or <http://git-annex.branchable.com/>

path: README


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

module Remote (
	Remote,
	uuid,
	name,
	storeKey,
	retrieveKeyFile,
	retrieveKeyFileCheap,
	removeKey,
	hasKey,
	hasKeyCheap,
	whereisKey,
	remoteFsck,

	remoteTypes,
	remoteList,
	gitSyncableRemote,
	remoteMap,
	remoteMap',
	uuidDescriptions,
	byName,
	byName',
	byNameOnly,
	byNameWithUUID,
	byCost,
	prettyPrintUUIDs,
	prettyListUUIDs,
	prettyUUID,
	remoteFromUUID,
	remotesWithUUID,
	remotesWithoutUUID,
	keyLocations,
	keyPossibilities,
	keyPossibilitiesTrusted,
	nameToUUID,
	nameToUUID',
	showTriedRemotes,
	showLocations,
	forceTrust,
	logStatus,
	checkAvailable,
	isXMPPRemote
) where

import qualified Data.Map as M
import Text.JSON
import Text.JSON.Generic
import Data.Ord

import Common.Annex
import Types.Remote
import qualified Annex
import Annex.UUID
import Logs.UUID
import Logs.Trust
import Logs.Location hiding (logStatus)
import Remote.List
import Config
import Git.Types (RemoteName)
import qualified Git

{- Map from UUIDs of Remotes to a calculated value. -}
remoteMap :: (Remote -> v) -> Annex (M.Map UUID v)
remoteMap mkv = remoteMap' mkv mkk
  where
	mkk r = case uuid r of
		NoUUID -> Nothing
		u -> Just u

remoteMap' :: Ord k => (Remote -> v) -> (Remote -> Maybe k) -> Annex (M.Map k v)
remoteMap' mkv mkk = M.fromList . mapMaybe mk <$> remoteList
  where
	mk r = case mkk r of
		Nothing -> Nothing
		Just k -> Just (k, mkv r)

{- Map of UUIDs of remotes and their descriptions.
 - The names of Remotes are added to suppliment any description that has
 - been set for a repository.  -}
uuidDescriptions :: Annex (M.Map UUID String)
uuidDescriptions = M.unionWith addName <$> uuidMap <*> remoteMap name

addName :: String -> RemoteName -> String
addName desc n
	| desc == n || null desc = "[" ++ n ++ "]"
	| otherwise = desc ++ " [" ++ n ++ "]"

{- When a name is specified, looks up the remote matching that name.
 - (Or it can be a UUID.) -}
byName :: Maybe RemoteName -> Annex (Maybe Remote)
byName Nothing = return Nothing
byName (Just n) = either error Just <$> byName' n

{- Like byName, but the remote must have a configured UUID. -}
byNameWithUUID :: Maybe RemoteName -> Annex (Maybe Remote)
byNameWithUUID = checkuuid <=< byName
  where
  	checkuuid Nothing = return Nothing
	checkuuid (Just r)
		| uuid r == NoUUID =
			if remoteAnnexIgnore (gitconfig r)
				then error $ noRemoteUUIDMsg r ++
					" (" ++ show (remoteConfig (repo r) "ignore") ++
					" is set)"
				else error $ noRemoteUUIDMsg r
		| otherwise = return $ Just r

byName' :: RemoteName -> Annex (Either String Remote)
byName' "" = return $ Left "no remote specified"
byName' n = handle . filter matching <$> remoteList
  where
	handle [] = Left $ "there is no available git remote named \"" ++ n ++ "\""
	handle (match:_) = Right match
	matching r = n == name r || toUUID n == uuid r

{- Only matches remote name, not UUID -}
byNameOnly :: RemoteName -> Annex (Maybe Remote)
byNameOnly n = headMaybe . filter matching <$> remoteList
  where
	matching r = n == name r

noRemoteUUIDMsg :: Remote -> String
noRemoteUUIDMsg r = "cannot determine uuid for " ++ name r

{- Looks up a remote by name (or by UUID, or even by description),
 - and returns its UUID. Finds even repositories that are not
 - configured in .git/config. -}
nameToUUID :: RemoteName -> Annex UUID
nameToUUID = either error return <=< nameToUUID'

nameToUUID' :: RemoteName -> Annex (Either String UUID)
nameToUUID' "." = Right <$> getUUID -- special case for current repo
nameToUUID' "here" = Right <$> getUUID
nameToUUID' n = byName' n >>= go
  where
	go (Right r) = return $ case uuid r of
		NoUUID -> Left $ noRemoteUUIDMsg r
		u -> Right u
	go (Left e) = do
		m <- uuidMap
		return $ case M.keys (M.filter (== n) m) of
			[u] -> Right u
			[] -> let u = toUUID n
				in case M.keys (M.filterWithKey (\k _ -> k == u) m) of
					[] -> Left e
					_ -> Right u
			_us -> Left "Found multiple repositories with that description"

{- Pretty-prints a list of UUIDs of remotes, for human display.
 -
 - When JSON is enabled, also generates a machine-readable description
 - of the UUIDs. -}
prettyPrintUUIDs :: String -> [UUID] -> Annex String
prettyPrintUUIDs desc uuids = do
	hereu <- getUUID
	m <- uuidDescriptions
	maybeShowJSON [(desc, map (jsonify m hereu) uuids)]
	return $ unwords $ map (\u -> "\t" ++ prettify m hereu u ++ "\n") uuids
  where
	finddescription m u = M.findWithDefault "" u m
	prettify m hereu u
		| not (null d) = fromUUID u ++ " -- " ++ d
		| otherwise = fromUUID u
	  where
		ishere = hereu == u
		n = finddescription m u
		d
			| null n && ishere = "here"
			| ishere = addName n "here"
			| otherwise = n
	jsonify m hereu u = toJSObject
		[ ("uuid", toJSON $ fromUUID u)
		, ("description", toJSON $ finddescription m u)
		, ("here", toJSON $ hereu == u)
		]

{- List of remote names and/or descriptions, for human display.  -}
prettyListUUIDs :: [UUID] -> Annex [String]
prettyListUUIDs uuids = do
	hereu <- getUUID
	m <- uuidDescriptions
	return $ map (prettify m hereu) uuids
  where
	finddescription m u = M.findWithDefault "" u m
	prettify m hereu u
		| u == hereu = addName n "here"
		| otherwise = n
	  where
		n = finddescription m u

{- Nice display of a remote's name and/or description. -}
prettyUUID :: UUID -> Annex String
prettyUUID u = concat <$> prettyListUUIDs [u]

{- Gets the remote associated with a UUID. -}
remoteFromUUID :: UUID -> Annex (Maybe Remote)
remoteFromUUID u = ifM ((==) u <$> getUUID)
	( return Nothing
	, maybe tryharder (return . Just) =<< findinmap
	)
  where
	findinmap = M.lookup u <$> remoteMap id
	{- Re-read remote list in case a new remote has popped up. -}
	tryharder = do
		void remoteListRefresh
		findinmap

{- Filters a list of remotes to ones that have the listed uuids. -}
remotesWithUUID :: [Remote] -> [UUID] -> [Remote]
remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs

{- Filters a list of remotes to ones that do not have the listed uuids. -}
remotesWithoutUUID :: [Remote] -> [UUID] -> [Remote]
remotesWithoutUUID rs us = filter (\r -> uuid r `notElem` us) rs

{- List of repository UUIDs that the location log indicates may have a key.
 - Dead repositories are excluded. -}
keyLocations :: Key -> Annex [UUID]
keyLocations key = trustExclude DeadTrusted =<< loggedLocations key

{- Cost ordered lists of remotes that the location log indicates
 - may have a key.
 -}
keyPossibilities :: Key -> Annex [Remote]
keyPossibilities key = fst <$> keyPossibilities' key []

{- Cost ordered lists of remotes that the location log indicates
 - may have a key.
 -
 - Also returns a list of UUIDs that are trusted to have the key
 - (some may not have configured remotes).
 -}
keyPossibilitiesTrusted :: Key -> Annex ([Remote], [UUID])
keyPossibilitiesTrusted key = keyPossibilities' key =<< trustGet Trusted

keyPossibilities' :: Key -> [UUID] -> Annex ([Remote], [UUID])
keyPossibilities' key trusted = do
	u <- getUUID

	-- uuids of all remotes that are recorded to have the key
	validuuids <- filter (/= u) <$> keyLocations key

	-- note that validuuids is assumed to not have dups
	let validtrusteduuids = validuuids `intersect` trusted

	-- remotes that match uuids that have the key
	allremotes <- filter (not . remoteAnnexIgnore . gitconfig)
		<$> remoteList
	let validremotes = remotesWithUUID allremotes validuuids

	return (sortBy (comparing cost) validremotes, validtrusteduuids)

{- Displays known locations of a key. -}
showLocations :: Key -> [UUID] -> String -> Annex ()
showLocations key exclude nolocmsg = do
	u <- getUUID
	uuids <- keyLocations key
	untrusteduuids <- trustGet UnTrusted
	let uuidswanted = filteruuids uuids (u:exclude++untrusteduuids)
	let uuidsskipped = filteruuids uuids (u:exclude++uuidswanted)
	ppuuidswanted <- Remote.prettyPrintUUIDs "wanted" uuidswanted
	ppuuidsskipped <- Remote.prettyPrintUUIDs "skipped" uuidsskipped
	showLongNote $ message ppuuidswanted ppuuidsskipped
	ignored <- filter (remoteAnnexIgnore . gitconfig) <$> remoteList
	unless (null ignored) $
		showLongNote $ "(Note that these git remotes have annex-ignore set: " ++ unwords (map name ignored) ++ ")"
  where
	filteruuids l x = filter (`notElem` x) l
	message [] [] = nolocmsg
	message rs [] = "Try making some of these repositories available:\n" ++ rs
	message [] us = "Also these untrusted repositories may contain the file:\n" ++ us
	message rs us = message rs [] ++ message [] us

showTriedRemotes :: [Remote] -> Annex ()
showTriedRemotes [] = noop
showTriedRemotes remotes =
	showLongNote $ "Unable to access these remotes: " ++
		intercalate ", " (map name remotes)

forceTrust :: TrustLevel -> String -> Annex ()
forceTrust level remotename = do
	u <- nameToUUID remotename
	Annex.changeState $ \s ->
		s { Annex.forcetrust = M.insert u level (Annex.forcetrust s) }

{- Used to log a change in a remote's having a key. The change is logged
 - in the local repo, not on the remote. The process of transferring the
 - key to the remote, or removing the key from it *may* log the change
 - on the remote, but this cannot always be relied on. -}
logStatus :: Remote -> Key -> LogStatus -> Annex ()
logStatus remote key = logChange key (uuid remote)

{- Orders remotes by cost, with ones with the lowest cost grouped together. -}
byCost :: [Remote] -> [[Remote]]
byCost = map snd . sortBy (comparing fst) . M.toList . costmap
  where
	costmap = M.fromListWith (++) . map costpair
	costpair r = (cost r, [r])

checkAvailable :: Bool -> Remote -> IO Bool
checkAvailable assumenetworkavailable =
	maybe (return assumenetworkavailable) doesDirectoryExist . localpath

{- Remotes using the XMPP transport have urls like xmpp::user@host -}
isXMPPRemote :: Remote -> Bool
isXMPPRemote remote = Git.repoIsUrl r && "xmpp::" `isPrefixOf` Git.repoLocation r
  where
	r = repo remote


code:
{- Using bup as a remote.
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Remote.Bup (remote) where

import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import System.Process
import Data.ByteString.Lazy.UTF8 (fromString)

import Common.Annex
import qualified Annex
import Types.Remote
import Types.Key
import Types.Creds
import qualified Git
import qualified Git.Command
import qualified Git.Config
import qualified Git.Construct
import qualified Git.Ref
import Config
import Config.Cost
import qualified Remote.Helper.Ssh as Ssh
import Remote.Helper.Special
import Remote.Helper.Encryptable
import Remote.Helper.Messages
import Crypto
import Utility.Hash
import Utility.UserInfo
import Annex.Content
import Annex.UUID
import Utility.Metered

type BupRepo = String

remote :: RemoteType
remote = RemoteType {
	typename = "bup",
	enumerate = findSpecialRemotes "buprepo",
	generate = gen,
	setup = bupSetup
}

gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = do
	bupr <- liftIO $ bup2GitRemote buprepo
	cst <- remoteCost gc $
		if bupLocal buprepo
			then nearlyCheapRemoteCost
			else expensiveRemoteCost
	(u', bupr') <- getBupUUID bupr u

	let new = Remote
		{ uuid = u'
		, cost = cst
		, name = Git.repoDescribe r
		, storeKey = store new buprepo
		, retrieveKeyFile = retrieve buprepo
		, retrieveKeyFileCheap = retrieveCheap buprepo
		, removeKey = remove
		, hasKey = checkPresent r bupr'
		, hasKeyCheap = bupLocal buprepo
		, whereisKey = Nothing
		, remoteFsck = Nothing
		, repairRepo = Nothing
		, config = c
		, repo = r
		, gitconfig = gc
		, localpath = if bupLocal buprepo && not (null buprepo)
			then Just buprepo
			else Nothing
		, remotetype = remote
		, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable
		, readonly = False
		}
	return $ Just $ encryptableRemote c
		(storeEncrypted new buprepo)
		(retrieveEncrypted buprepo)
		new
  where
	buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc

bupSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
bupSetup mu _ c = do
	u <- maybe (liftIO genUUID) return mu

	-- verify configuration is sane
	let buprepo = fromMaybe (error "Specify buprepo=") $
		M.lookup "buprepo" c
	c' <- encryptionSetup c

	-- bup init will create the repository.
	-- (If the repository already exists, bup init again appears safe.)
	showAction "bup init"
	unlessM (bup "init" buprepo []) $ error "bup init failed"

	storeBupUUID u buprepo

	-- The buprepo is stored in git config, as well as this repo's
	-- persistant state, so it can vary between hosts.
	gitConfigSpecialRemote u c' "buprepo" buprepo

	return (c', u)

bupParams :: String -> BupRepo -> [CommandParam] -> [CommandParam]
bupParams command buprepo params =
	Param command : [Param "-r", Param buprepo] ++ params

bup :: String -> BupRepo -> [CommandParam] -> Annex Bool
bup command buprepo params = do
	showOutput -- make way for bup output
	liftIO $ boolSystem "bup" $ bupParams command buprepo params

pipeBup :: [CommandParam] -> Maybe Handle -> Maybe Handle -> IO Bool
pipeBup params inh outh = do
	p <- runProcess "bup" (toCommand params)
		Nothing Nothing inh outh Nothing
	ok <- waitForProcess p
	case ok of
		ExitSuccess -> return True
		_ -> return False

bupSplitParams :: Remote -> BupRepo -> Key -> [CommandParam] -> Annex [CommandParam]
bupSplitParams r buprepo k src = do
	let os = map Param $ remoteAnnexBupSplitOptions $ gitconfig r
	showOutput -- make way for bup output
	return $ bupParams "split" buprepo
		(os ++ [Param "-n", Param (bupRef k)] ++ src)

store :: Remote -> BupRepo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store r buprepo k _f _p = sendAnnex k (rollback k buprepo) $ \src -> do
	params <- bupSplitParams r buprepo k [File src]
	liftIO $ boolSystem "bup" params

storeEncrypted :: Remote -> BupRepo -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted r buprepo (cipher, enck) k _p =
	sendAnnex k (rollback enck buprepo) $ \src -> do
		params <- bupSplitParams r buprepo enck []
		liftIO $ catchBoolIO $
			encrypt (getGpgEncParams r) cipher (feedFile src) $ \h ->
				pipeBup params (Just h) Nothing

retrieve :: BupRepo -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
retrieve buprepo k _f d _p = do
	let params = bupParams "join" buprepo [Param $ bupRef k]
	liftIO $ catchBoolIO $ withFile d WriteMode $
		pipeBup params Nothing . Just

retrieveCheap :: BupRepo -> Key -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False

retrieveEncrypted :: BupRepo -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
retrieveEncrypted buprepo (cipher, enck) _ f _p = liftIO $ catchBoolIO $
	withHandle StdoutHandle createProcessSuccess p $ \h -> do
		decrypt cipher (\toh -> L.hPut toh =<< L.hGetContents h) $
			readBytes $ L.writeFile f
		return True
  where
	params = bupParams "join" buprepo [Param $ bupRef enck]
	p = proc "bup" $ toCommand params

remove :: Key -> Annex Bool
remove _ = do
	warning "content cannot be removed from bup remote"
	return False

{- Cannot revert having stored a key in bup, but at least the data for the
 - key will be used for deltaing data of other keys stored later.
 -
 - We can, however, remove the git branch that bup created for the key.
 -}
rollback :: Key -> BupRepo -> Annex ()
rollback k bupr = go =<< liftIO (bup2GitRemote bupr)
  where
	go r
		| Git.repoIsUrl r = void $ onBupRemote r boolSystem "git" params
		| otherwise = void $ liftIO $ catchMaybeIO $
			boolSystem "git" $ Git.Command.gitCommandLine params r
	params = [ Params "branch -D", Param (bupRef k) ]

{- Bup does not provide a way to tell if a given dataset is present
 - in a bup repository. One way it to check if the git repository has
 - a branch matching the name (as created by bup split -n).
 -}
checkPresent :: Git.Repo -> Git.Repo -> Key -> Annex (Either String Bool)
checkPresent r bupr k
	| Git.repoIsUrl bupr = do
		showChecking r
		ok <- onBupRemote bupr boolSystem "git" params
		return $ Right ok
	| otherwise = liftIO $ catchMsgIO $
		boolSystem "git" $ Git.Command.gitCommandLine params bupr
  where
	params =
		[ Params "show-ref --quiet --verify"
		, Param $ "refs/heads/" ++ bupRef k
		]

{- Store UUID in the annex.uuid setting of the bup repository. -}
storeBupUUID :: UUID -> BupRepo -> Annex ()
storeBupUUID u buprepo = do
	r <- liftIO $ bup2GitRemote buprepo
	if Git.repoIsUrl r
		then do
			showAction "storing uuid"
			unlessM (onBupRemote r boolSystem "git"
				[Params $ "config annex.uuid " ++ v]) $
					error "ssh failed"
		else liftIO $ do
			r' <- Git.Config.read r
			let olduuid = Git.Config.get "annex.uuid" "" r'
			when (olduuid == "") $
				Git.Command.run
					[ Param "config"
					, Param "annex.uuid"
					, Param v
					] r'
  where
	v = fromUUID u

onBupRemote :: Git.Repo -> (FilePath -> [CommandParam] -> IO a) -> FilePath -> [CommandParam] -> Annex a
onBupRemote r a command params = do
	c <- Annex.getRemoteGitConfig r
	sshparams <- Ssh.toRepo r c [Param $
			"cd " ++ dir ++ " && " ++ unwords (command : toCommand params)]
	liftIO $ a "ssh" sshparams
  where
	path = Git.repoPath r
	base = fromMaybe path (stripPrefix "/~/" path)
	dir = shellEscape base

{- Allow for bup repositories on removable media by checking
 - local bup repositories to see if they are available, and getting their
 - uuid (which may be different from the stored uuid for the bup remote).
 -
 - If a bup repository is not available, returns NoUUID.
 - This will cause checkPresent to indicate nothing from the bup remote
 - is known to be present.
 -
 - Also, returns a version of the repo with config read, if it is local.
 -}
getBupUUID :: Git.Repo -> UUID -> Annex (UUID, Git.Repo)
getBupUUID r u
	| Git.repoIsUrl r = return (u, r)
	| otherwise = liftIO $ do
		ret <- tryIO $ Git.Config.read r
		case ret of
			Right r' -> return (toUUID $ Git.Config.get "annex.uuid" "" r', r')
			Left _ -> return (NoUUID, r)

{- Converts a bup remote path spec into a Git.Repo. There are some
 - differences in path representation between git and bup. -}
bup2GitRemote :: BupRepo -> IO Git.Repo
bup2GitRemote "" = do
	-- bup -r "" operates on ~/.bup
	h <- myHomeDir
	Git.Construct.fromAbsPath $ h </> ".bup"
bup2GitRemote r
	| bupLocal r =
		if "/" `isPrefixOf` r
			then Git.Construct.fromAbsPath r
			else error "please specify an absolute path"
	| otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir
  where
	bits = split ":" r
	host = Prelude.head bits
	dir = intercalate ":" $ drop 1 bits
	-- "host:~user/dir" is not supported specially by bup;
	-- "host:dir" is relative to the home directory;
	-- "host:" goes in ~/.bup
	slash d
		| null d = "/~/.bup"
		| "/" `isPrefixOf` d = d
		| otherwise = "/~/" ++ d

{- Converts a key into a git ref name, which bup-split -n will use to point
 - to it. -}
bupRef :: Key -> String
bupRef k
	| Git.Ref.legal True shown = shown
	| otherwise = "git-annex-" ++ show (sha256 (fromString shown))
  where
	shown = key2file k

bupLocal :: BupRepo -> Bool
bupLocal = notElem ':'


code:
{- Using ddar as a remote. Based on bup and rsync remotes.
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 - Copyright 2014 Robie Basak <robie@justgohome.co.uk>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Remote.Ddar (remote) where

import Control.Exception
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import System.IO.Error
import System.Process

import Data.String.Utils
import Common.Annex
import Types.Remote
import Types.Key
import Types.Creds
import qualified Git
import Config
import Config.Cost
import Remote.Helper.Special
import Remote.Helper.Encryptable
import Crypto
import Annex.Content
import Annex.Ssh
import Annex.UUID
import Utility.Metered

type DdarRepo = String

remote :: RemoteType
remote = RemoteType {
	typename = "ddar",
	enumerate = findSpecialRemotes "ddarrepo",
	generate = gen,
	setup = ddarSetup
}

gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = do
	cst <- remoteCost gc $
		if ddarLocal ddarrepo
			then nearlyCheapRemoteCost
			else expensiveRemoteCost

	let new = Remote
		{ uuid = u
		, cost = cst
		, name = Git.repoDescribe r
		, storeKey = store ddarrepo
		, retrieveKeyFile = retrieve ddarrepo
		, retrieveKeyFileCheap = retrieveCheap
		, removeKey = remove ddarrepo
		, hasKey = checkPresent ddarrepo
		, hasKeyCheap = ddarLocal ddarrepo
		, whereisKey = Nothing
		, remoteFsck = Nothing
		, repairRepo = Nothing
		, config = c
		, repo = r
		, gitconfig = gc
		, localpath = if ddarLocal ddarrepo && not (null ddarrepo)
			then Just ddarrepo
			else Nothing
		, remotetype = remote
		, availability = if ddarLocal ddarrepo then LocallyAvailable else GloballyAvailable
		, readonly = False
		}
	return $ Just $ encryptableRemote c
		(storeEncrypted new ddarrepo)
		(retrieveEncrypted ddarrepo)
		new
  where
	ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc

ddarSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
ddarSetup mu _ c = do
	u <- maybe (liftIO genUUID) return mu

	-- verify configuration is sane
	let ddarrepo = fromMaybe (error "Specify ddarrepo=") $
		M.lookup "ddarrepo" c
	c' <- encryptionSetup c

	-- The ddarrepo is stored in git config, as well as this repo's
	-- persistant state, so it can vary between hosts.
	gitConfigSpecialRemote u c' "ddarrepo" ddarrepo

	return (c', u)

pipeDdar :: [CommandParam] -> Maybe Handle -> Maybe Handle -> IO Bool
pipeDdar params inh outh = do
	p <- runProcess "ddar" (toCommand params)
		Nothing Nothing inh outh Nothing
	ok <- waitForProcess p
	case ok of
		ExitSuccess -> return True
		_ -> return False

store :: DdarRepo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store ddarrepo k _f _p = sendAnnex k (void $ remove ddarrepo k) $ \src -> do
	let params =
		[ Param "c"
		, Param "-N"
		, Param $ key2file k
		, Param ddarrepo
		, File src
		]
	liftIO $ boolSystem "ddar" params

storeEncrypted :: Remote -> DdarRepo -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted r ddarrepo (cipher, enck) k _p =
	sendAnnex k (void $ remove ddarrepo k) $ \src ->
		liftIO $ catchBoolIO $
			encrypt (getGpgEncParams r) cipher (feedFile src) $ \h ->
				pipeDdar params (Just h) Nothing
  where
	params =
		[ Param "c"
		, Param "-N"
		, Param $ key2file enck
		, Param ddarrepo
		, Param "-"
		]

{- Convert remote DdarRepo to host and path on remote end -}
splitRemoteDdarRepo :: DdarRepo -> (String, String)
splitRemoteDdarRepo ddarrepo =
	(host, ddarrepo')
  where
	(host, remainder) = span (/= ':') ddarrepo
	ddarrepo' = drop 1 remainder

{- Return the command and parameters to use for a ddar call that may need to be
 - made on a remote repository. This will call ssh if needed. -}

ddarRemoteCall :: DdarRepo -> Char -> [CommandParam] -> Annex (String, [CommandParam])
ddarRemoteCall ddarrepo cmd params
	| ddarLocal ddarrepo = return ("ddar", localParams)
	| otherwise = do
		remoteCachingParams <- sshCachingOptions (host, Nothing) []
		return ("ssh", remoteCachingParams ++ remoteParams)
  where
	(host, ddarrepo') = splitRemoteDdarRepo ddarrepo
	localParams = Param [cmd] : Param ddarrepo : params
	remoteParams = Param host : Param "ddar" : Param [cmd] : Param ddarrepo' : params

{- Specialized ddarRemoteCall that includes extraction command and flags -}

ddarExtractRemoteCall :: DdarRepo -> Key -> Annex (String, [CommandParam])
ddarExtractRemoteCall ddarrepo k =
	ddarRemoteCall ddarrepo 'x' [Param "--force-stdout", Param $ key2file k]

retrieve :: DdarRepo -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
retrieve ddarrepo k _f d _p = do
	(cmd, params) <- ddarExtractRemoteCall ddarrepo k
	liftIO $ catchBoolIO $ withFile d WriteMode $ \h -> do
		let p = (proc cmd $ toCommand params){ std_out = UseHandle h }
		(_, _, _, pid) <- Common.Annex.createProcess p
		forceSuccessProcess p pid
		return True

retrieveCheap :: Key -> FilePath -> Annex Bool
retrieveCheap _ _ = return False

retrieveEncrypted :: DdarRepo -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
retrieveEncrypted ddarrepo (cipher, enck) _ f _p = do
	(cmd, params) <- ddarExtractRemoteCall ddarrepo enck
	let p = proc cmd $ toCommand params
	liftIO $ catchBoolIO $ withHandle StdoutHandle createProcessSuccess p $ \h -> do
		decrypt cipher (\toh -> L.hPut toh =<< L.hGetContents h) $
			readBytes $ L.writeFile f
		return True

remove :: DdarRepo -> Key -> Annex Bool
remove ddarrepo key = do
	(cmd, params) <- ddarRemoteCall ddarrepo 'd' [Param $ key2file key]
	liftIO $ boolSystem cmd params

ddarDirectoryExists :: DdarRepo -> Annex (Either String Bool)
ddarDirectoryExists ddarrepo
	| ddarLocal ddarrepo = do
		maybeStatus <- liftIO $ tryJust (guard . isDoesNotExistError) $ getFileStatus ddarrepo
		return $ case maybeStatus of
			Left _ -> Right False
			Right status -> Right $ isDirectory status
	| otherwise = do
		sshCachingParams <- sshCachingOptions (host, Nothing) []
		exitCode <- liftIO $ safeSystem "ssh" $ sshCachingParams ++ params
		case exitCode of
			ExitSuccess -> return $ Right True
			ExitFailure 1 -> return $ Right False
			ExitFailure code -> return $ Left $ "ssh call " ++
				show (Data.String.Utils.join " " $ toCommand params) ++
				" failed with status " ++ show code
  where
	(host, ddarrepo') = splitRemoteDdarRepo ddarrepo
	params =
		[ Param host
		, Param "test"
		, Param "-d"
		, Param ddarrepo'
		]

{- Use "ddar t" to determine if a given key is present in a ddar archive -}
inDdarManifest :: DdarRepo -> Key -> Annex (Either String Bool)
inDdarManifest ddarrepo k = do
	(cmd, params) <- ddarRemoteCall ddarrepo 't' []
	let p = proc cmd $ toCommand params
	liftIO $ catchMsgIO $ withHandle StdoutHandle createProcessSuccess p $ \h -> do
		contents <- hGetContents h
		return $ elem k' $ lines contents
  where
	k' = key2file k

checkPresent :: DdarRepo -> Key -> Annex (Either String Bool)
checkPresent ddarrepo key = do
	directoryExists <- ddarDirectoryExists ddarrepo
	case directoryExists of
		Left e -> return $ Left e
		Right True -> inDdarManifest ddarrepo key
		Right False -> return $ Right False

ddarLocal :: DdarRepo -> Bool
ddarLocal = notElem ':'


code:
{- A "remote" that is just a filesystem directory.
 -
 - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}

module Remote.Directory (remote) where

import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M

import Common.Annex
import Types.Remote
import Types.Creds
import qualified Git
import Config.Cost
import Config
import Utility.FileMode
import Remote.Helper.Special
import Remote.Helper.ChunkedEncryptable
import qualified Remote.Directory.LegacyChunked as Legacy
import Annex.Content
import Annex.UUID
import Utility.Metered

remote :: RemoteType
remote = RemoteType {
	typename = "directory",
	enumerate = findSpecialRemotes "directory",
	generate = gen,
	setup = directorySetup
}

gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = do
	cst <- remoteCost gc cheapRemoteCost
	let chunkconfig = chunkConfig c
	return $ Just $ chunkedEncryptableRemote c
		(prepareStore dir chunkconfig)
		(retrieve dir chunkconfig)
		Remote {
			uuid = u,
			cost = cst,
			name = Git.repoDescribe r,
			storeKey = storeKeyDummy,
			retrieveKeyFile = retreiveKeyFileDummy,
			retrieveKeyFileCheap = retrieveCheap dir chunkconfig,
			removeKey = remove dir,
			hasKey = checkPresent dir chunkconfig,
			hasKeyCheap = True,
			whereisKey = Nothing,
			remoteFsck = Nothing,
			repairRepo = Nothing,
			config = c,
			repo = r,
			gitconfig = gc,
			localpath = Just dir,
			readonly = False,
			availability = LocallyAvailable,
			remotetype = remote
		}
  where
	dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc

directorySetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
directorySetup mu _ c = do
	u <- maybe (liftIO genUUID) return mu
	-- verify configuration is sane
	let dir = fromMaybe (error "Specify directory=") $
		M.lookup "directory" c
	absdir <- liftIO $ absPath dir
	liftIO $ unlessM (doesDirectoryExist absdir) $
		error $ "Directory does not exist: " ++ absdir
	c' <- encryptionSetup c

	-- The directory is stored in git config, not in this remote's
	-- persistant state, so it can vary between hosts.
	gitConfigSpecialRemote u c' "directory" absdir
	return (M.delete "directory" c', u)

{- Locations to try to access a given Key in the directory.
 - We try more than one since we used to write to different hash
 - directories. -}
locations :: FilePath -> Key -> [FilePath]
locations d k = map (d </>) (keyPaths k)

{- Returns the location off a Key in the directory. If the key is
 - present, returns the location that is actually used, otherwise
 - returns the first, default location. -}
getLocation :: FilePath -> Key -> IO FilePath
getLocation d k = do
	let locs = locations d k
	fromMaybe (Prelude.head locs) <$> firstM doesFileExist locs

{- Directory where the file(s) for a key are stored. -}
storeDir :: FilePath -> Key -> FilePath
storeDir d k = addTrailingPathSeparator $ d </> hashDirLower k </> keyFile k

{- Where we store temporary data for a key, in the directory, as it's being
 - written. -}
tmpDir :: FilePath -> Key -> FilePath
tmpDir d k = addTrailingPathSeparator $ d </> "tmp" </> keyFile k

{- Check if there is enough free disk space in the remote's directory to
 - store the key. Note that the unencrypted key size is checked. -}
prepareStore :: FilePath -> ChunkConfig -> Preparer Storer
prepareStore d chunkconfig = checkPrepare
	(\k -> checkDiskSpace (Just d) k 0)
	(byteStorer $ store d chunkconfig)

store :: FilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex Bool
store d chunkconfig k b p = liftIO $ do
	void $ tryIO $ createDirectoryIfMissing True tmpdir
	case chunkconfig of
		LegacyChunks chunksize -> Legacy.store chunksize finalizer k b p tmpdir destdir
		_ -> do
			let tmpf = tmpdir </> keyFile k
			meteredWriteFile p tmpf b
			finalizer tmpdir destdir
			return True
  where
	tmpdir = tmpDir d k
	destdir = storeDir d k
	finalizer tmp dest = do
		void $ tryIO $ allowWrite dest -- may already exist
		void $ tryIO $ removeDirectoryRecursive dest -- or not exist
		createDirectoryIfMissing True (parentDir dest)
		renameDirectory tmp dest
		-- may fail on some filesystems
		void $ tryIO $ do
			mapM_ preventWrite =<< dirContents dest
			preventWrite dest

retrieve :: FilePath -> ChunkConfig -> Preparer Retriever
retrieve d (LegacyChunks _) = Legacy.retrieve locations d
retrieve d _ = simplyPrepare $ byteRetriever $ \k ->
	liftIO $ L.readFile =<< getLocation d k

retrieveCheap :: FilePath -> ChunkConfig -> Key -> FilePath -> Annex Bool
-- no cheap retrieval possible for chunks
retrieveCheap _ (UnpaddedChunks _) _ _ = return False
retrieveCheap _ (LegacyChunks _) _ _ = return False
#ifndef mingw32_HOST_OS
retrieveCheap d NoChunks k f = liftIO $ catchBoolIO $ do
	file <- getLocation d k
	createSymbolicLink file f
	return True
#else
retrieveCheap _ _ _ _ = return False
#endif

remove :: FilePath -> Key -> Annex Bool
remove d k = liftIO $ do
	void $ tryIO $ allowWrite dir
#ifdef mingw32_HOST_OS
	{- Windows needs the files inside the directory to be writable
	 - before it can delete them. -}
	void $ tryIO $ mapM_ allowWrite =<< dirContents dir
#endif
	ok <- catchBoolIO $ do
		removeDirectoryRecursive dir
		return True
	{- Removing the subdirectory will fail if it doesn't exist.
	 - But, we want to succeed in that case, as long as the directory
	 - remote's top-level directory does exist. -}
	if ok
		then return ok
		else doesDirectoryExist d <&&> (not <$> doesDirectoryExist dir)
  where
	dir = storeDir d k

checkPresent :: FilePath -> ChunkConfig -> Key -> Annex (Either String Bool)
checkPresent d (LegacyChunks _) k = Legacy.checkPresent d locations k
checkPresent d _ k = liftIO $ do
	v <- catchMsgIO $ anyM doesFileExist (locations d k)
	case v of
		Right False -> ifM (doesDirectoryExist d)
			( return v
			, return $ Left $ "directory " ++ d ++ " is not accessible"
			)
		_ -> return v


code:
{- Legacy chunksize support for directory special remote.
 -
 - Can be removed eventually.
 -
 - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE Rank2Types #-}

module Remote.Directory.LegacyChunked where

import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S

import Common.Annex
import Utility.FileMode
import Remote.Helper.ChunkedEncryptable
import qualified Remote.Helper.Chunked.Legacy as Legacy
import Annex.Perms
import Utility.Metered

withCheckedFiles :: (FilePath -> IO Bool) -> FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool
withCheckedFiles _ [] _locations _ _ = return False
withCheckedFiles check d locations k a = go $ locations d k
  where
	go [] = return False
	go (f:fs) = do
		let chunkcount = f ++ Legacy.chunkCount
		ifM (check chunkcount)
			( do
				chunks <- Legacy.listChunks f <$> readFile chunkcount
				ifM (allM check chunks)
					( a chunks , return False )
			, do
				chunks <- Legacy.probeChunks f check
				if null chunks
					then go fs
					else a chunks
			)
withStoredFiles :: FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool
withStoredFiles = withCheckedFiles doesFileExist

{- Splits a ByteString into chunks and writes to dests, obeying configured
 - chunk size (not to be confused with the L.ByteString chunk size). -}
storeLegacyChunked :: MeterUpdate -> ChunkSize -> [FilePath] -> L.ByteString -> IO [FilePath]
storeLegacyChunked _ _ [] _ = error "bad storeLegacyChunked call"
storeLegacyChunked meterupdate chunksize alldests@(firstdest:_) b
	| L.null b = do
		-- always write at least one file, even for empty
		L.writeFile firstdest b
		return [firstdest]
	| otherwise = storeLegacyChunked' meterupdate chunksize alldests (L.toChunks b) []
storeLegacyChunked' :: MeterUpdate -> ChunkSize -> [FilePath] -> [S.ByteString] -> [FilePath] -> IO [FilePath]
storeLegacyChunked' _ _ [] _ _ = error "ran out of dests"
storeLegacyChunked' _ _  _ [] c = return $ reverse c
storeLegacyChunked' meterupdate chunksize (d:dests) bs c = do
	bs' <- withFile d WriteMode $
		feed zeroBytesProcessed chunksize bs
	storeLegacyChunked' meterupdate chunksize dests bs' (d:c)
  where
	feed _ _ [] _ = return []
	feed bytes sz (l:ls) h = do
		let len = S.length l
		let s = fromIntegral len
		if s <= sz || sz == chunksize
			then do
				S.hPut h l
				let bytes' = addBytesProcessed bytes len
				meterupdate bytes'
				feed bytes' (sz - s) ls h
			else return (l:ls)

storeHelper :: (FilePath -> FilePath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO Bool
storeHelper finalizer key storer tmpdir destdir = do
	void $ liftIO $ tryIO $ createDirectoryIfMissing True tmpdir
	Legacy.storeChunks key tmpdir destdir storer recorder finalizer
  where
	recorder f s = do
		void $ tryIO $ allowWrite f
		writeFile f s
		void $ tryIO $ preventWrite f

store :: ChunkSize -> (FilePath -> FilePath -> IO ()) -> Key -> L.ByteString -> MeterUpdate -> FilePath -> FilePath -> IO Bool
store chunksize finalizer k b p = storeHelper finalizer k $ \dests ->
	storeLegacyChunked p chunksize dests b

{- Need to get a single ByteString containing every chunk.
 - Done very innefficiently, by writing to a temp file.
 - :/ This is legacy code..
 -}
retrieve :: (FilePath -> Key -> [FilePath]) -> FilePath -> Preparer Retriever
retrieve locations d basek a = do
	showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow."
	tmpdir <- fromRepo $ gitAnnexTmpMiscDir
	createAnnexDirectory tmpdir
	let tmp = tmpdir </> keyFile basek ++ ".directorylegacy.tmp"
	a $ Just $ byteRetriever $ \k -> liftIO $ do
		void $ withStoredFiles d locations k $ \fs -> do
			forM_ fs $
				S.appendFile tmp <=< S.readFile
			return True
		b <- L.readFile tmp
		nukeFile tmp
		return b

checkPresent :: FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> Annex (Either String Bool)
checkPresent d locations k = liftIO $ catchMsgIO $
	withStoredFiles d locations k $
		-- withStoredFiles checked that it exists
		const $ return True


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

module Remote.External (remote) where

import Remote.External.Types
import qualified Annex
import Common.Annex
import Types.Remote
import Types.CleanupActions
import qualified Git
import Config
import Remote.Helper.Special
import Remote.Helper.ChunkedEncryptable
import Utility.Metered
import Logs.Transfer
import Logs.PreferredContent.Raw
import Logs.RemoteState
import Config.Cost
import Annex.UUID
import Annex.Exception
import Creds

import Control.Concurrent.STM
import System.Log.Logger (debugM)
import qualified Data.Map as M

remote :: RemoteType
remote = RemoteType {
	typename = "external",
	enumerate = findSpecialRemotes "externaltype",
	generate = gen,
	setup = externalSetup
}

gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = do
	external <- newExternal externaltype u c
	Annex.addCleanup (RemoteCleanup u) $ stopExternal external
	cst <- getCost external r gc
	avail <- getAvailability external r gc
	return $ Just $ chunkedEncryptableRemote c
		(simplyPrepare $ store external)
		(simplyPrepare $ retrieve external)
		Remote {
			uuid = u,
			cost = cst,
			name = Git.repoDescribe r,
			storeKey = storeKeyDummy,
			retrieveKeyFile = retreiveKeyFileDummy,
			retrieveKeyFileCheap = \_ _ -> return False,
			removeKey = remove external,
			hasKey = checkPresent external,
			hasKeyCheap = False,
			whereisKey = Nothing,
			remoteFsck = Nothing,
			repairRepo = Nothing,
			config = c,
			localpath = Nothing,
			repo = r,
			gitconfig = gc,
			readonly = False,
			availability = avail,
			remotetype = remote
		}
  where
	externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)

externalSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
externalSetup mu _ c = do
	u <- maybe (liftIO genUUID) return mu
	let externaltype = fromMaybe (error "Specify externaltype=") $
		M.lookup "externaltype" c
	c' <- encryptionSetup c

	external <- newExternal externaltype u c'
	handleRequest external INITREMOTE Nothing $ \resp -> case resp of
		INITREMOTE_SUCCESS -> Just noop
		INITREMOTE_FAILURE errmsg -> Just $ error errmsg
		_ -> Nothing
	c'' <- liftIO $ atomically $ readTMVar $ externalConfig external

	gitConfigSpecialRemote u c'' "externaltype" externaltype
	return (c'', u)

store :: External -> Storer
store external = fileStorer $ \k f p ->
	handleRequest external (TRANSFER Upload k f) (Just p) $ \resp ->
		case resp of
			TRANSFER_SUCCESS Upload k' | k == k' ->
				Just $ return True
			TRANSFER_FAILURE Upload k' errmsg | k == k' ->
				Just $ do
					warning errmsg
					return False
			_ -> Nothing

retrieve :: External -> Retriever
retrieve external = fileRetriever $ \d k p ->
	handleRequest external (TRANSFER Download k d) (Just p) $ \resp ->
		case resp of
			TRANSFER_SUCCESS Download k'
				| k == k' -> Just $ return ()
			TRANSFER_FAILURE Download k' errmsg
				| k == k' -> Just $ do
					error errmsg
			_ -> Nothing

remove :: External -> Key -> Annex Bool
remove external k = safely $
	handleRequest external (REMOVE k) Nothing $ \resp ->
		case resp of
			REMOVE_SUCCESS k'
				| k == k' -> Just $ return True
			REMOVE_FAILURE k' errmsg
				| k == k' -> Just $ do
					warning errmsg
					return False
			_ -> Nothing

checkPresent :: External -> Key -> Annex (Either String Bool)
checkPresent external k = either (Left . show) id <$> tryAnnex go
  where
	go = handleRequest external (CHECKPRESENT k) Nothing $ \resp ->
		case resp of
			CHECKPRESENT_SUCCESS k'
				| k' == k -> Just $ return $ Right True
			CHECKPRESENT_FAILURE k'
				| k' == k -> Just $ return $ Right False
			CHECKPRESENT_UNKNOWN k' errmsg
				| k' == k -> Just $ return $ Left errmsg
			_ -> Nothing

safely :: Annex Bool -> Annex Bool
safely a = go =<< tryAnnex a
  where
	go (Right r) = return r
	go (Left e) = do
		warning $ show e
		return False

{- Sends a Request to the external remote, and waits for it to generate
 - a Response. That is fed into the responsehandler, which should return
 - the action to run for it (or Nothing if there's a protocol error).
 -
 - While the external remote is processing the Request, it may send
 - any number of RemoteRequests, that are handled here.
 -
 - Only one request can be made at a time, so locking is used.
 -
 - May throw exceptions, for example on protocol errors, or
 - when the repository cannot be used.
 -}
handleRequest :: External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a
handleRequest external req mp responsehandler =
	withExternalLock external $ \lck ->
		handleRequest' lck external req mp responsehandler

handleRequest' :: ExternalLock -> External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a
handleRequest' lck external req mp responsehandler
	| needsPREPARE req = do
		checkPrepared lck external
		go
	| otherwise = go
  where
  	go = do
		sendMessage lck external req
		loop
	loop = receiveMessage lck external responsehandler
		(\rreq -> Just $ handleRemoteRequest rreq >> loop)
		(\msg -> Just $ handleAsyncMessage msg >> loop)

	handleRemoteRequest (PROGRESS bytesprocessed) =
		maybe noop (\a -> liftIO $ a bytesprocessed) mp
	handleRemoteRequest (DIRHASH k) =
		send $ VALUE $ hashDirMixed k
	handleRemoteRequest (SETCONFIG setting value) =
		liftIO $ atomically $ do
			let v = externalConfig external
			m <- takeTMVar v
			putTMVar v $ M.insert setting value m
	handleRemoteRequest (GETCONFIG setting) = do
		value <- fromMaybe "" . M.lookup setting
			<$> liftIO (atomically $ readTMVar $ externalConfig external)
		send $ VALUE value
	handleRemoteRequest (SETCREDS setting login password) = do
		c <- liftIO $ atomically $ readTMVar $ externalConfig external
		c' <- setRemoteCredPair c (credstorage setting) $
			Just (login, password)
		void $ liftIO $ atomically $ swapTMVar (externalConfig external) c'
	handleRemoteRequest (GETCREDS setting) = do
		c <- liftIO $ atomically $ readTMVar $ externalConfig external
		creds <- fromMaybe ("", "") <$>
			getRemoteCredPair c (credstorage setting)
		send $ CREDS (fst creds) (snd creds)
	handleRemoteRequest GETUUID = send $
		VALUE $ fromUUID $ externalUUID external
	handleRemoteRequest GETGITDIR = send . VALUE =<< fromRepo Git.localGitDir
	handleRemoteRequest (SETWANTED expr) =
		preferredContentSet (externalUUID external) expr
	handleRemoteRequest GETWANTED = do
		expr <- fromMaybe "" . M.lookup (externalUUID external)
			<$> preferredContentMapRaw
		send $ VALUE expr
	handleRemoteRequest (SETSTATE key state) =
		setRemoteState (externalUUID external) key state
	handleRemoteRequest (GETSTATE key) = do
		state <- fromMaybe ""
			<$> getRemoteState (externalUUID external) key
		send $ VALUE state
	handleRemoteRequest (DEBUG msg) = liftIO $ debugM "external" msg
	handleRemoteRequest (VERSION _) =
		sendMessage lck external $ ERROR "too late to send VERSION"

	handleAsyncMessage (ERROR err) = error $ "external special remote error: " ++ err

	send = sendMessage lck external

	credstorage setting = CredPairStorage
		{ credPairFile = base
		, credPairEnvironment = (base ++ "login", base ++ "password")
		, credPairRemoteKey = Just setting
		}
	  where
		base = replace "/" "_" $ fromUUID (externalUUID external) ++ "-" ++ setting

sendMessage :: Sendable m => ExternalLock -> External -> m -> Annex ()
sendMessage lck external m =
	fromExternal lck external externalSend $ \h ->
		liftIO $ do
			protocolDebug external True line
			hPutStrLn h line
			hFlush h
  where
	line = unwords $ formatMessage m

{- Waits for a message from the external remote, and passes it to the
 - apppropriate handler.
 -
 - If the handler returns Nothing, this is a protocol error.-}
receiveMessage
	:: ExternalLock
	-> External
	-> (Response -> Maybe (Annex a))
	-> (RemoteRequest -> Maybe (Annex a))
	-> (AsyncMessage -> Maybe (Annex a))
	-> Annex a
receiveMessage lck external handleresponse handlerequest handleasync =
	go =<< fromExternal lck external externalReceive
		(liftIO . catchMaybeIO . hGetLine)
  where
	go Nothing = protocolError False ""
	go (Just s) = do
		liftIO $ protocolDebug external False s
		case parseMessage s :: Maybe Response of
			Just resp -> maybe (protocolError True s) id (handleresponse resp)
			Nothing -> case parseMessage s :: Maybe RemoteRequest of
				Just req -> maybe (protocolError True s) id (handlerequest req)
				Nothing -> case parseMessage s :: Maybe AsyncMessage of
					Just msg -> maybe (protocolError True s) id (handleasync msg)
					Nothing -> protocolError False s
	protocolError parsed s = error $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++
		if parsed then "(command not allowed at this time)" else "(unable to parse command)"

protocolDebug :: External -> Bool -> String -> IO ()
protocolDebug external sendto line = debugM "external" $ unwords
	[ externalRemoteProgram (externalType external)
	, if sendto then "<--" else "-->"
	, line
	]

{- Starts up the external remote if it's not yet running,
 - and passes a value extracted from its state to an action.
 -}
fromExternal :: ExternalLock -> External -> (ExternalState -> v) -> (v -> Annex a) -> Annex a
fromExternal lck external extractor a =
	go =<< liftIO (atomically (tryReadTMVar v))
  where
	go (Just st) = run st
	go Nothing = do
		st <- startExternal $ externalType external
		void $ liftIO $ atomically $ do
			void $ tryReadTMVar v
			putTMVar v st

		{- Handle initial protocol startup; check the VERSION
		 - the remote sends. -}
		receiveMessage lck external
			(const Nothing)
			(checkVersion lck external)
			(const Nothing)

		run st

	run st = a $ extractor st
	v = externalState external

{- Starts an external remote process running, but does not handle checking
 - VERSION, etc. -}
startExternal :: ExternalType -> Annex ExternalState
startExternal externaltype = liftIO $ do
	(Just hin, Just hout, _, pid) <- createProcess $ (proc cmd [])
		{ std_in = CreatePipe
		, std_out = CreatePipe
		, std_err = Inherit
		}
	fileEncoding hin
	fileEncoding hout
	checkearlytermination =<< getProcessExitCode pid
	return $ ExternalState
		{ externalSend = hin
		, externalReceive = hout
		, externalPid = pid
		, externalPrepared = Unprepared
		}
  where
	cmd = externalRemoteProgram externaltype

	checkearlytermination Nothing = noop
	checkearlytermination (Just exitcode) = ifM (inPath cmd)
		( error $ unwords [ "failed to run", cmd, "(" ++ show exitcode ++ ")" ]
		, do
			path <- intercalate ":" <$> getSearchPath
			error $ cmd ++ " is not installed in PATH (" ++ path ++ ")"
		)

stopExternal :: External -> Annex ()
stopExternal external = liftIO $ stop =<< atomically (tryReadTMVar v)
  where
	stop Nothing = noop
	stop (Just st) = do
		void $ atomically $ tryTakeTMVar v
		hClose $ externalSend st
		hClose $ externalReceive st
		void $ waitForProcess $ externalPid st
	v = externalState external

externalRemoteProgram :: ExternalType -> String
externalRemoteProgram externaltype = "git-annex-remote-" ++ externaltype

checkVersion :: ExternalLock -> External -> RemoteRequest -> Maybe (Annex ())
checkVersion lck external (VERSION v) = Just $
	if v `elem` supportedProtocolVersions
		then noop
		else sendMessage lck external (ERROR "unsupported VERSION")
checkVersion _ _ _ = Nothing

{- If repo has not been prepared, sends PREPARE.
 -
 - If the repo fails to prepare, or failed before, throws an exception with
 - the error message. -}
checkPrepared :: ExternalLock -> External -> Annex ()
checkPrepared lck external =
	fromExternal lck external externalPrepared $ \prepared ->
		case prepared of
			Prepared -> noop
			FailedPrepare errmsg -> error errmsg
			Unprepared ->
				handleRequest' lck external PREPARE Nothing $ \resp ->
					case resp of
						PREPARE_SUCCESS -> Just $
							setprepared Prepared
						PREPARE_FAILURE errmsg -> Just $ do
							setprepared $ FailedPrepare errmsg
							error errmsg
						_ -> Nothing
  where
	setprepared status = liftIO . atomically $ do
		let v = externalState external
		st <- takeTMVar v
		void $ putTMVar v $ st { externalPrepared = status }

{- Caches the cost in the git config to avoid needing to start up an
 - external special remote every time time just to ask it what its
 - cost is. -}
getCost :: External -> Git.Repo -> RemoteGitConfig -> Annex Cost
getCost external r gc = go =<< remoteCost' gc
  where
	go (Just c) = return c
	go Nothing = do
		c <- handleRequest external GETCOST Nothing $ \req -> case req of
			COST c -> Just $ return c
			UNSUPPORTED_REQUEST -> Just $ return expensiveRemoteCost
			_ -> Nothing
		setRemoteCost r c
		return c

{- Caches the availability in the git config to avoid needing to start up an
 - external special remote every time time just to ask it what its
 - availability is.
 -
 - Most remotes do not bother to implement a reply to this request;
 - globally available is the default.
 -}
getAvailability :: External -> Git.Repo -> RemoteGitConfig -> Annex Availability
getAvailability external r gc = maybe query return (remoteAnnexAvailability gc)
  where
	query = do
		avail <- handleRequest external GETAVAILABILITY Nothing $ \req -> case req of
			AVAILABILITY avail -> Just $ return avail
			UNSUPPORTED_REQUEST -> Just $ return GloballyAvailable
			_ -> Nothing
		setRemoteAvailability r avail
		return avail


code:
{- External special remote data types.
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

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

module Remote.External.Types (
	External(..),
	newExternal,
	ExternalType,
	ExternalLock,
	withExternalLock,
	ExternalState(..),
	PrepareStatus(..),
	Proto.parseMessage,
	Proto.Sendable(..),
	Proto.Receivable(..),
	Request(..),
	needsPREPARE,
	Response(..),
	RemoteRequest(..),
	RemoteResponse(..),
	AsyncMessage(..),
	ErrorMsg,
	Setting,
	ProtocolVersion,
	supportedProtocolVersions,
) where

import Common.Annex
import Annex.Exception
import Types.Key (file2key, key2file)
import Types.StandardGroups (PreferredContentExpression)
import Utility.Metered (BytesProcessed(..))
import Logs.Transfer (Direction(..))
import Config.Cost (Cost)
import Types.Remote (RemoteConfig)
import Types.Availability (Availability(..))
import qualified Utility.SimpleProtocol as Proto

import Control.Concurrent.STM

-- If the remote is not yet running, the ExternalState TMVar is empty.
data External = External
	{ externalType :: ExternalType
	, externalUUID :: UUID
	-- Empty until the remote is running.
	, externalState :: TMVar ExternalState
	-- Empty when a remote is in use.
	, externalLock :: TMVar ExternalLock
	-- Never left empty.
	, externalConfig :: TMVar RemoteConfig
	}

newExternal :: ExternalType -> UUID -> RemoteConfig -> Annex External
newExternal externaltype u c = liftIO $ External
	<$> pure externaltype
	<*> pure u
	<*> atomically newEmptyTMVar
	<*> atomically (newTMVar ExternalLock)
	<*> atomically (newTMVar c)

type ExternalType = String

data ExternalState = ExternalState
	{ externalSend :: Handle
	, externalReceive :: Handle
	, externalPid :: ProcessHandle
	, externalPrepared :: PrepareStatus
	}

data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg

-- Constructor is not exported, and only created by newExternal.
data ExternalLock = ExternalLock

withExternalLock :: External -> (ExternalLock -> Annex a) -> Annex a
withExternalLock external = bracketIO setup cleanup
  where
	setup = atomically $ takeTMVar v
	cleanup = atomically . putTMVar v
	v = externalLock external

-- Messages that can be sent to the external remote to request it do something.
data Request
	= PREPARE
	| INITREMOTE
	| GETCOST
	| GETAVAILABILITY
	| TRANSFER Direction Key FilePath
	| CHECKPRESENT Key
	| REMOVE Key
	deriving (Show)

-- Does PREPARE need to have been sent before this request?
needsPREPARE :: Request -> Bool
needsPREPARE PREPARE = False
needsPREPARE INITREMOTE = False
needsPREPARE _ = True

instance Proto.Sendable Request where
	formatMessage PREPARE = ["PREPARE"]
	formatMessage INITREMOTE = ["INITREMOTE"]
	formatMessage GETCOST = ["GETCOST"]
	formatMessage GETAVAILABILITY = ["GETAVAILABILITY"]
	formatMessage (TRANSFER direction key file) =
		[ "TRANSFER"
		, Proto.serialize direction
		, Proto.serialize key
		, Proto.serialize file
		]
	formatMessage (CHECKPRESENT key) = [ "CHECKPRESENT", Proto.serialize key ]
	formatMessage (REMOVE key) = [ "REMOVE", Proto.serialize key ]

-- Responses the external remote can make to requests.
data Response
	= PREPARE_SUCCESS
	| PREPARE_FAILURE ErrorMsg
	| TRANSFER_SUCCESS Direction Key
	| TRANSFER_FAILURE Direction Key ErrorMsg
	| CHECKPRESENT_SUCCESS Key
	| CHECKPRESENT_FAILURE Key
	| CHECKPRESENT_UNKNOWN Key ErrorMsg
	| REMOVE_SUCCESS Key
	| REMOVE_FAILURE Key ErrorMsg
	| COST Cost
	| AVAILABILITY Availability
	| INITREMOTE_SUCCESS
	| INITREMOTE_FAILURE ErrorMsg
	| UNSUPPORTED_REQUEST
	deriving (Show)

instance Proto.Receivable Response where
	parseCommand "PREPARE-SUCCESS" = Proto.parse0 PREPARE_SUCCESS
	parseCommand "PREPARE-FAILURE" = Proto.parse1 PREPARE_FAILURE
	parseCommand "TRANSFER-SUCCESS" = Proto.parse2 TRANSFER_SUCCESS
	parseCommand "TRANSFER-FAILURE" = Proto.parse3 TRANSFER_FAILURE
	parseCommand "CHECKPRESENT-SUCCESS" = Proto.parse1 CHECKPRESENT_SUCCESS
	parseCommand "CHECKPRESENT-FAILURE" = Proto.parse1 CHECKPRESENT_FAILURE
	parseCommand "CHECKPRESENT-UNKNOWN" = Proto.parse2 CHECKPRESENT_UNKNOWN
	parseCommand "REMOVE-SUCCESS" = Proto.parse1 REMOVE_SUCCESS
	parseCommand "REMOVE-FAILURE" = Proto.parse2 REMOVE_FAILURE
	parseCommand "COST" = Proto.parse1 COST
	parseCommand "AVAILABILITY" = Proto.parse1 AVAILABILITY
	parseCommand "INITREMOTE-SUCCESS" = Proto.parse0 INITREMOTE_SUCCESS
	parseCommand "INITREMOTE-FAILURE" = Proto.parse1 INITREMOTE_FAILURE
	parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST
	parseCommand _ = Proto.parseFail

-- Requests that the external remote can send at any time it's in control.
data RemoteRequest
	= VERSION ProtocolVersion
	| PROGRESS BytesProcessed
	| DIRHASH Key
	| SETCONFIG Setting String
	| GETCONFIG Setting
	| SETCREDS Setting String String
	| GETCREDS Setting
	| GETUUID
	| GETGITDIR
	| SETWANTED PreferredContentExpression
	| GETWANTED
	| SETSTATE Key String
	| GETSTATE Key
	| DEBUG String
	deriving (Show)

instance Proto.Receivable RemoteRequest where
	parseCommand "VERSION" = Proto.parse1 VERSION
	parseCommand "PROGRESS" = Proto.parse1 PROGRESS
	parseCommand "DIRHASH" = Proto.parse1 DIRHASH
	parseCommand "SETCONFIG" = Proto.parse2 SETCONFIG
	parseCommand "GETCONFIG" = Proto.parse1 GETCONFIG
	parseCommand "SETCREDS" = Proto.parse3 SETCREDS
	parseCommand "GETCREDS" = Proto.parse1 GETCREDS
	parseCommand "GETUUID" = Proto.parse0 GETUUID
	parseCommand "GETGITDIR" = Proto.parse0 GETGITDIR
	parseCommand "SETWANTED" = Proto.parse1 SETWANTED
	parseCommand "GETWANTED" = Proto.parse0 GETWANTED
	parseCommand "SETSTATE" = Proto.parse2 SETSTATE
	parseCommand "GETSTATE" = Proto.parse1 GETSTATE
	parseCommand "DEBUG" = Proto.parse1 DEBUG
	parseCommand _ = Proto.parseFail

-- Responses to RemoteRequest.
data RemoteResponse
	= VALUE String
	| CREDS String String
	deriving (Show)

instance Proto.Sendable RemoteResponse where
	formatMessage (VALUE s) = [ "VALUE", Proto.serialize s ]
	formatMessage (CREDS login password) = [ "CREDS", Proto.serialize login, Proto.serialize password ]

-- Messages that can be sent at any time by either git-annex or the remote.
data AsyncMessage
	= ERROR ErrorMsg
	deriving (Show)

instance Proto.Sendable AsyncMessage where
	formatMessage (ERROR err) = [ "ERROR", Proto.serialize err ]

instance Proto.Receivable AsyncMessage where
	parseCommand "ERROR" = Proto.parse1 ERROR
	parseCommand _ = Proto.parseFail

-- Data types used for parameters when communicating with the remote.
-- All are serializable.
type ErrorMsg = String
type Setting = String
type ProtocolVersion = Int

supportedProtocolVersions :: [ProtocolVersion]
supportedProtocolVersions = [1]

instance Proto.Serializable Direction where
	serialize Upload = "STORE"
	serialize Download = "RETRIEVE"

	deserialize "STORE" = Just Upload
	deserialize "RETRIEVE" = Just Download
	deserialize _ = Nothing

instance Proto.Serializable Key where
	serialize = key2file
	deserialize = file2key

instance Proto.Serializable [Char] where
	serialize = id
	deserialize = Just

instance Proto.Serializable ProtocolVersion where
	serialize = show
	deserialize = readish

instance Proto.Serializable Cost where
	serialize = show
	deserialize = readish

instance Proto.Serializable Availability where
	serialize GloballyAvailable = "GLOBAL"
	serialize LocallyAvailable = "LOCAL"

	deserialize "GLOBAL" = Just GloballyAvailable
	deserialize "LOCAL" = Just LocallyAvailable
	deserialize _ = Nothing

instance Proto.Serializable BytesProcessed where
	serialize (BytesProcessed n) = show n
	deserialize = BytesProcessed <$$> readish


code:
{- git remotes encrypted using git-remote-gcrypt
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Remote.GCrypt (
	remote,
	gen,
	getGCryptUUID,
	coreGCryptId,
	setupRepo
) where

import qualified Data.Map as M
import qualified Data.ByteString.Lazy as L
import Control.Exception.Extensible

import Common.Annex
import Types.Remote
import Types.GitConfig
import Types.Crypto
import Types.Creds
import qualified Git
import qualified Git.Command
import qualified Git.Config
import qualified Git.GCrypt
import qualified Git.Construct
import qualified Git.Types as Git ()
import qualified Annex.Branch
import qualified Annex.Content
import Config
import Config.Cost
import Remote.Helper.Git
import Remote.Helper.Encryptable
import Remote.Helper.Special
import Remote.Helper.Messages
import qualified Remote.Helper.Ssh as Ssh
import Utility.Metered
import Crypto
import Annex.UUID
import Annex.Ssh
import qualified Remote.Rsync
import Utility.Rsync
import Utility.Tmp
import Logs.Remote
import Logs.Transfer
import Utility.Gpg
import Annex.Content

remote :: RemoteType
remote = RemoteType {
	typename = "gcrypt",
	-- Remote.Git takes care of enumerating gcrypt remotes too,
	-- and will call our gen on them.
	enumerate = return [],
	generate = gen,
	setup = gCryptSetup
}

gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen gcryptr u c gc = do
	g <- gitRepo
	-- get underlying git repo with real path, not gcrypt path
	r <- liftIO $ Git.GCrypt.encryptedRemote g gcryptr
	let r' = r { Git.remoteName = Git.remoteName gcryptr }
	-- doublecheck that cache matches underlying repo's gcrypt-id
	-- (which might not be set), only for local repos
	(mgcryptid, r'') <- getGCryptId True r'
	case (mgcryptid, Git.GCrypt.remoteRepoId g (Git.remoteName gcryptr)) of
		(Just gcryptid, Just cachedgcryptid)
			| gcryptid /= cachedgcryptid -> resetup gcryptid r''
		_ -> gen' r'' u c gc
  where
	-- A different drive may have been mounted, making a different
	-- gcrypt remote available. So need to set the cached
	-- gcrypt-id and annex-uuid of the remote to match the remote
	-- that is now available. Also need to set the gcrypt particiants
	-- correctly.
	resetup gcryptid r = do
		let u' = genUUIDInNameSpace gCryptNameSpace gcryptid
		v <- M.lookup u' <$> readRemoteLog
		case (Git.remoteName gcryptr, v) of
			(Just remotename, Just c') -> do
				setGcryptEncryption c' remotename
				setConfig (remoteConfig gcryptr "uuid") (fromUUID u')
				setConfig (ConfigKey $ Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid
				gen' r u' c' gc
			_ -> do
				warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r
				return Nothing

gen' :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen' r u c gc = do
	cst <- remoteCost gc $
		if repoCheap r then nearlyCheapRemoteCost else expensiveRemoteCost
	(rsynctransport, rsyncurl) <- rsyncTransportToObjects r
	let rsyncopts = Remote.Rsync.genRsyncOpts c gc rsynctransport rsyncurl
	let this = Remote
		{ uuid = u
		, cost = cst
		, name = Git.repoDescribe r
		, storeKey = \_ _ _ -> noCrypto
		, retrieveKeyFile = \_ _ _ _ -> noCrypto
		, retrieveKeyFileCheap = \_ _ -> return False
		, removeKey = remove this rsyncopts
		, hasKey = checkPresent this rsyncopts
		, hasKeyCheap = repoCheap r
		, whereisKey = Nothing
		, remoteFsck = Nothing
		, repairRepo = Nothing
		, config = c
		, localpath = localpathCalc r
		, repo = r
		, gitconfig = gc { remoteGitConfig = Just $ extractGitConfig r }
		, readonly = Git.repoIsHttp r
		, availability = availabilityCalc r
		, remotetype = remote
	}
	return $ Just $ encryptableRemote c
		(store this rsyncopts)
		(retrieve this rsyncopts)
		this

rsyncTransportToObjects :: Git.Repo -> Annex ([CommandParam], String)
rsyncTransportToObjects r = do
	(rsynctransport, rsyncurl, _) <- rsyncTransport r
	return (rsynctransport, rsyncurl ++ "/annex/objects")

rsyncTransport :: Git.Repo -> Annex ([CommandParam], String, AccessMethod)
rsyncTransport r
	| "ssh://" `isPrefixOf` loc = sshtransport $ break (== '/') $ drop (length "ssh://") loc
	| "//:" `isInfixOf` loc = othertransport
	| ":" `isInfixOf` loc = sshtransport $ separate (== ':') loc
	| otherwise = othertransport
  where
  	loc = Git.repoLocation r
	sshtransport (host, path) = do
		let rsyncpath = if "/~/" `isPrefixOf` path
			then drop 3 path
			else path
		opts <- sshCachingOptions (host, Nothing) []
		return (rsyncShell $ Param "ssh" : opts, host ++ ":" ++ rsyncpath, AccessShell)
	othertransport = return ([], loc, AccessDirect)

noCrypto :: Annex a
noCrypto = error "cannot use gcrypt remote without encryption enabled"

unsupportedUrl :: Annex a
unsupportedUrl = error "using non-ssh remote repo url with gcrypt is not supported"

gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
gCryptSetup mu _ c = go $ M.lookup "gitrepo" c
  where
	remotename = fromJust (M.lookup "name" c)
  	go Nothing = error "Specify gitrepo="
	go (Just gitrepo) = do
		c' <- encryptionSetup c
		inRepo $ Git.Command.run
			[ Params "remote add"
			, Param remotename
			, Param $ Git.GCrypt.urlPrefix ++ gitrepo
			]

		setGcryptEncryption c' remotename

		{- Run a git fetch and a push to the git repo in order to get
		 - its gcrypt-id set up, so that later git annex commands
		 - will use the remote as a gcrypt remote. The fetch is
		 - needed if the repo already exists; the push is needed
		 - if the repo has not yet been initialized by gcrypt. -}
		void $ inRepo $ Git.Command.runBool
			[ Param "fetch"
			, Param remotename
			]
		void $ inRepo $ Git.Command.runBool
			[ Param "push"
			, Param remotename
			, Param $ Git.fromRef Annex.Branch.fullname
			]
		g <- inRepo Git.Config.reRead
		case Git.GCrypt.remoteRepoId g (Just remotename) of
			Nothing -> error "unable to determine gcrypt-id of remote"
			Just gcryptid -> do
				let u = genUUIDInNameSpace gCryptNameSpace gcryptid
				if Just u == mu || isNothing mu
					then do
						method <- setupRepo gcryptid =<< inRepo (Git.Construct.fromRemoteLocation gitrepo)
						gitConfigSpecialRemote u c' "gcrypt" (fromAccessMethod method)
						return (c', u)
					else error $ "uuid mismatch " ++ show (u, mu, gcryptid)

{- Sets up the gcrypt repository. The repository is either a local
 - repo, or it is accessed via rsync directly, or it is accessed over ssh
 - and git-annex-shell is available to manage it.
 -
 - The GCryptID is recorded in the repository's git config for later use.
 - Also, if the git config has receive.denyNonFastForwards set, disable
 - it; gcrypt relies on being able to fast-forward branches.
 -}
setupRepo :: Git.GCrypt.GCryptId -> Git.Repo -> Annex AccessMethod
setupRepo gcryptid r
	| Git.repoIsUrl r = do
		(_, _, accessmethod) <- rsyncTransport r
		case accessmethod of
			AccessDirect -> rsyncsetup
			AccessShell -> ifM gitannexshellsetup
				( return AccessShell
				, rsyncsetup
				)
	| Git.repoIsLocalUnknown r = localsetup =<< liftIO (Git.Config.read r)
	| otherwise = localsetup r
  where
	localsetup r' = do
		let setconfig k v = liftIO $ Git.Command.run [Param "config", Param k, Param v] r'
		setconfig coreGCryptId gcryptid
		setconfig denyNonFastForwards (Git.Config.boolConfig False)
		return AccessDirect

	{- As well as modifying the remote's git config,
	 - create the objectDir on the remote,
	 - which is needed for direct rsync of objects to work.
	 -}
  	rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do
		liftIO $ createDirectoryIfMissing True $ tmp </> objectDir
		(rsynctransport, rsyncurl, _) <- rsyncTransport r
		let tmpconfig = tmp </> "config"
		void $ liftIO $ rsync $ rsynctransport ++
			[ Param $ rsyncurl ++ "/config"
			, Param tmpconfig
			]
		liftIO $ do
			void $ Git.Config.changeFile tmpconfig coreGCryptId gcryptid
			void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig False)
		ok <- liftIO $ rsync $ rsynctransport ++
			[ Params "--recursive"
			, Param $ tmp ++ "/"
			, Param rsyncurl
			]
		unless ok $
			error "Failed to connect to remote to set it up."
		return AccessDirect

	{-  Ask git-annex-shell to configure the repository as a gcrypt
	 -  repository. May fail if it is too old. -}
	gitannexshellsetup = Ssh.onRemote r (boolSystem, False)
		"gcryptsetup" [ Param gcryptid ] []

	denyNonFastForwards = "receive.denyNonFastForwards"

shellOrRsync :: Remote -> Annex a -> Annex a -> Annex a
shellOrRsync r ashell arsync = case method of
	AccessShell -> ashell
	_ -> arsync
  where
  	method = toAccessMethod $ fromMaybe "" $
		remoteAnnexGCrypt $ gitconfig r

{- Configure gcrypt to use the same list of keyids that
 - were passed to initremote as its participants.
 - Also, configure it to use a signing key that is in the list of
 - participants, which gcrypt requires is the case, and may not be
 - depending on system configuration.
 -
 - (For shared encryption, gcrypt's default behavior is used.)
 -
 - Also, sets gcrypt-publish-participants to avoid unncessary gpg
 - passphrase prompts.
 -}
setGcryptEncryption :: RemoteConfig -> String -> Annex ()
setGcryptEncryption c remotename = do
	let participants = remoteconfig Git.GCrypt.remoteParticipantConfigKey
	case extractCipher c of
		Nothing -> noCrypto
		Just (EncryptedCipher _ _ (KeyIds { keyIds = ks})) -> do
			setConfig participants (unwords ks)
			let signingkey = ConfigKey $ Git.GCrypt.remoteSigningKey remotename
			skeys <- M.keys <$> liftIO secretKeys
			case filter (`elem` ks) skeys of
				[] -> noop
				(k:_) -> setConfig signingkey k
		Just (SharedCipher _) ->
			unsetConfig participants
	setConfig (remoteconfig Git.GCrypt.remotePublishParticipantConfigKey)
		(Git.Config.boolConfig True)
  where
	remoteconfig n = ConfigKey $ n remotename

store :: Remote -> Remote.Rsync.RsyncOpts -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
store r rsyncopts (cipher, enck) k p
	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $
		metered (Just p) k $ \meterupdate -> spoolencrypted $ \h -> do
			let dest = gCryptLocation r enck
			createDirectoryIfMissing True $ parentDir dest
			readBytes (meteredWriteFile meterupdate dest) h
			return True
	| Git.repoIsSsh (repo r) = shellOrRsync r storeshell storersync
	| otherwise = unsupportedUrl
  where
  	gpgopts = getGpgEncParams r
	storersync = Remote.Rsync.storeEncrypted rsyncopts gpgopts (cipher, enck) k p
	storeshell = withTmp enck $ \tmp ->
		ifM (spoolencrypted $ readBytes $ \b -> catchBoolIO $ L.writeFile tmp b >> return True)
			( Ssh.rsyncHelper (Just p)
				=<< Ssh.rsyncParamsRemote False r Upload enck tmp Nothing
			, return False
			)
	spoolencrypted a = Annex.Content.sendAnnex k noop $ \src ->
		liftIO $ catchBoolIO $
			encrypt gpgopts cipher (feedFile src) a

retrieve :: Remote -> Remote.Rsync.RsyncOpts -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
retrieve r rsyncopts (cipher, enck) k d p
	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
		retrievewith $ L.readFile src
		return True
	| Git.repoIsSsh (repo r) = shellOrRsync r retrieveshell retrieversync
	| otherwise = unsupportedUrl
  where
	src = gCryptLocation r enck
	retrievewith a = metered (Just p) k $ \meterupdate -> liftIO $
		a >>= \b ->
			decrypt cipher (feedBytes b)
				(readBytes $ meteredWriteFile meterupdate d)
	retrieversync = Remote.Rsync.retrieveEncrypted rsyncopts (cipher, enck) k d p
	retrieveshell = withTmp enck $ \tmp ->
		ifM (Ssh.rsyncHelper (Just p) =<< Ssh.rsyncParamsRemote False r Download enck tmp Nothing)
			( liftIO $ catchBoolIO $ do
				decrypt cipher (feedFile tmp) $
					readBytes $ L.writeFile d
				return True
			, return False
			)

remove :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex Bool
remove r rsyncopts k
	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
		liftIO $ removeDirectoryRecursive $ parentDir $ gCryptLocation r k
		return True
	| Git.repoIsSsh (repo r) = shellOrRsync r removeshell removersync
	| otherwise = unsupportedUrl
  where
	removersync = Remote.Rsync.remove rsyncopts k
	removeshell = Ssh.dropKey (repo r) k

checkPresent :: Remote -> Remote.Rsync.RsyncOpts -> Key -> Annex (Either String Bool)
checkPresent r rsyncopts k
	| not $ Git.repoIsUrl (repo r) =
		guardUsable (repo r) (cantCheck $ repo r) $
			liftIO $ catchDefaultIO (cantCheck $ repo r) $
				Right <$> doesFileExist (gCryptLocation r k)
	| Git.repoIsSsh (repo r) = shellOrRsync r checkshell checkrsync
	| otherwise = unsupportedUrl
  where
  	checkrsync = Remote.Rsync.checkPresent (repo r) rsyncopts k
	checkshell = Ssh.inAnnex (repo r) k

{- Annexed objects are hashed using lower-case directories for max
 - portability. -}
gCryptLocation :: Remote -> Key -> FilePath
gCryptLocation r key = Git.repoLocation (repo r) </> objectDir </> keyPath key hashDirLower

data AccessMethod = AccessDirect | AccessShell

fromAccessMethod :: AccessMethod -> String
fromAccessMethod AccessShell = "shell"
fromAccessMethod AccessDirect = "true"

toAccessMethod :: String -> AccessMethod
toAccessMethod "shell" = AccessShell
toAccessMethod _ = AccessDirect

getGCryptUUID :: Bool -> Git.Repo -> Annex (Maybe UUID)
getGCryptUUID fast r = (genUUIDInNameSpace gCryptNameSpace <$>) . fst
	<$> getGCryptId fast r

coreGCryptId :: String
coreGCryptId = "core.gcrypt-id"

{- gcrypt repos set up by git-annex as special remotes have a
 - core.gcrypt-id setting in their config, which can be mapped back to
 - the remote's UUID.
 -
 - In fast mode, only checks local repos. To check a remote repo,
 - tries git-annex-shell and direct rsync of the git config file.
 -
 - (Also returns a version of input repo with its config read.) -}
getGCryptId :: Bool -> Git.Repo -> Annex (Maybe Git.GCrypt.GCryptId, Git.Repo)
getGCryptId fast r
	| Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$>
		liftIO (catchMaybeIO $ Git.Config.read r)
	| not fast = extract . liftM fst <$> getM (eitherToMaybe <$>)
		[ Ssh.onRemote r (Git.Config.fromPipe r, Left undefined) "configlist" [] []
		, getConfigViaRsync r
		]
	| otherwise = return (Nothing, r)
  where
	extract Nothing = (Nothing, r)
	extract (Just r') = (Git.Config.getMaybe coreGCryptId r', r')

getConfigViaRsync :: Git.Repo -> Annex (Either SomeException (Git.Repo, String))
getConfigViaRsync r = do
	(rsynctransport, rsyncurl, _) <- rsyncTransport r
	liftIO $ do
		withTmpFile "tmpconfig" $ \tmpconfig _ -> do
			void $ rsync $ rsynctransport ++
				[ Param $ rsyncurl ++ "/config"
				, Param tmpconfig
				]
			Git.Config.fromFile r tmpconfig