tagging package git-annex version 5.20140517

-----BEGIN PGP SIGNATURE-----
 Version: GnuPG v1
 
 iQIVAwUAU3egY8kQ2SIlEuPHAQK1eA/9G1DpwdWKiXAlztU9zTDVZ7/QfHkKlWJF
 bej++81nIejMcVOoQIJ5OuT6jdJ49/aDE8//TH+X6sadaH/ZL0vUMaiZunoJclH9
 jl5rDCdHNymdEV86UTI8JVQZzFHomfabbtu4WBDdoBUUWnunBG1Fv+jrEHa/z5ot
 xoGBYUU8lLDQmnOVR7J9R/n55IztDW6Tto1LIOq3qZVGfZxSgmv9cwhRHSqf7Dl4
 6isDQe7GdhJdfT/zn8LlnO4S4r2tzSdNtSbWMNGOjxVxtuRpHberWZWrVW7fuJjw
 IQqUAdZ3TylwtKWRB6CMjRhMz6OSwwmvGdOcPNSF/xkENULdLxaLWNLPO6hyd3Jf
 tRWuvF6VEgtWZiUCvoQGIJIIo3qLHa0uD3/7CAp/+akBFil7qgfvwacFW/2g3KiK
 i1M8oUve1c9TDUqKpJ875QQbAymLcdrN43vlZM7vxu4H1lFFNgMJD9Xwec5JpMcC
 unoQhF9Y6O9H2A+H7oEaQpnVxShByZGNFWdmef1bzVkaQAJkhptMXQhUhCK1gcOm
 1oCU8JDIJt8H37wekFWW3ww0ScsqNUhmT9zxnUzoBp1x1Twe7Ch2KEcjJhKVh6hV
 tfXFcbAYUIvuJyon3AFrej48k+FHCXq1HLj1sMHTgonHzSKg35RbLQt/UsEycB48
 vq7aY5uUPIk=
 =QnPf
 -----END PGP SIGNATURE-----

Merge tag '5.20140517' into debian-wheezy-backport

tagging package git-annex version 5.20140517

# gpg: Signature made Sat May 17 18:46:11 2014 BST using RSA key ID 2512E3C7
# gpg: Good signature from "Joey Hess <joeyh@debian.org>"
# gpg:                 aka "Joey Hess <joey@kitenet.net>"
# gpg:                 aka "Joey Hess <id@joeyh.name>"
# gpg: WARNING: This key is not certified with a trusted signature!
# gpg:          There is no indication that the signature belongs to the owner.
# Primary key fingerprint: E85A 5F63 B31D 24C1 EBF0  D81C C910 D922 2512 E3C7

Annex.hs

@@ -28,6 +28,7 @@ module Annex (
 	getGitConfig,
 	changeGitConfig,
 	changeGitRepo,
+	getRemoteGitConfig,
 	withCurrentState,
 ) where
 
@@ -267,6 +268,13 @@ changeGitRepo r = changeState $ \s -> s
 	, gitconfig = extractGitConfig r
 	}
 
+{- Gets the RemoteGitConfig from a remote, given the Git.Repo for that
+ - remote. -}
+getRemoteGitConfig :: Git.Repo -> Annex RemoteGitConfig
+getRemoteGitConfig r = do
+	g <- gitRepo
+	return $ extractRemoteGitConfig g (Git.repoDescribe r)
+
 {- Converts an Annex action into an IO action, that runs with a copy
  - of the current Annex state. 
  -

Annex/Ssh.hs

@@ -16,6 +16,8 @@ module Annex.Ssh (
 	sshCachingTo,
 	inRepoWithSshCachingTo,
 	runSshCaching,
+	sshAskPassEnv,
+	runSshAskPass
 ) where
 
 import qualified Data.Map as M
@@ -230,7 +232,7 @@ sshReadPort params = (port, reverse args)
 {- When this env var is set, git-annex runs ssh with parameters
  - to use the socket file that the env var contains.
  -
- - This is a workaround for GiT_SSH not being able to contain
+ - This is a workaround for GIT_SSH not being able to contain
  - additional parameters to pass to ssh. -}
 sshCachingEnv :: String
 sshCachingEnv = "GIT_ANNEX_SSHCACHING"
@@ -268,8 +270,17 @@ sshCachingTo remote g
   where
 	uncached = return g
 
-runSshCaching :: [String] -> String -> IO ()
+runSshCaching :: [String] -> FilePath -> IO ()
 runSshCaching args sockfile = do
 	let args' = toCommand (sshConnectionCachingParams sockfile) ++ args
 	let p = proc "ssh" args'
 	exitWith =<< waitForProcess . processHandle =<< createProcess p
+
+{- When this env var is set, git-annex is being used as a ssh-askpass
+ - program, and should read the password from the specified location,
+ - and output it for ssh to read. -}
+sshAskPassEnv :: String
+sshAskPassEnv = "GIT_ANNEX_SSHASKPASS"
+
+runSshAskPass :: FilePath -> IO ()
+runSshAskPass passfile = putStrLn =<< readFile passfile

Assistant.hs

@@ -84,9 +84,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
 				fdToHandle =<< dup stdError
 			let undaemonize a = do
 				debugM desc $ "logging to " ++ logfile
-				Utility.Daemon.lockPidFile pidfile
+				Utility.Daemon.foreground logfd (Just pidfile) a
-				Utility.LogFile.redirLog logfd
-				a
 			start undaemonize $ 
 				case startbrowser of
 					Nothing -> Nothing

Assistant/CredPairCache.hs

@@ -0,0 +1,53 @@
+{- git-annex assistant CredPair cache.
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE BangPatterns #-}
+
+module Assistant.CredPairCache (
+	cacheCred,
+	getCachedCred,
+	expireCachedCred,
+) where
+
+import Assistant.Types.CredPairCache
+import Types.Creds
+import Assistant.Common
+import Utility.ThreadScheduler
+
+import qualified Data.Map as M
+import Control.Concurrent
+
+{- Caches a CredPair, but only for a limited time, after which it
+ - will expire.
+ -
+ - Note that repeatedly caching the same CredPair
+ - does not reset its expiry time.
+ -}
+cacheCred :: CredPair -> Seconds -> Assistant ()
+cacheCred (login, password) expireafter = do
+	cache <- getAssistant credPairCache
+	liftIO $ do
+		changeStrict cache $ M.insert login password
+		void $ forkIO $ do
+			threadDelaySeconds expireafter
+			changeStrict cache $ M.delete login
+
+getCachedCred :: Login -> Assistant (Maybe Password)
+getCachedCred login = do
+	cache <- getAssistant credPairCache
+	liftIO $ M.lookup login <$> readMVar cache
+
+expireCachedCred :: Login -> Assistant ()
+expireCachedCred login = do
+	cache <- getAssistant credPairCache
+	liftIO $ changeStrict cache $ M.delete login
+
+{- Update map strictly to avoid keeping references to old creds in memory. -}
+changeStrict :: CredPairCache -> (M.Map Login Password -> M.Map Login Password) -> IO ()
+changeStrict cache a = modifyMVar_ cache $ \m -> do
+	let !m' = a m
+	return m'

Assistant/Monad.hs

@@ -44,6 +44,7 @@ import Assistant.Types.Buddies
 import Assistant.Types.NetMessager
 import Assistant.Types.ThreadName
 import Assistant.Types.RemoteControl
+import Assistant.Types.CredPairCache
 
 newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
 	deriving (
@@ -70,6 +71,7 @@ data AssistantData = AssistantData
 	, buddyList :: BuddyList
 	, netMessager :: NetMessager
 	, remoteControl :: RemoteControl
+	, credPairCache :: CredPairCache
 	}
 
 newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
@@ -89,6 +91,7 @@ newAssistantData st dstatus = AssistantData
 	<*> newBuddyList
 	<*> newNetMessager
 	<*> newRemoteControl
+	<*> newCredPairCache
 
 runAssistant :: AssistantData -> Assistant a -> IO a
 runAssistant d a = runReaderT (mkAssistant a) d

Assistant/Threads/MountWatcher.hs

@@ -63,7 +63,11 @@ dbusThread urlrenderer = do
 				wasmounted <- liftIO $ swapMVar mvar nowmounted
 				handleMounts urlrenderer wasmounted nowmounted
 			liftIO $ forM_ mountChanged $ \matcher ->
+#if MIN_VERSION_dbus(0,10,7)
+				void $ addMatch client matcher handleevent
+#else
 				listen client matcher handleevent
+#endif
 		, do
 			liftAnnex $
 				warning "No known volume monitor available through dbus; falling back to mtab polling"

Assistant/Threads/NetWatcher.hs

@@ -112,7 +112,12 @@ checkNetMonitor client = do
  -}
 listenNMConnections :: Client -> (Bool -> IO ()) -> IO ()
 listenNMConnections client setconnected =
-	listen client matcher $ \event -> mapM_ handle
+#if MIN_VERSION_dbus(0,10,7)
+	void $ addMatch client matcher
+#else
+	listen client matcher
+#endif
+		$ \event -> mapM_ handle
 			(map dictionaryItems $ mapMaybe fromVariant $ signalBody event)
   where
 	matcher = matchAny
@@ -142,10 +147,10 @@ listenNMConnections client setconnected =
  -}
 listenWicdConnections :: Client -> (Bool -> IO ()) -> IO ()
 listenWicdConnections client setconnected = do
-	listen client connmatcher $ \event ->
+	match connmatcher $ \event ->
 		when (any (== wicd_success) (signalBody event)) $
 			setconnected True
-	listen client statusmatcher $ \event -> handle (signalBody event)
+	match statusmatcher $ \event -> handle (signalBody event)
   where
 	connmatcher = matchAny
 		{ matchInterface = Just "org.wicd.daemon"
@@ -160,7 +165,12 @@ listenWicdConnections client setconnected = do
 	handle status
 		| any (== wicd_disconnected) status = setconnected False
 		| otherwise = noop
-
+	match matcher a = 
+#if MIN_VERSION_dbus(0,10,7)
+		void $ addMatch client matcher a
+#else
+		listen client matcher a
+#endif
 #endif
 
 handleConnection :: Assistant ()

Assistant/Threads/SanityChecker.hs

@@ -46,6 +46,7 @@ import Assistant.WebApp.Types
 #ifndef mingw32_HOST_OS
 import Utility.LogFile
 #endif
+import Types.Key (keyBackendName)
 
 import Data.Time.Clock.POSIX
 import qualified Data.Text as T
@@ -82,6 +83,10 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta
 	{- Fix up ssh remotes set up by past versions of the assistant. -}
 	liftIO $ fixUpSshRemotes
 
+	{- Clean up old temp files. -}
+	liftAnnex cleanOldTmpMisc
+	liftAnnex cleanReallyOldTmp
+
 	{- If there's a startup delay, it's done here. -}
 	liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay
 
@@ -258,3 +263,54 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit
 #else
 		debug [show $ renderTense Past msg]
 #endif
+
+{- Files may be left in misctmp by eg, an interrupted add of files
+ - by the assistant, which hard links files to there as part of lockdown
+ - checks. Delete these files if they're more than a day old.
+ -
+ - Note that this is not safe to run after the Watcher starts up, since it
+ - will create such files, and due to hard linking they may have old
+ - mtimes. So, this should only be called from the
+ - sanityCheckerStartupThread, which runs before the Watcher starts up.
+ -
+ - Also, if a git-annex add is being run at the same time the assistant
+ - starts up, its tmp files could be deleted. However, the watcher will
+ - come along and add everything once it starts up anyway, so at worst
+ - this would make the git-annex add fail unexpectedly.
+ -}
+cleanOldTmpMisc :: Annex ()
+cleanOldTmpMisc = do
+	now <- liftIO getPOSIXTime
+	let oldenough = now - (60 * 60 * 24)
+	tmp <- fromRepo gitAnnexTmpMiscDir
+	liftIO $ mapM_ (cleanOld (<= oldenough)) =<< dirContentsRecursive tmp
+
+{- While .git/annex/tmp is now only used for storing partially transferred
+ - objects, older versions of git-annex used it for misctemp. Clean up any
+ - files that might be left from that, by looking for files whose names
+ - cannot be the key of an annexed object. Only delete files older than
+ - 1 week old.
+ -
+ - Also, some remotes such as rsync may use this temp directory for storing
+ - eg, encrypted objects that are being transferred. So, delete old
+ - objects that use a GPGHMAC backend.
+ -}
+cleanReallyOldTmp :: Annex ()
+cleanReallyOldTmp = do
+	now <- liftIO getPOSIXTime
+	let oldenough = now - (60 * 60 * 24 * 7)
+	tmp <- fromRepo gitAnnexTmpObjectDir
+	liftIO $ mapM_ (cleanjunk (<= oldenough)) =<< dirContentsRecursive tmp
+  where
+	cleanjunk check f = case fileKey (takeFileName f) of
+		Nothing -> cleanOld check f
+		Just k
+			| "GPGHMAC" `isPrefixOf` keyBackendName k ->
+				cleanOld check f
+			| otherwise -> noop
+
+cleanOld :: (POSIXTime -> Bool) -> FilePath -> IO ()
+cleanOld check f = do
+	mtime <- realToFrac . modificationTime <$> getFileStatus f
+	when (check mtime) $
+		nukeFile f

Assistant/Threads/Upgrader.hs

@@ -18,11 +18,8 @@ import Assistant.Types.UrlRenderer
 import Assistant.DaemonStatus
 import Assistant.Alert
 import Utility.NotificationBroadcaster
-import Utility.Tmp
 import qualified Annex
 import qualified Build.SysConfig
-import qualified Utility.Url as Url
-import qualified Annex.Url as Url
 import qualified Git.Version
 import Types.Distribution
 #ifdef WITH_WEBAPP
@@ -62,7 +59,7 @@ upgraderThread urlrenderer = namedThread "Upgrader" $
 checkUpgrade :: UrlRenderer -> Assistant ()
 checkUpgrade urlrenderer = do
 	debug [ "Checking if an upgrade is available." ]
-	go =<< getDistributionInfo
+	go =<< downloadDistributionInfo
   where
 	go Nothing = debug [ "Failed to check if upgrade is available." ]
 	go (Just d) = do
@@ -86,16 +83,3 @@ canUpgrade urgency urlrenderer d = ifM autoUpgradeEnabled
 		noop
 #endif
 	)
-
-getDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
-getDistributionInfo = do
-	uo <- liftAnnex Url.getUrlOptions
-	liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do
-		hClose h
-		ifM (Url.downloadQuiet distributionInfoUrl tmpfile uo)
-			( readish <$> readFileStrict tmpfile
-			, return Nothing
-			)
-
-distributionInfoUrl :: String
-distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info"

Assistant/Types/CredPairCache.hs

@@ -0,0 +1,18 @@
+{- git-annex assistant CredPair cache.
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Types.CredPairCache where
+
+import Types.Creds
+
+import Control.Concurrent
+import qualified Data.Map as M
+
+type CredPairCache = MVar (M.Map Login Password)
+
+newCredPairCache :: IO CredPairCache
+newCredPairCache = newMVar M.empty

Assistant/Upgrade.hs

@@ -32,7 +32,11 @@ import Config.Files
 import Utility.ThreadScheduler
 import Utility.Tmp
 import Utility.UserInfo
+import Utility.Gpg
 import qualified Utility.Lsof as Lsof
+import qualified Build.SysConfig
+import qualified Utility.Url as Url
+import qualified Annex.Url as Url
 
 import qualified Data.Map as M
 import Data.Tuple.Utils
@@ -313,3 +317,48 @@ upgradeSanityCheck = ifM usingDistribution
 
 usingDistribution :: IO Bool
 usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV"
+
+downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
+downloadDistributionInfo = do
+	uo <- liftAnnex Url.getUrlOptions
+	liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do
+		let infof = tmpdir </> "info"
+		let sigf = infof ++ ".sig"
+		ifM (Url.downloadQuiet distributionInfoUrl infof uo
+			<&&> Url.downloadQuiet distributionInfoSigUrl sigf uo
+			<&&> verifyDistributionSig sigf)
+			( readish <$> readFileStrict infof
+			, return Nothing
+			)
+
+distributionInfoUrl :: String
+distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info"
+
+distributionInfoSigUrl :: String
+distributionInfoSigUrl = distributionInfoUrl ++ ".sig"
+
+{- Verifies that a file from the git-annex distribution has a valid
+ - signature. Pass the detached .sig file; the file to be verified should
+ - be located next to it.
+ -
+ - The gpg keyring used to verify the signature is located in
+ - trustedkeys.gpg, next to the git-annex program.
+ -}
+verifyDistributionSig :: FilePath -> IO Bool
+verifyDistributionSig sig = do
+	p <- readProgramFile
+	if isAbsolute p
+		then withTmpDir "git-annex-gpg.tmp" $ \gpgtmp -> do
+			let trustedkeys = takeDirectory p </> "trustedkeys.gpg"
+			boolSystem gpgcmd
+				[ Param "--no-default-keyring"
+				, Param "--no-auto-check-trustdb"
+				, Param "--no-options"
+				, Param "--homedir"
+				, File gpgtmp
+				, Param "--keyring"
+				, File trustedkeys
+				, Param "--verify"
+				, File sig
+				]
+		else return False

Assistant/WebApp/Bootstrap3.hs

@@ -0,0 +1,284 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+-- | Helper functions for creating forms when using Bootstrap v3.
+-- This is a copy of the Yesod.Form.Bootstrap3 module that has been slightly
+-- modified to be compatible with Yesod 1.0.1
+module Assistant.WebApp.Bootstrap3
+  ( -- * Rendering forms
+    renderBootstrap3
+  , BootstrapFormLayout(..)
+  , BootstrapGridOptions(..)
+    -- * Field settings
+  , bfs
+  , withPlaceholder
+  , withAutofocus
+  , withLargeInput
+  , withSmallInput
+    -- * Submit button
+  , bootstrapSubmit
+  , mbootstrapSubmit
+  , BootstrapSubmit(..)
+  ) where
+
+import Control.Arrow (second)
+import Control.Monad (liftM)
+import Data.Text (Text)
+import Data.String (IsString(..))
+import Yesod.Core
+
+import qualified Data.Text as T
+
+import Yesod.Form.Types
+import Yesod.Form.Functions
+
+-- | Create a new 'FieldSettings' with the classes that are
+-- required by Bootstrap v3.
+--
+-- Since: yesod-form 1.3.8
+bfs :: RenderMessage site msg => msg -> FieldSettings site
+bfs msg =
+    FieldSettings (SomeMessage msg) Nothing Nothing Nothing [("class", "form-control")]
+
+
+-- | Add a placeholder attribute to a field.  If you need i18n
+-- for the placeholder, currently you\'ll need to do a hack and
+-- use 'getMessageRender' manually.
+--
+-- Since: yesod-form 1.3.8
+withPlaceholder :: Text -> FieldSettings site -> FieldSettings site
+withPlaceholder placeholder fs = fs { fsAttrs = newAttrs }
+    where newAttrs = ("placeholder", placeholder) : fsAttrs fs
+
+
+-- | Add an autofocus attribute to a field.
+--
+-- Since: yesod-form 1.3.8
+withAutofocus :: FieldSettings site -> FieldSettings site
+withAutofocus fs = fs { fsAttrs = newAttrs }
+    where newAttrs = ("autofocus", "autofocus") : fsAttrs fs
+
+
+-- | Add the @input-lg@ CSS class to a field.
+--
+-- Since: yesod-form 1.3.8
+withLargeInput :: FieldSettings site -> FieldSettings site
+withLargeInput fs = fs { fsAttrs = newAttrs }
+    where newAttrs = addClass "input-lg" (fsAttrs fs)
+
+
+-- | Add the @input-sm@ CSS class to a field.
+--
+-- Since: yesod-form 1.3.8
+withSmallInput :: FieldSettings site -> FieldSettings site
+withSmallInput fs = fs { fsAttrs = newAttrs }
+    where newAttrs = addClass "input-sm" (fsAttrs fs)
+
+
+addClass :: Text -> [(Text, Text)] -> [(Text, Text)]
+addClass klass []                    = [("class", klass)]
+addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest
+addClass klass (other         :rest) = other : addClass klass rest
+
+
+-- | How many bootstrap grid columns should be taken (see
+-- 'BootstrapFormLayout').
+--
+-- Since: yesod-form 1.3.8
+data BootstrapGridOptions =
+    ColXs !Int
+  | ColSm !Int
+  | ColMd !Int
+  | ColLg !Int
+    deriving (Eq, Ord, Show)
+
+toColumn :: BootstrapGridOptions -> String
+toColumn (ColXs 0) = ""
+toColumn (ColSm 0) = ""
+toColumn (ColMd 0) = ""
+toColumn (ColLg 0) = ""
+toColumn (ColXs columns) = "col-xs-" ++ show columns
+toColumn (ColSm columns) = "col-sm-" ++ show columns
+toColumn (ColMd columns) = "col-md-" ++ show columns
+toColumn (ColLg columns) = "col-lg-" ++ show columns
+
+toOffset :: BootstrapGridOptions -> String
+toOffset (ColXs 0) = ""
+toOffset (ColSm 0) = ""
+toOffset (ColMd 0) = ""
+toOffset (ColLg 0) = ""
+toOffset (ColXs columns) = "col-xs-offset-" ++ show columns
+toOffset (ColSm columns) = "col-sm-offset-" ++ show columns
+toOffset (ColMd columns) = "col-md-offset-" ++ show columns
+toOffset (ColLg columns) = "col-lg-offset-" ++ show columns
+
+addGO :: BootstrapGridOptions -> BootstrapGridOptions -> BootstrapGridOptions
+addGO (ColXs a) (ColXs b) = ColXs (a+b)
+addGO (ColSm a) (ColSm b) = ColSm (a+b)
+addGO (ColMd a) (ColMd b) = ColMd (a+b)
+addGO (ColLg a) (ColLg b) = ColLg (a+b)
+addGO a b     | a > b = addGO b a
+addGO (ColXs a) other = addGO (ColSm a) other
+addGO (ColSm a) other = addGO (ColMd a) other
+addGO (ColMd a) other = addGO (ColLg a) other
+addGO (ColLg _) _     = error "Yesod.Form.Bootstrap.addGO: never here"
+
+
+-- | The layout used for the bootstrap form.
+--
+-- Since: yesod-form 1.3.8
+data BootstrapFormLayout =
+    BootstrapBasicForm
+  | BootstrapInlineForm
+  | BootstrapHorizontalForm
+      { bflLabelOffset :: !BootstrapGridOptions
+      , bflLabelSize   :: !BootstrapGridOptions
+      , bflInputOffset :: !BootstrapGridOptions
+      , bflInputSize   :: !BootstrapGridOptions
+      }
+    deriving (Show)
+
+
+-- | Render the given form using Bootstrap v3 conventions.
+--
+-- Sample Hamlet for 'BootstrapHorizontalForm':
+--
+-- >  <form .form-horizontal role=form method=post action=@{ActionR} enctype=#{formEnctype}>
+-- >    ^{formWidget}
+-- >    ^{bootstrapSubmit MsgSubmit}
+--
+-- Since: yesod-form 1.3.8
+#if MIN_VERSION_yesod(1,2,0)
+renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a
+#else
+renderBootstrap3 :: BootstrapFormLayout -> FormRender sub master a
+#endif
+renderBootstrap3 formLayout aform fragment = do
+    (res, views') <- aFormToForm aform
+    let views = views' []
+        has (Just _) = True
+        has Nothing  = False
+        widget = [whamlet|
+#if MIN_VERSION_yesod(1,2,0)
+            $newline never
+#endif
+            #{fragment}
+            $forall view <- views
+              <div .form-group :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.has-error>
+                $case formLayout
+                  $of BootstrapBasicForm
+                    $if nequals (fvId view) bootstrapSubmitId
+                      <label for=#{fvId view}>#{fvLabel view}
+                    ^{fvInput view}
+                    ^{helpWidget view}
+                  $of BootstrapInlineForm
+                    $if nequals (fvId view) bootstrapSubmitId
+                      <label .sr-only for=#{fvId view}>#{fvLabel view}
+                    ^{fvInput view}
+                    ^{helpWidget view}
+                  $of f@(BootstrapHorizontalForm _ _ _ _)
+                    $if nequals (fvId view) bootstrapSubmitId
+                      <label .control-label .#{toOffset (bflLabelOffset f)} .#{toColumn (bflLabelSize f)} for=#{fvId view}>#{fvLabel view}
+                      <div .#{toOffset (bflInputOffset f)} .#{toColumn (bflInputSize f)}>
+                        ^{fvInput view}
+                        ^{helpWidget view}
+                    $else
+                      <div .#{toOffset (addGO (bflInputOffset f) (addGO (bflLabelOffset f) (bflLabelSize f)))} .#{toColumn (bflInputSize f)}>
+                        ^{fvInput view}
+                        ^{helpWidget view}
+                |]
+    return (res, widget)
+  where
+    nequals a b = a /= b -- work around older hamlet versions not liking /=
+
+-- | (Internal) Render a help widget for tooltips and errors.
+#if MIN_VERSION_yesod(1,2,0)
+helpWidget :: FieldView site -> WidgetT site IO ()
+#else
+helpWidget :: FieldView sub master -> GWidget sub master ()
+#endif
+helpWidget view = [whamlet|
+    $maybe tt <- fvTooltip view
+      <span .help-block>#{tt}
+    $maybe err <- fvErrors view
+      <span .help-block>#{err}
+|]
+
+
+-- | How the 'bootstrapSubmit' button should be rendered.
+--
+-- Since: yesod-form 1.3.8
+data BootstrapSubmit msg =
+    BootstrapSubmit
+        { bsValue   :: msg
+          -- ^ The text of the submit button.
+        , bsClasses :: Text
+          -- ^ Classes added to the @<button>@.
+        , bsAttrs   :: [(Text, Text)]
+          -- ^ Attributes added to the @<button>@.
+        } deriving (Show)
+
+instance IsString msg => IsString (BootstrapSubmit msg) where
+    fromString msg = BootstrapSubmit (fromString msg) " btn-default " []
+
+
+-- | A Bootstrap v3 submit button disguised as a field for
+-- convenience.  For example, if your form currently is:
+--
+-- > Person <$> areq textField "Name"    Nothing
+-- >        <*> areq textField "Surname" Nothing
+--
+-- Then just change it to:
+--
+-- > Person <$> areq textField "Name"    Nothing
+-- >        <*> areq textField "Surname" Nothing
+-- >        <*  bootstrapSubmit "Register"
+--
+-- (Note that @<*@ is not a typo.)
+--
+-- Alternatively, you may also just create the submit button
+-- manually as well in order to have more control over its
+-- layout.
+--
+-- Since: yesod-form 1.3.8
+#if MIN_VERSION_yesod(1,2,0)
+bootstrapSubmit
+    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+    => BootstrapSubmit msg -> AForm m ()
+#else
+bootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> AForm sub master ()
+#endif
+bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
+
+
+-- | Same as 'bootstrapSubmit' but for monadic forms.  This isn't
+-- as useful since you're not going to use 'renderBootstrap3'
+-- anyway.
+--
+-- Since: yesod-form 1.3.8
+#if MIN_VERSION_yesod(1,2,0)
+mbootstrapSubmit
+    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+    => BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
+#else
+mbootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> MForm sub master (FormResult (), FieldView sub master)
+#endif
+mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
+    let res = FormSuccess ()
+        widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]
+        fv  = FieldView { fvLabel    = ""
+                        , fvTooltip  = Nothing
+                        , fvId       = bootstrapSubmitId
+                        , fvInput    = widget
+                        , fvErrors   = Nothing
+                        , fvRequired = False }
+    in return (res, fv)
+
+
+-- | A royal hack.  Magic id used to identify whether a field
+-- should have no label.  A valid HTML4 id which is probably not
+-- going to clash with any other id should someone use
+-- 'bootstrapSubmit' outside 'renderBootstrap3'.
+bootstrapSubmitId :: Text
+bootstrapSubmitId = "b:ootstrap___unique__:::::::::::::::::submit-id"

Assistant/WebApp/Common.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Assistant.WebApp.Common (module X) where
 
 import Assistant.Common as X
@@ -13,6 +15,9 @@ import Assistant.WebApp.Page as X
 import Assistant.WebApp.Form as X
 import Assistant.WebApp.Types as X
 import Assistant.WebApp.RepoId as X
+#if MIN_VERSION_yesod(1,2,0)
 import Utility.Yesod as X hiding (textField, passwordField, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
-
+#else
+import Utility.Yesod as X hiding (textField, passwordField, selectField, selectFieldList, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
+#endif
 import Data.Text as X (Text)

Assistant/WebApp/Configurators/AWS.hs

@@ -68,8 +68,8 @@ s3InputAForm defcreds = AWSInput
 	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
 	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
 	<*> datacenterField AWS.S3
-	<*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy)
+	<*> areq (selectFieldList storageclasses) (bfs "Storage class") (Just StandardRedundancy)
-	<*> areq textField "Repository name" (Just "S3")
+	<*> areq textField (bfs "Repository name") (Just "S3")
 	<*> enableEncryptionField
   where
 	storageclasses :: [(Text, StorageClass)]
@@ -84,7 +84,7 @@ glacierInputAForm defcreds = AWSInput
 	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
 	<*> datacenterField AWS.Glacier
 	<*> pure StandardRedundancy
-	<*> areq textField "Repository name" (Just "glacier")
+	<*> areq textField (bfs "Repository name") (Just "glacier")
 	<*> enableEncryptionField
 
 awsCredsAForm :: Maybe CredPair -> MkAForm AWSCreds
@@ -93,7 +93,7 @@ awsCredsAForm defcreds = AWSCreds
 	<*> secretAccessKeyField (T.pack . snd <$> defcreds)
 
 accessKeyIDField :: Widget -> Maybe Text -> MkAForm Text
-accessKeyIDField help = areq (textField `withNote` help) "Access Key ID"
+accessKeyIDField help = areq (textField `withNote` help) (bfs "Access Key ID")
 
 accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text
 accessKeyIDFieldWithHelp = accessKeyIDField help
@@ -104,10 +104,10 @@ accessKeyIDFieldWithHelp = accessKeyIDField help
 |]
 
 secretAccessKeyField :: Maybe Text -> MkAForm Text
-secretAccessKeyField = areq passwordField "Secret Access Key"
+secretAccessKeyField = areq passwordField (bfs "Secret Access Key")
 
 datacenterField :: AWS.Service -> MkAForm Text
-datacenterField service = areq (selectFieldList list) "Datacenter" defregion
+datacenterField service = areq (selectFieldList list) (bfs "Datacenter") defregion
   where
 	list = M.toList $ AWS.regionMap service
 	defregion = Just $ AWS.defaultRegion service
@@ -120,7 +120,7 @@ postAddS3R :: Handler Html
 postAddS3R = awsConfigurator $ do
 	defcreds <- liftAnnex previouslyUsedAWSCreds
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ s3InputAForm defcreds
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ s3InputAForm defcreds
 	case result of
 		FormSuccess input -> liftH $ do
 			let name = T.unpack $ repoName input
@@ -143,7 +143,7 @@ postAddGlacierR :: Handler Html
 postAddGlacierR = glacierConfigurator $ do
 	defcreds <- liftAnnex previouslyUsedAWSCreds
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ glacierInputAForm defcreds
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ glacierInputAForm defcreds
 	case result of
 		FormSuccess input -> liftH $ do
 			let name = T.unpack $ repoName input
@@ -186,7 +186,7 @@ enableAWSRemote :: RemoteType -> UUID -> Widget
 enableAWSRemote remotetype uuid = do
 	defcreds <- liftAnnex previouslyUsedAWSCreds
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ awsCredsAForm defcreds
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ awsCredsAForm defcreds
 	case result of
 		FormSuccess creds -> liftH $ do
 			m <- liftAnnex readRemoteLog

Assistant/WebApp/Configurators/Delete.hs

@@ -89,8 +89,8 @@ deleteCurrentRepository = dangerPage $ do
 	havegitremotes <- haveremotes syncGitRemotes
 	havedataremotes <- haveremotes syncDataRemotes
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ sanityVerifierAForm $
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
-			SanityVerifier magicphrase
+			sanityVerifierAForm $ SanityVerifier magicphrase
 	case result of
 		FormSuccess _ -> liftH $ do
 			dir <- liftAnnex $ fromRepo Git.repoPath
@@ -122,7 +122,7 @@ data SanityVerifier = SanityVerifier T.Text
 
 sanityVerifierAForm :: SanityVerifier -> MkAForm SanityVerifier
 sanityVerifierAForm template = SanityVerifier
-	<$> areq checksanity "Confirm deletion?" Nothing
+	<$> areq checksanity (bfs "Confirm deletion?") Nothing
   where
 	checksanity = checkBool (\input -> SanityVerifier input == template)
 		insane textField

Assistant/WebApp/Configurators/Edit.hs

@@ -142,9 +142,9 @@ setRepoConfig uuid mremote oldc newc = do
 editRepositoryAForm :: Maybe Remote -> RepoConfig -> MkAForm RepoConfig
 editRepositoryAForm mremote def = RepoConfig
 	<$> areq (if ishere then readonlyTextField else textField)
-		"Name" (Just $ repoName def)
+		(bfs "Name") (Just $ repoName def)
-	<*> aopt textField "Description" (Just $ repoDescription def)
+	<*> aopt textField (bfs "Description") (Just $ repoDescription def)
-	<*> areq (selectFieldList groups `withNote` help) "Repository group" (Just $ repoGroup def)
+	<*> areq (selectFieldList groups `withNote` help) (bfs "Repository group") (Just $ repoGroup def)
 	<*> associateddirectory
 	<*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def)
   where
@@ -166,7 +166,7 @@ editRepositoryAForm mremote def = RepoConfig
 
 	associateddirectory = case repoAssociatedDirectory def of
 		Nothing -> aopt hiddenField "" Nothing
-		Just d -> aopt textField "Associated directory" (Just $ Just d)
+		Just d -> aopt textField (bfs "Associated directory") (Just $ Just d)
 
 getEditRepositoryR :: RepoId -> Handler Html
 getEditRepositoryR = postEditRepositoryR
@@ -195,7 +195,7 @@ editForm new (RepoUUID uuid) = page "Edit repository" (Just Configuration) $ do
 	curr <- liftAnnex $ getRepoConfig uuid mremote
 	liftAnnex $ checkAssociatedDirectory curr mremote
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ editRepositoryAForm mremote curr
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ editRepositoryAForm mremote curr
 	case result of
 		FormSuccess input -> liftH $ do
 			setRepoConfig uuid mremote curr input

Assistant/WebApp/Configurators/Fsck.hs

@@ -64,10 +64,10 @@ runFsckForm new activity = case activity of
 		u <- liftAnnex getUUID
 		repolist <- liftAssistant (getrepolist ru)
 		runFormPostNoToken $ \msg -> do
-			(reposRes, reposView) <- mreq (selectFieldList repolist) "" (Just ru)
+			(reposRes, reposView) <- mreq (selectFieldList repolist) (bfs "") (Just ru)
-			(durationRes, durationView) <- mreq intField "" (Just $ durationSeconds d `quot` 60 )
+			(durationRes, durationView) <- mreq intField (bfs "") (Just $ durationSeconds d `quot` 60 )
-			(timeRes, timeView) <- mreq (selectFieldList times) "" (Just t)
+			(timeRes, timeView) <- mreq (selectFieldList times) (bfs "") (Just t)
-			(recurranceRes, recurranceView) <- mreq (selectFieldList recurrances) "" (Just r)
+			(recurranceRes, recurranceView) <- mreq (selectFieldList recurrances) (bfs "") (Just r)
 			let form = do
 				webAppFormAuthToken
 				$(widgetFile "configurators/fsck/formcontent")
@@ -175,7 +175,8 @@ fsckPreferencesAForm def = FsckPreferences
 runFsckPreferencesForm :: Handler ((FormResult FsckPreferences, Widget), Enctype)
 runFsckPreferencesForm = do
 	prefs <- liftAnnex getFsckPreferences
-	runFormPostNoToken $ renderBootstrap $ fsckPreferencesAForm prefs
+	runFormPostNoToken $ renderBootstrap3 formLayout $ fsckPreferencesAForm prefs
+  where formLayout = BootstrapHorizontalForm (ColSm 0) (ColSm 2) (ColSm 0) (ColSm 10)
 
 showFsckPreferencesForm :: Widget
 showFsckPreferencesForm = do

Assistant/WebApp/Configurators/IA.hs

@@ -83,8 +83,8 @@ iaInputAForm :: Maybe CredPair -> MkAForm IAInput
 iaInputAForm defcreds = IAInput
 	<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
 	<*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
-	<*> areq (selectFieldList mediatypes) "Media Type" (Just MediaOmitted)
+	<*> areq (selectFieldList mediatypes) (bfs "Media Type") (Just MediaOmitted)
-	<*> areq (textField `withExpandableNote` ("Help", itemNameHelp)) "Item Name" Nothing
+	<*> areq (textField `withExpandableNote` ("Help", itemNameHelp)) (bfs "Item Name") Nothing
   where
 	mediatypes :: [(Text, MediaType)]
 	mediatypes = map (\t -> (T.pack $ showMediaType t, t)) [minBound..]
@@ -126,7 +126,7 @@ postAddIAR :: Handler Html
 postAddIAR = iaConfigurator $ do
 	defcreds <- liftAnnex previouslyUsedIACreds
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ iaInputAForm defcreds
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ iaInputAForm defcreds
 	case result of
 		FormSuccess input -> liftH $ do
 			let name = escapeBucket $ T.unpack $ itemName input
@@ -165,7 +165,7 @@ enableIARemote :: UUID -> Widget
 enableIARemote uuid = do
 	defcreds <- liftAnnex previouslyUsedIACreds
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ iaCredsAForm defcreds
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ iaCredsAForm defcreds
 	case result of
 		FormSuccess creds -> liftH $ do
 			m <- liftAnnex readRemoteLog

Assistant/WebApp/Configurators/Local.hs

@@ -143,7 +143,7 @@ defaultRepositoryPath firstrun = do
 
 newRepositoryForm :: FilePath -> Hamlet.Html -> MkMForm RepositoryPath
 newRepositoryForm defpath msg = do
-	(pathRes, pathView) <- mreq (repositoryPathField True) ""
+	(pathRes, pathView) <- mreq (repositoryPathField True) (bfs "")
 		(Just $ T.pack $ addTrailingPathSeparator defpath)
 	let (err, errmsg) = case pathRes of
 		FormMissing -> (False, "")
@@ -217,10 +217,10 @@ getCombineRepositoryR newrepopath newrepouuid = do
 	remotename = takeFileName newrepopath
 
 selectDriveForm :: [RemovableDrive] -> Hamlet.Html -> MkMForm RemovableDrive
-selectDriveForm drives = renderBootstrap $ RemovableDrive
+selectDriveForm drives = renderBootstrap3 bootstrapFormLayout $ RemovableDrive
 	<$> pure Nothing
-	<*> areq (selectFieldList pairs `withNote` onlywritable) "Select drive:" Nothing
+	<*> areq (selectFieldList pairs `withNote` onlywritable) (bfs "Select drive:") Nothing
-	<*> areq textField "Use this directory on the drive:"
+	<*> areq textField (bfs "Use this directory on the drive:")
 		(Just $ T.pack gitAnnexAssistantDefaultDir)
   where
 	pairs = zip (map describe drives) (map mountPoint drives)

Assistant/WebApp/Configurators/Pairing.hs

@@ -265,8 +265,8 @@ data InputSecret = InputSecret { secretText :: Maybe Text }
 promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler Html
 promptSecret msg cont = pairPage $ do
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
-			InputSecret <$> aopt textField "Secret phrase" Nothing
+			InputSecret <$> aopt textField (bfs "Secret phrase") Nothing
 	case result of
 		FormSuccess v -> do
 			let rawsecret = fromMaybe "" $ secretText v

Assistant/WebApp/Configurators/Preferences.hs

@@ -36,13 +36,13 @@ data PrefsForm = PrefsForm
 prefsAForm :: PrefsForm -> MkAForm PrefsForm
 prefsAForm def = PrefsForm
 	<$> areq (storageField `withNote` diskreservenote)
-		"Disk reserve" (Just $ diskReserve def)
+		(bfs "Disk reserve") (Just $ diskReserve def)
 	<*> areq (positiveIntField `withNote` numcopiesnote)
-		"Number of copies" (Just $ numCopies def)
+		(bfs "Number of copies") (Just $ numCopies def)
 	<*> areq (checkBoxField `withNote` autostartnote)
 		"Auto start" (Just $ autoStart def)
 	<*> areq (selectFieldList autoUpgradeChoices)
-		autoUpgradeLabel (Just $ autoUpgrade def)
+		(bfs autoUpgradeLabel) (Just $ autoUpgrade def)
 	<*> areq (checkBoxField `withNote` debugnote)
 		"Enable debug logging" (Just $ debugEnabled def)
   where
@@ -109,7 +109,7 @@ postPreferencesR :: Handler Html
 postPreferencesR = page "Preferences" (Just Configuration) $ do
 	((result, form), enctype) <- liftH $ do
 		current <- liftAnnex getPrefs
-		runFormPostNoToken $ renderBootstrap $ prefsAForm current
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ prefsAForm current
 	case result of
 		FormSuccess new -> liftH $ do
 			liftAnnex $ storePrefs new

Assistant/WebApp/Configurators/Ssh.hs

@@ -1,6 +1,6 @@
 {- git-annex assistant webapp configurator for ssh-based remotes
  -
- - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -13,6 +13,7 @@ module Assistant.WebApp.Configurators.Ssh where
 import Assistant.WebApp.Common
 import Assistant.WebApp.Gpg
 import Assistant.Ssh
+import Annex.Ssh
 import Assistant.WebApp.MakeRemote
 import Logs.Remote
 import Remote
@@ -25,9 +26,15 @@ import qualified Remote.GCrypt as GCrypt
 import Annex.UUID
 import Logs.UUID
 import Assistant.RemoteControl
+import Types.Creds
+import Assistant.CredPairCache
+import Config.Files
+import Utility.Tmp
+import Utility.FileMode
+import Utility.ThreadScheduler
+import Utility.Env
 
 #ifdef mingw32_HOST_OS
-import Utility.Tmp
 import Utility.Rsync
 #endif
 
@@ -42,10 +49,17 @@ sshConfigurator = page "Add a remote server" (Just Configuration)
 data SshInput = SshInput
 	{ inputHostname :: Maybe Text
 	, inputUsername :: Maybe Text
+	, inputAuthMethod :: AuthMethod
+	, inputPassword :: Maybe Text
 	, inputDirectory :: Maybe Text
 	, inputPort :: Int
 	}
-	deriving (Show)
+
+data AuthMethod
+	= Password
+	| CachedPassword
+	| ExistingSshKey
+	deriving (Eq, Show)
 
 {- SshInput is only used for applicative form prompting, this converts
  - the result of such a form into a SshData. -}
@@ -66,6 +80,8 @@ mkSshInput :: SshData -> SshInput
 mkSshInput s = SshInput
 	{ inputHostname = Just $ sshHostName s
 	, inputUsername = sshUserName s
+	, inputAuthMethod = if needsPubKey s then CachedPassword else ExistingSshKey
+	, inputPassword = Nothing
 	, inputDirectory = Just $ sshDirectory s
 	, inputPort = sshPort s
 	}
@@ -76,11 +92,19 @@ sshInputAForm :: Field Handler Text -> SshInput -> AForm Handler SshInput
 sshInputAForm :: Field WebApp WebApp Text -> SshInput -> AForm WebApp WebApp SshInput
 #endif
 sshInputAForm hostnamefield def = SshInput
-	<$> aopt check_hostname "Host name" (Just $ inputHostname def)
+	<$> aopt check_hostname (bfs "Host name") (Just $ inputHostname def)
-	<*> aopt check_username "User name" (Just $ inputUsername def)
+	<*> aopt check_username (bfs "User name") (Just $ inputUsername def)
-	<*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ inputDirectory def)
+	<*> areq (selectFieldList authmethods) (bfs "Authenticate with") (Just $ inputAuthMethod def)
-	<*> areq intField "Port" (Just $ inputPort def)
+	<*> aopt passwordField (bfs "Password") Nothing
+	<*> aopt textField (bfs "Directory") (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ inputDirectory def)
+	<*> areq intField (bfs "Port") (Just $ inputPort def)
   where
+	authmethods :: [(Text, AuthMethod)]
+	authmethods =
+		[ ("password", Password)
+		, ("existing ssh key", ExistingSshKey)
+		]
+
 	check_username = checkBool (all (`notElem` "/:@ \t") . T.unpack)
 		bad_username textField
 
@@ -121,11 +145,11 @@ postAddSshR :: Handler Html
 postAddSshR = sshConfigurator $ do
 	username <- liftIO $ T.pack <$> myUserName
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ sshInputAForm textField $
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ sshInputAForm textField $
-			SshInput Nothing (Just username) Nothing 22
+			SshInput Nothing (Just username) Password Nothing Nothing 22
 	case result of
 		FormSuccess sshinput -> do
-			s <- liftIO $ testServer sshinput
+			s <- liftAssistant $ testServer sshinput
 			case s of
 				Left status -> showform form enctype status
 				Right (sshdata, u) -> liftH $ redirect $ ConfirmSshR sshdata u
@@ -173,13 +197,13 @@ enableSpecialSshRemote getsshinput rsyncnetsetup genericsetup u = do
 	case (mkSshInput . unmangle <$> getsshinput m, M.lookup "name" m) of
 		(Just sshinput, Just reponame) -> sshConfigurator $ do
 			((result, form), enctype) <- liftH $
-				runFormPostNoToken $ renderBootstrap $ sshInputAForm textField sshinput
+				runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ sshInputAForm textField sshinput
 			case result of
 				FormSuccess sshinput'
 					| isRsyncNet (inputHostname sshinput') ->
 						void $ liftH $ rsyncnetsetup sshinput' reponame
 					| otherwise -> do
-						s <- liftIO $ testServer sshinput'
+						s <- liftAssistant $ testServer sshinput'
 						case s of
 							Left status -> showform form enctype status
 							Right (sshdata, _u) -> void $ liftH $ genericsetup
@@ -205,44 +229,34 @@ wrapCommand cmd = "if [ -x " ++ commandWrapper ++ " ]; then " ++ commandWrapper
 commandWrapper :: String
 commandWrapper = "~/.ssh/git-annex-wrapper"
 
-{- Test if we can ssh into the server.
+{- Test if we can ssh into the server, using the specified AuthMethod.
- -
- - Two probe attempts are made. First, try sshing in using the existing
- - configuration, but don't let ssh prompt for any password. If
- - passwordless login is already enabled, use it. Otherwise,
- - a special ssh key will need to be generated just for this server.
  -
  - Once logged into the server, probe to see if git-annex-shell,
  - git, and rsync are available. 
  -
- - Note that, ~/.ssh/git-annex-shell may be
+ - Note that ~/.ssh/git-annex-shell may be present, while
- - present, while git-annex-shell is not in PATH.
+ - git-annex-shell is not in PATH.
  - Also, git and rsync may not be in PATH; as long as the commandWrapper
  - is present, assume it is able to be used to run them.
  -
  - Also probe to see if there is already a git repository at the location
  - with either an annex-uuid or a gcrypt-id set. (If not, returns NoUUID.)
  -}
-testServer :: SshInput -> IO (Either ServerStatus (SshData, UUID))
+testServer :: SshInput -> Assistant (Either ServerStatus (SshData, UUID))
 testServer (SshInput { inputHostname = Nothing }) = return $
 	Left $ UnusableServer "Please enter a host name."
 testServer sshinput@(SshInput { inputHostname = Just hn }) = do
-	(status, u) <- probe [sshOpt "NumberOfPasswordPrompts" "0"]
+	(status, u) <- probe
 	case capabilities status of
-		[] -> do
+		[] -> return $ Left status
-			(status', u') <- probe []
+		cs -> do
-			case capabilities status' of
-				[] -> return $ Left status'
-				cs -> ret cs True u'
-		cs -> ret cs False u
-  where
-	ret cs needspubkey u = do
 			let sshdata = (mkSshData sshinput)
-			{ needsPubKey = needspubkey
+				{ needsPubKey = inputAuthMethod sshinput /= ExistingSshKey
 				, sshCapabilities = cs
 				}
 			return $ Right (sshdata, u)
-	probe extraopts = do
+  where
+	probe = do
 		let remotecommand = shellWrap $ intercalate ";"
 			[ report "loggedin"
 			, checkcommand "git-annex-shell"
@@ -252,12 +266,13 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
 			, checkcommand commandWrapper
 			, getgitconfig (T.unpack <$> inputDirectory sshinput)
 			]
-		knownhost <- knownHost hn
+		knownhost <- liftIO $ knownHost hn
-		let sshopts = filter (not . null) $ extraopts ++
+		let sshopts =
 			{- If this is an already known host, let
 			 - ssh check it as usual.
 			 - Otherwise, trust the host key. -}
-			[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
+			[ sshOpt "StrictHostKeyChecking" $
+				if knownhost then "yes" else "no"
 			, "-n" -- don't read from stdin
 			, "-p", show (inputPort sshinput)
 			, genSshHost
@@ -265,7 +280,7 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
 				(inputUsername sshinput)
 			, remotecommand
 			]
-		parsetranscript . fst <$> sshTranscript sshopts Nothing
+		parsetranscript . fst <$> sshAuthTranscript sshinput sshopts Nothing
 	parsetranscript s =
 		let cs = map snd $ filter (reported . fst)
 			[ ("git-annex-shell", GitAnnexShellCapable)
@@ -298,19 +313,84 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
 		| not (null d) = "cd " ++ shellEscape d ++ " && git config --list"
 	getgitconfig _ = "echo"
 
-{- Runs a ssh command; if it fails shows the user the transcript,
+{- Runs a ssh command to set up the repository; if it fails shows
- - and if it succeeds, runs an action. -}
+ - the user the transcript, and if it succeeds, runs an action. -}
-sshSetup :: [String] -> Maybe String -> Handler Html -> Handler Html
+sshSetup :: SshInput -> [String] -> Maybe String -> Handler Html -> Handler Html
-sshSetup opts input a = do
+sshSetup sshinput opts input a = do
-	(transcript, ok) <- liftIO $ sshTranscript opts input
+	(transcript, ok) <- liftAssistant $ sshAuthTranscript sshinput opts input
 	if ok
-		then a
+		then do
-		else showSshErr transcript
+			liftAssistant $ expireCachedCred $ getLogin sshinput
+			a
+		else sshErr sshinput transcript
 
-showSshErr :: String -> Handler Html
+sshErr :: SshInput -> String -> Handler Html
-showSshErr msg = sshConfigurator $
+sshErr sshinput msg
+	| inputAuthMethod sshinput == CachedPassword =
+		ifM (liftAssistant $ isNothing <$> getCachedCred (getLogin sshinput))
+			( sshConfigurator $
+				$(widgetFile "configurators/ssh/expiredpassword")
+			, showerr
+			)
+	| otherwise = showerr
+  where
+	showerr = sshConfigurator $
 		$(widgetFile "configurators/ssh/error")
 
+{- Runs a ssh command, returning a transcript of its output.
+ -
+ - Depending on the SshInput, avoids using a password, or uses a
+ - cached password. ssh is coaxed to use git-annex as SSH_ASKPASS
+ - to get the password.
+ -
+ - Note that ssh will only use SSH_ASKPASS when DISPLAY is set and there
+ - is no controlling terminal. On Unix, that is set up when the assistant
+ - starts, by calling createSession. On Windows, all of stdin, stdout, and
+ - stderr must be disconnected from the terminal. This is accomplished
+ - by always providing input on stdin.
+ -}
+sshAuthTranscript :: SshInput -> [String] -> (Maybe String) -> Assistant (String, Bool)
+sshAuthTranscript sshinput opts input = case inputAuthMethod sshinput of
+	ExistingSshKey -> liftIO $ go [passwordprompts 0] Nothing
+	CachedPassword -> setupAskPass
+	Password -> do
+		cacheCred (login, geti inputPassword) (Seconds $ 60 * 10)
+		setupAskPass
+  where
+	login = getLogin sshinput
+	geti f = maybe "" T.unpack (f sshinput)
+
+	go extraopts env = processTranscript' "ssh" (extraopts ++ opts) env $
+		Just (fromMaybe "" input)
+
+	setupAskPass = do
+		program <- liftIO readProgramFile
+		v <- getCachedCred login
+		liftIO $ case v of
+			Nothing -> go [passwordprompts 0] Nothing
+			Just pass -> withTmpFile "ssh" $ \passfile h -> do
+				hClose h
+				writeFileProtected passfile pass
+				env <- getEnvironment
+				let env' = addEntries
+					[ ("SSH_ASKPASS", program)
+					, (sshAskPassEnv, passfile)
+					-- ssh does not use SSH_ASKPASS
+					-- unless DISPLAY is set, and
+					-- there is no controlling
+					-- terminal.
+					, ("DISPLAY", ":0")
+					] env
+				go [passwordprompts 1] (Just env')
+	
+	passwordprompts :: Int -> String
+	passwordprompts = sshOpt "NumberOfPasswordPrompts" . show
+
+getLogin :: SshInput -> Login
+getLogin sshinput = geti inputUsername ++ "@" ++ geti inputHostname
+  where
+	geti f = maybe "" T.unpack (f sshinput)
+
 {- The UUID will be NoUUID when the repository does not already exist,
  - or was not a git-annex repository before. -}
 getConfirmSshR :: SshData -> UUID -> Handler Html
@@ -343,7 +423,7 @@ getCombineSshR sshdata = prepSsh False sshdata $ \sshdata' ->
 
 getRetrySshR :: SshData -> Handler ()
 getRetrySshR sshdata = do
-	s <- liftIO $ testServer $ mkSshInput sshdata
+	s <- liftAssistant $ testServer $ mkSshInput sshdata
 	redirect $ either (const $ ConfirmSshR sshdata NoUUID) (uncurry ConfirmSshR) s
 
 {- Making a new git repository. -}
@@ -403,7 +483,7 @@ prepSsh needsinit sshdata a
 	| otherwise = prepSsh' needsinit sshdata sshdata Nothing a
 
 prepSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> (SshData -> Handler Html) -> Handler Html
-prepSsh' needsinit origsshdata sshdata keypair a = sshSetup
+prepSsh' needsinit origsshdata sshdata keypair a = sshSetup (mkSshInput origsshdata)
 	 [ "-p", show (sshPort origsshdata)
 	 , genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
 	 , remoteCommand
@@ -450,8 +530,8 @@ getAddRsyncNetR = postAddRsyncNetR
 postAddRsyncNetR :: Handler Html
 postAddRsyncNetR = do
 	((result, form), enctype) <- runFormPostNoToken $
-		renderBootstrap $ sshInputAForm hostnamefield $
+		renderBootstrap3 bootstrapFormLayout $ sshInputAForm hostnamefield $
-			SshInput Nothing Nothing Nothing 22
+			SshInput Nothing Nothing Password Nothing Nothing 22
 	let showform status = inpage $
 		$(widgetFile "configurators/rsync.net/add")
 	case result of
@@ -476,6 +556,7 @@ postAddRsyncNetR = do
 	go sshinput = do
 		let reponame = genSshRepoName "rsync.net" 
 			(maybe "" T.unpack $ inputDirectory sshinput)
+		
 		prepRsyncNet sshinput reponame $ \sshdata -> inpage $ 
 			checkExistingGCrypt sshdata $ do
 				secretkeys <- sortBy (comparing snd) . M.toList
@@ -490,7 +571,7 @@ getMakeRsyncNetGCryptR :: SshData -> RepoKey -> Handler Html
 getMakeRsyncNetGCryptR sshdata NoRepoKey = whenGcryptInstalled $
 	withNewSecretKey $ getMakeRsyncNetGCryptR sshdata . RepoKey
 getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $
-	sshSetup [sshhost, gitinit] Nothing $ makeGCryptRepo keyid sshdata
+	sshSetup (mkSshInput sshdata) [sshhost, gitinit] Nothing $ makeGCryptRepo keyid sshdata
   where
 	sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
 	gitinit = "git init --bare " ++ T.unpack (sshDirectory sshdata)
@@ -514,11 +595,6 @@ enableRsyncNetGCrypt sshinput reponame =
  - To append the ssh key to rsync.net's authorized_keys, their
  - documentation recommends a dd methodd, where the line is fed
  - in to ssh over stdin.
- -
- - On Windows, ssh password prompting happens on stdin, so cannot
- - feed the key in that way. Instead, first rsync down any current
- - authorized_keys file, then modifiy it, and then rsync it back up.
- - This means 2 password prompts rather than one for Windows.
  -}
 prepRsyncNet :: SshInput -> String -> (SshData -> Handler Html) -> Handler Html
 prepRsyncNet sshinput reponame a = do
@@ -536,7 +612,6 @@ prepRsyncNet sshinput reponame a = do
 		, sshhost
 		, cmd
 		]
-#ifndef mingw32_HOST_OS
 	{- I'd prefer to separate commands with && , but
 	 - rsync.net's shell does not support that. -}
 	let remotecommand = intercalate ";"
@@ -545,22 +620,7 @@ prepRsyncNet sshinput reponame a = do
 		, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
 		, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
 		]
-	sshSetup (torsyncnet remotecommand) (Just $ sshPubKey keypair) (a sshdata)
+	sshSetup sshinput (torsyncnet remotecommand) (Just $ sshPubKey keypair) (a sshdata)
-#else
-	liftIO $ withTmpDir "rsyncnet" $ \tmpdir -> do
-		createDirectory $ tmpdir </> ".ssh"
-		(oldkeys, _) <- sshTranscript (torsyncnet "cat .ssh/authorized_keys") Nothing
-		writeFile (tmpdir </> ".ssh" </> "authorized_keys")
-			(sshPubKey keypair ++ "\n" ++ oldkeys)
-		liftIO $ putStrLn "May need to prompt for your rsync.net password one more time..."
-		void $ rsync
-			[ Param "-r"
-			, File $ tmpdir </> ".ssh/"
-			, Param $ sshhost ++ ":.ssh/"
-			]
-	let remotecommand = "mkdir -p " ++ T.unpack (sshDirectory sshdata)
-	sshSetup (torsyncnet remotecommand) Nothing (a sshdata)
-#endif
 
 isRsyncNet :: Maybe Text -> Bool
 isRsyncNet Nothing = False

Assistant/WebApp/Configurators/Unused.hs

@@ -27,9 +27,9 @@ data UnusedForm = UnusedForm
 
 unusedForm :: UnusedForm -> Hamlet.Html -> MkMForm UnusedForm
 unusedForm def msg = do
-	(enableRes, enableView) <- mreq (selectFieldList enabledisable) ""
+	(enableRes, enableView) <- mreq (selectFieldList enabledisable) (bfs "")
 		(Just $ enableExpire def)
-	(whenRes, whenView) <- mreq intField ""
+	(whenRes, whenView) <- mreq intField (bfs "")
 		(Just $ expireWhen def)
 	let form = do
 		webAppFormAuthToken

Assistant/WebApp/Configurators/WebDAV.hs

@@ -45,16 +45,16 @@ toCredPair input = (T.unpack $ user input, T.unpack $ password input)
 
 boxComAForm :: Maybe CredPair -> MkAForm WebDAVInput
 boxComAForm defcreds = WebDAVInput
-	<$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
+	<$> areq textField (bfs "Username or Email") (T.pack . fst <$> defcreds)
-	<*> areq passwordField "Box.com Password" (T.pack . snd <$> defcreds)
+	<*> areq passwordField (bfs "Box.com Password") (T.pack . snd <$> defcreds)
 	<*> areq checkBoxField "Share this account with other devices and friends?" (Just True)
-	<*> areq textField "Directory" (Just "annex")
+	<*> areq textField (bfs "Directory") (Just "annex")
 	<*> enableEncryptionField
 
 webDAVCredsAForm :: Maybe CredPair -> MkAForm WebDAVInput
 webDAVCredsAForm defcreds = WebDAVInput
-	<$> areq textField "Username or Email" (T.pack . fst <$> defcreds)
+	<$> areq textField (bfs "Username or Email") (T.pack . fst <$> defcreds)
-	<*> areq passwordField "Password" (T.pack . snd <$> defcreds)
+	<*> areq passwordField (bfs "Password") (T.pack . snd <$> defcreds)
 	<*> pure False
 	<*> pure T.empty
 	<*> pure NoEncryption -- not used!
@@ -66,7 +66,8 @@ postAddBoxComR :: Handler Html
 postAddBoxComR = boxConfigurator $ do
 	defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"
 	((result, form), enctype) <- liftH $
-		runFormPostNoToken $ renderBootstrap $ boxComAForm defcreds
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout
+			$ boxComAForm defcreds
 	case result of
 		FormSuccess input -> liftH $ 
 			makeWebDavRemote initSpecialRemote "box.com" (toCredPair input) $ M.fromList
@@ -109,7 +110,8 @@ postEnableWebDAVR uuid = do
 			maybe (pure Nothing) previouslyUsedWebDAVCreds $
 				urlHost url
 		((result, form), enctype) <- liftH $
-			runFormPostNoToken $ renderBootstrap $ webDAVCredsAForm defcreds
+			runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
+				webDAVCredsAForm defcreds
 		case result of
 			FormSuccess input -> liftH $
 				makeWebDavRemote enableSpecialRemote name (toCredPair input) M.empty

Assistant/WebApp/Configurators/XMPP.hs

@@ -99,7 +99,7 @@ xmppform :: Route WebApp -> Handler Html
 xmppform next = xmppPage $ do
 	((result, form), enctype) <- liftH $ do
 		oldcreds <- liftAnnex getXMPPCreds
-		runFormPostNoToken $ renderBootstrap $ xmppAForm $
+		runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ xmppAForm $
 			creds2Form <$> oldcreds
 	let showform problem = $(widgetFile "configurators/xmpp")
 	case result of
@@ -162,8 +162,8 @@ creds2Form c = XMPPForm (xmppJID c) (xmppPassword c)
 
 xmppAForm :: (Maybe XMPPForm) -> MkAForm XMPPForm
 xmppAForm def = XMPPForm
-	<$> areq jidField "Jabber address" (formJID <$> def)
+	<$> areq jidField (bfs "Jabber address") (formJID <$> def)
-	<*> areq passwordField "Password" Nothing
+	<*> areq passwordField (bfs "Password") Nothing
 
 jidField :: MkField Text
 jidField = checkBool (isJust . parseJID) bad textField

Assistant/WebApp/Form.hs

@@ -15,9 +15,18 @@ module Assistant.WebApp.Form where
 import Assistant.WebApp.Types
 import Assistant.Gpg
 
+#if MIN_VERSION_yesod(1,2,0)
 import Yesod hiding (textField, passwordField)
 import Yesod.Form.Fields as F
+#else
+import Yesod hiding (textField, passwordField, selectField, selectFieldList)
+import Yesod.Form.Fields as F hiding (selectField, selectFieldList)
+import Data.String (IsString (..))
+import Control.Monad (unless)
+import Data.Maybe (listToMaybe)
+#endif
 import Data.Text (Text)
+import Assistant.WebApp.Bootstrap3 hiding (bfs)
 
 {- Yesod's textField sets the required attribute for required fields.
  - We don't want this, because many of the forms used in this webapp 
@@ -48,6 +57,54 @@ passwordField = F.passwordField
 |]
 	}
 
+{- In older Yesod versions attrs is written into the <option> tag instead of the
+ - surrounding <select>. This breaks the Bootstrap 3 layout of select fields as
+ - it requires the "form-control" class on the <select> tag.
+ - We need to change that to behave the same way as in newer versions.
+ -}
+#if ! MIN_VERSION_yesod(1,2,0)
+selectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a
+selectFieldList = selectField . optionsPairs
+
+selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
+selectField = selectFieldHelper
+	(\theId name attrs inside -> [whamlet|<select ##{theId} name=#{name} *{attrs}>^{inside}|]) -- outside
+	(\_theId _name isSel -> [whamlet|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
+	(\_theId _name _attrs value isSel text -> [whamlet|<option value=#{value} :isSel:selected>#{text}|]) -- inside
+
+selectFieldHelper :: (Eq a, RenderMessage master FormMessage)
+	=> (Text -> Text -> [(Text, Text)] -> GWidget sub master () -> GWidget sub master ())
+	-> (Text -> Text -> Bool -> GWidget sub master ())
+	-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> GWidget sub master ())
+	-> GHandler sub master (OptionList a) -> Field sub master a
+selectFieldHelper outside onOpt inside opts' = Field
+	{ fieldParse = \x -> do
+		opts <- opts'
+		return $ selectParser opts x
+	, fieldView = \theId name attrs val isReq -> do
+		opts <- fmap olOptions $ lift opts'
+		outside theId name attrs $ do
+			unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
+			flip mapM_ opts $ \opt -> inside
+				theId
+				name
+				((if isReq then (("required", "required"):) else id) attrs)
+				(optionExternalValue opt)
+				((render opts val) == optionExternalValue opt)
+				(optionDisplay opt)
+	}
+  where
+	render _ (Left _) = ""
+	render opts (Right a) = maybe "" optionExternalValue $ listToMaybe $ filter ((== a) . optionInternalValue) opts
+	selectParser _ [] = Right Nothing
+	selectParser opts (s:_) = case s of
+		"" -> Right Nothing
+		"none" -> Right Nothing
+		x -> case olReadExternal opts x of
+			Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
+			Just y -> Right $ Just y
+#endif
+
 {- Makes a note widget be displayed after a field. -}
 #if MIN_VERSION_yesod(1,2,0)
 withNote :: (Monad m, ToWidget (HandlerSite m) a) => Field m v -> a -> Field m v
@@ -67,7 +124,7 @@ withExpandableNote :: (Monad m, ToWidget (HandlerSite m) w) => Field m v -> (Str
 withExpandableNote :: Field sub master v -> (String, GWidget sub master ()) -> Field sub master v
 #endif
 withExpandableNote field (toggle, note) = withNote field $ [whamlet|
-<a .btn data-toggle="collapse" data-target="##{ident}">#{toggle}</a>
+<a .btn .btn-default data-toggle="collapse" data-target="##{ident}">#{toggle}</a>
 <div ##{ident} .collapse>
   ^{note}
 |]
@@ -80,10 +137,27 @@ enableEncryptionField :: (RenderMessage site FormMessage) => AForm (HandlerT sit
 #else
 enableEncryptionField :: RenderMessage master FormMessage => AForm sub master EnableEncryption
 #endif
-enableEncryptionField = areq (selectFieldList choices) "Encryption" (Just SharedEncryption)
+enableEncryptionField = areq (selectFieldList choices) (bfs "Encryption") (Just SharedEncryption)
   where
 	choices :: [(Text, EnableEncryption)]
 	choices =
 		[ ("Encrypt all data", SharedEncryption)
 		, ("Disable encryption", NoEncryption)
 		]
+
+{- Defines the layout used by the Bootstrap3 form helper -}
+bootstrapFormLayout :: BootstrapFormLayout
+bootstrapFormLayout = BootstrapHorizontalForm (ColSm 0) (ColSm 2) (ColSm 0) (ColSm 10)
+
+{- Adds the form-control class used by Bootstrap3 for layout to a field
+ - This is the same as Yesod.Form.Bootstrap3.bfs except it takes just a Text
+ - parameter as I couldn't get the original bfs to compile due to type ambiguities.
+ -}
+bfs :: Text -> FieldSettings master
+bfs msg = FieldSettings
+	{ fsLabel = SomeMessage msg
+	, fsName  = Nothing
+	, fsId    = Nothing
+	, fsAttrs = [("class", "form-control")]
+	, fsTooltip = Nothing
+	}

Assistant/WebApp/Gpg.hs

@@ -27,7 +27,8 @@ import qualified Data.Map as M
 gpgKeyDisplay :: KeyId -> Maybe UserId -> Widget
 gpgKeyDisplay keyid userid = [whamlet|
   <span title="key id #{keyid}">
-    <i .icon-user></i> #
+    <span .glyphicon .glyphicon-user>
+    \ 
     $maybe name <- userid
       #{name}
     $nothing

Assistant/WebApp/Page.hs

@@ -59,14 +59,12 @@ customPage' with_longpolling navbaritem content = do
 		Nothing -> do
 			navbar <- map navdetails <$> selectNavBar
 			pageinfo <- widgetToPageContent $ do
-				addStylesheet $ StaticR bootstrap_css
+				addStylesheet $ StaticR css_bootstrap_css
-				addStylesheet $ StaticR bootstrap_responsive_css
+				addStylesheet $ StaticR css_bootstrap_theme_css
-				addScript $ StaticR jquery_full_js
+				addScript $ StaticR js_jquery_full_js
-				addScript $ StaticR bootstrap_dropdown_js
+				addScript $ StaticR js_bootstrap_js
-				addScript $ StaticR bootstrap_modal_js
-				addScript $ StaticR bootstrap_collapse_js
 				when with_longpolling $
-					addScript $ StaticR longpolling_js
+					addScript $ StaticR js_longpolling_js
 				$(widgetFile "page")
 			giveUrlRenderer $(Hamlet.hamletFile $ hamletTemplate "bootstrap")
 		Just msg -> error msg

Assistant/WebApp/RepoList.hs

@@ -113,10 +113,10 @@ cloudRepoList = repoListDisplay RepoSelector
 repoListDisplay :: RepoSelector -> Widget
 repoListDisplay reposelector = do
 	autoUpdate ident (NotifierRepoListR reposelector) (10 :: Int) (10 :: Int)
-	addScript $ StaticR jquery_ui_core_js
+	addScript $ StaticR js_jquery_ui_core_js
-	addScript $ StaticR jquery_ui_widget_js
+	addScript $ StaticR js_jquery_ui_widget_js
-	addScript $ StaticR jquery_ui_mouse_js
+	addScript $ StaticR js_jquery_ui_mouse_js
-	addScript $ StaticR jquery_ui_sortable_js
+	addScript $ StaticR js_jquery_ui_sortable_js
 
 	repolist <- liftH $ repoList reposelector
 	let addmore = nudgeAddMore reposelector
@@ -223,17 +223,17 @@ getRepositoriesReorderR = do
 	{- Get uuid of the moved item, and the list it was moved within. -}
 	moved <- fromjs <$> runInputGet (ireq textField "moved")
 	list <- map fromjs <$> lookupGetParams "list[]"
-	liftAnnex $ go list =<< Remote.remoteFromUUID moved
+	liftAnnex $ go list =<< repoIdRemote moved
 	liftAssistant updateSyncRemotes
   where
 	go _ Nothing = noop
   	go list (Just remote) = do
-		rs <- catMaybes <$> mapM Remote.remoteFromUUID list
+		rs <- catMaybes <$> mapM repoIdRemote list
 		forM_ (reorderCosts remote rs) $ \(r, newcost) ->
 			when (Remote.cost r /= newcost) $
 				setRemoteCost (Remote.repo r) newcost
 		void remoteListRefresh
-  	fromjs = toUUID . T.unpack
+  	fromjs = fromMaybe (RepoUUID NoUUID) . readish . T.unpack
 
 reorderCosts :: Remote -> [Remote] -> [(Remote, Cost)]
 reorderCosts remote rs = zip rs'' (insertCostAfter costs i)

Assistant/WebApp/SideBar.hs

@@ -38,7 +38,7 @@ sideBarDisplay = do
 	bootstrapclass :: AlertClass -> Text
 	bootstrapclass Activity = "alert-info"
 	bootstrapclass Warning = "alert"
-	bootstrapclass Error = "alert-error"
+	bootstrapclass Error = "alert-danger"
 	bootstrapclass Success = "alert-success"
 	bootstrapclass Message = "alert-info"
 
@@ -106,4 +106,4 @@ htmlIcon UpgradeIcon = bootstrapIcon "arrow-up"
 htmlIcon ConnectionIcon = bootstrapIcon "signal"
 
 bootstrapIcon :: Text -> Widget
-bootstrapIcon name = [whamlet|<i .icon-#{name}></i>|]
+bootstrapIcon name = [whamlet|<span .glyphicon .glyphicon-#{name}>|]

Assistant/WebApp/Types.hs

@@ -73,8 +73,10 @@ instance Yesod WebApp where
 	defaultLayout content = do
 		webapp <- getYesod
 		pageinfo <- widgetToPageContent $ do
-			addStylesheet $ StaticR bootstrap_css
+			addStylesheet $ StaticR css_bootstrap_css
-			addStylesheet $ StaticR bootstrap_responsive_css
+			addStylesheet $ StaticR css_bootstrap_theme_css
+			addScript $ StaticR js_jquery_full_js
+			addScript $ StaticR js_bootstrap_js
 			$(widgetFile "error")
 		giveUrlRenderer $(hamletFile $ hamletTemplate "bootstrap")
 

Build/Configure.hs

@@ -7,7 +7,6 @@ import Control.Applicative
 import System.Environment (getArgs)
 import Control.Monad.IfElse
 import Control.Monad
-import System.IO
 
 import Build.TestConfig
 import Build.Version
@@ -63,11 +62,7 @@ shaTestCases l = map make l
 		key = "sha" ++ show n
 	  	search [] = return Nothing
 		search (c:cmds) = do
-			putStr $ "(" ++ c
-			hFlush stdout
 			sha <- externalSHA c n "/dev/null"
-			putStr $ ":" ++ show sha ++ ")"
-			hFlush stdout
 			if sha == Right knowngood
 				then return $ Just c
 				else search cmds

Build/DistributionUpdate.hs

@@ -96,7 +96,7 @@ signFile f = do
 	void $ liftIO $ boolSystem "gpg"
 		[ Param "-a"
 		, Param $ "--default-key=" ++ signingKey
-		, Param "--sign"
+		, Param "--detach-sign"
 		, File f
 		]
 	liftIO $ rename (f ++ ".asc") (f ++ ".sig")

Build/EvilSplicer.hs

@@ -460,6 +460,11 @@ mangleCode = flip_colon
 	 -
 	 - Nothing
 	 -   -> foo
+	 -
+	 - -- This is not yet handled!
+	 - ComplexConstructor  var var
+	 -        var var
+	 -   -> foo
 	 -}
 	case_layout_multiline = parsecAndReplace $ do
 		void newline

CmdLine/GitAnnex.hs

@@ -199,5 +199,11 @@ run args = do
 #ifdef WITH_EKG
 	_ <- forkServer "localhost" 4242
 #endif
-	maybe (dispatch True args cmds gitAnnexOptions [] header Git.CurrentRepo.get)
+	go envmodes
-		(runSshCaching args) =<< getEnv sshCachingEnv
+  where
+	go [] = dispatch True args cmds gitAnnexOptions [] header Git.CurrentRepo.get
+	go ((v, a):rest) = maybe (go rest) a =<< getEnv v
+	envmodes =
+		[ (sshCachingEnv, runSshCaching args)
+		, (sshAskPassEnv, runSshAskPass)
+		]

Command/Group.hs

@@ -26,10 +26,14 @@ start :: [String] -> CommandStart
 start (name:g:[]) = do
 	showStart "group" name
 	u <- Remote.nameToUUID name
-	next $ perform u g
+	next $ setGroup u g
+start (name:[]) = do
+	u <- Remote.nameToUUID name
+	showRaw . unwords . S.toList =<< lookupGroups u
+	stop
 start _ = error "Specify a repository and a group."
 
-perform :: UUID -> Group -> CommandPerform
+setGroup :: UUID -> Group -> CommandPerform
-perform uuid g = do
+setGroup uuid g = do
 	groupChange uuid (S.insert g) 
 	next $ return True

Command/Map.hs

@@ -203,7 +203,8 @@ tryScan r
 
 	configlist = Ssh.onRemote r (pipedconfig, Nothing) "configlist" [] []
 	manualconfiglist = do
-		sshparams <- Ssh.toRepo r [Param sshcmd]
+		gc <- Annex.getRemoteGitConfig r
+		sshparams <- Ssh.toRepo r gc [Param sshcmd]
 		liftIO $ pipedconfig "ssh" sshparams
 	  where
 		sshcmd = cddir ++ " && " ++

Makefile

@@ -120,6 +120,7 @@ linuxstandalone-nobuild: Build/Standalone Build/LinuxMkLibs
 	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)"
 	
@@ -150,6 +151,7 @@ osxapp: Build/Standalone Build/OSXMkLibs
 	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)
 

Remote.hs

@@ -87,9 +87,8 @@ uuidDescriptions = M.unionWith addName <$> uuidMap <*> remoteMap name
 
 addName :: String -> RemoteName -> String
 addName desc n
-	| desc == n = desc
+	| desc == n || null desc = "[" ++ n ++ "]"
-	| null desc = n
+	| otherwise = desc ++ " [" ++ n ++ "]"
-	| otherwise = n ++ " (" ++ desc ++ ")"
 
 {- When a name is specified, looks up the remote matching that name.
  - (Or it can be a UUID.) -}

Remote/Bup.hs

@@ -13,6 +13,7 @@ import System.Process
 import Data.ByteString.Lazy.UTF8 (fromString)
 
 import Common.Annex
+import qualified Annex
 import Types.Remote
 import Types.Key
 import Types.Creds
@@ -223,7 +224,8 @@ storeBupUUID u buprepo = do
 
 onBupRemote :: Git.Repo -> (FilePath -> [CommandParam] -> IO a) -> FilePath -> [CommandParam] -> Annex a
 onBupRemote r a command params = do
-	sshparams <- Ssh.toRepo r [Param $
+	c <- Annex.getRemoteGitConfig r
+	sshparams <- Ssh.toRepo r c [Param $
 			"cd " ++ dir ++ " && " ++ unwords (command : toCommand params)]
 	liftIO $ a "ssh" sshparams
   where

Remote/Ddar.hs

@@ -0,0 +1,229 @@
+{- 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 ':'

Remote/Git.hs

@@ -87,10 +87,9 @@ list = do
  - cached UUID value. -}
 configRead :: Git.Repo -> Annex Git.Repo
 configRead r = do
-	g <- fromRepo id
+	gc <- Annex.getRemoteGitConfig r
-	let c = extractRemoteGitConfig g (Git.repoDescribe r)
 	u <- getRepoUUID r
-	case (repoCheap r, remoteAnnexIgnore c, u) of
+	case (repoCheap r, remoteAnnexIgnore gc, u) of
 		(_, True, _) -> return r
 		(True, _, _) -> tryGitConfigRead r
 		(False, _, NoUUID) -> tryGitConfigRead r
@@ -197,7 +196,7 @@ tryGitConfigRead r
 				)
 		case v of
 			Left _ -> do
-				set_ignore "not usable by git-annex"
+				set_ignore "not usable by git-annex" False
 				return r
 			Right r' -> do
 				-- Cache when http remote is not bare for
@@ -225,15 +224,18 @@ tryGitConfigRead r
 	configlist_failed = case Git.remoteName r of
 		Nothing -> return r
 		Just n -> do
-			whenM (inRepo $ Git.Command.runBool [Param "fetch", Param "--quiet", Param n]) $
+			whenM (inRepo $ Git.Command.runBool [Param "fetch", Param "--quiet", Param n]) $ do
-				set_ignore "does not have git-annex installed"
+				set_ignore "does not have git-annex installed" True
 			return r
 	
-	set_ignore msg = do
+	set_ignore msg longmessage = do
 		let k = "annex-ignore"
 		case Git.remoteName r of
 			Nothing -> noop
-			Just n -> warning $ "Remote " ++ n ++ " " ++ msg ++ "; setting " ++ k
+			Just n -> do
+				warning $ "Remote " ++ n ++ " " ++ msg ++ "; setting " ++ k
+				when longmessage $
+					warning $ "This could be a problem with the git-annex installation on the remote. Please make sure that git-annex-shell is available in PATH when you ssh into the remote. Once you have fixed the git-annex installation, run: git config remote." ++ n ++ "." ++ k ++ " false"
 		setremote k (Git.Config.boolConfig True)
 	
 	setremote k v = case Git.remoteName r of

Remote/Helper/Ssh.hs

@@ -8,13 +8,13 @@
 module Remote.Helper.Ssh where
 
 import Common.Annex
+import qualified Annex
 import qualified Git
 import qualified Git.Url
 import Annex.UUID
 import Annex.Ssh
 import CmdLine.GitAnnexShell.Fields (Field, fieldName)
 import qualified CmdLine.GitAnnexShell.Fields as Fields
-import Types.GitConfig
 import Types.Key
 import Remote.Helper.Messages
 import Utility.Metered
@@ -26,11 +26,9 @@ import Config
 {- Generates parameters to ssh to a repository's host and run a command.
  - Caller is responsible for doing any neccessary shellEscaping of the
  - passed command. -}
-toRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam]
+toRepo :: Git.Repo -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam]
-toRepo r sshcmd = do
+toRepo r gc sshcmd = do
-	g <- fromRepo id
+	let opts = map Param $ remoteAnnexSshOptions gc
-	let c = extractRemoteGitConfig g (Git.repoDescribe r)
-	let opts = map Param $ remoteAnnexSshOptions c
 	let host = fromMaybe (error "bad ssh url") $ Git.Url.hostuser r
 	params <- sshCachingOptions (host, Git.Url.port r) opts
 	return $ params ++ Param host : sshcmd
@@ -41,16 +39,18 @@ git_annex_shell :: Git.Repo -> String -> [CommandParam] -> [(Field, String)] ->
 git_annex_shell r command params fields
 	| not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts ++ fieldopts)
 	| Git.repoIsSsh r = do
+		gc <- Annex.getRemoteGitConfig r
 		u <- getRepoUUID r
-		sshparams <- toRepo r [Param $ sshcmd u ]
+		sshparams <- toRepo r gc [Param $ sshcmd u gc]
 		return $ Just ("ssh", sshparams)
 	| otherwise = return Nothing
   where
 	dir = Git.repoPath r
 	shellcmd = "git-annex-shell"
 	shellopts = Param command : File dir : params
-	sshcmd u = unwords $
+	sshcmd u gc = unwords $
-		shellcmd : map shellEscape (toCommand shellopts) ++
+		fromMaybe shellcmd (remoteAnnexShell gc)
+			: map shellEscape (toCommand shellopts) ++
 		uuidcheck u ++
 		map shellEscape (toCommand fieldopts)
 	uuidcheck NoUUID = []

Remote/List.hs

@@ -15,7 +15,6 @@ import Common.Annex
 import qualified Annex
 import Logs.Remote
 import Types.Remote
-import Types.GitConfig
 import Annex.UUID
 import Remote.Helper.Hooks
 import Remote.Helper.ReadOnly
@@ -38,6 +37,7 @@ import qualified Remote.WebDAV
 import qualified Remote.Tahoe
 #endif
 import qualified Remote.Glacier
+import qualified Remote.Ddar
 import qualified Remote.Hook
 import qualified Remote.External
 
@@ -59,6 +59,7 @@ remoteTypes =
 	, Remote.Tahoe.remote
 #endif
 	, Remote.Glacier.remote
+	, Remote.Ddar.remote
 	, Remote.Hook.remote
 	, Remote.External.remote
 	]
@@ -92,8 +93,7 @@ remoteListRefresh = do
 remoteGen :: M.Map UUID RemoteConfig -> RemoteType -> Git.Repo -> Annex (Maybe Remote)
 remoteGen m t r = do
 	u <- getRepoUUID r
-	g <- fromRepo id
+	gc <- Annex.getRemoteGitConfig r
-	let gc = extractRemoteGitConfig g (Git.repoDescribe r)
 	let c = fromMaybe M.empty $ M.lookup u m
 	mrmt <- generate t r u c gc
 	return $ adjustReadOnly . addHooks <$> mrmt

Types/Creds.hs

@@ -9,4 +9,6 @@ module Types.Creds where
 
 type Creds = String -- can be any data that contains credentials
 
-type CredPair = (String, String) -- login, password
+type CredPair = (Login, Password)
+type Login = String
+type Password = String -- todo: use securemem

Types/GitConfig.hs

@@ -119,6 +119,7 @@ data RemoteGitConfig = RemoteGitConfig
 
 	{- These settings are specific to particular types of remotes
 	 - including special remotes. -}
+	, remoteAnnexShell :: Maybe String
 	, remoteAnnexSshOptions :: [String]
 	, remoteAnnexRsyncOptions :: [String]
 	, remoteAnnexRsyncUploadOptions :: [String]
@@ -131,6 +132,7 @@ data RemoteGitConfig = RemoteGitConfig
 	, remoteAnnexBupSplitOptions :: [String]
 	, remoteAnnexDirectory :: Maybe FilePath
 	, remoteAnnexGCrypt :: Maybe String
+	, remoteAnnexDdarRepo :: Maybe String
 	, remoteAnnexHookType :: Maybe String
 	, remoteAnnexExternalType :: Maybe String
 	{- A regular git remote's git repository config. -}
@@ -150,6 +152,7 @@ extractRemoteGitConfig r remotename = RemoteGitConfig
 	, remoteAnnexAvailability = getmayberead "availability"
 	, remoteAnnexBare = getmaybebool "bare"
 
+	, remoteAnnexShell = getmaybe "shell"
 	, remoteAnnexSshOptions = getoptions "ssh-options"
 	, remoteAnnexRsyncOptions = getoptions "rsync-options"
 	, remoteAnnexRsyncDownloadOptions = getoptions "rsync-download-options"
@@ -162,6 +165,7 @@ extractRemoteGitConfig r remotename = RemoteGitConfig
 	, remoteAnnexBupSplitOptions = getoptions "bup-split-options"
 	, remoteAnnexDirectory = notempty $ getmaybe "directory"
 	, remoteAnnexGCrypt = notempty $ getmaybe "gcrypt"
+	, remoteAnnexDdarRepo = getmaybe "ddarrepo"
 	, remoteAnnexHookType = notempty $ getmaybe "hooktype"
 	, remoteAnnexExternalType = notempty $ getmaybe "externaltype"
 	, remoteGitConfig = Nothing

Utility/Applicative.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.Applicative where

Utility/Base64.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2011 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.Base64 (toB64, fromB64Maybe, fromB64) where

Utility/Batch.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}

Utility/CoProcess.hs

@@ -3,7 +3,7 @@
  -
  - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}
@@ -62,7 +62,7 @@ query ch send receive = do
 	s <- readMVar ch
 	restartable s (send $ coProcessTo s) $ const $
 		restartable s (hFlush $ coProcessTo s) $ const $
-			restartable s (receive $ coProcessFrom s) $
+			restartable s (receive $ coProcessFrom s)
 				return
   where
   	restartable s a cont

Utility/CopyFile.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}

Utility/DBus.hs

@@ -2,13 +2,14 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
 
 module Utility.DBus where
 
+import Utility.PartialPrelude
 import Utility.Exception
 
 import DBus.Client
@@ -22,7 +23,7 @@ type ServiceName = String
 listServiceNames :: Client -> IO [ServiceName]
 listServiceNames client = do
 	reply <- callDBus client "ListNames" []
-	return $ fromMaybe [] $ fromVariant (methodReturnBody reply !! 0)
+	return $ fromMaybe [] $ fromVariant =<< headMaybe (methodReturnBody reply)
 
 callDBus :: Client -> MemberName -> [Variant] -> IO MethodReturn
 callDBus client name params = call_ client $

Utility/Daemon.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}
@@ -36,7 +36,7 @@ daemonize logfd pidfile changedirectory a = do
 	_ <- forkProcess child1
 	out
   where
-	checkalreadyrunning f = maybe noop (const $ alreadyRunning) 
+	checkalreadyrunning f = maybe noop (const alreadyRunning) 
 		=<< checkDaemon f
 	child1 = do
 		_ <- createSession
@@ -54,6 +54,15 @@ daemonize logfd pidfile changedirectory a = do
 		wait =<< asyncWithUnmask (\unmask -> unmask a)
 		out
 	out = exitImmediately ExitSuccess
+
+{- To run an action that is normally daemonized in the forground. -}
+foreground :: Fd -> Maybe FilePath -> IO () -> IO ()
+foreground logfd pidfile a = do
+	maybe noop lockPidFile pidfile
+	_ <- createSession
+	redirLog logfd
+	a
+	exitImmediately ExitSuccess
 #endif
 
 {- Locks the pid file, with an exclusive, non-blocking lock,

Utility/Data.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.Data where

Utility/DataUnits.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2011 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -
  -
  - And now a rant: 
@@ -111,7 +111,7 @@ roughSize units short i
 	| i < 0 = '-' : findUnit units' (negate i)
 	| otherwise = findUnit units' i
   where
-	units' = reverse $ sort units -- largest first
+	units' = sortBy (flip compare) units -- largest first
 
 	findUnit (u@(Unit s _ _):us) i'
 		| i' >= s = showUnit i' u

Utility/DirWatcher.hs

@@ -6,7 +6,7 @@
  -
  - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}

Utility/DirWatcher/FSEvents.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.DirWatcher.FSEvents where

Utility/DirWatcher/INotify.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.DirWatcher.INotify where

Utility/DirWatcher/Kqueue.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE ForeignFunctionInterface #-}

Utility/DirWatcher/Types.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.DirWatcher.Types where

Utility/DirWatcher/Win32Notify.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.DirWatcher.Win32Notify where

Utility/Directory.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}
@@ -43,7 +43,7 @@ dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
  - When the directory does not exist, no exception is thrown,
  - instead, [] is returned. -}
 dirContentsRecursive :: FilePath -> IO [FilePath]
-dirContentsRecursive topdir = dirContentsRecursiveSkipping (const False) True topdir
+dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
 
 {- Skips directories whose basenames match the skipdir. -}
 dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]

Utility/DiskFree.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012, 2014 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE ForeignFunctionInterface, CPP #-}

Utility/Dot.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2010 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.Dot where -- import qualified

Utility/Env.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}

Utility/Exception.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -18,7 +18,7 @@ import Utility.Data
 
 {- Catches IO errors and returns a Bool -}
 catchBoolIO :: IO Bool -> IO Bool
-catchBoolIO a = catchDefaultIO False a
+catchBoolIO = catchDefaultIO False
 
 {- Catches IO errors and returns a Maybe -}
 catchMaybeIO :: IO a -> IO (Maybe a)

Utility/ExternalSHA.hs

@@ -5,7 +5,7 @@
  -
  - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.ExternalSHA (externalSHA) where

Utility/FileMode.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}

Utility/FileSystemEncoding.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}

Utility/Format.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.Format (

Utility/FreeDesktop.hs

@@ -7,7 +7,7 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.FreeDesktop (

Utility/Glob.hs

@@ -5,7 +5,7 @@
  -
  - Copyright 2014 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}

Utility/Gpg.hs

@@ -145,7 +145,7 @@ findPubKeys :: String -> IO KeyIds
 findPubKeys for = KeyIds . parse . lines <$> readStrict params
   where
 	params = [Params "--with-colons --list-public-keys", Param for]
-	parse = catMaybes . map (keyIdField . split ":")
+	parse = mapMaybe (keyIdField . split ":")
 	keyIdField ("pub":_:_:_:f:_) = Just f
 	keyIdField _ = Nothing
 
@@ -195,7 +195,7 @@ genSecretKey keytype passphrase userid keysize =
 					Algo n -> show n
 			, Just $ "Key-Length: " ++ show keysize
 			, Just $ "Name-Real: " ++ userid
-			, Just $ "Expire-Date: 0"
+			, Just "Expire-Date: 0"
 			, if null passphrase
 				then Nothing
 				else Just $ "Passphrase: " ++ passphrase

Utility/HumanNumber.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.HumanNumber where
@@ -17,5 +17,5 @@ showImprecise precision n
 	int :: Integer
 	(int, frac) = properFraction n
 	remainder = round (frac * 10 ^ precision) :: Integer
-	pad0s s = (take (precision - length s) (repeat '0')) ++ s
+	pad0s s = replicate (precision - length s) '0' ++ s
 	striptrailing0s = reverse . dropWhile (== '0') . reverse

Utility/HumanTime.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.HumanTime (
@@ -59,7 +59,7 @@ parseDuration = Duration <$$> go 0
 fromDuration :: Duration -> String
 fromDuration Duration { durationSeconds = d }
 	| d == 0 = "0s"
-	| otherwise = concat $ map showunit $ go [] units d
+	| otherwise = concatMap showunit $ go [] units d
   where
 	showunit (u, n)
 		| n > 0 = show n ++ [u]

Utility/InodeCache.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.InodeCache where

Utility/JSONStream.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2011 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.JSONStream (

Utility/LinuxMkLibs.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.LinuxMkLibs where
@@ -49,7 +49,7 @@ inTop top f = top ++ f
  - link to. Note that some of the libraries may not exist 
  - (eg, linux-vdso.so) -}
 parseLdd :: String -> [FilePath]
-parseLdd = catMaybes . map (getlib . dropWhile isSpace) . lines
+parseLdd = mapMaybe (getlib . dropWhile isSpace) . lines
   where
 	getlib l = headMaybe . words =<< lastMaybe (split " => " l)
 

Utility/LogFile.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}

Utility/Lsof.hs

@@ -2,10 +2,10 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
-{-# LANGUAGE BangPatterns, CPP #-}
+{-# LANGUAGE CPP #-}
 
 module Utility.Lsof where
 
@@ -110,7 +110,7 @@ parseFormatted s = bundle $ go [] $ lines s
 
 {- Parses lsof's default output format. -}
 parseDefault :: LsofParser
-parseDefault = catMaybes . map parseline . drop 1 . lines
+parseDefault = mapMaybe parseline . drop 1 . lines
   where
 	parseline l = case words l of
 		(command : spid : _user : _fd : _type : _device : _size : _node : rest) -> 

Utility/Matcher.hs

@@ -12,7 +12,7 @@
  -
  - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE Rank2Types, KindSignatures #-}
@@ -64,10 +64,10 @@ generate = simplify . process MAny . tokenGroups
 	process m [] = m
 	process m ts = uncurry process $ consume m ts
 
-	consume m ((One And):rest) = term (m `MAnd`) rest
+	consume m (One And:rest) = term (m `MAnd`) rest
-	consume m ((One Or):rest) = term (m `MOr`) rest
+	consume m (One Or:rest) = term (m `MOr`) rest
-	consume m ((One Not):rest) = term (\p -> m `MAnd` (MNot p)) rest
+	consume m (One Not:rest) = term (\p -> m `MAnd` (MNot p)) rest
-	consume m ((One (Operation o)):rest) = (m `MAnd` MOp o, rest)
+	consume m (One (Operation o):rest) = (m `MAnd` MOp o, rest)
 	consume m (Group g:rest) = (process m g, rest)
 	consume m (_:rest) = consume m rest
 	consume m [] = (m, [])

Utility/Metered.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE TypeSynonymInstances #-}

Utility/Misc.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}

Utility/Monad.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.Monad where

Utility/Network.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.Network where

Utility/NotificationBroadcaster.hs

@@ -8,7 +8,7 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.NotificationBroadcaster (

Utility/OSX.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.OSX where

Utility/PID.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2014 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}

Utility/Parallel.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.Parallel where

Utility/Path.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE PackageImports, CPP #-}

Utility/Percentage.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.Percentage (

Utility/PosixFiles.hs

@@ -4,7 +4,7 @@
  -
  - Copyright 2014 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}

Utility/Process.hs

@@ -3,7 +3,7 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP, Rank2Types #-}
@@ -167,10 +167,10 @@ processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
 processTranscript cmd opts input = processTranscript' cmd opts Nothing input
 
 processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)
+processTranscript' cmd opts environ input = do
 #ifndef mingw32_HOST_OS
 {- This implementation interleves stdout and stderr in exactly the order
  - the process writes them. -}
-processTranscript' cmd opts environ input = do
 	(readf, writef) <- createPipe
 	readh <- fdToHandle readf
 	writeh <- fdToHandle writef
@@ -184,24 +184,13 @@ processTranscript' cmd opts environ input = do
 	hClose writeh
 
 	get <- mkreader readh
-
+	writeinput input p
-	-- now write and flush any input
-	case input of
-		Just s -> do
-			let inh = stdinHandle p
-			unless (null s) $ do
-				hPutStr inh s
-				hFlush inh
-			hClose inh
-		Nothing -> return ()
-
 	transcript <- get
 
 	ok <- checkSuccessProcess pid
 	return (transcript, ok)
 #else
 {- This implementation for Windows puts stderr after stdout. -}
-processTranscript' cmd opts environ input = do
 	p@(_, _, _, pid) <- createProcess $
 		(proc cmd opts)
 			{ std_in = if isJust input then CreatePipe else Inherit
@@ -212,17 +201,9 @@ processTranscript' cmd opts environ input = do
 
 	getout <- mkreader (stdoutHandle p)
 	geterr <- mkreader (stderrHandle p)
-
+	writeinput input p
-	case input of
-		Just s -> do
-			let inh = stdinHandle p
-			unless (null s) $ do
-				hPutStr inh s
-				hFlush inh
-			hClose inh
-		Nothing -> return ()
-	
 	transcript <- (++) <$> getout <*> geterr
+
 	ok <- checkSuccessProcess pid
 	return (transcript, ok)
 #endif
@@ -237,6 +218,14 @@ processTranscript' cmd opts environ input = do
 			takeMVar v
 			return s
 
+	writeinput (Just s) p = do
+		let inh = stdinHandle p
+		unless (null s) $ do
+			hPutStr inh s
+			hFlush inh
+		hClose inh
+	writeinput Nothing _ = return ()
+
 {- Runs a CreateProcessRunner, on a CreateProcess structure, that
  - is adjusted to pipe only from/to a single StdHandle, and passes
  - the resulting Handle to an action. -}

Utility/QuickCheck.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}

Utility/Quvi.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE OverloadedStrings #-}

Utility/Rsync.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.Rsync where

Utility/SRV.hs

@@ -5,7 +5,7 @@
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}

Utility/SafeCommand.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.SafeCommand where

Utility/Scheduled.hs

@@ -2,7 +2,7 @@
  - 
  - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 module Utility.Scheduled (

Utility/Shell.hs

@@ -2,7 +2,7 @@
  -
  - Copyright 2013 Joey Hess <joey@kitenet.net>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - License: BSD-2-clause
  -}
 
 {-# LANGUAGE CPP #-}